Add consolidation, tie up with typechecker

[scheme.git] / compiler.scm

diff --git a/compiler.scm b/compiler.scm
new file mode 100644 (file)
index 0000000..351e11b
--- /dev/null
+++ b/compiler.scm
@@ -0,0 +1,59 @@
+(load "typecheck.scm")
+
+(define (emit . s)
+  (begin
+    (apply printf s)
+    (display "\n")))
+
+(define (compile-add xs)
+  (define (go ys)
+    (if (null? ys)
+      (emit "movq %rbx, %rax")
+      (begin
+       (emit "addq $~a, %rbx" (car ys))
+       (go (cdr ys)))))
+  (begin
+    (emit "movq $0, %rbx")
+    (go xs)))
+
+(define (compile-expr e)
+  (if (and (list? e) (eq? (car e) '+))
+      (compile-add (cdr e))
+      (emit "movq $~a, %rax" e)))
+
+(define (compile-program program)
+  (emit ".text")
+  (emit ".p2align 4,,15")
+  (emit ".globl _scheme_entry")
+  (emit "_scheme_entry:")
+
+  ; handle incoming call from C
+  (emit "push %rbp")
+  (emit "push %rbx")
+  (for-each (lambda (i)
+             (emit (string-append
+                    "push %r"
+                    (number->string i))))
+           '(12 13 14 15))
+
+  ; our code goes here
+  (compile-expr program)
+
+  ; restore preserved registers
+  (for-each (lambda (i)
+             (emit (string-append
+                    "pop %r"
+                    (number->string i))))
+           '(15 14 13 12))
+  (emit "pop %rbx")
+  (emit "pop %rbp")
+
+  (emit "ret"))
+
+(define (compile-to-binary program)
+  (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
+  (let ([tmp-path "/tmp/a.s"])
+    (when (file-exists? tmp-path) (delete-file tmp-path))
+    (with-output-to-file tmp-path
+      (lambda () (compile-program program)))
+    (system "clang -fomit-frame-pointer /tmp/a.s rts.c")))