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))
55 ; recursive let bindings: build environment as we go
57 (lambda (env name expr offset)
58 (codegen-expr expr inner-si env)
59 (emit "movq %rax, ~a(%rsp)" offset)
60 (cons (cons name offset) env))
61 env names exprs stack-offsets)))
62 (for-each (lambda (form)
63 (codegen-expr form inner-si inner-env))
66 (define (codegen-var name si env)
67 (when (not (assoc name env))
68 (error #f (format "Variable ~a is not bound" name)))
69 (let ((offset (cdr (assoc name env))))
70 (emit "movq ~a(%rsp), %rax" offset)))
73 (define (fresh-lambda)
74 (set! cur-lambda (+ 1 cur-lambda))
75 (format "_lambda~a" (- cur-lambda 1)))
77 ; for now we can only call closures
78 (define (codegen-call closure args si env)
79 (let* ((captured (caddr closure))
80 (label (cadr closure))
81 (argument-start (length captured)))
83 ; first move the captured variables into param registers
86 (emit "movq ~a(%rsp), ~a"
87 (cdr (assoc e env)) ; offset of the var
89 captured (range 0 (length captured)))
92 ; then codegen the arguments and move them into the next param registers
96 (codegen-expr e si env)
97 ; move result to correct param register
98 (emit "movq %rax, ~a" (param-register i))))
99 args (range argument-start (length args)))
102 (emit "callq ~a" label)))
105 (define (codegen-lambda l)
106 (let* ((label (car l))
110 ; captured, then args
111 (vars (append captured args))
113 (param-registers (map param-register
114 (range 0 (length vars))))
115 (stack-offsets (map (lambda (i)
117 (range 0 (length vars))))
119 (copy-insts (map (lambda (r o)
120 (format "movq ~a, ~a(%rsp)"
122 param-registers stack-offsets))
124 (env (map cons vars stack-offsets)))
126 (display "## lambda body: ")
129 (display "## environment: ")
134 (for-each emit copy-insts)
135 (codegen-expr body (* (- wordsize) (length vars)) env)
136 )))) ; move args and capture vars to stack
138 (define (codegen-expr e si env)
143 (let ((callee (codegen-expr (car e) si env)))
145 ('+ (codegen-add (cdr e) si env))
146 ('- (codegen-sub (cadr e) (caddr e) si env))
147 ('* (codegen-mul (cadr e) (caddr e) si env))
148 ('! (codegen-not (cadr e) si env))
149 ('bool->int (codegen-expr (cadr e) si env))
150 (else (codegen-call callee (cdr e) si env)))))
152 ('let (codegen-let (let-bindings e)
157 ('var (codegen-var e si env))
159 ('string-literal (emit "movq ~a, %rax" label))
160 ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
161 ('int-literal (emit "movq $~a, %rax" e))
163 (else (error #f "don't know how to codegen this"))))
166 (define (fold-map f x) (fold-left append '() (map f x)))
168 (define (free-vars prog)
172 ('builtin '()) ; do nothing
173 ('var (if (memq e bound) '() (list e)))
175 (set! bound (append (lambda-args e) bound))
176 (collect (lambda-body e)))
178 ('app (fold-map collect e))
180 (let ((bind-fvs (fold-map (lambda (a)
181 ((set! bound (cons (car a) bound))
183 (let-bindings cadr)))
184 (body-fvs (fold-map collect (let-body e))))
185 (append bind-fvs body-fvs)))
189 ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
190 (define (extract-lambdas program)
192 (define (add-lambda e)
193 (let* ((label (fresh-lambda))
194 (args (lambda-args e))
195 (captured (free-vars e))
196 (body (extract (lambda-body e)))
197 (new-lambda (list label args captured body)))
198 (set! lambdas (cons new-lambda lambdas))
199 `(closure ,label ,captured))) ; todo: should we string->symbol?
202 ('lambda (add-lambda e))
204 ,(map extract (let-bindings e))
205 ,@(map extract (let-body e))))
206 ('app (append (list (extract (car e)))
207 (map extract (cdr e))))
209 (let ((transformed (extract program)))
210 (cons lambdas transformed)))
212 ;(define (extract-strings program))
214 (define (amd64-abi f)
218 (for-each (lambda (i)
221 (number->string i))))
225 ; restore preserved registers
226 (for-each (lambda (i)
229 (number->string i))))
236 ; 16(%rbp) mem arg 0 prev frame
237 ; -----------------------
238 ; 8(%rbp) return address cur frame
240 ; -8(%rbp) do what you want
241 ; ... do what you want
242 ; 0(%rsp) do what you want
244 (define (param-register n)
252 (else (error #f "need to test out the below"))
253 (else (format "~a(%rsp)" (- n 6)))))
255 (define (codegen program)
256 (let* ((extract-result (extract-lambdas program))
257 (lambdas (car extract-result))
258 (xform-prog (cdr extract-result)))
260 (emit ".p2align 4,,15")
262 (for-each codegen-lambda lambdas)
264 (emit ".globl _scheme_entry")
265 (emit "_scheme_entry:")
269 (lambda () (codegen-expr xform-prog 0 '())))))
271 (define (compile-to-binary program output)
272 (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
273 (let ([tmp-path "/tmp/a.s"])
274 (when (file-exists? tmp-path) (delete-file tmp-path))
275 (with-output-to-file tmp-path
276 (lambda () (codegen program)))
277 (system (format "clang -fomit-frame-pointer /tmp/a.s rts.c -o ~a" output))))