Improve CPS.

Goodbye soup. Thanks to "Compiling with Continuations" by Appel.

9 files changed, 357 insertions, 431 deletions

diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index d51d10c..d3cfb6d 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -1,13 +1,10 @@
 (import (scheme base)
-        (only (csc hash-map)
-          map->alist)
         (only (csc ir1)
           make-call
           make-constant
           make-define-syntax
           make-if
           make-lambda
-          make-lambda-case
           make-letrec
           make-lexical-ref
           make-lexical-set
@@ -15,6 +12,8 @@
           make-sequence)
         (only (csc ir2)
           ir2=?
+          make-apply
+          make-fix
           make-atom
           make-branch
           make-call-closure
@@ -22,170 +21,143 @@
           make-kargs
           make-klabel
           make-ktail
-          make-lambda-args
           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))))
+(define (tail x)
+  (make-apply (make-lexical-ref 'tail #f) (list x)))
 
 
 (test atom-const
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel
-                (make-atom (make-constant 5) 1)))
-      (cons 1 (make-ktail)))
-    (soup->alist (ir1->ir2 (make-constant 5)))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f) (list (make-constant 5)))
+    (ir1->ir2 (make-constant 5) tail)))
 
 
 (test atom-lexical-ref
-  (assert-equal soup=?
-    (list
-      (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)))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'var #f)))
+    (ir1->ir2 (make-lexical-ref 'var #f) tail)))
 
 
 (test atom-library-ref
-  (assert-equal soup=?
-    (list
-      (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))))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f)
+      (list (make-library-ref 'var '(csc builtins))))
+    (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail)))
 
 
 (test lexical-set
-  (assert-equal soup=?
-    (list
-      (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))
-                (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))))))
+  (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))
+              tail)))
 
 
 (test no-op-define-syntax
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel (make-atom (make-constant #f) 1)))
-      (cons 1 (make-ktail)))
-    (soup->alist (ir1->ir2 (make-define-syntax 'name '(transformer))))))
+  (assert-equal ir2=?
+    (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f)))
+    (ir1->ir2 (make-define-syntax 'name '(transformer))
+              tail)))
 
 
 (test branch
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel (make-atom (make-constant #t) 4)))
-      (cons 1 (make-ktail))
-      (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)
-                  2 3))))
-    (soup->alist (ir1->ir2 (make-if (make-constant #t)
-                             (make-constant 1)
-                             (make-constant 2))))))
+  (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-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)))))
+    (ir1->ir2 (make-if (make-constant #t)
+                (make-constant 1)
+                (make-constant 2))
+              tail)))
 
 
 (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)))))))
+  (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-constant 1)
+                                                 (make-constant 2))))
+    (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2)))
+              tail)))
 
 
 (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))))))
+  (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)))
+              tail)))
 
 
 (test closure
-  (assert-equal soup=?
-    (list
-      (cons 0 (make-klabel
-                (make-closure
-                  (list (make-lambda-args 2 #t 3))
-                  1)))
-      (cons 1 (make-ktail))
-      (cons 2 (make-ktail))
-      (cons 3 (make-kargs (list (make-lexical-ref 'a #f)
-                                (make-lexical-ref 'b #f)
-                                (make-lexical-ref 'c #f))
-                (make-atom (make-constant 5) 2))))
-    (soup->alist (ir1->ir2 (make-lambda
-                             (make-lambda-case
-                               '(a b)
-                               'c
-                               '(#f #f #f)
-                               (make-constant 5)
-                               #f))))))
+  (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))))
+    (ir1->ir2 (make-lambda
+                (list (make-lexical-ref 'a #f) (make-lexical-ref 'b #f))
+                (make-lexical-ref 'c #f)
+                (make-constant 5))
+              tail)))
 
 
-(test letrec-to-lambda
-  (assert-equal soup=?
-    (list
-      ; God help you when it's time to debug this test.
-      (cons 0 (make-klabel
-                (make-closure
+(test letrec-in-order
+  (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-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-fix
+          (list
+            (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)
+                                                                        (make-lexical-ref 'a #f)) #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-fix
                   (list
-                    (make-lambda-args 1 #f 7))
-                  3)))
-      (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))
-                  1)))
-      (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-atom (make-constant #f) 2)))
-      (cons 4 (make-ktail))
-      (cons 5 (make-klabel
-                (make-atom (make-constant 2) 4)))
-      (cons 6 (make-kargs (list (make-lexical-ref 'generated-symbol #f))
-                (make-update (make-lexical-ref 'a #f) (make-lexical-ref 'generated-symbol #f) 5)))
-      (cons 7 (make-kargs (list (make-lexical-ref 'a #f))
-                 (make-atom (make-constant 1) 6))))
-    (soup->alist (ir1->ir2 (make-letrec
-                             #t
-                             '(a)
-                             '(#f)
-                             (list (make-constant 1))
-                             (make-constant 2))))))
+                    (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-constant 2)))))))
+          (make-apply (make-lexical-ref 'generated-symbol #f)
+                      (list (make-lexical-ref 'generated-symbol #f)
+                            (make-constant 1))))))
+    (ir1->ir2 (make-letrec
+                #t
+                '(a f b)
+                '(#f #f #f)
+                (list (make-constant 1)
+                      (make-lambda (list (make-lexical-ref 'x #f)) #f (make-constant 5))
+                      (make-constant 2))
+                (make-constant 10))
+              tail)))
diff --git a/csc/cps.csc b/csc/cps.csc
index 0c85707..cf4a26d 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -16,15 +16,13 @@
             if-consequent
             if-test
             if?
+            lambda-arguments
             lambda-body
-            lambda-case-alternate
-            lambda-case-arguments
-            lambda-case-body
-            lambda-case-gensyms
-            lambda-case-rest
+            lambda-rest
             lambda?
             letrec-expression
             letrec-gensyms
+            letrec-in-order?
             letrec-names
             letrec-values
             letrec?
@@ -39,7 +37,6 @@
             make-call
             make-constant
             make-lambda
-            make-lambda-case
             make-lexical-ref
             make-lexical-set
             make-sequence
@@ -47,14 +44,15 @@
             sequence-tail
             sequence?)
           (only (csc ir2)
+            make-apply
             make-atom
             make-branch
             make-call-closure
             make-closure
+            make-fix
             make-kargs
             make-klabel
             make-ktail
-            make-lambda-args
             make-update)
           (only (csc loop)
             loop
@@ -67,116 +65,132 @@
       (make-lexical-ref 'generated-symbol (gensym)))
 
 
-    (define (to-cps expr continuation add-continuation)
+    (define (collect-functions-and-variables expr)
+      (loop for name in (letrec-names expr)
+            for gensym in (letrec-gensyms expr)
+            for value in (letrec-values expr)
+            if (lambda? value)
+              collect (let ((continuation (new-ref)))
+                        (make-closure
+                          (make-lexical-ref name gensym)
+                          (cons continuation (lambda-arguments value))
+                          (lambda-rest value)
+                          (ir1->ir2
+                            (lambda-body value)
+                            (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)
       (cond
         ((or (constant? expr)
              (lexical-ref? expr)
              (library-ref? expr))
-          (make-atom expr continuation))
+          (continuation expr))
         ((lexical-set? expr)
-          (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)))
+          (ir1->ir2
+            (lexical-set-expression expr)
+            (lambda (val)
+              (make-update (lexical-set-ref expr) val (continuation (make-constant #f))))))
         ((library-define? expr)
-          (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)))
+          (ir1->ir2
+            (library-define-expression expr)
+            (lambda (val)
+              (make-update (library-define-ref expr) val (continuation (make-constant #f))))))
         ((define-syntax? expr)
           ; no-op
-          (make-atom (make-constant #f) continuation))
+          (continuation (make-constant #f)))
         ((if? expr)
-          (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)))
+          (ir1->ir2
+            (if-test expr)
+            (lambda (val)
+              (define continuation-ref (new-ref))
+              (define result-ref (new-ref))
+              (make-fix
+                (list (make-closure continuation-ref (list result-ref) #f
+                        (continuation result-ref)))
+                (make-branch val
+                  (ir1->ir2
+                    (if-consequent expr)
+                    (lambda (result)
+                      (make-apply continuation-ref (list result))))
+                  (ir1->ir2
+                    (if-alternate expr)
+                    (lambda (result)
+                      (make-apply continuation-ref (list result)))))))))
         ((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)))
+          (let ((return-address (new-ref))
+                (result (new-ref)))
+            (make-fix
+              (list (make-closure return-address (list result) #f (continuation result)))
+              (ir1->ir2
+                (call-procedure expr)
+                (lambda (f)
+                  ; Technically the order of evaluation is unspecified.
+                  ; We evaluate expressions left to right.
+                  ;
+                  ; I would use the loop macro, but it mutates the loop
+                  ; variables which plays badly with building a lambda.
+                  (let loop ((args (reverse (call-arguments expr)))
+                             (exprs (lambda (vals)
+                                      (make-apply f (cons return-address (reverse vals))))))
+                    (if (null? args)
+                      (exprs '())
+                      (loop (cdr args)
+                            (lambda (vals)
+                              (ir1->ir2
+                                (car args)
+                                (lambda (val)
+                                  (exprs (cons val vals)))))))))))))
         ((sequence? expr)
-          (to-cps
+          (ir1->ir2
             (sequence-head expr)
-            (add-continuation
-              (make-klabel
-                (to-cps (sequence-tail expr) continuation add-continuation)))
-            add-continuation))
+            (lambda (x)
+              (ir1->ir2
+                (sequence-tail expr)
+                continuation))))
         ((lambda? expr)
-          (make-closure
-            (loop with tail = (add-continuation (make-ktail))
-                  for lambda-case = (lambda-body expr) then (lambda-case-alternate lambda-case)
-                  while lambda-case
-                  collect (let ((args (lambda-case-arguments lambda-case))
-                                (rest (lambda-case-rest lambda-case)))
-                            (make-lambda-args
-                              (length args)
-                              (not (not rest))
-                              (add-continuation
-                                (make-kargs (map make-lexical-ref
-                                              (append args (list rest))
-                                              (lambda-case-gensyms lambda-case))
-                                  (to-cps (lambda-case-body lambda-case) tail add-continuation))))))
-            continuation))
+          (let ((f (new-ref))
+                (k (new-ref)))
+            (make-fix
+              (list
+                (make-closure f (cons k (lambda-arguments expr)) (lambda-rest expr)
+                  (ir1->ir2
+                    (lambda-body expr)
+                    (lambda (ret)
+                      (make-apply k (list ret))))))
+              (continuation f))))
         ((letrec? expr)
-          ; We re-write a letrec into a corresponding lambda form.
-          (let ((names (letrec-names expr))
-                (gensyms (letrec-gensyms expr)))
-            (to-cps
-              (make-call
-                (make-lambda
-                  (make-lambda-case
-                    names
-                    #f
-                    gensyms
-                    (make-sequence
-                      (loop for name in names
-                            for gensym in gensyms
-                            for value in (letrec-values expr)
-                            for set = (make-lexical-set (make-lexical-ref name gensym) value)
-                            for body = set then (make-sequence body set)
-                            finally (return body))
+          (let-values (((functions variable-names variable-values) (collect-functions-and-variables expr)))
+            (make-fix functions
+              (ir1->ir2
+                ; We re-write a letrec into a corresponding lambda form.
+                (if (letrec-in-order? expr)
+                  (loop for name in (reverse variable-names)
+                        for value in (reverse variable-values)
+                        for expr = (make-call
+                                     (make-lambda
+                                       (list name)
+                                       #f
+                                       (letrec-expression expr))
+                                     (list value))
+                                 then (make-call
+                                        (make-lambda
+                                          (list name)
+                                          #f
+                                          expr)
+                                        (list value))
+                        finally (return expr))
+                  (make-call
+                    (make-lambda
+                      variable-names
+                      #f
                       (letrec-expression expr))
-                    #f))
-                (map (lambda (x) (make-constant #f)) names))
-              continuation
-              add-continuation)))
-        (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)
-      (define current-continuation-id 0)
-      (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 (add-continuation (make-ktail)))
-      (define entrypoint (to-cps program ktail add-continuation))
-      (insert soup 0 (make-klabel entrypoint)))))
+                    variable-values))
+                continuation))))
+        (else (error "unexpected type in ir1->ir2" expr))))))
diff --git a/csc/ir1.csc b/csc/ir1.csc
index 26b885b..d82cf12 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -14,13 +14,9 @@
     if?
     import?
     ir1=?
+    lambda-arguments
     lambda-body
-    lambda-case-alternate
-    lambda-case-arguments
-    lambda-case-body
-    lambda-case-gensyms
-    lambda-case-rest
-    lambda-case?
+    lambda-rest
     lambda?
     letrec-expression
     letrec-gensyms
@@ -45,7 +41,6 @@
     make-define-syntax
     make-if
     make-lambda
-    make-lambda-case
     make-letrec
     make-lexical-ref
     make-lexical-set
@@ -56,6 +51,8 @@
     sequence-tail
     sequence?)
   (import (scheme base)
+          (only (csc list)
+            all)
           (only (csc loop) loop return))
   (begin
     ; This library defines the intermediate representation IR1. An expression
@@ -151,37 +148,16 @@
 
 
     ; <lambda> body
-    ; A closure. body is an expression of type <lambda-case>.
+    ; A closure. Arguments is a list of lexical-refs.
+    ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter.
     (define-record-type <lambda>
-      (make-lambda body)
+      (make-lambda arguments rest body)
       lambda?
+      (arguments lambda-arguments)
+      (rest lambda-rest)
       (body lambda-body))
 
 
-    ; <lambda-case> arguments rest gensyms body alternate
-    ; One clause of a case-lambda. A lambda expression in Scheme is treated as
-    ; a case-lambda with one clause.
-    ;
-    ; arguments is a list of the procedures arguments, as symbols. rest is the
-    ; name of the rest argument, or #f. gensyms is a list of gensyms
-    ; corresponding to all arguments: first all of the normal arguments, then
-    ; the rest argument if any.
-    ;
-    ; body is the name of the clause (??). If the procedure is called with an
-    ; appropriate number of arguments, body is evaluated in tail position.
-    ; Otherwise if there is an alternate, it should be a <lambda-case>
-    ; expression, representing the next clause to try. If alternate is #f, an
-    ; error is signaled.
-    (define-record-type <lambda-case>
-      (make-lambda-case arguments rest gensyms body alternate)
-      lambda-case?
-      (arguments lambda-case-arguments)
-      (rest lambda-case-rest)
-      (gensyms lambda-case-gensyms)
-      (body lambda-case-body)
-      (alternate lambda-case-alternate))
-
-
     ; <letrec> in-order? names gensyms values expression
     ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true.
     ; names are the original binding names, gensyms are gensyms corresponding
@@ -233,25 +209,27 @@
             (ir1=? (sequence-head x) (sequence-head y))
             (ir1=? (sequence-tail x) (sequence-tail y))))
         ((and (lambda? x) (lambda? y))
-          (ir1=? (lambda-body x) (lambda-body y)))
-        ((and (lambda-case? x) (lambda-case? y))
-          (and
-            (equal? (lambda-case-arguments x) (lambda-case-arguments y))
-            (eq? (lambda-case-rest x) (lambda-case-rest y))
-            (ir1=? (lambda-case-body x) (lambda-case-body y))
-            (or (and (null? (lambda-case-alternate x))
-                     (null? (lambda-case-alternate y)))
-                (ir1=? (lambda-case-alternate x) (lambda-case-alternate y)))))
+          (let ((x-args (lambda-arguments x))
+                (x-rest (lambda-rest x))
+                (y-args (lambda-arguments y))
+                (y-rest (lambda-rest y)))
+            (and (= (length x-args) (length y-args))
+                 (all ir1=? x-args y-args)
+                 (or (and (not x-rest) (not y-rest))
+                     (ir1=? x-rest y-rest))
+                 (ir1=? (lambda-body x) (lambda-body y)))))
         ((and (letrec? x) (letrec? y))
-          (and
-            (boolean=? (letrec-in-order? x) (letrec-in-order? y))
-            (map symbol=? (letrec-names x) (letrec-names y))
-            (= (length (letrec-values x)) (length (letrec-values y)))
-            (loop for x-val in (letrec-values x)
-                  for y-val in (letrec-values y)
-                  unless (ir1=? x-val y-val) return #f
-                  finally (return #t))
-            (ir1=? (letrec-expression x) (letrec-expression y))))
+          (let ((x-names (letrec-names x))
+                (x-values (letrec-values x))
+                (y-names (letrec-names y))
+                (y-values (letrec-values y)))
+            (and
+              (boolean=? (letrec-in-order? x) (letrec-in-order? y))
+              (= (length x-names) (length y-names))
+              (all symbol=? x-names y-names)
+              (= (length x-values) (length y-values))
+              (all ir1=? x-values y-values)
+              (ir1=? (letrec-expression x) (letrec-expression y)))))
         (else #f)))
 
 
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 1872b65..9b9397f 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -1,5 +1,8 @@
 (define-library (csc ir2)
   (export
+    apply-arguments
+    apply-procedure
+    apply?
     atom-continuation
     atom-expression
     atom?
@@ -10,9 +13,14 @@
     call-closure-args
     call-closure-closure
     call-closure?
-    closure-cases
-    closure-continuation
+    closure-arguments
+    closure-body
+    closure-name
+    closure-rest
     closure?
+    fix-body
+    fix-functions
+    fix?
     ir2=?
     kargs-expression
     kargs-refs
@@ -20,18 +28,15 @@
     klabel-expression
     klabel?
     ktail?
-    lambda-args-kargs
-    lambda-args-nargs
-    lambda-args-rest
-    lambda-args?
+    make-apply
     make-atom
     make-branch
     make-call-closure
     make-closure
+    make-fix
     make-kargs
     make-klabel
     make-ktail
-    make-lambda-args
     make-update
     update-atom
     update-continuation
@@ -91,23 +96,6 @@
     ;   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 atom and a continuation.
-    (define-record-type <atom>
-      (make-atom expression continuation)
-      atom?
-      (expression atom-expression)
-      (continuation atom-continuation))
-
 
     ; Modifies a library or lexically bound variable to the given atom.
     (define-record-type <update>
@@ -118,7 +106,7 @@
       (continuation update-continuation))
 
 
-    ; Evaluates the given atom.
+    ; Branches depending on the given atom.
     ; If it is true, continue with continuation true.
     ; If false, continue with continuation false.
     (define-record-type <branch>
@@ -129,99 +117,72 @@
       (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))
-
+    ; Applies a procedure to a list of arguments. Apply does not take a
+    ; continuation. Instead the continuation will be passed as the first
+    ; argument to the function.
+    (define-record-type <apply>
+      (make-apply procedure arguments)
+      apply?
+      (procedure apply-procedure)
+      (arguments apply-arguments))
 
-    ; One branch of a case-lambda. nargs encodes the number of required
-    ; arguments, and rest is a boolean indicating whether the function takes a
-    ; rest parameter. kargs is a continuation ID pointing to a
-    ; kargs continuation.
-    (define-record-type <lambda-args>
-      (make-lambda-args nargs rest kargs)
-      lambda-args?
-      (nargs lambda-args-nargs)
-      (rest lambda-args-rest)
-      (kargs lambda-args-kargs))
 
-
-    ; A lambda expression.
+    ; A procedure. All closures are allocated in a fix expression. A closure
+    ; does not take a continuation. Instead, the procedure will accept the
+    ; continuation as an argument.
     (define-record-type <closure>
-      (make-closure cases continuation)
+      (make-closure name arguments rest body)
       closure?
-      (cases closure-cases)
-      (continuation closure-continuation))
-
-
-    ; CPS continuations.
-
-
-    ; The tail continuation.
-    (define-record-type <ktail>
-      (make-ktail)
-      ktail?)
+      (name closure-name)
+      (arguments closure-arguments)
+      (rest closure-rest)
+      (body closure-body))
 
 
-    ; 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))
+    ; Defines a list of mutually recursive procedures.
+    ; Functions is a list of closures, and body is an expression.
+    (define-record-type <fix>
+      (make-fix functions body)
+      fix?
+      (functions fix-functions)
+      (body fix-body))
 
 
-    ; Ignores any incoming values and evaluates the given expression.
-    (define-record-type <klabel>
-      (make-klabel expression)
-      klabel?
-      (expression klabel-expression))
+    (define (closure=? x y)
+      (let ((x-args (closure-arguments x))
+            (x-rest (closure-rest x))
+            (y-args (closure-arguments y))
+            (y-rest (closure-rest y)))
+        (and (ir1=? (closure-name x) (closure-name y))
+             (= (length x-args) (length y-args))
+             (all ir1=? x-args y-args)
+             (or (and (not x-rest) (not y-rest))
+                 (and x-rest y-rest (ir1=? x-rest y-rest)))
+             (ir2=? (closure-body x) (closure-body y)))))
 
 
     (define (ir2=?-sametype x y)
       (cond
-        ((and (atom? x) (atom? y))
-          (and (ir1=? (atom-expression x) (atom-expression y))
-               (= (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))))
+               (ir2=? (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))
+               (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 (lambda (x) x) (map ir1=? x-args y-args))
-                 (= (call-closure-continuation x) (call-closure-continuation y)))))
-        ((and (lambda-args? x) (lambda-args? y))
-          (and (= (lambda-args-nargs x) (lambda-args-nargs y))
-               (boolean=? (lambda-args-rest x) (lambda-args-rest y))
-               (= (lambda-args-kargs x) (lambda-args-kargs y))))
-        ((and (closure? x) (closure? y))
-          (let ((x-cases (closure-cases x))
-                (y-cases (closure-cases y)))
-            (and (= (length x-cases) (length y-cases))
-                 (all (lambda (x) x) (map ir2=? x-cases y-cases))
-                 (= (closure-continuation x) (closure-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))
-                 (all (lambda (x) x) (map ir1=? x-refs y-refs))
-                 (ir2=? (kargs-expression x) (kargs-expression y)))))
-        ((and (klabel? x) (klabel? y))
-          (ir2=? (klabel-expression x) (klabel-expression y)))
+                 (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)))
 
 
diff --git a/csc/list-test.csc b/csc/list-test.csc
index faa90b6..e16feee 100644
--- a/csc/list-test.csc
+++ b/csc/list-test.csc
@@ -113,3 +113,9 @@
   (assert-equal
     #f
     (all (lambda (x) (= 0 (remainder x 2))) '(2 13 8))))
+
+
+(test all-equal
+  (assert-equal
+    #t
+    (all = '(1 2 3) '(1 2 3))))
diff --git a/csc/list.csc b/csc/list.csc
index cc64168..b1c2298 100644
--- a/csc/list.csc
+++ b/csc/list.csc
@@ -74,8 +74,12 @@
             finally (return (values xs ys))))
 
 
-    (define (all pred l)
-      (loop for x in l
-            unless (pred x)
+    (define (all pred . ls)
+      (loop for ls = ls then (map cdr ls)
+            while (loop for l in ls
+                        if (null? l)
+                          return #f
+                        finally (return #t))
+            unless (apply pred (map car ls))
               return #f
             finally (return #t)))))
diff --git a/csc/loop.csc b/csc/loop.csc
index a323495..dbd6200 100644
--- a/csc/loop.csc
+++ b/csc/loop.csc
@@ -88,12 +88,13 @@
                       clause* ...)))
         ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init then subseq clause* ...)
           (let ((first #t)
+                (init-value (lambda () init)) ; put the body of init outside the scope of x.
                 (x #f))
             (loop-aux "variable-clause-collector"
                       ((body ... (if first
                                    (begin
                                      (set! first #f)
-                                     (set! x init))
+                                     (set! x (init-value)))
                                    (set! x subseq)))
                        fin)
                       clause* ...)))
diff --git a/csc/macros-test.csc b/csc/macros-test.csc
index fd9d1ae..db78324 100644
--- a/csc/macros-test.csc
+++ b/csc/macros-test.csc
@@ -8,7 +8,6 @@
           lexical-set-expression
           lexical-set?
           make-constant
-          make-lambda-case
           make-letrec
           make-lexical-ref
           make-library-ref
@@ -177,28 +176,30 @@
       builtins-environment)))
 
 
-(test builtin-case-lambda-cases
+(test builtin-lambda-rest
   (assert-equal ir1=?
-    (make-lambda-case '(x y z) #f #f (make-sequence (make-constant #f) (make-constant 5))
-      (make-lambda-case '(a b c) 'd #f (make-sequence (make-constant #f) (make-constant 6)) '()))
+    (make-lambda (list
+                   (make-lexical-ref 'a #f)
+                   (make-lexical-ref 'b #f)
+                   (make-lexical-ref 'c #f))
+                 (make-lexical-ref 'd #f)
+                 (make-sequence (make-constant #f) (make-constant 5)))
     (expand
-      '(case-lambda
-         ((x y z) (quote 5))
-         ((a b c . d) (quote 6)))
+      '(lambda
+         (a b c . d) (quote 5))
       builtins-environment)))
 
 
 (test builtin-case-lambda-defines
   (assert-equal ir1=?
-    (make-lambda-case '(x) #f #f
+    (make-lambda (list (make-lexical-ref 'x #f)) #f
       (make-letrec #t '(a b) #f
         (list (make-constant 6)
               (make-lexical-ref 'a #f))
-        (make-sequence (make-constant #f) (make-constant 7))) '())
+        (make-sequence (make-constant #f) (make-constant 7))))
     (expand
-      '(case-lambda
-         ((x)
-           (builtin-define a (quote 6))
-           (builtin-define b a)
-           (quote 7)))
+      '(lambda (x)
+        (builtin-define a (quote 6))
+        (builtin-define b a)
+        (quote 7))
       builtins-environment)))
diff --git a/csc/macros.csc b/csc/macros.csc
index ff5b63a..6364e19 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -34,7 +34,6 @@
             make-call
             make-constant
             make-lambda
-            make-lambda-case
             make-letrec
             make-lexical-ref
             make-library-define
@@ -698,31 +697,21 @@
                   (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body)))))))))
 
 
-    (define (case-lambda-helper form)
-      (syntax-case form
-        ('() '())
-        (((formals . body) . clauses)
-          (let-values (((args rest) (split-args-rest formals)))
-            (make-lambda-case
-              args
-              rest
-              (map
-                (lambda (x) (gensym))
-                (if rest
-                  (cons rest args)
-                  args))
-              (expand-lambda-body body)
-              (case-lambda-helper clauses))))
-        (_ (raise-syntax-error "unexpected form in case-lambda-helper" form))))
-
-
-    (define builtin-case-lambda
+    (define builtin-lambda
       (make-macro-transformer
         (lambda (x)
           (syntax-case x
-            ((_ clause . clauses)
-              (case-lambda-helper (with-wrap (cons clause clauses) x)))
-            (_ (raise-syntax-error "unexpected form in case-lambda" x))))))
+            ((_ formals . body)
+              (let-values (((args rest) (split-args-rest formals)))
+                (make-lambda
+                  (map (lambda (name)
+                         (make-lexical-ref name (gensym)))
+                       args)
+                  (if rest
+                    (make-lexical-ref rest (gensym))
+                    #f)
+                  (expand-lambda-body body))))
+            (_ (raise-syntax-error "unexpected form in lambda" x))))))
 
 
     (define builtin-define
@@ -746,7 +735,7 @@
                 (cons '... (make-library-ref '... '(scheme base)))
                 (cons 'builtin-let-syntax builtin-let-syntax)
                 (cons 'quote builtin-quote)
-                (cons 'case-lambda builtin-case-lambda)
+                (cons 'lambda builtin-lambda)
                 (cons 'builtin-define builtin-define)))
         'main))