More CPS.

I improved the abstraction in to-cps.

3 files changed, 151 insertions, 62 deletions

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index 0aead27..ea1d177 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -2,17 +2,21 @@
         (only (csc hash-map)
           map->alist)
         (only (csc ir1)
+          make-call
           make-constant
           make-define-syntax
           make-if
           make-lexical-ref
           make-lexical-set
-          make-library-ref)
+          make-library-ref
+          make-sequence)
         (only (csc ir2)
           ir2=?
           make-atom
           make-branch
+          make-call-closure
           make-kargs
+          make-klabel
           make-ktail
           make-update)
         (only (csc loop)
@@ -42,7 +46,7 @@
 (test atom-const
   (assert-equal soup=?
     (list
-      (cons 0 (make-kargs '()
+      (cons 0 (make-klabel
                 (make-atom (make-constant 5) 1)))
       (cons 1 (make-ktail)))
     (soup->alist (ir1->ir2 (make-constant 5)))))
@@ -51,7 +55,7 @@
 (test atom-lexical-ref
   (assert-equal soup=?
     (list
-      (cons 0 (make-kargs '()
+      (cons 0 (make-klabel
                 (make-atom (make-lexical-ref 'var #f) 1)))
       (cons 1 (make-ktail)))
     (soup->alist (ir1->ir2 (make-lexical-ref 'var #f)))))
@@ -60,7 +64,7 @@
 (test atom-library-ref
   (assert-equal soup=?
     (list
-      (cons 0 (make-kargs '()
+      (cons 0 (make-klabel
                 (make-atom (make-library-ref 'var '(csc builtins)) 1)))
       (cons 1 (make-ktail)))
     (soup->alist (ir1->ir2 (make-library-ref 'var '(csc builtins))))))
@@ -69,7 +73,7 @@
 (test lexical-set
   (assert-equal soup=?
     (list
-      (cons 0 (make-kargs '()
+      (cons 0 (make-klabel
                 (make-atom (make-constant 5) 2)))
       (cons 1 (make-ktail))
       (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
@@ -81,7 +85,7 @@
 (test no-op-define-syntax
   (assert-equal soup=?
     (list
-      (cons 0 (make-kargs '() (make-atom (make-constant #f) 1)))
+      (cons 0 (make-klabel (make-atom (make-constant #f) 1)))
       (cons 1 (make-ktail)))
     (soup->alist (ir1->ir2 (make-define-syntax 'name '(transformer))))))
 
@@ -89,13 +93,40 @@
 (test branch
   (assert-equal soup=?
     (list
-      (cons 0 (make-kargs '() (make-atom (make-constant #t) 2)))
+      (cons 0 (make-klabel (make-atom (make-constant #t) 4)))
       (cons 1 (make-ktail))
-      (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
+      (cons 2 (make-klabel (make-atom (make-constant 1) 1)))
+      (cons 3 (make-klabel (make-atom (make-constant 2) 1)))
+      (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
                 (make-branch (make-lexical-ref 'generated-symbol #f)
-                  3 4)))
-      (cons 3 (make-kargs '() (make-atom (make-constant 1) 1)))
-      (cons 4 (make-kargs '() (make-atom (make-constant 2) 1))))
+                  2 3))))
     (soup->alist (ir1->ir2 (make-if (make-constant #t)
                              (make-constant 1)
                              (make-constant 2))))))
+
+
+(test call-closure
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-klabel (make-atom (make-lexical-ref 'f #f) 4)))
+      (cons 1 (make-ktail))
+      (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
+                (make-call-closure (make-lexical-ref 'generated-symbol #f)
+                  (list (make-lexical-ref 'generated-symbol #f)
+                        (make-lexical-ref 'generated-symbol #f))
+                  1)))
+      (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
+                (make-atom (make-constant 2) 2)))
+      (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
+                (make-atom (make-constant 1) 3))))
+    (soup->alist (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2)))))))
+
+
+(test sequence
+  (assert-equal soup=?
+    (list
+      (cons 0 (make-klabel (make-atom (make-constant 1) 2)))
+      (cons 1 (make-ktail))
+      (cons 2 (make-klabel (make-atom (make-constant 2) 1))))
+    (soup->alist (ir1->ir2 (make-sequence (make-constant 1)
+                                          (make-constant 2))))))
diff --git a/csc/cps.csc b/csc/cps.csc
index e60e198..55e7e81 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -3,10 +3,13 @@
     ir1->ir2)
   (import (only (csc gensym) gensym)
           (only (csc hash-map)
-            alist->map
             insert
+            make-map
             merge)
           (only (csc ir1)
+            call-arguments
+            call-procedure
+            call?
             constant?
             define-syntax?
             if-alternate
@@ -22,69 +25,86 @@
             library-define?
             library-ref?
             make-constant
-            make-lexical-ref)
+            make-lexical-ref
+            sequence-head
+            sequence-tail
+            sequence?)
           (only (csc ir2)
             make-atom
             make-branch
+            make-call-closure
             make-kargs
+            make-klabel
             make-ktail
             make-update)
+          (only (csc loop)
+            loop
+            return)
           (scheme base))
   (begin
 
 
-    (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)
+    (define (to-cps expr continuation add-continuation)
       (cond
         ((or (constant? expr)
              (lexical-ref? expr)
              (library-ref? expr))
-          (values (make-atom expr continuation) (make-soup)))
+          (make-atom expr continuation))
         ((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))))
+          (let ((ref (new-ref)))
+            (to-cps
+              (lexical-set-expression expr)
+              (add-continuation
+                (make-kargs (list ref)
+                  (make-update (lexical-set-ref expr) ref continuation)))
+              add-continuation)))
         ((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))))
+          (let ((ref (new-ref)))
+            (to-cps
+              (library-define-expression expr)
+              (add-continuation
+                (make-kargs (list ref)
+                  (make-update (library-define-ref expr) ref continuation)))
+              add-continuation)))
         ((define-syntax? expr)
           ; no-op
-          (values (make-atom (make-constant #f) continuation) (make-soup)))
+          (make-atom (make-constant #f) continuation))
         ((if? expr)
-          (let-values (((id) (next-id))
-                       ((test-ref) (new-ref))
-                       ((true-id) (next-id))
-                       ((false-id) (next-id))
-                       ((true-expr true-soup) (to-cps (if-consequent expr) continuation next-id))
-                       ((false-expr false-soup) (to-cps (if-alternate expr) continuation next-id)))
-            (cps-merge
-              (merge true-soup false-soup
-                (make-soup (cons id (make-kargs (list test-ref)
-                                      (make-branch test-ref true-id false-id)))
-                           (cons true-id (make-kargs '() true-expr))
-                           (cons false-id (make-kargs '() false-expr))))
-              (to-cps (if-test expr) id next-id))))
+          (let* ((true-id (add-continuation
+                            (make-klabel
+                              (to-cps (if-consequent expr) continuation add-continuation))))
+                 (false-id (add-continuation
+                             (make-klabel
+                               (to-cps (if-alternate expr) continuation add-continuation))))
+                 (test-ref (new-ref))
+                 (branch-id (add-continuation
+                              (make-kargs (list test-ref)
+                                (make-branch test-ref true-id false-id)))))
+            (to-cps (if-test expr) branch-id add-continuation)))
+        ((call? expr)
+          ; Technically the order of evaluation is unspecified. We evaluate
+          ; expressions left to right.
+          (loop with terms = (cons (call-procedure expr) (call-arguments expr))
+                with temps = (map (lambda (x) (new-ref)) terms)
+                with expr = (make-call-closure (car temps) (cdr temps) continuation)
+                for term in (reverse terms)
+                for temp in (reverse temps)
+                do (set! expr (to-cps term
+                                (add-continuation
+                                  (make-kargs (list temp) expr))
+                                add-continuation))
+                finally (return expr)))
+        ((sequence? expr)
+          (to-cps
+            (sequence-head expr)
+            (add-continuation
+              (make-klabel
+                (to-cps (sequence-tail expr) continuation add-continuation)))
+            add-continuation))
         (else (error "unexpected type in to-cps" expr))))
 
 
@@ -92,11 +112,13 @@
     ; By convention the continuation at key 0 is the entrypoint.
     (define (ir1->ir2 program)
       (define current-continuation-id 0)
-      (define (next-id)
+      (define soup (make-map (lambda (x) x) <))
+      (define (add-continuation continuation)
         (set! current-continuation-id (+ 1 current-continuation-id))
+        (set! soup (insert soup
+                     current-continuation-id
+                     continuation))
         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)))
+      (define ktail (add-continuation (make-ktail)))
+      (define entrypoint (to-cps program ktail add-continuation))
+      (insert soup 0 (make-klabel entrypoint)))))
diff --git a/csc/ir2.csc b/csc/ir2.csc
index bd2c1b6..fc31ce3 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -7,14 +7,21 @@
     branch-false
     branch-true
     branch?
+    call-closure-args
+    call-closure-closure
+    call-closure?
     ir2=?
     kargs-expression
     kargs-refs
     kargs?
+    klabel-expression
+    klabel?
     ktail?
     make-atom
     make-branch
+    make-call-closure
     make-kargs
+    make-klabel
     make-ktail
     make-update
     update-atom
@@ -112,6 +119,15 @@
       (false branch-false))
 
 
+    ; Calls the given closure. Closure is an atom, and args is a list of atoms.
+    (define-record-type <call-closure>
+      (make-call-closure closure args continuation)
+      call-closure?
+      (closure call-closure-closure)
+      (args call-closure-args)
+      (continuation call-closure-continuation))
+
+
     ; CPS continuations.
 
 
@@ -130,6 +146,13 @@
       (expression kargs-expression))
 
 
+    ; Ignores any incoming values and evaluates the given expression.
+    (define-record-type <klabel>
+      (make-klabel expression)
+      klabel?
+      (expression klabel-expression))
+
+
     (define (ir2=?-sametype x y)
       (cond
         ((and (atom? x) (atom? y))
@@ -139,6 +162,21 @@
           (and (ir1=? (update-ref x) (update-ref y))
                (ir1=? (update-atom x) (update-atom y))
                (= (update-continuation x) (update-continuation y))))
+        ((and (branch? x) (branch? y))
+          (and (ir1=? (branch-atom x) (branch-atom y))
+               (= (branch-true x) (branch-true y))
+               (= (branch-false x) (branch-false y))))
+        ((and (call-closure? x) (call-closure? y))
+          (let ((x-args (call-closure-args x))
+                (y-args (call-closure-args y)))
+            (and (ir1=? (call-closure-closure x) (call-closure-closure y))
+                 (= (length x-args) (length y-args))
+                 (loop for x-arg in (call-closure-args x)
+                       for y-arg in (call-closure-args y)
+                       unless (ir1=? x-arg y-arg)
+                         return #f
+                       finally (return #t))
+                 (= (call-closure-continuation x) (call-closure-continuation y)))))
         ((and (ktail? x) (ktail? y)) #t)
         ((and (kargs? x) (kargs? y))
           (let ((x-refs (kargs-refs x))
@@ -150,10 +188,8 @@
                          return #f
                        finally (return #t))
                  (ir2=? (kargs-expression x) (kargs-expression y)))))
-        ((and (branch? x) (branch? y))
-          (and (ir1=? (branch-atom x) (branch-atom y))
-               (= (branch-true x) (branch-true y))
-               (= (branch-false x) (branch-false y))))
+        ((and (klabel? x) (klabel? y))
+          (ir2=? (klabel-expression x) (klabel-expression y)))
         (else #f)))