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