Fix test failures.

3 files changed, 115 insertions, 97 deletions

diff --git a/csc/codegen-test.csc b/csc/codegen-test.csc
index ef1c88b..29d1da5 100644
--- a/csc/codegen-test.csc
+++ b/csc/codegen-test.csc
@@ -36,11 +36,11 @@
     (test codegen-apply
       (define p (test-var))
       (assert-equal
-        '((label init)
-          (peek (local 1) (local 0) (const 5))
+        '((peek (local 1) (local 0) (const 5))
           (mov (local 2) (local 1))
           (mov (local 1) (const 10))
-          (jmp (local 2)))
+          (jmp (local 2))
+          (label 0))
         (ir2->ir3
           (make-fix '()
             (make-primitive 'peek (list *globals* (make-constant 5)) (list p)
@@ -50,12 +50,12 @@
     (test codegen-call-global
       (define p (test-var))
       (assert-equal
-        '((label init)
-          (peek (local 1) (local 0) (global cons (csc based)))
+        '((peek (local 1) (local 0) (global cons (csc based)))
           (mov (local 3) (local 1))
           (mov (local 1) (const 5))
           (mov (local 2) (const ()))
-          (jmp (local 3)))
+          (jmp (local 3))
+          (label 0))
         (ir2->ir3
           (make-fix '()
             (make-primitive 'peek (list *globals* (make-library-ref 'cons '(csc based))) (list p)
@@ -66,12 +66,12 @@
       (define f (test-label))
       (define ret (test-var))
       (assert-equal
-        '((label 0)
+        '((mov (local 1) (label 1))
+          (jmp (label 1))
+          (label 1)
           (mov (local 2) (local 1))
           (jmp (local 2))
-          (label init)
-          (mov (local 1) (label 0))
-          (jmp (label 0)))
+          (label 0))
         (ir2->ir3
           (make-fix
             (list (make-closure f (list ret)
@@ -88,20 +88,20 @@
       (define g2 (test-var))
       (define g3 (test-var))
       (assert-equal
-        '((label 0)
+        '((mov (local 1) (const 0))
+          (mov (local 2) (const 1))
+          (jmp (label 1))
+          (label 1)
           (mov (local 127) (local 1))
           (mov (local 1) (local 2))
           (mov (local 2) (local 127))
           (mov (local 3) (const 0))
-          (jmp (label 1))
-          (label 1)
+          (jmp (label 2))
+          (label 2)
           (mov (local 2) (local 1))
           (mov (local 1) (local 3))
-          (jmp (label 0))
-          (label init)
-          (mov (local 1) (const 0))
-          (mov (local 2) (const 1))
-          (jmp (label 0)))
+          (jmp (label 1))
+          (label 0))
         (ir2->ir3
           (make-fix
             (list (make-closure f (list f1 f2)
@@ -114,16 +114,16 @@
     (test codegen-branch
       (define p (test-var))
       (assert-equal
-        '((label init)
-          (peek (local 1) (local 0) (const 1))
-          (jmpif (const #t) (label 0))
+        '((peek (local 1) (local 0) (const 1))
+          (jmpif (const #t) (label 1))
           (mov (local 2) (local 1))
           (mov (local 1) (const 10))
           (jmp (local 2))
-          (label 0)
+          (label 1)
           (mov (local 2) (local 1))
           (mov (local 1) (const 5))
-          (jmp (local 2)))
+          (jmp (local 2))
+          (label 0))
         (ir2->ir3
           (make-fix '()
             (make-primitive 'peek (list *globals* (make-constant 1)) (list p)
diff --git a/csc/cps-test.csc b/csc/cps-test.csc
index 6439d78..156ba60 100644
--- a/csc/cps-test.csc
+++ b/csc/cps-test.csc
@@ -477,14 +477,13 @@
       (define ret-sym (gensym))
       (define x-sym (gensym))
       (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list (test-var))
-          (make-fix
-            (list
-              (make-closure (make-label (gensym)) (list (test-var) (test-var) (test-var))
-                (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
-                  (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '()
-                    (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
-                      (make-apply (test-var) (list (test-var) (make-constant #f))))))))
+        (make-fix
+          (list (make-closure (make-label (gensym)) (list (test-var) (test-var) (test-var))
+                  (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
+                    (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '()
+                      (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
+                        (make-apply (test-var) (list (test-var) (make-constant #f))))))))
+          (make-primitive 'alloc (list (make-constant 1)) (list (test-var))
             (make-primitive 'alloc (list (make-constant 2)) (list (test-var))
               (make-primitive 'poke (list (make-label (gensym)) (test-var) (make-constant 0)) '()
                 (make-primitive 'poke (list (test-var) (test-var) (make-constant 1)) '()
diff --git a/csc/cps.csc b/csc/cps.csc
index cdd6611..0dc8a96 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -447,6 +447,24 @@
           continuation)))
 
 
+    (define (hoist expr)
+      (define functions '())
+      (define body
+        (let hoist ((expr expr))
+          (match expr
+            ((% %primitive op args res cont)
+              (make-primitive op args res (hoist cont)))
+            ((% %branch atom true false)
+              (make-branch atom (hoist true) (hoist false)))
+            ((% %apply . _) expr)
+            ((% %tail) expr)
+            ((% %fix funs body)
+              (set! functions (append funs functions))
+              (hoist body))
+            (_ (error "Unexpected form in hoist" expr)))))
+      (make-fix functions body))
+
+
     (define (free-vars-expr expr bound-vars)
       (define (free? ref)
         (and (lexical-ref? ref)
@@ -514,70 +532,71 @@
     ; converts a CPS expression into an equivalent expression with no
     ; free variables.
     (define (closure-convert expr)
-      (let convert ((expr expr)
-                    (env (make-ref-map)))
-        (define (translate ref)
-          (translate-ref ref env))
-        (match expr
-          ((% %primitive op args res continuation)
-            (loop for r in res
-                  do (set! env (insert env r (make-variable (gensym)))))
-            (make-primitive op (map translate args) (map translate res) (convert continuation env)))
-          ((% %branch atom true false)
-            (make-branch (translate atom) (convert true env) (convert false env)))
-          ((% %apply proc args)
-            (let ((p (translate proc))
-                  (fn (make-variable (gensym))))
-              (make-primitive 'peek (list p (make-constant 0)) (list fn)
-                (make-apply fn (cons p (map translate args))))))
-          ((% %tail)
-            *tail*)
-          ((% %fix functions body)
-            (define frees (map free-vars functions))
-            (define fn-ptrs (loop for fun in functions
-                                  collect (make-label (gensym))))
-            (define converted-functions (loop for fun in functions
-                                              for fn-ptr in fn-ptrs
-                                              for free-list in frees
-                                              for env* = env
-                                              for name = (closure-name fun)
-                                              for closure = (make-variable (gensym))
-                                              if (lexical-ref? name)
-                                                do (set! env* (insert env* name closure))
-                                              do (loop for arg in (closure-arguments fun)
-                                                       do (set! env* (insert env* arg (make-variable (gensym)))))
-                                                 (loop for var in free-list
-                                                       do (set! env* (insert env* var (make-variable (gensym)))))
-                                              collect (let ((new-body (convert (closure-body fun) env*)))
-                                                        (loop for var in free-list
-                                                              for i from 0
-                                                              do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*))
-                                                                                  new-body)))
-                                                        (make-closure
-                                                          fn-ptr
-                                                          (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun)))
-                                                          new-body))))
-            (loop for fun in functions
-                  for name = (closure-name fun)
-                  if (lexical-ref? name)
-                    do (set! env (insert env name (make-variable (gensym)))))
-            (let ((new-body (convert body env)))
-              ; Build the closures.
-              (loop for fun in functions
-                    for free-list in frees
-                    for ptr in fn-ptrs
-                    for closure = (translate (closure-name fun))
-                    do (loop for var in free-list
-                             for i from 1
-                             do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '()
-                                                 new-body)))
-                       (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '()
-                                        new-body)))
-              ; Allocate the closures.
+      (hoist
+        (let convert ((expr expr)
+                      (env (make-ref-map)))
+          (define (translate ref)
+            (translate-ref ref env))
+          (match expr
+            ((% %primitive op args res continuation)
+              (loop for r in res
+                    do (set! env (insert env r (make-variable (gensym)))))
+              (make-primitive op (map translate args) (map translate res) (convert continuation env)))
+            ((% %branch atom true false)
+              (make-branch (translate atom) (convert true env) (convert false env)))
+            ((% %apply proc args)
+              (let ((p (translate proc))
+                    (fn (make-variable (gensym))))
+                (make-primitive 'peek (list p (make-constant 0)) (list fn)
+                  (make-apply fn (cons p (map translate args))))))
+            ((% %tail)
+              *tail*)
+            ((% %fix functions body)
+              (define frees (map free-vars functions))
+              (define fn-ptrs (loop for fun in functions
+                                    collect (make-label (gensym))))
+              (define converted-functions (loop for fun in functions
+                                                for fn-ptr in fn-ptrs
+                                                for free-list in frees
+                                                for env* = env
+                                                for name = (closure-name fun)
+                                                for closure = (make-variable (gensym))
+                                                if (lexical-ref? name)
+                                                  do (set! env* (insert env* name closure))
+                                                do (loop for arg in (closure-arguments fun)
+                                                         do (set! env* (insert env* arg (make-variable (gensym)))))
+                                                   (loop for var in free-list
+                                                         do (set! env* (insert env* var (make-variable (gensym)))))
+                                                collect (let ((new-body (convert (closure-body fun) env*)))
+                                                          (loop for var in free-list
+                                                                for i from 0
+                                                                do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*))
+                                                                                    new-body)))
+                                                          (make-closure
+                                                            fn-ptr
+                                                            (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun)))
+                                                            new-body))))
               (loop for fun in functions
-                    for free-list in frees
-                    for closure = (translate (closure-name fun))
-                    do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure)
-                                        new-body)))
-              (make-fix converted-functions new-body)))
-          (_ (error "Unexpected form in closure-convert" expr)))))))
+                    for name = (closure-name fun)
+                    if (lexical-ref? name)
+                      do (set! env (insert env name (make-variable (gensym)))))
+              (let ((new-body (convert body env)))
+                ; Build the closures.
+                (loop for fun in functions
+                      for free-list in frees
+                      for ptr in fn-ptrs
+                      for closure = (translate (closure-name fun))
+                      do (loop for var in free-list
+                               for i from 1
+                               do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '()
+                                                   new-body)))
+                         (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '()
+                                          new-body)))
+                ; Allocate the closures.
+                (loop for fun in functions
+                      for free-list in frees
+                      for closure = (translate (closure-name fun))
+                      do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure)
+                                          new-body)))
+                (make-fix converted-functions new-body)))
+            (_ (error "Unexpected form in closure-convert" expr))))))))