compiler.scm

   1 (load "typecheck.scm")
   2 (load "ast.scm")
   3
   4 (define (emit . s)
   5   (begin
   6     (apply printf s)
   7     (display "\n")))
   8
   9 (define (codegen-add xs)
  10   (define (go ys)
  11     (if (null? ys)
  12       (emit "movq %rbx, %rax")
  13       (begin
  14         (emit "addq $~a, %rbx" (car ys))
  15         (go (cdr ys)))))
  16   (begin
  17     (emit "movq $0, %rbx")
  18     (go xs)))
  19
  20 (define (range s n)
  21   (if (= 0 n) '()
  22       (append (range s (- n 1))
  23               (list (+ s (- n 1))))))
  24
  25 (define wordsize 8)
  26
  27 (define (codegen-let bindings body si env)
  28   (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize)))
  29                              (range 0 (length bindings))))
  30          (inner-si (- si (* (length bindings) wordsize)))
  31          (names (map car bindings))
  32          (exprs (map cadr bindings))
  33          (inner-env (append (map cons names stack-offsets) env)))
  34   (for-each (lambda (expr offset)
  35               (codegen-expr expr inner-si env)
  36               (emit "movq %rax, ~a(%rsp)" offset))
  37             exprs stack-offsets)
  38   (for-each (lambda (form) (codegen-expr form inner-si inner-env)) body)))
  39
  40 (define (codegen-var name si env)
  41   (let ((offset (cdr (assoc name env))))
  42     (emit "movq ~a(%rsp), %rax" offset)))
  43
  44 (define (codegen-expr e si env)
  45   (cond ((and (list? e) (eq? (car e) '+))
  46          (codegen-add (cdr e)))
  47         ((let? e) (codegen-let
  48                    (let-bindings e)
  49                    (let-body e)
  50                    si
  51                    env))
  52         ((var? e) (codegen-var e si env))
  53         (else (emit "movq $~a, %rax" e))))
  54
  55 (define (codegen program)
  56   (emit ".text")
  57   (emit ".p2align 4,,15")
  58   (emit ".globl _scheme_entry")
  59   (emit "_scheme_entry:")
  60
  61   ; handle incoming call from C
  62   (emit "push %rbp")
  63   (emit "push %rbx")
  64   (for-each (lambda (i)
  65               (emit (string-append
  66                      "push %r"
  67                      (number->string i))))
  68             '(12 13 14 15))
  69
  70   ; our code goes here
  71   (codegen-expr program 0 '())
  72
  73   ; restore preserved registers
  74   (for-each (lambda (i)
  75               (emit (string-append
  76                      "pop %r"
  77                      (number->string i))))
  78             '(15 14 13 12))
  79   (emit "pop %rbx")
  80   (emit "pop %rbp")
  81
  82   (emit "ret"))
  83
  84 (define (compile-to-binary program)
  85   (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
  86   (let ([tmp-path "/tmp/a.s"])
  87     (when (file-exists? tmp-path) (delete-file tmp-path))
  88     (with-output-to-file tmp-path
  89       (lambda () (codegen program)))
  90     (system "clang -fomit-frame-pointer /tmp/a.s rts.c")))