compiler.scm

   1 (load "typecheck.scm")
   2
   3 (define (emit . s)
   4   (begin
   5     (apply printf s)
   6     (display "\n")))
   7
   8 (define (compile-add xs)
   9   (define (go ys)
  10     (if (null? ys)
  11       (emit "movq %rbx, %rax")
  12       (begin
  13         (emit "addq $~a, %rbx" (car ys))
  14         (go (cdr ys)))))
  15   (begin
  16     (emit "movq $0, %rbx")
  17     (go xs)))
  18
  19 (define (compile-expr e)
  20   (if (and (list? e) (eq? (car e) '+))
  21       (compile-add (cdr e))
  22       (emit "movq $~a, %rax" e)))
  23
  24 (define (compile-program program)
  25   (emit ".text")
  26   (emit ".p2align 4,,15")
  27   (emit ".globl _scheme_entry")
  28   (emit "_scheme_entry:")
  29
  30   ; handle incoming call from C
  31   (emit "push %rbp")
  32   (emit "push %rbx")
  33   (for-each (lambda (i)
  34               (emit (string-append
  35                      "push %r"
  36                      (number->string i))))
  37             '(12 13 14 15))
  38
  39   ; our code goes here
  40   (compile-expr program)
  41
  42   ; restore preserved registers
  43   (for-each (lambda (i)
  44               (emit (string-append
  45                      "pop %r"
  46                      (number->string i))))
  47             '(15 14 13 12))
  48   (emit "pop %rbx")
  49   (emit "pop %rbp")
  50
  51   (emit "ret"))
  52
  53 (define (compile-to-binary program)
  54   (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
  55   (let ([tmp-path "/tmp/a.s"])
  56     (when (file-exists? tmp-path) (delete-file tmp-path))
  57     (with-output-to-file tmp-path
  58       (lambda () (compile-program program)))
  59     (system "clang -fomit-frame-pointer /tmp/a.s rts.c")))