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