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/ir2.csc | 104 ++++++++++++++++++++++++++++--------------------------------
 1 file changed, 49 insertions(+), 55 deletions(-)

(limited to 'csc/ir2.csc')

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