9 (define (codegen-add xs si env)
12 (emit "movq ~a(%rbp), %rax" si)
16 (emit "addq $~a, ~a(%rbp)" y si)
18 (codegen-expr y (- si wordsize) env)
19 (emit "addq %rax, ~a(%rbp)" si))))
22 ; use si(%rbp) as the accumulator
23 (emit "movq $0, ~a(%rbp)" si)
26 (define (codegen-binop opcode)
28 (codegen-expr b si env)
29 (emit "movq %rax, ~a(%rbp)" si)
30 (codegen-expr a (- si wordsize) env)
31 (emit "~a ~a(%rbp), %rax" opcode si)))
33 (define codegen-sub (codegen-binop "sub"))
35 (define codegen-mul (codegen-binop "imul"))
37 (define (codegen-not x si env)
38 (codegen-expr x si env)
40 (emit "andq $1, %rax"))
42 (define (codegen-eq a b si env)
43 (codegen-expr a si env)
44 (emit "movq %rax, ~a(%rbp)" si)
45 (codegen-expr b (- si wordsize) env)
46 (emit "subq ~a(%rbp), %rax" si)
48 (emit "andq $1, %rax"))
50 (define (codegen-print x si env)
51 (codegen-expr x si env) ; x should be a static-string, producing a label
53 ; get the length of the null terminated string
54 (emit "mov %rax, %rdi")
55 (emit "xor %al, %al") ; set %al to 0
56 (emit "mov $-1, %rcx") ; max search length = max int = -1
57 (emit "cld") ; clear direction flag, search up in memory
58 (emit "repne scasb") ; scan string, %rcx = -strlen - 1 - 1
60 (emit "not %rcx") ; -%rcx = strlen + 1
63 (emit "mov %rcx, %rdx") ; number of bytes
64 (emit "mov %rax, %rsi") ; addr of string
65 (emit "mov $1, %rax") ; file handle 1 (stdout)
66 (emit "mov $1, %rdi") ; syscall 1 (write)
71 (append (range s (- n 1))
72 (list (+ s (- n 1))))))
76 (define (codegen-let bindings body si env)
77 (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize)))
78 (range 0 (length bindings))))
79 (inner-si (- si (* (length bindings) wordsize)))
80 (names (map car bindings))
81 (exprs (map cadr bindings))
83 ; recursive let bindings: build environment as we go
85 (lambda (env name expr offset)
86 (codegen-expr expr inner-si env)
87 (emit "movq %rax, ~a(%rbp)" offset)
88 (cons (cons name offset) env))
89 env names exprs stack-offsets)))
90 (for-each (lambda (form)
91 (codegen-expr form inner-si inner-env))
94 (define (codegen-var name si env)
95 (when (not (assoc name env))
96 (error #f (format "Variable ~a is not bound" name)))
97 (let ((offset (cdr (assoc name env))))
98 (emit "movq ~a(%rbp), %rax" offset)))
100 (define cur-lambda 0)
101 (define (fresh-lambda)
102 (set! cur-lambda (+ 1 cur-lambda))
103 (format "_lambda~a" (- cur-lambda 1)))
105 ; for now we can only call closures
106 (define (codegen-call closure args si env)
107 (when (not (eq? (ast-type closure) 'closure))
108 (error #f (format "~a is not a closure" closure)))
109 (let* ((captured (caddr closure))
110 (label (cadr closure))
111 (argument-start (length captured)))
113 ; first move the captured variables into param registers
116 (emit "movq ~a(%rbp), ~a"
117 (cdr (assoc e env)) ; offset of the var
119 captured (range 0 (length captured)))
122 ; then codegen the arguments and move them into the next param registers
126 (codegen-expr e si env)
127 ; move result to correct param register
128 (emit "movq %rax, ~a" (param-register i))))
129 args (range argument-start (length args)))
131 (emit "addq $~a, %rsp" si) ; adjust the stack pointer to account all the stuff we put in the env
132 (emit "callq ~a" label)
133 (emit "subq $~a, %rsp" si)))
135 (define (codegen-lambda l)
136 (let* ((label (car l))
140 ; params = what actually gets passed
141 (params (append captured args))
143 (param-registers (map param-register
144 (range 0 (length params))))
145 (stack-offsets (map (lambda (i)
147 (range 1 (length params))))
149 (copy-insts (map (lambda (r o)
150 (format "movq ~a, ~a(%rbp)" r o))
151 param-registers stack-offsets))
153 (env (map cons params stack-offsets)))
155 (display "## lambda body: ")
158 (display "## environment: ")
162 (emit "push %rbp") ; preserve caller's base pointer
163 (emit "movq %rsp, %rbp") ; set up our own base pointer
165 (for-each emit copy-insts)
166 (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
168 (emit "pop %rbp") ; restore caller's base pointer
172 (define (fresh-label)
173 (set! cur-label (+ 1 cur-label))
174 (format "label~a" (- cur-label 1)))
176 (define (codegen-if cond then else si env)
177 (codegen-expr cond si env)
178 (emit "cmpq $0, %rax")
179 (let ((exit-label (fresh-label))
180 (else-label (fresh-label)))
181 (emit "je ~a" else-label)
182 (codegen-expr then si env)
183 (emit "jmp ~a" exit-label)
184 (emit "~a:" else-label)
185 (codegen-expr else si env)
186 (emit "~a:" exit-label)))
188 (define (codegen-expr e si env)
193 (let ((callee (codegen-expr (car e) si env)))
195 ('+ (codegen-add (cdr e) si env))
196 ('- (codegen-sub (cadr e) (caddr e) si env))
197 ('* (codegen-mul (cadr e) (caddr e) si env))
198 ('! (codegen-not (cadr e) si env))
199 ('= (codegen-eq (cadr e) (caddr e) si env))
200 ('bool->int (codegen-expr (cadr e) si env))
201 ('print (codegen-print (cadr e) si env))
202 (else (codegen-call callee (cdr e) si env)))))
204 ('let (codegen-let (let-bindings e)
209 ('var (codegen-var e si env))
211 ('if (codegen-if (cadr e) (caddr e) (cadddr e) si env))
213 ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
214 ('int-literal (emit "movq $~a, %rax" e))
216 ('static-string (emit "movq $~a, %rax" (cadr e))) ; move label
218 (else (error #f "don't know how to codegen this"))))
221 (define (fold-map f x) (fold-left append '() (map f x)))
223 (define (free-vars prog)
227 ('builtin '()) ; do nothing
228 ('var (if (memq e bound) '() (list e)))
230 (set! bound (append (lambda-args e) bound))
231 (collect (lambda-body e)))
233 ('app (fold-map collect e))
235 (let ((bind-fvs (fold-map (lambda (a)
236 ((set! bound (cons (car a) bound))
238 (let-bindings cadr)))
239 (body-fvs (fold-map collect (let-body e))))
240 (append bind-fvs body-fvs)))
244 ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
245 (define (extract-lambdas program)
247 (define (add-lambda e)
248 (let* ((label (fresh-lambda))
249 (args (lambda-args e))
250 (captured (free-vars e))
251 (body (extract (lambda-body e)))
252 (new-lambda (list label args captured body)))
253 (set! lambdas (cons new-lambda lambdas))
254 `(closure ,label ,captured))) ; todo: should we string->symbol?
257 ('lambda (add-lambda e))
258 ('let `(let ,(map extract (let-bindings e))
259 ,@(map extract (let-body e))))
260 ('app (append (list (extract (car e)))
261 (map extract (cdr e))))
262 (else (ast-traverse extract e))))
263 (let ((transformed (extract program)))
264 (cons lambdas transformed)))
266 (define (extract-strings program)
268 (strings '())) ; assoc list of labels -> string
269 (define (fresh-string)
270 (set! cur-string (+ cur-string 1))
271 (format "string~a" (- cur-string 1)))
275 (let ((label (fresh-string)))
276 (set! strings (cons (cons label e) strings))
277 `(static-string ,label)))
278 (else (ast-traverse extract e))))
279 (let ((transformed (extract program)))
280 (cons strings transformed))))
282 (define (codegen-string-data s)
284 (emit "\t.string \"~a\"" (cdr s)))
286 ;; (define (amd64-abi f)
287 ;; ; preserve registers
288 ;; (emit "push %rbp")
289 ;; ;; (emit "push %rbx")
290 ;; ;; (for-each (lambda (i)
291 ;; ;; (emit (string-append
293 ;; ;; (number->string i))))
294 ;; ;; '(12 13 14 15))
296 ;; (emit "movq %rsp, %rbp") ; set up the base pointer
299 ;; ; restore preserved registers
300 ;; ;; (for-each (lambda (i)
301 ;; ;; (emit (string-append
303 ;; ;; (number->string i))))
304 ;; ;; '(15 14 13 12))
305 ;; ;; (emit "pop %rbx")
310 ; 16(%rbp) mem arg 0 prev frame
311 ; -----------------------
312 ; 8(%rbp) return address cur frame
314 ; -8(%rbp) do what you want
315 ; ... do what you want
316 ; 0(%rsp) do what you want
318 (define (param-register n)
326 (else (error #f "need to test out the below"))
327 (else (format "~a(%rsp)" (- n 6)))))
329 (define (codegen program)
330 (let* ((extract-res-0 (extract-strings program))
331 (strings (car extract-res-0))
332 (extract-res-1 (extract-lambdas (cdr extract-res-0)))
333 (lambdas (car extract-res-1))
334 (xform-prog (cdr extract-res-1)))
336 (emit "\t.global _start")
338 ; (emit ".p2align 4,,15") is this needed?
340 (for-each codegen-lambda lambdas)
343 (emit "movq %rsp, %rbp") ; set up the base pointer
344 (codegen-expr xform-prog 0 '())
347 (emit "mov %rax, %rdi")
348 (emit "mov $60, %rax")
353 (for-each codegen-string-data strings)))
355 (define (compile-to-binary program output)
356 (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
357 (let ([tmp-path "/tmp/a.s"])
358 (when (file-exists? tmp-path) (delete-file tmp-path))
359 (with-output-to-file tmp-path
360 (lambda () (codegen program)))
361 (system (format "clang -nostdlib /tmp/a.s -o ~a" output))))