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 "notq %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   (when (not (assoc name env))
  63     (error #f (format "Variable ~a is not bound" name)))
  64   (let ((offset (cdr (assoc name env))))
  65     (emit "movq ~a(%rsp), %rax" offset)))
  66
  67 (define cur-lambda 0)
  68 (define (fresh-lambda)
  69   (set! cur-lambda (+ 1 cur-lambda))
  70   (format "_lambda~a" (- cur-lambda 1)))
  71
  72                                         ; for now we can only call closures
  73 (define (codegen-call closure args si env)
  74   (let* ((captured (caddr closure))
  75          (label (cadr closure))
  76          (argument-start (length captured)))
  77
  78                                         ; first move the captured variables into param registers
  79     (for-each
  80      (lambda (e i)
  81        (emit "movq ~a(%rsp), ~a"
  82              (cdr (assoc e env)) ; offset of the var
  83              (param-register i)))
  84      captured (range 0 (length captured)))
  85
  86
  87                                         ; then codegen the arguments and move them into the next param registers
  88     (for-each
  89      (lambda (e i)
  90        (begin
  91          (codegen-expr e si env)
  92                                         ; move result to correct param register
  93          (emit "movq %rax, ~a" (param-register i))))
  94      args (range argument-start (length args)))
  95
  96                                         ; now call
  97     (emit "callq ~a" label)))
  98
  99
 100 (define (codegen-lambda l)
 101   (let* ((label (car l))
 102          (args (cadr l))
 103          (captured (caddr l))
 104          (body (cadddr l))
 105          ; captured, then args
 106          (vars (append captured args))
 107
 108          (param-registers (map param-register
 109                              (range 0 (length vars))))
 110          (stack-offsets (map (lambda (i)
 111                                (* (- wordsize) i))
 112                              (range 0 (length vars))))
 113
 114          (copy-insts (map (lambda (r o)
 115                             (format "movq ~a, ~a(%rsp)"
 116                                     r o))
 117                           param-registers stack-offsets))
 118
 119          (env (map cons vars stack-offsets)))
 120     (emit "~a:" label)
 121     (display "## lambda body: ")
 122     (display body)
 123     (newline)
 124     (display "## environment: ")
 125     (display env)
 126     (newline)
 127     (amd64-abi
 128      (lambda ()
 129        (for-each emit copy-insts)
 130        (codegen-expr body (* (- wordsize) (length vars)) env)
 131        ))))                     ; move args and capture vars to stack
 132
 133 (define (codegen-expr e si env)
 134   (cond ((builtin? e) e)
 135         ((closure? e) e)
 136
 137         ((app? e)
 138          (let ((callee (codegen-expr (car e) si env)))
 139            (case callee
 140              ('+ (codegen-add (cdr e) si env))
 141              ('- (codegen-sub (cadr e) (caddr e) si env))
 142              ('* (codegen-mul (cadr e) (caddr e) si env))
 143              ('! (codegen-not (cadr e) si env))
 144              ('bool->int (codegen-expr (cadr e) si env))
 145              (else (codegen-call callee (cdr e) si env)))))
 146
 147         ((let? e) (codegen-let
 148                    (let-bindings e)
 149                    (let-body e)
 150                    si
 151                    env))
 152         ((var? e) (codegen-var e si env))
 153         ((boolean? e) (emit "movq $~a, %rax" (if e 1 0)))
 154         (else (emit "movq $~a, %rax" e))))
 155
 156 (define (fold-map f x) (fold-left append '() (map f x)))
 157
 158 (define (free-vars prog)
 159   (define bound '())
 160   (define (collect e)
 161     (cond
 162      ((builtin? e) '()) ; do nothing
 163      ((var? e) (if (memq e bound) '() (list e)))
 164      ((lambda? e)
 165       (set! bound (append (lambda-args e) bound))
 166       (collect (lambda-body e)))
 167
 168      ((app? e) (fold-map collect e))
 169      ((let? e)
 170       (let ((bind-fvs (fold-map (lambda (a)
 171                   ((set! bound (cons (car a) bound))
 172                    (collect (cdr a))))
 173                            (let-bindings cadr)))
 174             (body-fvs (fold-map collect (let-body e))))
 175         (append bind-fvs body-fvs)))
 176      (else '())))
 177   (collect prog))
 178
 179 (define (closure? e)
 180   (and (list? e) (eqv? (car e) 'closure)))
 181
 182                                         ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
 183 (define (extract-lambdas program)
 184   (define lambdas '())
 185   (define (add-lambda e)
 186     (let* ((label (fresh-lambda))
 187            (args (lambda-args e))
 188            (captured (free-vars e))
 189            (body (extract (lambda-body e)))
 190            (new-lambda (list label args captured body)))
 191       (set! lambdas (cons new-lambda lambdas))
 192       `(closure ,label ,captured))) ; todo: should we string->symbol?
 193   (define (extract e)
 194     (cond
 195      ((lambda? e) (add-lambda e))
 196      ((let? e) `(let
 197                     ,(map extract (let-bindings e))
 198                   ,@(map extract (let-body e))))
 199      ((app? e) (append (list (extract (car e)))
 200                        (map extract (cdr e))))
 201      (else e)))
 202   (let ((transformed (extract program)))
 203     (cons lambdas transformed)))
 204
 205 (define (amd64-abi f)
 206                                         ; preserve registers
 207   (emit "push %rbp")
 208   (emit "push %rbx")
 209   (for-each (lambda (i)
 210               (emit (string-append
 211                      "push %r"
 212                      (number->string i))))
 213             '(12 13 14 15))
 214
 215   (f) ; call stuff
 216                                         ; restore preserved registers
 217   (for-each (lambda (i)
 218               (emit (string-append
 219                      "pop %r"
 220                      (number->string i))))
 221             '(15 14 13 12))
 222   (emit "pop %rbx")
 223   (emit "pop %rbp")
 224   (emit "ret"))
 225
 226                                         ; 24(%rbp) mem arg 1
 227                                         ; 16(%rbp) mem arg 0          prev frame
 228                                         ; -----------------------
 229                                         ;  8(%rbp) return address     cur frame
 230                                         ;  0(%rbp) prev %rbp
 231                                         ; -8(%rbp) do what you want
 232                                         ;  ...     do what you want
 233                                         ;  0(%rsp) do what you want
 234
 235 (define (param-register n)
 236   (case n
 237     (0 "%rdi")
 238     (1 "%rsi")
 239     (2 "%rdx")
 240     (3 "%rcx")
 241     (4 "%r8")
 242     (5 "%r9")
 243     (else (error #f "need to test out the below"))
 244     (else (format "~a(%rsp)" (- n 6)))))
 245
 246
 247
 248 (define (codegen program)
 249   (let* ((extract-result (extract-lambdas program))
 250          (lambdas (car extract-result))
 251          (xform-prog (cdr extract-result)))
 252     (emit ".text")
 253     (emit ".p2align 4,,15")
 254
 255     (for-each codegen-lambda lambdas)
 256
 257     (emit ".globl _scheme_entry")
 258     (emit "_scheme_entry:")
 259
 260
 261     (amd64-abi
 262      (lambda () (codegen-expr xform-prog 0 '())))))
 263
 264 (define (compile-to-binary program output)
 265   (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
 266   (let ([tmp-path "/tmp/a.s"])
 267     (when (file-exists? tmp-path) (delete-file tmp-path))
 268     (with-output-to-file tmp-path
 269       (lambda () (codegen program)))
 270     (system (format "clang -fomit-frame-pointer /tmp/a.s rts.c -o ~a" output))))