From 429aa3c3c58d93c3897fafc98d9b44ddc271e0d6 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Fri, 1 Jul 2022 08:29:57 -0700
Subject: Add update conversion.

Now variables can't be updated after they're created, so they can be
freely copied into closures.
---
 csc/cps-test.csc | 153 +++++++++++++++++++++++-------------
 csc/cps.csc      | 233 ++++++++++++++++++++++++++++++++++++++++++++++---------
 csc/ir2.csc      | 104 ++++++++++++-------------
 3 files changed, 345 insertions(+), 145 deletions(-)

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index d3cfb6d..3f0d743 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -1,4 +1,5 @@
 (import (scheme base)
+        (only (csc gensym) gensym)
         (only (csc ir1)
           make-call
           make-constant
@@ -13,55 +14,60 @@
         (only (csc ir2)
           ir2=?
           make-apply
-          make-fix
           make-atom
           make-branch
           make-call-closure
           make-closure
+          make-fix
           make-kargs
           make-klabel
           make-ktail
-          make-update)
+          make-primitive)
         (only (csc testing)
           assert-equal
           test)
         (csc cps))
 
 
+(define (test-ref name)
+  (make-lexical-ref name (gensym)))
+
+
 (define (tail x)
-  (make-apply (make-lexical-ref 'tail #f) (list x)))
+  (make-apply (test-ref 'tail) (list x)))
 
 
 (test atom-const
   (assert-equal ir2=?
-    (make-apply (make-lexical-ref 'tail #f) (list (make-constant 5)))
+    (make-apply (test-ref 'tail) (list (make-constant 5)))
     (ir1->ir2 (make-constant 5) tail)))
 
 
 (test atom-lexical-ref
   (assert-equal ir2=?
-    (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'var #f)))
-    (ir1->ir2 (make-lexical-ref 'var #f) tail)))
+    (make-apply (test-ref 'tail) (list (test-ref 'var)))
+    (ir1->ir2 (test-ref 'var) tail)))
 
 
 (test atom-library-ref
   (assert-equal ir2=?
-    (make-apply (make-lexical-ref 'tail #f)
-      (list (make-library-ref 'var '(csc builtins))))
+    (make-primitive 'peek (list (make-library-ref 'var '(csc builtins)) (make-constant 0))
+                          (list (test-ref 'generated-symbol))
+      (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
     (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail)))
 
 
 (test lexical-set
   (assert-equal ir2=?
-    (make-update (make-lexical-ref 'var #f) (make-constant 5)
-                 (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f))))
-    (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5))
+    (make-primitive 'poke (list (make-constant 5) (test-ref 'var) (make-constant 0)) '()
+      (make-apply (test-ref 'tail) (list (make-constant #f))))
+    (ir1->ir2 (make-lexical-set (test-ref 'var) (make-constant 5))
               tail)))
 
 
 (test no-op-define-syntax
   (assert-equal ir2=?
-    (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f)))
+    (make-apply (test-ref 'tail) (list (make-constant #f)))
     (ir1->ir2 (make-define-syntax 'name '(transformer))
               tail)))
 
@@ -70,11 +76,11 @@
   (assert-equal ir2=?
     (make-fix
       (list
-        (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
-          (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))))
+        (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
+          (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
       (make-branch (make-constant #t)
-        (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 1)))
-        (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 2)))))
+        (make-apply (test-ref 'generated-symbol) (list (make-constant 1)))
+        (make-apply (test-ref 'generated-symbol) (list (make-constant 2)))))
     (ir1->ir2 (make-if (make-constant #t)
                 (make-constant 1)
                 (make-constant 2))
@@ -85,22 +91,22 @@
   (assert-equal ir2=?
     (make-fix
       (list
-        (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
-          (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))))
-      (make-apply (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f)
+        (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 1)
                                                  (make-constant 2))))
-    (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2)))
+    (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 1) (make-constant 2)))
               tail)))
 
 
 (test sequence
   (assert-equal ir2=?
-    (make-update (make-lexical-ref 'a #f) (make-constant 5)
-      (make-update (make-lexical-ref 'b #f) (make-constant 6)
-        (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f)))))
-    (ir1->ir2 (make-sequence (make-lexical-set (make-lexical-ref 'a #f) (make-constant 5))
-                             (make-lexical-set (make-lexical-ref 'b #f) (make-constant 6)))
+    (make-primitive 'poke (list (make-constant 5) (test-ref 'a) (make-constant 0)) '()
+      (make-primitive 'poke (list (make-constant 6) (test-ref 'b) (make-constant 0)) '()
+        (make-apply (test-ref 'tail) (list (make-constant #f)))))
+    (ir1->ir2 (make-sequence (make-lexical-set (test-ref 'a) (make-constant 5))
+                             (make-lexical-set (test-ref 'b) (make-constant 6)))
               tail)))
 
 
@@ -108,16 +114,16 @@
   (assert-equal ir2=?
     (make-fix
       (list
-        (make-closure (make-lexical-ref 'generated-symbol #f)
-                      (list (make-lexical-ref 'generated-symbol #f)
-                            (make-lexical-ref 'a #f)
-                            (make-lexical-ref 'b #f))
-                      (make-lexical-ref 'c #f)
-          (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 5)))))
-      (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))
+        (make-closure (test-ref 'generated-symbol)
+                      (list (test-ref 'generated-symbol)
+                            (test-ref 'a)
+                            (test-ref 'b))
+                      (test-ref 'c)
+          (make-apply (test-ref 'generated-symbol) (list (make-constant 5)))))
+      (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))
     (ir1->ir2 (make-lambda
-                (list (make-lexical-ref 'a #f) (make-lexical-ref 'b #f))
-                (make-lexical-ref 'c #f)
+                (list (test-ref 'a) (test-ref 'b))
+                (test-ref 'c)
                 (make-constant 5))
               tail)))
 
@@ -126,38 +132,81 @@
   (assert-equal ir2=?
     (make-fix
       (list
-        (make-closure (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f)
-                                                     (make-lexical-ref 'x #f)) #f
-          (make-apply (make-lexical-ref 'generated-symbol #f) (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 (make-constant 5)))))
       (make-fix
         (list
-          (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
-            (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))))
+          (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) #f
+            (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))))
         (make-fix
           (list
-            (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)
-                                                                        (make-lexical-ref 'a #f)) #f
+            (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)
+                                                             (test-ref 'a)) #f
               (make-fix
                 (list
-                  (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f
-                    (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)))))
+                  (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 (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)
-                                                                                (make-lexical-ref 'b #f)) #f
-                      (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 10)))))
-                  (make-apply (make-lexical-ref 'generated-symbol #f)
-                              (list (make-lexical-ref 'generated-symbol #f)
+                    (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 (make-lexical-ref 'generated-symbol #f)
-                      (list (make-lexical-ref 'generated-symbol #f)
+          (make-apply (test-ref 'generated-symbol)
+                      (list (test-ref 'generated-symbol)
                             (make-constant 1))))))
     (ir1->ir2 (make-letrec
                 #t
                 '(a f b)
-                '(#f #f #f)
+                (list (gensym) (gensym) (gensym))
                 (list (make-constant 1)
-                      (make-lambda (list (make-lexical-ref 'x #f)) #f (make-constant 5))
+                      (make-lambda (list (test-ref 'x)) #f (make-constant 5))
                       (make-constant 2))
                 (make-constant 10))
               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)
+                                        (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))
+
+
+(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))
diff --git a/csc/cps.csc b/csc/cps.csc
index b6decbb..cf46e05 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -2,9 +2,13 @@
   (export
     ir1->ir2)
   (import (scheme base)
-          (only (csc gensym) gensym)
+          (only (csc gensym)
+            gensym
+            gensym->int)
           (only (csc hash-map)
             insert
+            key-not-found-error?
+            lookup
             make-map
             merge)
           (only (csc ir1)
@@ -20,7 +24,11 @@
             constant?
             if?
             lambda?
+            letrec-gensyms
+            letrec-names
+            letrec-values
             letrec?
+            lexical-ref-gensym
             lexical-ref?
             lexical-set?
             library-define?
@@ -33,6 +41,14 @@
             make-sequence
             sequence?)
           (only (csc ir2)
+            %apply
+            %branch
+            %fix
+            %primitive
+            closure-arguments
+            closure-body
+            closure-name
+            closure-rest
             make-apply
             make-atom
             make-branch
@@ -42,56 +58,71 @@
             make-kargs
             make-klabel
             make-ktail
-            make-update)
+            make-primitive)
           (only (csc loop)
             loop
             return)
-          (only (csc match) match))
+          (only (csc match)
+            define-match-record-type
+            match))
   (begin
 
 
+    ; Update is a CPS expression that is used internally as part of
+    ; CPS conversion.
+    ; Update expressions are then removed by box-conversion.
+    (define-match-record-type <update>
+      (make-update ref atom continuation)
+      update?
+      %update
+      (ref update-ref)
+      (atom update-atom)
+      (continuation update-continuation))
+
+
     (define (new-ref)
       (make-lexical-ref 'generated-symbol (gensym)))
 
 
     (define (collect-functions-and-variables expr)
-      (match expr
-        ((% %letrec _ names gensyms vals _)
-          (loop for name in names
-                for gensym in gensyms
-                for value in vals
-                if (lambda? value)
-                  collect (match value
-                            ((% %lambda args rest body)
-                              (define continuation (new-ref))
-                              (make-closure
-                                (make-lexical-ref name gensym)
-                                (cons continuation args)
-                                rest
-                                (ir1->ir2
-                                  body
-                                  (lambda (z)
-                                    (make-apply continuation (list z)))))))
-                          into functions
-                else
-                  collect (make-lexical-ref name gensym) into variable-names
-                  and collect value into variable-values
-                finally (return (values functions variable-names variable-values))))))
+      (let ((names (letrec-names expr))
+            (gensyms (letrec-gensyms expr))
+            (vals (letrec-values expr)))
+        (loop for name in names
+              for gensym in gensyms
+              for value in vals
+              if (lambda? value)
+                collect (match value
+                          ((% %lambda args rest body)
+                            (define continuation (new-ref))
+                            (make-closure
+                              (make-lexical-ref name gensym)
+                              (cons continuation args)
+                              rest
+                              (to-cps
+                                body
+                                (lambda (z)
+                                  (make-apply continuation (list z)))))))
+                        into functions
+              else
+                collect (make-lexical-ref name gensym) into variable-names
+                and collect value into variable-values
+              finally (return (values functions variable-names variable-values)))))
 
 
-    (define (ir1->ir2 expr continuation)
+    (define (to-cps expr continuation)
       (match expr
         (_ (when (or (constant? expr)
                      (lexical-ref? expr)
                      (library-ref? expr)))
           (continuation expr))
         ((% %lexical-set ref arg)
-          (ir1->ir2
+          (to-cps
             arg
             (lambda (val)
               (make-update ref val (continuation (make-constant #f))))))
         ((% %library-define ref arg)
-          (ir1->ir2
+          (to-cps
             arg
             (lambda (val)
               (make-update ref val (continuation (make-constant #f))))))
@@ -99,7 +130,7 @@
           ; no-op
           (continuation (make-constant #f)))
         ((% %if test consequent alternate)
-          (ir1->ir2
+          (to-cps
             test
             (lambda (val)
               (define continuation-ref (new-ref))
@@ -108,11 +139,11 @@
                 (list (make-closure continuation-ref (list result-ref) #f
                         (continuation result-ref)))
                 (make-branch val
-                  (ir1->ir2
+                  (to-cps
                     consequent
                     (lambda (result)
                       (make-apply continuation-ref (list result))))
-                  (ir1->ir2
+                  (to-cps
                     alternate
                     (lambda (result)
                       (make-apply continuation-ref (list result)))))))))
@@ -121,7 +152,7 @@
           (define result (new-ref))
           (make-fix
             (list (make-closure return-address (list result) #f (continuation result)))
-            (ir1->ir2
+            (to-cps
               proc
               (lambda (f)
                 ; Technically the order of evaluation is unspecified.
@@ -136,15 +167,15 @@
                     (exprs '())
                     (loop (cdr args*)
                           (lambda (vals)
-                            (ir1->ir2
+                            (to-cps
                               (car args*)
                               (lambda (val)
                                 (exprs (cons val vals))))))))))))
         ((% %sequence head tail)
-          (ir1->ir2
+          (to-cps
             head
             (lambda (x)
-              (ir1->ir2
+              (to-cps
                 tail
                 continuation))))
         ((% %lambda args rest body)
@@ -153,7 +184,7 @@
           (make-fix
             (list
               (make-closure f (cons k args) rest
-                (ir1->ir2
+                (to-cps
                   body
                   (lambda (ret)
                     (make-apply k (list ret))))))
@@ -161,7 +192,7 @@
         ((% %letrec in-order? _ _ _ body)
           (define-values (functions variable-names variable-values) (collect-functions-and-variables expr))
           (make-fix functions
-            (ir1->ir2
+            (to-cps
               ; We re-write a letrec into a corresponding lambda form.
               (if in-order?
                 (loop for name in (reverse variable-names)
@@ -186,4 +217,130 @@
                     body)
                   variable-values))
               continuation)))
-        (_ (error "unexpected type in ir1->ir2" expr))))))
+        (_ (error "unexpected type in to-cps" expr))))
+
+
+    (define (make-ref-map)
+      (make-map
+        (lambda (ref)
+          (gensym->int (lexical-ref-gensym ref)))
+        (lambda (x y) (< (gensym->int (lexical-ref-gensym x))
+                         (gensym->int (lexical-ref-gensym y))))))
+
+
+    (define (get-boxed expr)
+      (match expr
+        ((% %update ref _ continuation)
+          (define m (get-boxed continuation))
+          (when (lexical-ref? ref)
+            (set! m (insert m ref #t)))
+          m)
+        ((% %primitive _ _ _ continuation)
+          (get-boxed continuation))
+        ((% %branch _ true false)
+          (merge
+            (get-boxed true)
+            (get-boxed false)))
+        ((% %apply proc args)
+          (make-ref-map))
+        ((% %fix funs body)
+          (loop with m = (get-boxed body)
+                for fun in funs
+                do (set! m (merge m (get-boxed (closure-body fun))))
+                finally (return m)))
+        (_ (error "Unexpected form in get-boxed"))))
+
+
+    (define (all-closure-args fun)
+      (define args (closure-arguments fun))
+      (define rest (closure-rest fun))
+      (when rest
+        (set! args (cons rest args)))
+      args)
+
+
+    ; Rewrites the given expression to have no more <update> forms.
+    (define (box-conversion expr)
+      (define boxed-refs (get-boxed expr))
+      (define (boxed? ref)
+        (or (library-ref? ref) ; globals are always boxed
+            (and (lexical-ref? ref)
+                 (guard (e ((key-not-found-error? e) #f))
+                   (lookup boxed-refs ref)))))
+      (define (convert-arg-list args)
+        (define boxed-args (loop for arg in args
+                                 if (boxed? arg)
+                                   collect arg))
+        (define vars (loop for x in boxed-args
+                           collect (new-ref)))
+        (define new-args (loop with v* = vars
+                               for arg in args
+                               collect (if (boxed? arg)
+                                         (car v*)
+                                         arg)
+                               if (boxed? arg)
+                                 do (set! v* (cdr v*))))
+        (values new-args boxed-args vars))
+      (let convert ((expr expr))
+        (match expr
+          ((% %update ref atom continuation)
+            (make-primitive 'poke (list atom ref (make-constant 0)) '() (convert continuation)))
+          ((% %primitive op args res continuation)
+            ; Note that no reference in res can be boxed.
+            (define-values (new-args boxed-args vars) (convert-arg-list args))
+            (define new-expr (make-primitive op new-args res (convert continuation)))
+            (loop for arg in boxed-args
+                  for var in vars
+                  do (set! new-expr (make-primitive 'peek (list arg (make-constant 0)) (list var)
+                                      new-expr))
+                  finally (return new-expr)))
+          ((% %branch atom true false)
+            (if (boxed? atom)
+              (let ((var (new-ref)))
+                (make-primitive 'peek (list atom (make-constant 0)) (list var)
+                                (make-branch var (convert true) (convert false))))
+              (make-branch atom (convert true) (convert false))))
+          ((% %apply proc args)
+            (define-values (new-params boxed-params vars) (convert-arg-list (cons proc args)))
+            (define new-expr (make-apply (car new-params) (cdr new-params)))
+            (loop for p in boxed-params
+                  for var in vars
+                  do (set! new-expr (make-primitive 'peek (list p (make-constant 0)) (list var)
+                                      new-expr))
+                  finally (return new-expr)))
+          ((% %fix funs body)
+            (define-values (new-names boxed-names temp-names) (convert-arg-list (loop for fun in funs
+                                                                                      collect (closure-name fun))))
+            (define new-funs (loop for fun in funs
+                                   for new-name in new-names
+                                   for rest = (closure-rest fun)
+                                   collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (all-closure-args fun))))
+                                             (make-closure
+                                               new-name
+                                               (if rest
+                                                 (cdr new-args)
+                                                 new-args)
+                                               (if rest
+                                                 (car new-args)
+                                                 #f)
+                                               (let ((new-expr (convert (closure-body fun))))
+                                                 (loop for arg in boxed-args
+                                                       for var in temp-args
+                                                       do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list arg)
+                                                                           (make-primitive 'poke (list var arg (make-constant 0)) '()
+                                                                             new-expr)))
+                                                       finally (return new-expr)))))))
+            (define new-body (convert body))
+            (loop for name in boxed-names
+                  for var in temp-names
+                  do (set! new-body (make-primitive 'poke (list var name (make-constant 0)) '()
+                                      new-body)))
+            (define new-expr (make-fix new-funs new-body))
+            (loop for name in boxed-names
+                  do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list name)
+                                      new-expr))
+                  finally (return expr))))))
+
+
+    (define (ir1->ir2 expr continuation)
+      (box-conversion (to-cps expr continuation)))))
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 40109fe..7aea0a3 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -1,5 +1,10 @@
 (define-library (csc ir2)
   (export
+    %apply
+    %branch
+    %closure
+    %fix
+    %primitive
     apply-arguments
     apply-procedure
     apply?
@@ -37,10 +42,12 @@
     make-kargs
     make-klabel
     make-ktail
-    make-update
-    update-atom
-    update-continuation
-    update-ref
+    make-primitive
+    primitive-arguments
+    primitive-continuation
+    primitive-operation
+    primitive-results
+    primitive?
 
     ; Re-exports from IR1.
     constant-expression
@@ -80,7 +87,8 @@
             loop
             return)
           (only (csc match)
-            define-match-record-type))
+            define-match-record-type
+            match))
   (begin
     ; This library defines the intermediate representation IR2.
     ; It's CPS time bitch.
@@ -92,26 +100,6 @@
     ;     - constant,
     ;     - lexical-ref,
     ;     - or library-ref
-    ;   After closure conversion, lexical refs are no longer allowed.
-    ;   Lexical refs are converted to one of the below data types.
-
-
-    ; A variable representing the address of a function in the same compilation
-    ; unit. This will be a constant after linking.
-    (define-match-record-type <label>
-      (make-label gensym)
-      label?
-      %label
-      (gensym label-gensym))
-
-
-    ; A local variable. This can be an argument to a function or the result of
-    ; a primitive.
-    (define-match-record-type <var>
-      (make-var gensym)
-      var?
-      %var
-      (gensym var-gensym))
 
 
     ; CPS expressions:
@@ -120,14 +108,21 @@
     ;   And they take a continuation.
 
 
-    ; Modifies a library or lexically bound variable to the given atom.
-    (define-match-record-type <update>
-      (make-update ref atom continuation)
-      update?
-      %update
-      (ref update-ref)
-      (atom update-atom)
-      (continuation update-continuation))
+    ; A primitive encodes one of a number of primitive operations.
+    ; Each operation takes a number of arguments,
+    ; and binds some number of result variables.
+    ; The known primitives are listed below, along with their arity.
+    ;   - alloc: size -> result
+    ;   - peek: pointer * offset -> result
+    ;   - poke: word * pointer * offset -> ()
+    (define-match-record-type <primitive>
+      (make-primitive operation arguments results continuation)
+      primitive?
+      %primitive
+      (operation primitive-operation)
+      (arguments primitive-arguments)
+      (results primitive-results)
+      (continuation primitive-continuation))
 
 
     ; Branches depending on the given atom.
@@ -190,28 +185,27 @@
 
 
     (define (ir2=?-sametype x y)
-      (cond
-        ((and (update? x) (update? y))
-          (and (ir1=? (update-ref x) (update-ref y))
-               (ir1=? (update-atom x) (update-atom y))
-               (ir2=? (update-continuation x) (update-continuation y))))
-        ((and (branch? x) (branch? y))
-          (and (ir1=? (branch-atom x) (branch-atom y))
-               (ir2=? (branch-true x) (branch-true y))
-               (ir2=? (branch-false x) (branch-false y))))
-        ((and (apply? x) (apply? y))
-          (let ((x-args (apply-arguments x))
-                (y-args (apply-arguments y)))
-            (and (ir1=? (apply-procedure x) (apply-procedure y))
-                 (= (length x-args) (length y-args))
-                 (all ir1=? x-args y-args))))
-        ((and (fix? x) (fix? y))
-          (let ((x-funs (fix-functions x))
-                (y-funs (fix-functions y)))
-            (and (= (length x-funs) (length y-funs))
-                 (all closure=? x-funs y-funs)
-                 (ir2=? (fix-body x) (fix-body y)))))
-        (else #f)))
+      (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)
+               (= (length x-res) (length y-res))
+               (all ir1=? 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)
+               (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)
+               (= (length x-args) (length y-args))
+               (all ir1=? 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)
-- 
cgit v1.3.1