From a5cb98a823ad4e4f6b8e4522fec86c1805ad3f8b Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 26 Jan 2018 21:09:40 -0800
Subject: [PATCH] Simplify the rename-db implementation.

---
 src/runtime/runtime.pkg       |  3 +-
 src/runtime/syntax-rename.scm | 84 +++++++++++++++++++----------------
 src/runtime/syntax.scm        |  2 +-
 3 files changed, 49 insertions(+), 40 deletions(-)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index a3722e3a6..eaaeb010f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4384,13 +4384,14 @@ USA.
   (files "syntax")
   (parent (runtime syntax))
   (export ()
+	  (make-synthetic-identifier new-identifier)
 	  capture-syntactic-environment
 	  close-syntax
 	  identifier->symbol
 	  identifier=?
 	  identifier?
 	  make-syntactic-closure
-	  make-synthetic-identifier
+	  new-identifier
 	  reverse-syntactic-environments
 	  strip-syntactic-closures
 	  syntactic-closure-form
diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm
index 995ceae8d..532ccc878 100644
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -49,48 +49,58 @@ USA.
 (declare (usual-integrations))
 
 (define (make-local-identifier-renamer)
-  (let ((id (make-rename-id)))
-    (lambda (identifier)
-      (rename-identifier identifier id))))
+  ((rdb:identifier-renamer (rename-db)) new-identifier))
 
 (define (with-identifier-renaming thunk)
-  (parameterize* (list (cons rename-db (initial-rename-database)))
+  (parameterize* (list (cons rename-db (initial-rename-db)))
 		 (lambda () (post-process-output (thunk)))))
 
 (define-deferred rename-db
   (make-unsettable-parameter 'unbound))
 
-(define-structure (rename-database (constructor initial-rename-database ())
-				   (conc-name rename-database/))
-  (frame-number 0)
-  (mapping-table (make-equal-hash-table) read-only #t)
-  (unmapping-table (make-strong-eq-hash-table) read-only #t))
-
-(define (make-rename-id)
-  (delay
-    (let* ((renames (rename-db))
-	   (n (+ (rename-database/frame-number renames) 1)))
-      (set-rename-database/frame-number! renames n)
-      n)))
-
-(define (rename-identifier identifier rename-id)
-  (let ((key (cons identifier rename-id))
-	(renames (rename-db)))
-    (let ((mapping-table (rename-database/mapping-table renames)))
-      (or (hash-table/get mapping-table key #f)
-	  (let ((mapped-identifier
-		 (string->uninterned-symbol (symbol->string identifier))))
-	    (hash-table/put! mapping-table key mapped-identifier)
-	    (hash-table/put! (rename-database/unmapping-table renames)
-			     mapped-identifier
-			     key)
-	    mapped-identifier)))))
+(define-record-type <rename-db>
+    (make-rename-db identifier-renamer lookup-rename)
+    rename-db?
+  (identifier-renamer rdb:identifier-renamer)
+  (lookup-rename rdb:lookup-rename))
+
+(define (initial-rename-db)
+  (let ((frame-id 0)
+	(mapping-table (make-strong-eq-hash-table))
+	(unmapping-table (make-strong-eq-hash-table)))
+
+    (define (identifier-renamer get-rename)
+      (let ((delayed-frame-id (delay (new-frame-id))))
+	(lambda (identifier)
+	  (guarantee identifier? identifier)
+	  (let ((bucket
+		 (hash-table-intern! mapping-table
+				     identifier
+				     (lambda () (list 'bucket)))))
+	    (let ((entry (assq delayed-frame-id (cdr bucket))))
+	      (if entry
+		  (cdr entry)
+		  (let ((rename (get-rename identifier)))
+		    (set-cdr! bucket
+			      (cons (cons delayed-frame-id rename)
+				    (cdr bucket)))
+		    (hash-table-set! unmapping-table
+				     rename
+				     (cons identifier delayed-frame-id))
+		    rename)))))))
+
+    (define (new-frame-id)
+      (let ((n (+ frame-id 1)))
+	(set! frame-id n)
+	n))
+
+    (define (lookup-rename rename)
+      (hash-table/get unmapping-table rename #f))
+
+    (make-rename-db identifier-renamer lookup-rename)))
 
 (define (rename->original rename)
-  (let ((entry
-	 (hash-table/get (rename-database/unmapping-table (rename-db))
-			 rename
-			 #f)))
+  (let ((entry ((rdb:lookup-rename (rename-db)) rename)))
     (if entry
 	(car entry)
 	rename)))
@@ -119,14 +129,12 @@ USA.
     free))
 
 (define (make-final-substitution safe-set)
-  (let ((uninterned-table (make-strong-eq-hash-table)))
+  (let ((lookup-rename (rdb:lookup-rename (rename-db)))
+	(uninterned-table (make-strong-eq-hash-table)))
 
     (define (finalize-renamed-identifier rename)
       (guarantee identifier? rename 'finalize-renamed-identifier)
-      (let ((entry
-	     (hash-table/get (rename-database/unmapping-table (rename-db))
-			     rename
-			     #f)))
+      (let ((entry (lookup-rename rename)))
 	(if entry
 	    (let ((original (car entry))
 		  (frame-id (force (cdr entry))))
diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index 18e9bc340..5321c1838 100644
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -126,7 +126,7 @@ USA.
 (register-predicate! raw-identifier? 'raw-identifier '<= identifier?)
 (register-predicate! closed-identifier? 'closed-identifier '<= identifier?)
 
-(define (make-synthetic-identifier identifier)
+(define (new-identifier identifier)
   (string->uninterned-symbol (symbol->string (identifier->symbol identifier))))
 
 (define (identifier->symbol identifier)
-- 
2.25.1