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