1 files changed, 161 insertions, 0 deletions
diff --git a/lib/csc/codegen.scheme b/lib/csc/codegen.scheme
new file mode 100644
index 0000000..5423e91
--- /dev/null
+++ b/lib/csc/codegen.scheme
@@ -0,0 +1,161 @@
+(define-library (csc codegen)
+  (export cps->bytecode)
+  (import (scheme base)
+          (prefix (csc gensym) gensym.)
+          (prefix (csc ir) ir.)
+          (prefix (csc list) list.)
+          (prefix (csc map) map.))
+  (import (scheme write))
+  (begin
+
+
+    (define (const? x)
+      (or (ir.const? x)
+          (ir.void? x)
+          (ir.label? x)))
+
+
+    (define (const->bytecode atom)
+      (cond
+        ((ir.const? atom)
+          (let ((x (ir.const-val atom)))
+            (cond
+              ((and (integer? x)
+                    (> x (- (expt 2 30) 1)))  ; out of range for a small int
+                (error "I don't support big ints yet"))
+              ((or (integer? x)
+                   (boolean? x)
+                   (null? x))
+                (list 'const x))
+              (else (error "Only small ints and bool constants are supported for now" x)))))
+        ((ir.void? atom)
+          'void)
+        ((ir.label? atom)
+          (list 'label (gensym.gensym->int (ir.label-var atom))))
+        (else (error "unexpected form in const->bytecode" atom))))
+
+
+    (define (atom->bytecode atom translate)
+      (if (gensym.gensym? atom)
+        (translate atom)
+        (const->bytecode atom)))
+
+
+    (define *temp-reg* 255)
+
+
+    ; https://en.wikipedia.org/wiki/Topological_sorting
+    (define (topological-sort g)
+      (define s
+        (list.filter
+          (lambda (x) (not (memv x (map cdr g))))
+          (map car g)))
+      (let loop ((s s)
+                 (g g))
+        (if (null? s)
+          (if (null? g)
+            '()
+            (let ((n (caar g)))
+              (cons (list 'mov (list 'local *temp-reg*) (list 'local n))
+                (loop (list n)
+                  (map
+                    (lambda (p)
+                      (if (= n (cdr p))
+                        (cons (car p) *temp-reg*)
+                        p))
+                    g)))))
+          (let ((n (car s))
+                (s (cdr s)))
+            (define g* (list.filter (lambda (p) (not (= n (car p)))) g))
+            (cond
+              ((assv n g) => (lambda (p)
+                (define m (cdr p))
+                (cons (list 'mov (list 'local n) (list 'local m))
+                  (if (list.any (lambda (p) (= m (cdr p))) g*)
+                    (loop s g*)
+                    (loop (cons m s) g*)))))
+              (else (loop s g*)))))))
+
+
+    (define (check-primop-args op args vals conts)
+      (unless (and (= args (length (ir.primop-args op)))
+                   (= vals (length (ir.primop-vals op)))
+                   (= conts (length (ir.primop-ks op))))
+        (error "wrong number of arguments passed to primop" op)))
+
+
+    (define (convert-cexpr expr translate)
+      (define (a->b atom)
+        (atom->bytecode atom translate))
+      (cond
+        ((ir.apply? expr)
+          (let ((args (cons (ir.apply-func expr) (ir.apply-args expr))))
+            (define constants
+              (let loop ((args args)
+                         (i 0))
+                (if (null? args)
+                  '()
+                  (let ((x (car args)))
+                    (if (const? x)
+                      (cons (list 'mov (list 'local i) (const->bytecode x))
+                        (loop (cdr args) (+ 1 i)))
+                      (loop (cdr args) (+ 1 i)))))))
+            (define g
+              (let loop ((args args)
+                         (i 0)
+                         (g '()))
+                (if (null? args)
+                  g
+                  (let ((x (car args)))
+                    (define y (translate x))
+                    (if (and (gensym.gensym? x) (not (= y i)))
+                      (loop (cdr args) (+ 1 i)
+                        (cons (cons i y) g))
+                      (loop (cdr args) (+ 1 i) g))))))
+            (append
+              constants
+              (topological-sort g)
+              (list (list 'jmp (list 'local 0))))))
+        ((and (ir.primop? expr) (symbol=? 'exit (ir.primop-name expr)))
+          (unless (= 1 (length (ir.primop-args expr)))
+            (error "wrong number of arguments passed to primop" expr))
+          (list (list 'exit (atom->bytecode (car (ir.primop-args expr)) translate))))
+        ((and (ir.primop? expr)
+              (memq (ir.primop-name expr)
+                '(peek
+                  cons)))
+          (check-primop-args expr 2 1 1)
+          (cons
+            (list 'peek (a->b (car (ir.primop-vals expr)))
+                        (a->b (car (ir.primop-args expr)))
+                        (a->b (cadr (ir.primop-args expr))))
+            (convert-cexpr (car (ir.primop-ks expr)) translate)))
+        (else (error "unexpected form in convert-cexpr" expr))))
+
+
+    (define (make-translate args)
+      (define m (map.empty -))
+      (define next-local 0)
+      (define (translate x)
+        (if (gensym.gensym? x)
+          (let ((n (gensym.gensym->int x)))
+            (or (map.lookup m n #f)
+                (let ((l next-local))
+                  (set! m (map.insert m n l))
+                  (set! next-local (+ 1 l))
+                  l)))
+          x))
+      (for-each translate args)
+      translate)
+
+
+    (define (cps->bytecode expr)
+      (apply append
+        (convert-cexpr (ir.letrec-body expr) (make-translate '()))
+        (map
+          (lambda (p)
+            (define name (car p))
+            (define func (cdr p))
+            (cons (const->bytecode name)
+              (convert-cexpr (ir.lambda-body func) (make-translate (ir.lambda-vars func)))))
+          (ir.letrec-funcs expr))))))