More CPS.

I improved the abstraction in to-cps.

1 files changed, 69 insertions, 47 deletions

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)))))