From 37e086d27d478246e72b8f5c1b75ed5d092495fa Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Sat, 2 Jul 2022 23:04:28 -0700
Subject: Write closure conversion.

I desperately need a diffing library.
---
 csc/cps-test.csc      | 202 +++++++++++++++++++++++++++++++++-----------------
 csc/cps.csc           | 197 ++++++++++++++++++++++++++++++++++++++++--------
 csc/hash-map-test.csc |  17 ++---
 csc/hash-map.csc      |   8 +-
 csc/ir1.csc           |  12 +--
 csc/ir2.csc           |  68 ++++++++++-------
 csc/linker.csc        |   9 +--
 csc/macros.csc        |  10 +--
 8 files changed, 358 insertions(+), 165 deletions(-)

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index 3f0d743..c72aca6 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -22,7 +22,8 @@
           make-kargs
           make-klabel
           make-ktail
-          make-primitive)
+          make-primitive
+          make-variable)
         (only (csc testing)
           assert-equal
           test)
@@ -128,85 +129,152 @@
               tail)))
 
 
-(test letrec-in-order
+(test letrec-functions
+  (define x (test-ref 'x))
+  (define f (gensym))
   (assert-equal ir2=?
     (make-fix
       (list
-        (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)
-                                          (test-ref 'x)) #f
-          (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
+        (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x)) #f
+          (make-apply (test-ref 'generated-symbol) (list (test-ref 'x)))))
       (make-fix
         (list
           (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
             (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
+        (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (make-constant 10)))))
+    (ir1->ir2
+      (make-letrec #f '(f) (list f)
+                   (list (make-lambda (list x) #f x))
+        (make-call (make-lexical-ref 'f f) (list (make-constant 10))))
+      tail)))
+
+
+(test letrec-in-order
+  (assert-equal ir2=?
+    (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'b))
+      (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'a))
         (make-fix
           (list
-            (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)
-                                                             (test-ref 'a)) #f
-              (make-fix
-                (list
-                  (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
-                    (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))))
-                (make-fix
-                  (list
-                    (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)
-                                                                     (test-ref 'b)) #f
-                      (make-apply (test-ref 'generated-symbol) (list (make-constant 10)))))
-                  (make-apply (test-ref 'generated-symbol)
-                              (list (test-ref 'generated-symbol)
-                                    (make-constant 2)))))))
-          (make-apply (test-ref 'generated-symbol)
-                      (list (test-ref 'generated-symbol)
-                            (make-constant 1))))))
-    (ir1->ir2 (make-letrec
-                #t
-                '(a f b)
-                (list (gensym) (gensym) (gensym))
-                (list (make-constant 1)
-                      (make-lambda (list (test-ref 'x)) #f (make-constant 5))
-                      (make-constant 2))
-                (make-constant 10))
-              tail)))
+            (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'x)) #f
+              (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
+          (make-primitive 'poke (list (make-constant 1) (test-ref 'a) (make-constant 0)) '()
+            (make-primitive 'poke (list (make-constant 2) (test-ref 'b) (make-constant 0)) '()
+              (make-apply (test-ref 'tail) (list (make-constant 10))))))))
+    (ir1->ir2
+      (make-letrec #t
+        '(a f b)
+        (list (gensym) (gensym) (gensym))
+        (list (make-constant 1)
+              (make-lambda (list (test-ref 'x)) #f (make-constant 5))
+              (make-constant 2))
+        (make-constant 10))
+      tail)))
+
+
+; What does the following letrec return?
+; (letrec* ((f (lambda () x))
+;           (x (f)))
+;   x)
+(test letrec-very-cool
+  (define f (gensym))
+  (define x (gensym))
+  (assert-equal ir2=?
+    (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x))
+      (make-fix
+        (list
+          (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)) #f
+            (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol))
+              (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))))
+        (make-fix
+          (list
+            (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
+              (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '()
+                (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol))
+                  (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))))
+          (make-apply (test-ref 'f) (list (test-ref 'generated-symbol))))))
+    (ir1->ir2
+      (make-letrec #t
+        '(f x)
+        (list f x)
+        (list (make-lambda '() #f (make-lexical-ref 'x x))
+              (make-call (make-lexical-ref 'f f) '()))
+        (make-lexical-ref 'x x))
+      tail)))
 
 
 (test set-argument
-  (make-fix
-    (list
-      (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)
-                                        (test-ref 'generated-symbol)) #f
-        (make-primitive 'alloc (list (make-constant 1))
-                               (list (test-ref 'x))
-          (make-primitive 'poke (list (test-ref 'generated-symbol)
-                                      (test-ref 'x)
-                                      (make-constant 0)) '()
-            (make-primitive 'poke (list (make-constant 10)
+  (define test-sym (gensym))
+  (assert-equal ir2=?
+    (make-fix
+      (list
+        (make-closure (test-ref 'f) (list (test-ref 'generated-symbol)
+                                          (test-ref 'generated-symbol)) #f
+          (make-primitive 'alloc (list (make-constant 1))
+                                 (list (test-ref 'x))
+            (make-primitive 'poke (list (test-ref 'generated-symbol)
                                         (test-ref 'x)
                                         (make-constant 0)) '()
-              (make-apply (test-ref 'generated-symbol) (list (make-constant #f))))))))
-    (make-apply (test-ref 'tail) (make-constant 5)))
-  (ir1->ir2 (make-letrec
-              #f
-              '(f)
-              (list (gensym))
-              (list (make-lambda (list (test-ref 'x)) #f
-                      (make-lexical-set (test-ref 'x) (make-constant 10))))
-              (make-constant 5))
-            tail))
-
+              (make-primitive 'poke (list (make-constant 10)
+                                          (test-ref 'x)
+                                          (make-constant 0)) '()
+                (make-apply (test-ref 'generated-symbol) (list (make-constant #f))))))))
+      (make-apply (test-ref 'tail) (list (make-constant 5))))
+    (ir1->ir2 (make-letrec
+                #f
+                '(f)
+                (list (gensym))
+                (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f
+                        (make-lexical-set (make-lexical-ref 'x test-sym) (make-constant 10))))
+                (make-constant 5))
+              tail)))
 
 (test set-function
-  (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f))
-    (make-fix
-      (list
-        (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
-          (make-apply (test-ref 'generated-symbol) (list (make-constant 10)))))
-      (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '()
-        (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '()
-          (make-apply (test-ref 'tail) (make-constant #f))))))
-  (ir1->ir2 (make-letrec
-              #f
-              '(f)
-              (list (gensym))
-              (list (make-lambda '() #f (make-constant 10)))
-              (make-lexical-set (test-ref 'f) (make-constant 5)))
-            tail))
+  (define test-sym (gensym))
+  (assert-equal ir2=?
+    (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f))
+      (make-fix
+        (list
+          (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
+            (make-apply (test-ref 'generated-symbol) (list (make-constant 10)))))
+        (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'f) (make-constant 0)) '()
+          (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '()
+            (make-apply (test-ref 'tail) (list (make-constant #f)))))))
+    (ir1->ir2 (make-letrec
+                #f
+                '(f)
+                (list test-sym)
+                (list (make-lambda '() #f (make-constant 10)))
+                (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5)))
+              tail)))
+
+
+(define (test-var)
+  (make-variable (gensym)))
+
+
+(test closure-convert-primitive
+  (define a-sym (gensym))
+  (define f-sym (gensym))
+  (define ret-sym (gensym))
+  (define x-sym (gensym))
+  (assert-equal ir2=?
+    (make-primitive 'alloc (list (make-constant 1)) (list (test-var))
+      (make-fix
+        (list
+          (make-closure (test-var) (list (test-var) (test-var) (test-var)) #f
+            (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
+              (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '()
+                (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
+                  (make-apply (test-var) (list (test-var) (make-constant #f))))))))
+        (make-primitive 'alloc (list (make-constant 2)) (list (test-var))
+          (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '()
+            (make-primitive 'poke (list (test-var) (test-var) (make-constant 1)) '()
+              (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
+                (make-apply (test-var) (list (test-var) (make-library-ref 'tail '(csc builtins)) (make-constant 10)))))))))
+    (closure-convert (make-primitive 'alloc (list (make-constant 1)) (list (make-lexical-ref 'a a-sym))
+                       (make-fix
+                         (list
+                           (make-closure (make-lexical-ref 'f f-sym) (list (make-lexical-ref 'ret ret-sym) (make-lexical-ref 'x x-sym)) #f
+                             (make-primitive 'poke (list (make-lexical-ref 'x x-sym) (make-lexical-ref 'a a-sym) (make-constant 0)) '()
+                               (make-apply (make-lexical-ref 'ret ret-sym) (list (make-constant #f))))))
+                         (make-apply (make-lexical-ref 'f f-sym) (list (make-library-ref 'tail '(csc builtins)) (make-constant 10))))))))
diff --git a/csc/cps.csc b/csc/cps.csc
index cf46e05..827f4b7 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -1,5 +1,6 @@
 (define-library (csc cps)
   (export
+    closure-convert
     ir1->ir2)
   (import (scheme base)
           (only (csc gensym)
@@ -10,6 +11,7 @@
             key-not-found-error?
             lookup
             make-map
+            map->alist
             merge)
           (only (csc ir1)
             %call
@@ -17,6 +19,7 @@
             %if
             %lambda
             %letrec
+            %lexical-ref
             %lexical-set
             %library-define
             %sequence
@@ -58,7 +61,8 @@
             make-kargs
             make-klabel
             make-ktail
-            make-primitive)
+            make-primitive
+            make-variable)
           (only (csc loop)
             loop
             return)
@@ -189,34 +193,23 @@
                   (lambda (ret)
                     (make-apply k (list ret))))))
             (continuation f)))
-        ((% %letrec in-order? _ _ _ body)
+        ((% %letrec _ _ _ _ body)
           (define-values (functions variable-names variable-values) (collect-functions-and-variables expr))
-          (make-fix functions
-            (to-cps
-              ; We re-write a letrec into a corresponding lambda form.
-              (if in-order?
-                (loop for name in (reverse variable-names)
-                      for value in (reverse variable-values)
-                      for expr = (make-call
-                                   (make-lambda
-                                     (list name)
-                                     #f
-                                     body)
-                                   (list value))
-                               then (make-call
-                                      (make-lambda
-                                        (list name)
-                                        #f
-                                        expr)
-                                      (list value))
-                      finally (return expr))
-                (make-call
-                  (make-lambda
-                    variable-names
-                    #f
-                    body)
-                  variable-values))
-              continuation)))
+          (if (null? variable-names)
+            (make-fix functions
+              (to-cps body continuation))
+            (loop with new-expr = (make-fix functions
+                                    (loop for var in (reverse variable-names)
+                                          for val in (reverse variable-values)
+                                          with new-body = (to-cps body continuation)
+                                          do (set! new-body (to-cps val (lambda (x)
+                                                                          (make-update var x
+                                                                            new-body))))
+                                          finally (return new-body)))
+                  for var in variable-names
+                  do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var)
+                                      new-expr))
+                  finally (return new-expr))))
         (_ (error "unexpected type in to-cps" expr))))
 
 
@@ -224,7 +217,8 @@
       (make-map
         (lambda (ref)
           (gensym->int (lexical-ref-gensym ref)))
-        (lambda (x y) (< (gensym->int (lexical-ref-gensym x))
+        (lambda (x y)
+          (< (gensym->int (lexical-ref-gensym x))
                          (gensym->int (lexical-ref-gensym y))))))
 
 
@@ -248,7 +242,7 @@
                 for fun in funs
                 do (set! m (merge m (get-boxed (closure-body fun))))
                 finally (return m)))
-        (_ (error "Unexpected form in get-boxed"))))
+        (_ (error "Unexpected form in get-boxed" expr))))
 
 
     (define (all-closure-args fun)
@@ -339,8 +333,147 @@
             (loop for name in boxed-names
                   do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list name)
                                       new-expr))
-                  finally (return expr))))))
+                  finally (return new-expr)))
+          (_ (error "Unexpected form in box-conversion" expr)))))
 
 
     (define (ir1->ir2 expr continuation)
-      (box-conversion (to-cps expr continuation)))))
+      (box-conversion (to-cps expr continuation)))
+
+
+    (define (free-vars-expr expr bound-vars)
+      (define (free? ref)
+        (and (lexical-ref? ref)
+             (not (guard (e ((key-not-found-error? e) #f))
+                    (lookup bound-vars ref)))))
+      (match expr
+        ((% %primitive _ args res continuation)
+          (loop for r in res
+                if (lexical-ref? r)
+                  do (set! bound-vars (insert bound-vars r #t)))
+          (loop with m = (free-vars-expr continuation bound-vars)
+                for arg in args
+                if (free? arg)
+                  do (set! m (insert m arg #t))
+                finally (return m)))
+        ((% %branch atom true false)
+          (define m (merge (free-vars-expr true bound-vars) (free-vars-expr false bound-vars)))
+          (if (free? atom)
+            (set! m (insert m atom #t)))
+          m)
+        ((% %apply proc args)
+          (define m (make-ref-map))
+          (if (free? proc)
+            (set! m (insert m proc #t)))
+          (loop for arg in args
+                if (free? arg)
+                  do (set! m (insert m arg #t))
+                finally (return m)))
+        ((% %fix funs body)
+          (loop for fun in funs
+                for name = (closure-name fun)
+                if (lexical-ref? name)
+                  do (set! bound-vars (insert bound-vars name #t)))
+          (define m (free-vars-expr body bound-vars))
+          (loop for fun in funs
+                do (set! m (merge m (free-vars-closure fun bound-vars)))
+                finally (return m)))
+        (_ (error "Unexpected form in free-vars-expr" expr))))
+
+
+    (define (free-vars-closure fun bound-vars)
+      (define name (closure-name fun))
+      (define rest (closure-rest fun))
+      (when (lexical-ref? name)
+        (set! bound-vars (insert bound-vars name #t)))
+      (when rest
+        (set! bound-vars (insert bound-vars rest #t)))
+      (loop for arg in (closure-arguments fun)
+            do (set! bound-vars (insert bound-vars arg #t)))
+      (free-vars-expr (closure-body fun) bound-vars))
+
+
+    ; Returns a list of the free variables in a closure.
+    (define (free-vars expr)
+      (define m (free-vars-closure expr (make-ref-map)))
+      (map car (map->alist m)))
+
+
+    (define (translate-ref ref env)
+      (if (lexical-ref? ref)
+        (guard (e ((key-not-found-error? e) (error "Undefined symbol in closure-convert" ref)))
+          (lookup env ref))
+        ref))
+
+
+    ; converts a CPS expression into an equivalent expression with no
+    ; free variables.
+    (define (closure-convert expr)
+      (let convert ((expr expr)
+                    (env (make-ref-map)))
+        (define (translate ref)
+          (translate-ref ref env))
+        (match expr
+          ((% %primitive op args res continuation)
+            (loop for r in res
+                  do (set! env (insert env r (make-variable (gensym)))))
+            (make-primitive op (map translate args) (map translate res) (convert continuation env)))
+          ((% %branch atom true false)
+            (make-branch (translate atom) (convert true env) (convert false env)))
+          ((% %apply proc args)
+            (let ((p (translate proc))
+                  (fn (make-variable (gensym))))
+              (make-primitive 'peek (list p (make-constant 0)) (list fn)
+                (make-apply fn (cons p (map translate args))))))
+          ((% %fix functions body)
+            (define frees (map free-vars functions))
+            (define fn-ptrs (loop for fun in functions
+                                  collect (make-variable (gensym))))
+            (define converted-functions (loop for fun in functions
+                                              for fn-ptr in fn-ptrs
+                                              for free-list in frees
+                                              for env* = env
+                                              for name = (closure-name fun)
+                                              for closure = (make-variable (gensym))
+                                              if (lexical-ref? name)
+                                                do (set! env* (insert env* name closure))
+                                              do (loop for arg in (closure-arguments fun)
+                                                       do (set! env* (insert env* arg (make-variable (gensym)))))
+                                                 (loop for var in free-list
+                                                       do (set! env* (insert env* var (make-variable (gensym)))))
+                                              collect (let ((new-body (convert (closure-body fun) env*)))
+                                                        (loop for var in free-list
+                                                              for i from 0
+                                                              do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*))
+                                                                                  new-body)))
+                                                        (make-closure
+                                                          fn-ptr
+                                                          (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun)))
+                                                          (if (closure-rest fun)
+                                                            (translate (closure-rest fun))
+                                                            #f)
+                                                          new-body))))
+            (loop for fun in functions
+                  for name = (closure-name fun)
+                  if (lexical-ref? name)
+                    do (set! env (insert env name (make-variable (gensym)))))
+            (let ((new-body (convert body env)))
+              ; Build the closures.
+              (loop for fun in functions
+                    for free-list in frees
+                    for ptr in fn-ptrs
+                    for closure = (translate (closure-name fun))
+                    do (loop for var in free-list
+                             for i from 1
+                             do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '()
+                                                 new-body)))
+                       (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '()
+                                        new-body)))
+              ; Allocate the closures.
+              (loop for fun in functions
+                    for free-list in frees
+                    for closure = (translate (closure-name fun))
+                    do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure)
+                                        new-body)))
+              (make-fix converted-functions new-body)))
+          (_ (error "Unexpected form in closure-convert" expr)))))))
diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc
index f346e1e..677406e 100644
--- a/csc/hash-map-test.csc
+++ b/csc/hash-map-test.csc
@@ -15,15 +15,8 @@
   (string<? (symbol->string s1) (symbol->string s2)))
 
 
-(define (cmp-symbols s1 s2)
-  (cond
-    ((symbol<? s1 s2) -1)
-    ((symbol=? s1 s2) 0)
-    (else 1)))
-
-
 (define (alist->map->alist l)
-  (map->alist (alist->map hash-symbol cmp-symbols l)))
+  (map->alist (alist->map hash-symbol symbol<? l)))
 
 
 (define (sort-alist l)
@@ -77,12 +70,12 @@
 (test lookup
   (assert-equal
     2
-    (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'b)))
+    (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'b)))
 
 
 (test lookup-notfound
   (assert-raises key-not-found-error?
-    (lookup (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2) (c . 3))) 'd)))
+    (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'd)))
 
 
 (test merge
@@ -91,5 +84,5 @@
     (sort-alist
       (map->alist
         (merge
-          (alist->map hash-symbol cmp-symbols '((a . 1) (b . 2)))
-          (alist->map hash-symbol cmp-symbols '((c . 3) (d . 4))))))))
+          (alist->map hash-symbol symbol<? '((a . 1) (b . 2)))
+          (alist->map hash-symbol symbol<? '((c . 3) (d . 4))))))))
diff --git a/csc/hash-map.csc b/csc/hash-map.csc
index ae5c3df..be9e507 100644
--- a/csc/hash-map.csc
+++ b/csc/hash-map.csc
@@ -26,11 +26,15 @@
     (define (key-hash<? k1 k2 cmp)
       (cond ((< (key-hash-hash k1) (key-hash-hash k2)) #t)
             ((> (key-hash-hash k1) (key-hash-hash k2)) #f)
-            (else (< (cmp (key-hash-value k1) (key-hash-value k2)) 0))))
+            (else (cmp (key-hash-value k1) (key-hash-value k2)))))
 
 
     (define (key-hash=? k1 k2 cmp)
-      (and (= (key-hash-hash k1) (key-hash-hash k2)) (= 0 (cmp (key-hash-value k1) (key-hash-value k2)))))
+      (let ((v1 (key-hash-value k1))
+            (v2 (key-hash-value k2)))
+        (and (= (key-hash-hash k1) (key-hash-hash k2))
+             (not (cmp v1 v2))
+             (not (cmp v2 v1)))))
 
 
     (define-record-type <node>
diff --git a/csc/ir1.csc b/csc/ir1.csc
index 73ec703..33588c9 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -196,7 +196,7 @@
       (expression letrec-expression))
 
 
-    (define (ir1=?-sametype x y)
+    (define (ir1=? x y)
       (cond
         ((and (constant? x) (constant? y))
           (equal? (constant-expression x) (constant-expression y)))
@@ -253,12 +253,4 @@
               (= (length x-values) (length y-values))
               (all ir1=? x-values y-values)
               (ir1=? (letrec-expression x) (letrec-expression y)))))
-        (else #f)))
-
-
-    (define (ir1=? x y)
-      (cond
-        ((ir1=?-sametype x y) #t)
-        ((and (ir1=?-sametype x x) (ir1=?-sametype y y))
-          #f)
-        (else (error "One or more arguments has a type unknown to ir1=?" x y))))))
+        (else #f)))))
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 7aea0a3..462a4a4 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -5,6 +5,7 @@
     %closure
     %fix
     %primitive
+    %variable
     apply-arguments
     apply-procedure
     apply?
@@ -43,11 +44,14 @@
     make-klabel
     make-ktail
     make-primitive
+    make-variable
     primitive-arguments
     primitive-continuation
     primitive-operation
     primitive-results
     primitive?
+    variable-gensym
+    variable?
 
     ; Re-exports from IR1.
     constant-expression
@@ -100,6 +104,17 @@
     ;     - constant,
     ;     - lexical-ref,
     ;     - or library-ref
+    ;   After closure conversion, there are no more lexical refs.
+    ;   Each lexical ref will be converted to one of the following
+    ;   data types.
+
+
+    ; A function argument or local variable.
+    (define-match-record-type <variable>
+      (make-variable gensym)
+      variable?
+      %variable
+      (gensym variable-gensym))
 
 
     ; CPS expressions:
@@ -171,46 +186,45 @@
       (body fix-body))
 
 
+    (define (atom=? x y)
+      (if (and (variable? x) (variable? y))
+        #t
+        (ir1=? x y)))
+
+
     (define (closure=? x y)
-      (let ((x-args (closure-arguments x))
-            (x-rest (closure-rest x))
-            (y-args (closure-arguments y))
-            (y-rest (closure-rest y)))
-        (and (ir1=? (closure-name x) (closure-name y))
-             (= (length x-args) (length y-args))
-             (all ir1=? x-args y-args)
-             (or (and (not x-rest) (not y-rest))
-                 (and x-rest y-rest (ir1=? x-rest y-rest)))
-             (ir2=? (closure-body x) (closure-body y)))))
-
-
-    (define (ir2=?-sametype x y)
+      (and (closure? x) (closure? y)
+        (let ((x-args (closure-arguments x))
+              (x-rest (closure-rest x))
+              (y-args (closure-arguments y))
+              (y-rest (closure-rest y)))
+          (and (atom=? (closure-name x) (closure-name y))
+               (= (length x-args) (length y-args))
+               (all atom=? x-args y-args)
+               (or (and (not x-rest) (not y-rest))
+                   (and x-rest y-rest (atom=? x-rest y-rest)))
+               (ir2=? (closure-body x) (closure-body y))))))
+
+
+    (define (ir2=? x y)
       (match (cons x y)
         (((% %primitive x-oper x-args x-res x-cont) . (% %primitive y-oper y-args y-res y-cont))
           (and (symbol=? x-oper y-oper)
                (= (length x-args) (length y-args))
-               (all ir1=? x-args y-args)
+               (all atom=? x-args y-args)
                (= (length x-res) (length y-res))
-               (all ir1=? x-res y-res)
+               (all atom=? x-res y-res)
                (ir2=? x-cont y-cont)))
         (((% %branch x-atom x-true x-false) . (% %branch y-atom y-true y-false))
-          (and (ir1=? x-atom y-atom)
+          (and (atom=? x-atom y-atom)
                (ir2=? x-true y-true)
                (ir2=? x-false y-false)))
         (((% %apply x-proc x-args) . (% %apply y-proc y-args))
-          (and (ir1=? x-proc y-proc)
+          (and (atom=? x-proc y-proc)
                (= (length x-args) (length y-args))
-               (all ir1=? x-args y-args)))
+               (all atom=? x-args y-args)))
         (((% %fix x-funs x-body) . (% %fix y-funs y-body))
           (and (= (length x-funs) (length y-funs))
                (all closure=? x-funs y-funs)
                (ir2=? x-body y-body)))
-        (_ #f)))
-
-
-    (define (ir2=? x y)
-      (cond
-        ((ir2=?-sametype x y) #t)
-        ((and (ir2=?-sametype x x) (ir2=?-sametype y y))
-          #f)
-        (else (error "One or more arguments has a type unknown to ir2=?" x y))))))
+        (_ #f)))))
diff --git a/csc/linker.csc b/csc/linker.csc
index b3f2a5d..852ee13 100644
--- a/csc/linker.csc
+++ b/csc/linker.csc
@@ -41,15 +41,8 @@
       (hash-bytevector (string->utf8 s)))
 
 
-    (define (cmp-strings s1 s2)
-      (cond
-        ((string<? s1 s2) -1)
-        ((string=? s1 s2) 0)
-        (else 1)))
-
-
     (define (make-label-map program)
-      (let loop ((m (make-map hash-string cmp-strings))
+      (let loop ((m (make-map hash-string string<?))
                  (program program)
                  (i 0))
         (match program
diff --git a/csc/macros.csc b/csc/macros.csc
index 6364e19..045194b 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -17,7 +17,6 @@
             insert
             key-not-found-error?
             lookup
-            make-map
             map-for-each
             merge)
           (only (csc ir1)
@@ -374,15 +373,12 @@
       (hash-bytevector (string->utf8 (identifier-uuid i))))
 
 
-    (define (cmp-identifier i1 i2)
-      (cond
-        ((string<? (identifier-uuid i1) (identifier-uuid i2)) -1)
-        ((string=? (identifier-uuid i1) (identifier-uuid i2)) 0)
-        (else 1)))
+    (define (identifier<? i1 i2)
+      (string<? (identifier-uuid i1) (identifier-uuid i2)))
 
 
     (define (alist->substitutions l)
-      (alist->map hash-identifier cmp-identifier l))
+      (alist->map hash-identifier identifier<? l))
 
 
     (define (is-underscore expression)
-- 
cgit v1.3.1