Write closure conversion.

I desperately need a diffing library.

1 files changed, 39 insertions, 25 deletions

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)))))
+      (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=?-sametype x 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)))))