Continue work on continuation passing style.

6 files changed, 235 insertions, 43 deletions

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index dd66078..5bd6c1a 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -1,18 +1,75 @@
 (import (scheme base)
+        (only (csc hash-map)
+          map->alist)
+        (only (csc ir1)
+          make-constant
+          make-lexical-ref
+          make-lexical-set
+          make-library-ref)
         (only (csc ir2)
           ir2=?
           make-atom
-          make-tail
-          make-constant)
+          make-kargs
+          make-ktail
+          make-update)
+        (only (csc loop)
+          loop
+          return)
+        (only (csc sort) sort)
         (only (csc testing)
           assert-equal
           test)
         (csc cps))
 
 
+(define (soup->alist s)
+  (sort (lambda (x y) (< (car x) (car y))) (map->alist s)))
+
+
+(define (soup=? x y)
+  (and (= (length x) (length y))
+       (loop for x* in x
+             for y* in y
+             unless (and (= (car x*) (car y*))
+                         (ir2=? (cdr x*) (cdr y*)))
+               return #f
+             finally (return #t))))
+
+
 (test atom-const
-  (assert-equal ir2=?
-    (make-atom
-      (make-constant 5)
-      (make-tail))
-    (ir1->ir2 (make-constant 5))))
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-kargs '()
+                (make-atom (make-constant 5) 1)))
+      (cons 1 (make-ktail)))
+    (soup->alist (ir1->ir2 (make-constant 5)))))
+
+
+(test atom-lexical-ref
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-kargs '()
+                (make-atom (make-lexical-ref 'var #f) 1)))
+      (cons 1 (make-ktail)))
+    (soup->alist (ir1->ir2 (make-lexical-ref 'var #f)))))
+
+
+(test atom-library-ref
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-kargs '()
+                (make-atom (make-library-ref 'var '(csc builtins)) 1)))
+      (cons 1 (make-ktail)))
+    (soup->alist (ir1->ir2 (make-library-ref 'var '(csc builtins))))))
+
+
+(test lexical-set
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-kargs '()
+                (make-atom (make-constant 5) 2)))
+      (cons 1 (make-ktail))
+      (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
+                (make-update (make-lexical-ref 'var #f)
+                             (make-lexical-ref 'generated-symbol #f) 1))))
+    (soup->alist (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5))))))
diff --git a/csc/cps.csc b/csc/cps.csc
index bd4f088..26e0591 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -1,26 +1,79 @@
 (define-library (csc cps)
   (export
     ir1->ir2)
-  (import (only (csc ir1)
-            make-constant
+  (import (only (csc gensym) gensym)
+          (only (csc hash-map)
+            alist->map
+            insert
+            merge)
+          (only (csc ir1)
             constant?
             lexical-ref?
-            library-ref?)
+            lexical-set-expression
+            lexical-set-ref
+            lexical-set?
+            library-define-expression
+            library-define-ref
+            library-define?
+            library-ref?
+            make-constant
+            make-lexical-ref)
           (only (csc ir2)
             make-atom
-            make-tail)
+            make-kargs
+            make-ktail
+            make-update)
           (scheme base))
   (begin
 
 
-    (define (to-cps expr continuation)
+    (define (make-soup . l)
+      (alist->map (lambda (x) x) < l))
+
+
+    (define (new-ref)
+      (make-lexical-ref 'generated-symbol (gensym)))
+
+
+    (define-syntax cps-merge
+      (syntax-rules ()
+        ((cps-merge new-continuations sub-cps)
+          (let-values (((expr soup) sub-cps))
+            (values expr (merge soup new-continuations))))))
+
+
+    (define (to-cps expr continuation next-id)
       (cond
         ((or (constant? expr)
              (lexical-ref? expr)
              (library-ref? expr))
-          (make-atom expr continuation))
+          (values (make-atom expr continuation) (make-soup)))
+        ((lexical-set? expr)
+          (let ((id (next-id))
+                (ref (new-ref)))
+            (cps-merge
+              (make-soup (cons id (make-kargs (list ref)
+                                    (make-update (lexical-set-ref expr) ref continuation))))
+              (to-cps (lexical-set-expression expr) id next-id))))
+        ((library-define? expr)
+          (let ((id (next-id))
+                (ref (new-ref)))
+            (cps-merge
+              (make-soup (cons id (make-kargs (list ref)
+                                    (make-update (library-define-ref expr) ref continuation))))
+              (to-cps (library-define-expression expr) id next-id))))
         (else (error "unexpected type in to-cps" expr))))
 
 
+    ; Returns a map from integers to CPS continuations.
+    ; By convention the continuation at key 0 is the entrypoint.
     (define (ir1->ir2 program)
-      (to-cps program (make-tail)))))
+      (define current-continuation-id 0)
+      (define (next-id)
+        (set! current-continuation-id (+ 1 current-continuation-id))
+        current-continuation-id)
+      (define ktail (next-id))
+      (define-values (expr m) (to-cps program ktail next-id))
+      (set! m (insert m ktail (make-ktail)))
+      (set! m (insert m 0 (make-kargs '() expr)))
+      m)))
diff --git a/csc/ir1.csc b/csc/ir1.csc
index ab60fc9..76faef9 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -32,12 +32,10 @@
     lexical-ref-name
     lexical-ref?
     lexical-set-expression
-    lexical-set-gensym
-    lexical-set-name
+    lexical-set-ref
     lexical-set?
     library-define-expression
-    library-define-library
-    library-define-name
+    library-define-ref
     library-define?
     library-ref-library
     library-ref-name
@@ -97,21 +95,19 @@
     ; <lexical-set> name gensym expression
     ; Sets a lexically-bound variable.
     (define-record-type <lexical-set>
-      (make-lexical-set name gensym expression)
+      (make-lexical-set ref expression)
       lexical-set?
-      (name lexical-set-name)
-      (gensym lexical-set-gensym)
+      (ref lexical-set-ref)
       (expression lexical-set-expression))
 
 
     ; <library-define> name expression
     ; Defines a new variable in the current library.
     (define-record-type <library-define>
-      (make-library-define name expression library)
+      (make-library-define ref expression)
       library-define?
-      (name library-define-name)
-      (expression library-define-expression)
-      (library library-define-library))
+      (ref library-define-ref)
+      (expression library-define-expression))
 
 
     ; <define-syntax> name transformer
@@ -212,7 +208,7 @@
           (equal? (library-ref-library x) (library-ref-library y)))
         ((and (lexical-set? x) (lexical-set? y))
           (and
-            (symbol=? (lexical-set-name x) (lexical-set-name y))
+            (ir1=? (lexical-set-ref x) (lexical-set-ref y))
             (ir1=? (lexical-set-expression x) (lexical-set-expression y))))
         ((and (library-define? x) (library-define? y))
           (and
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 708d7b1..6ab0705 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -4,28 +4,82 @@
     atom-expression
     atom?
     ir2=?
+    kargs-expression
+    kargs-refs
+    kargs?
+    ktail?
     make-atom
-    make-tail
-    tail?
+    make-kargs
+    make-ktail
+    make-update
+    update-atom
+    update-continuation
+    update-ref
 
     ; Re-exports from IR1.
     constant-expression
     constant?
-    make-constant)
+    lexical-ref-gensym
+    lexical-ref-name
+    lexical-ref?
+    library-ref-library
+    library-ref-name
+    library-ref?
+    make-constant
+    make-lexical-ref
+    lexical-set-expression
+    lexical-set-ref
+    lexical-set?
+    make-lexical-set
+    make-library-ref)
   (import (scheme base)
           (only (csc ir1)
             constant?
             ir1=?
-            make-constant))
+            lexical-ref-gensym
+            lexical-ref-name
+            lexical-ref?
+            lexical-set-expression
+            lexical-set-ref
+            lexical-set?
+            library-ref-library
+            library-ref-name
+            library-ref?
+            make-constant
+            make-lexical-ref
+            make-lexical-set
+            make-library-ref)
+          (only (csc loop)
+            loop
+            return))
   (begin
     ; This library defines the intermediate representation IR2.
     ; It's CPS time bitch.
 
+    ; CPS atom:
+    ;   An atom is a value that can be computed immediately without
+    ;   any subexpressions.
+    ;   Atoms consist of
+    ;     - constant,
+    ;     - lexical-ref,
+    ;     - or library-ref
+
+    ; CPS expressions:
+    ;   CPS expressions are similar to IR1 expressions,
+    ;   but constrained not to have any subexpressions except atoms.
+    ;   And they take a continuation.
+
+    ; CPS continuations
+    ;   There are a few continuations.
+    ;   Continuations are identified by an integer ID into the
+    ;   continuation map.
+    ;   Guile calls this map the "continuation soup".
+
 
     ; CPS expressions.
 
 
-    ; An atom consists of an ir1 expression and a continuation.
+    ; An atom consists of an atom and a continuation.
     (define-record-type <atom>
       (make-atom expression continuation)
       atom?
@@ -33,21 +87,53 @@
       (continuation atom-continuation))
 
 
+    ; Modifies a library or lexically bound variable to the given atom.
+    (define-record-type <update>
+      (make-update ref atom continuation)
+      update?
+      (ref update-ref)
+      (atom update-atom)
+      (continuation update-continuation))
+
+
     ; CPS continuations.
 
 
-    ; tail is the tail continuation.
-    (define-record-type <tail>
-      (make-tail)
-      tail?)
+    ; The tail continuation.
+    (define-record-type <ktail>
+      (make-ktail)
+      ktail?)
+
+
+    ; Binds the incoming values to the given lexically-bound variables
+    ; and then evaluates expression.
+    (define-record-type <kargs>
+      (make-kargs refs expression)
+      kargs?
+      (refs kargs-refs)
+      (expression kargs-expression))
 
 
     (define (ir2=?-sametype x y)
       (cond
         ((and (atom? x) (atom? y))
           (and (ir1=? (atom-expression x) (atom-expression y))
-               (ir2=? (atom-continuation x) (atom-continuation y))))
-        ((and (tail? x) (tail? y)) #t)
+               (= (atom-continuation x) (atom-continuation y))))
+        ((and (update? x) (update? y))
+          (and (ir1=? (update-ref x) (update-ref y))
+               (ir1=? (update-atom x) (update-atom y))
+               (= (update-continuation x) (update-continuation y))))
+        ((and (ktail? x) (ktail? y)) #t)
+        ((and (kargs? x) (kargs? y))
+          (let ((x-refs (kargs-refs x))
+                (y-refs (kargs-refs y)))
+            (and (= (length x-refs) (length y-refs))
+                 (loop for x-ref in x-refs
+                       for y-ref in y-refs
+                       unless (ir1=? x-ref y-ref)
+                         return #f
+                       finally (return #t))
+                 (ir2=? (kargs-expression x) (kargs-expression y)))))
         (else #f)))
 
 
diff --git a/csc/macros-test.csc b/csc/macros-test.csc
index 92fda88..fd9d1ae 100644
--- a/csc/macros-test.csc
+++ b/csc/macros-test.csc
@@ -6,7 +6,6 @@
           lexical-ref-name
           lexical-ref?
           lexical-set-expression
-          lexical-set-name
           lexical-set?
           make-constant
           make-lambda-case
diff --git a/csc/macros.csc b/csc/macros.csc
index dfcfa64..ff5b63a 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -27,7 +27,7 @@
             lexical-ref-gensym
             lexical-ref?
             library-define-expression
-            library-define-name
+            library-define-ref
             library-define?
             library-ref-name
             library-ref?
@@ -681,7 +681,7 @@
             (define expanded-expr (expand-syntax-object expr))
             (cond
               ((library-define? expanded-expr)
-                (let ((name (library-define-name expanded-expr))
+                (let ((name (library-ref-name (library-define-ref expanded-expr)))
                       (g (gensym)))
                   (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body))
                         (cons name names)
@@ -731,9 +731,10 @@
           (syntax-case x
             ((_ symbol expression)
               (make-library-define
-                (identifier-name symbol)
-                (expand-syntax-object expression)
-                (environment-library (syntax-object-environment x))))
+                (make-library-ref
+                  (identifier-name symbol)
+                  (environment-library (syntax-object-environment x)))
+                (expand-syntax-object expression)))
             (_ (raise-syntax-error "unexpected form in builtin-define" x))))))