9 (define (codegen-add xs si env)
12 (emit "movq ~a(%rsp), %rax" si)
16 (emit "addq $~a, ~a(%rsp)" y si)
18 (codegen-expr y (- si wordsize) env)
19 (emit "addq %rax, ~a(%rsp)" si))))
22 ; use si(%rsp) as the accumulator
23 (emit "movq $0, ~a(%rsp)" si)
26 (define (codegen-binop opcode)
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)))
33 (define codegen-sub (codegen-binop "sub"))
34 (define codegen-mul (codegen-binop "imul"))
36 (define (codegen-not x si env)
37 (codegen-expr x si env)
39 (emit "andq $1, %rax"))
43 (append (range s (- n 1))
44 (list (+ s (- n 1))))))
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))
59 (for-each (lambda (form) (codegen-expr form inner-si inner-env)) body)))
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)))
68 (define (fresh-lambda)
69 (set! cur-lambda (+ 1 cur-lambda))
70 (format "_lambda~a" (- cur-lambda 1)))
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)))
78 ; first move the captured variables into param registers
81 (emit "movq ~a(%rsp), ~a"
82 (cdr (assoc e env)) ; offset of the var
84 captured (range 0 (length captured)))
87 ; then codegen the arguments and move them into the next param registers
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)))
97 (emit "callq ~a" label)))
100 (define (codegen-lambda l)
101 (let* ((label (car l))
105 ; captured, then args
106 (vars (append captured args))
108 (param-registers (map param-register
109 (range 0 (length vars))))
110 (stack-offsets (map (lambda (i)
112 (range 0 (length vars))))
114 (copy-insts (map (lambda (r o)
115 (format "movq ~a, ~a(%rsp)"
117 param-registers stack-offsets))
119 (env (map cons vars stack-offsets)))
121 (display "## lambda body: ")
124 (display "## environment: ")
129 (for-each emit copy-insts)
130 (codegen-expr body (* (- wordsize) (length vars)) env)
131 )))) ; move args and capture vars to stack
133 (define (codegen-expr e si env)
134 (cond ((builtin? e) e)
138 (let ((callee (codegen-expr (car e) si env)))
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)))))
147 ((let? e) (codegen-let
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))))
156 (define (fold-map f x) (fold-left append '() (map f x)))
158 (define (free-vars prog)
162 ((builtin? e) '()) ; do nothing
163 ((var? e) (if (memq e bound) '() (list e)))
165 (set! bound (append (lambda-args e) bound))
166 (collect (lambda-body e)))
168 ((app? e) (fold-map collect e))
170 (let ((bind-fvs (fold-map (lambda (a)
171 ((set! bound (cons (car a) bound))
173 (let-bindings cadr)))
174 (body-fvs (fold-map collect (let-body e))))
175 (append bind-fvs body-fvs)))
180 (and (list? e) (eqv? (car e) 'closure)))
182 ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
183 (define (extract-lambdas program)
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?
195 ((lambda? e) (add-lambda e))
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))))
202 (let ((transformed (extract program)))
203 (cons lambdas transformed)))
205 (define (amd64-abi f)
209 (for-each (lambda (i)
212 (number->string i))))
216 ; restore preserved registers
217 (for-each (lambda (i)
220 (number->string i))))
227 ; 16(%rbp) mem arg 0 prev frame
228 ; -----------------------
229 ; 8(%rbp) return address cur frame
231 ; -8(%rbp) do what you want
232 ; ... do what you want
233 ; 0(%rsp) do what you want
235 (define (param-register n)
243 (else (error #f "need to test out the below"))
244 (else (format "~a(%rsp)" (- n 6)))))
248 (define (codegen program)
249 (let* ((extract-result (extract-lambdas program))
250 (lambdas (car extract-result))
251 (xform-prog (cdr extract-result)))
253 (emit ".p2align 4,,15")
255 (for-each codegen-lambda lambdas)
257 (emit ".globl _scheme_entry")
258 (emit "_scheme_entry:")
262 (lambda () (codegen-expr xform-prog 0 '())))))
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))))