Write unit tests for codegen.

2 files changed, 169 insertions, 74 deletions

diff --git a/csc/codegen-test.csc b/csc/codegen-test.csc
index b85ebc3..01eda04 100644
--- a/csc/codegen-test.csc
+++ b/csc/codegen-test.csc
@@ -4,8 +4,12 @@
         (only (csc ir2)
           *globals*
           make-apply
+          make-branch
+          make-closure
           make-constant
           make-fix
+          make-label
+          make-library-ref
           make-primitive
           make-variable)
         (only (csc loop)
@@ -19,31 +23,103 @@
         (csc codegen))
 
 
-(define transform-bytecode
-  (list
-    (cons (lambda (expr)
-            (match expr
-              (('label _) #t)
-              (_ #f)))
-          (lambda (expr) 'label))
-    (cons (lambda (expr)
-            (match expr
-              (('local _) #t)
-              (_ #f)))
-          (lambda (expr) 'local))))
-
-
 (define (test-var)
   (make-variable (gensym)))
 
 
+(define (test-label)
+  (make-label (gensym)))
+
+
 (test codegen-apply
+  (define p (test-var))
+  (assert-equal
+    '((peek (local 1) (local 0) (const 5))
+      (mov (local 2) (local 1))
+      (mov (local 1) (const 10))
+      (jmp (local 2)))
+    (ir2->ir3
+      (make-fix '()
+        (make-primitive 'peek (list *globals* (make-constant 5)) (list p)
+          (make-apply p (list (make-constant 10))))))))
+
+
+(test codegen-call-global
+  (define p (test-var))
+  (assert-equal
+    '((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)))
+    (ir2->ir3
+      (make-fix '()
+        (make-primitive 'peek (list *globals* (make-library-ref 'cons '(csc based))) (list p)
+          (make-apply p (list (make-constant 5) (make-constant '()))))))))
+
+
+(test codegen-call-known
+  (define f (test-label))
+  (define ret (test-var))
+  (assert-equal
+    '((mov (local 1) (label 0))
+      (jmp (label 0))
+      (label 0)
+      (mov (local 2) (local 1))
+      (jmp (local 2)))
+    (ir2->ir3
+      (make-fix
+        (list (make-closure f (list ret)
+                (make-apply ret (list ret))))
+        (make-apply f (list f))))))
+
+
+(test codegen-permute
+  (define f (test-label))
+  (define g (test-label))
+  (define f1 (test-var))
+  (define f2 (test-var))
+  (define g1 (test-var))
+  (define g2 (test-var))
+  (define g3 (test-var))
+  (assert-equal
+    '((mov (local 1) (const 0))
+      (mov (local 2) (const 1))
+      (jmp (label 0))
+      (label 0)
+      (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)
+      (mov (local 2) (local 1))
+      (mov (local 1) (local 3))
+      (jmp (label 0)))
+    (ir2->ir3
+      (make-fix
+        (list (make-closure f (list f1 f2)
+                (make-apply g (list f2 f1 (make-constant 0))))
+              (make-closure g (list g1 g2 g3)
+                (make-apply f (list g3 g1))))
+        (make-apply f (list (make-constant 0) (make-constant 1)))))))
+
+
+(test codegen-branch
+  (define p (test-var))
   (assert-equal
-    '((peek (local #f) (local #f) (const 5))
-      (mov (local #f) (const 10))
-      (jmp (local #f)))
+    '((peek (local 1) (local 0) (const 1))
+      (jmpif (const #t) (label 0))
+      (mov (local 2) (local 1))
+      (mov (local 1) (const 10))
+      (jmp (local 2))
+      (label 0)
+      (mov (local 2) (local 1))
+      (mov (local 1) (const 5))
+      (jmp (local 2)))
     (ir2->ir3
       (make-fix '()
-        (make-primitive 'peek (list *globals* (make-constant 5)) (list (test-var))
-          (make-apply (test-var) (list (make-constant 10))))))
-    transform-bytecode))
+        (make-primitive 'peek (list *globals* (make-constant 1)) (list p)
+          (make-branch (make-constant #t)
+            (make-apply p (list (make-constant 5)))
+            (make-apply p (list (make-constant 10)))))))))
diff --git a/csc/codegen.csc b/csc/codegen.csc
index aab8e23..f97beec 100644
--- a/csc/codegen.csc
+++ b/csc/codegen.csc
@@ -5,6 +5,7 @@
           (only (csc format)
             sprintf)
           (only (csc gensym)
+            gensym
             gensym->int)
           (only (csc hash-map)
             compare-numbers
@@ -39,6 +40,7 @@
             library-ref?
             make-apply
             make-constant
+            make-label
             make-primitive
             variable-gensym
             variable?)
@@ -49,26 +51,6 @@
   (begin
 
 
-    (define *next-label-id* 0)
-
-
-    (define (new-label)
-      (define id *next-label-id*)
-      (set! *next-label-id* (+ 1 *next-label-id*))
-      id)
-
-
-    (define *label-map* (make-map (make-comparer
-                                    (lambda (x) (gensym->int (label-gensym x)))
-                                    (lambda (x y) (- (gensym->int (label-gensym y)) (gensym->int (label-gensym x)))))))
-
-
-    (define (translate-label x)
-      (define new-id (new-label))
-      (set! *label-map* (insert *label-map* x new-id))
-      new-id)
-
-
     (define (atom->bytecode atom translate-local)
       (match atom
         ((% %constant x)
@@ -76,9 +58,10 @@
             ((and (integer? x)
                   (> x (- (expt 2 30) 1)))  ; out of range for a small int
               (error "I don't support big ints yet"))
-            ((integer? x)
+            ((or (integer? x)
+                 (boolean? x))
               (list 'const x))
-            (else (error "Only integer constants are supported for now"))))
+            (else (error "Only small ints and bool constants are supported for now"))))
         ((% %library-ref x lib)
           (list 'global x lib))
         ((% %variable sym)
@@ -87,7 +70,7 @@
           ; The globals array is stored in register 0.
           (list 'local 0))
         ((% %label sym)
-          (list 'label (translate-label atom)))
+          (list 'label (translate-local atom)))
         (_ (error "Unexpected form in atom->bytecode" atom))))
 
 
@@ -121,6 +104,16 @@
         #f))
 
 
+    (define (get-least m)
+      (define least #f)
+      (map-for-each (lambda (k v)
+                      (when (or (not least)
+                              (< k least))
+                        (set! least k)))
+        m)
+      least)
+
+
     (define (chains in->out)
       (define out->in (make-map compare-numbers))
       (map-for-each (lambda (k v)
@@ -128,21 +121,28 @@
         in->out)
       (define currently-in-temp #f)
       (loop with results = out->in
-            for easy-result = (get-satisfying results (lambda (x) (not (lookup in->out x #f))))
+            with save-regs = in->out
+            for easy-result = (get-satisfying results (lambda (x) (not (lookup save-regs x #f))))
             until (empty? results)
             if easy-result
-              collect (list 'mov (list 'local easy-result) (list 'local (lookup out->in easy-result)))
-              and do (set! results (delete out->in easy-result))
+              collect (let ((in (lookup out->in easy-result)))
+                        (set! results (delete results easy-result))
+                        (set! save-regs (delete save-regs in))
+                        (list 'mov (list 'local easy-result) (list 'local (lookup out->in easy-result))))
             else if currently-in-temp
-              collect (list 'mov (list 'local (lookup in->out currently-in-temp)) (list 'local currently-in-temp))
+              collect (let ((target (lookup in->out currently-in-temp)))
+                        (set! results (delete results target))
+                        (list 'mov (list 'local target) (list 'local *temp-reg*)))
               and do (set! currently-in-temp #f)
             else
-              append (let ((any-result (get-satisfying results (lambda (x) #t))))
+              append (let* ((any-result (get-least results))
+                            (in (lookup out->in any-result)))
                         (set! currently-in-temp any-result)
+                        (set! results (delete results any-result))
+                        (set! save-regs (delete save-regs any-result))
                         (list
                           (list 'mov (list 'local *temp-reg*) (list 'local any-result))
-                          (list 'mov (list 'local any-result) (list 'local (lookup out->in any-result)))))
-              and do (set! results (delete out->in any-result))))
+                          (list 'mov (list 'local any-result) (list 'local in))))))
 
 
     (define (hash-symbol s)
@@ -165,46 +165,57 @@
             (append (list op) (map a->b res) (map a->b args))
             (ir2->bytecode cont translate-local)))
         ((% %branch atom true false)
-          (define temp1 (new-label))
-          (define temp2 (new-label))
+          (define temp (translate-local (make-label (gensym))))
           (append
             (list
-              (list 'jmpif (a->b atom) temp1))
+              (list 'jmpif (a->b atom) (list 'label temp)))
             (ir2->bytecode false translate-local)
             (list
-              (list 'jmp (list 'label temp2))
-              (list 'label temp1))
-            (ir2->bytecode true translate-local)
-            (list
-              (list 'label temp2))))
+              (list 'label temp))
+            (ir2->bytecode true translate-local)))
         ((% %apply proc args)
           (define in->out (make-map compare-numbers))
           (define constants
             (loop for arg in args
                   for i from 1
                   if (variable? arg)
-                    do (set! in->out (insert in->out (translate-local arg) i))
+                    unless (= (translate-local arg) i)
+                      do (set! in->out (insert in->out (translate-local arg) i))
+                    end
                   else if (globals? arg)
                     do (set! in->out (insert in->out 0 i))
                   else if (constant? arg)
                     collect (list 'mov (list 'local i) (list 'const (constant-expression arg)))
                   else if (label? arg)
-                    collect (list 'mov (list 'local i) (list 'label (translate-label arg)))
+                    collect (list 'mov (list 'local i) (list 'label (translate-local arg)))
                   else if (library-ref? arg)
                     collect (list 'mov (list 'local i) (list 'global
                                                              (library-ref-name arg)
                                                              (library-ref-library arg)))
                   else
                     do (error "Unexpected form in arguments list" arg)))
-          (append (chains in->out)
-                  constants
-                  (list
-                    (if (label? proc)
-                      (list 'jmp (list 'label (translate-label proc)))
-                      (list 'jmp (a->b proc))))))
+          (define proc-temp (translate-local proc))
+          (when (and (variable? proc)
+                     (<= proc-temp (length args)))
+            (let ((available-reg (+ 1 (length args))))
+              (set! in->out (insert in->out proc-temp available-reg))
+              (set! proc-temp available-reg)))
+          (append
+            (chains in->out)
+            constants
+            (list
+              (if (label? proc)
+                (list 'jmp (list 'label proc-temp))
+                (list 'jmp (list 'local proc-temp))))))
         (_ (error "Unexpected form in ir2->bytecode expr"))))
 
 
+    (define compare-labels
+      (make-comparer
+        (lambda (x) (gensym->int (label-gensym x)))
+        (lambda (x y) (- (gensym->int (label-gensym y)) (gensym->int (label-gensym x))))))
+
+
     (define compare-variables
       (make-comparer
         (lambda (x) (gensym->int (variable-gensym x)))
@@ -213,6 +224,14 @@
 
     ; Converts an IR2 program into bytecode.
     (define (ir2->ir3 expr)
+      (define label-map (make-map compare-labels))
+      (define next-label-id 0)
+      (define (translate-label x)
+        (or (lookup label-map x #f)
+            (let ((id next-label-id))
+              (set! next-label-id (+ 1 next-label-id))
+              (set! label-map (insert label-map x id))
+              id)))
       (define (make-locals-map args)
         (define locals-map (make-map compare-variables))
         (loop for arg in args
@@ -220,14 +239,14 @@
               do (set! locals-map (insert locals-map arg i)))
         (define local-count (length args))
         (lambda (x)
-          (define res (lookup locals-map x #f))
-          (if res
-            res
-            (begin
-              (set! local-count (+ 1 local-count))
-              ; start at 1, because register 0 holds the globals array
-              (set! locals-map (insert locals-map x local-count))
-              local-count))))
+          (if (label? x)
+            (translate-label x)
+            (or (lookup locals-map x #f)
+                (begin
+                  (set! local-count (+ 1 local-count))
+                  ; start at 1, because register 0 holds the globals array
+                  (set! locals-map (insert locals-map x local-count))
+                  local-count)))))
       (append
         (ir2->bytecode (fix-body expr) (make-locals-map '()))
         (loop for func in (fix-functions expr)