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"))
41 (define (codegen-eq a b si env)
42 (codegen-expr a si env)
43 (emit "movq %rax, ~a(%rsp)" si)
44 (codegen-expr b (- si wordsize) env)
45 (emit "subq ~a(%rsp), %rax" si)
47 (emit "andq $1, %rax"))
49 (define (codegen-print x si env)
50 (codegen-expr x si env) ; x should be a static-string, producing a label
52 ; get the length of the null terminated string
53 (emit "mov %rax, %rdi")
54 (emit "xor %al, %al") ; set %al to 0
55 (emit "mov $-1, %rcx") ; max search length = max int = -1
56 (emit "cld") ; clear direction flag, search up in memory
57 (emit "repne scasb") ; scan string, %rcx = -strlen - 1 - 1
59 (emit "not %rcx") ; -%rcx = strlen + 1
62 (emit "mov %rcx, %rdx") ; number of bytes
63 (emit "mov %rax, %rsi") ; addr of string
64 (emit "mov $1, %rax") ; file handle 1 (stdout)
65 (emit "mov $1, %rdi") ; syscall 1 (write)
70 (append (range s (- n 1))
71 (list (+ s (- n 1))))))
75 (define (codegen-let bindings body si env)
76 (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize)))
77 (range 0 (length bindings))))
78 (inner-si (- si (* (length bindings) wordsize)))
79 (names (map car bindings))
80 (exprs (map cadr bindings))
82 ; recursive let bindings: build environment as we go
84 (lambda (env name expr offset)
85 (codegen-expr expr inner-si env)
86 (emit "movq %rax, ~a(%rsp)" offset)
87 (cons (cons name offset) env))
88 env names exprs stack-offsets)))
89 (for-each (lambda (form)
90 (codegen-expr form inner-si inner-env))
93 (define (codegen-var name si env)
94 (when (not (assoc name env))
95 (error #f (format "Variable ~a is not bound" name)))
96 (let ((offset (cdr (assoc name env))))
97 (emit "movq ~a(%rsp), %rax" offset)))
100 (define (fresh-lambda)
101 (set! cur-lambda (+ 1 cur-lambda))
102 (format "_lambda~a" (- cur-lambda 1)))
104 ; for now we can only call closures
105 (define (codegen-call closure args si env)
106 (when (not (eq? (ast-type closure) 'closure))
107 (error #f (format "~a is not a closure" closure)))
108 (let* ((captured (caddr closure))
109 (label (cadr closure))
110 (argument-start (length captured)))
112 ; first move the captured variables into param registers
115 (emit "movq ~a(%rsp), ~a"
116 (cdr (assoc e env)) ; offset of the var
118 captured (range 0 (length captured)))
121 ; then codegen the arguments and move them into the next param registers
125 (codegen-expr e si env)
126 ; move result to correct param register
127 (emit "movq %rax, ~a" (param-register i))))
128 args (range argument-start (length args)))
131 (emit "callq ~a" label)))
134 (define (codegen-lambda l)
135 (let* ((label (car l))
139 ; captured, then args
140 (vars (append captured args))
142 (param-registers (map param-register
143 (range 0 (length vars))))
144 (stack-offsets (map (lambda (i)
146 (range 0 (length vars))))
148 (copy-insts (map (lambda (r o)
149 (format "movq ~a, ~a(%rsp)"
151 param-registers stack-offsets))
153 (env (map cons vars stack-offsets)))
155 (display "## lambda body: ")
158 (display "## environment: ")
163 (for-each emit copy-insts)
164 (codegen-expr body (* (- wordsize) (length vars)) env)
165 )))) ; move args and capture vars to stack
168 (define (fresh-label)
169 (set! cur-label (+ 1 cur-label))
170 (format "label~a" (- cur-label 1)))
172 (define (codegen-if cond then else si env)
173 (codegen-expr cond si env)
174 (emit "cmpq $0, %rax")
175 (let ((exit-label (fresh-label))
176 (else-label (fresh-label)))
177 (emit "je ~a" else-label)
178 (codegen-expr then si env)
179 (emit "jmp ~a" exit-label)
180 (emit "~a:" else-label)
181 (codegen-expr else si env)
182 (emit "~a:" exit-label)))
184 (define (codegen-expr e si env)
189 (let ((callee (codegen-expr (car e) si env)))
191 ('+ (codegen-add (cdr e) si env))
192 ('- (codegen-sub (cadr e) (caddr e) si env))
193 ('* (codegen-mul (cadr e) (caddr e) si env))
194 ('! (codegen-not (cadr e) si env))
195 ('= (codegen-eq (cadr e) (caddr e) si env))
196 ('bool->int (codegen-expr (cadr e) si env))
197 ('print (codegen-print (cadr e) si env))
198 (else (codegen-call callee (cdr e) si env)))))
200 ('let (codegen-let (let-bindings e)
205 ('var (codegen-var e si env))
207 ('if (codegen-if (cadr e) (caddr e) (cadddr e) si env))
209 ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
210 ('int-literal (emit "movq $~a, %rax" e))
212 ('static-string (emit "movq $~a, %rax" (cadr e))) ; move label
214 (else (error #f "don't know how to codegen this"))))
217 (define (fold-map f x) (fold-left append '() (map f x)))
219 (define (free-vars prog)
223 ('builtin '()) ; do nothing
224 ('var (if (memq e bound) '() (list e)))
226 (set! bound (append (lambda-args e) bound))
227 (collect (lambda-body e)))
229 ('app (fold-map collect e))
231 (let ((bind-fvs (fold-map (lambda (a)
232 ((set! bound (cons (car a) bound))
234 (let-bindings cadr)))
235 (body-fvs (fold-map collect (let-body e))))
236 (append bind-fvs body-fvs)))
240 ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
241 (define (extract-lambdas program)
243 (define (add-lambda e)
244 (let* ((label (fresh-lambda))
245 (args (lambda-args e))
246 (captured (free-vars e))
247 (body (extract (lambda-body e)))
248 (new-lambda (list label args captured body)))
249 (set! lambdas (cons new-lambda lambdas))
250 `(closure ,label ,captured))) ; todo: should we string->symbol?
253 ('lambda (add-lambda e))
254 ('let `(let ,(map extract (let-bindings e))
255 ,@(map extract (let-body e))))
256 ('app (append (list (extract (car e)))
257 (map extract (cdr e))))
258 (else (ast-traverse extract e))))
259 (let ((transformed (extract program)))
260 (cons lambdas transformed)))
262 (define (extract-strings program)
264 (strings '())) ; assoc list of labels -> string
265 (define (fresh-string)
266 (set! cur-string (+ cur-string 1))
267 (format "string~a" (- cur-string 1)))
271 (let ((label (fresh-string)))
272 (set! strings (cons (cons label e) strings))
273 `(static-string ,label)))
274 (else (ast-traverse extract e))))
275 (let ((transformed (extract program)))
276 (cons strings transformed))))
278 (define (codegen-string-data s)
280 (emit "\t.string \"~a\"" (cdr s)))
282 (define (amd64-abi f)
286 (for-each (lambda (i)
289 (number->string i))))
293 ; restore preserved registers
294 (for-each (lambda (i)
297 (number->string i))))
304 ; 16(%rbp) mem arg 0 prev frame
305 ; -----------------------
306 ; 8(%rbp) return address cur frame
308 ; -8(%rbp) do what you want
309 ; ... do what you want
310 ; 0(%rsp) do what you want
312 (define (param-register n)
320 (else (error #f "need to test out the below"))
321 (else (format "~a(%rsp)" (- n 6)))))
323 (define (codegen program)
324 (let* ((extract-res-0 (extract-strings program))
325 (strings (car extract-res-0))
326 (extract-res-1 (extract-lambdas (cdr extract-res-0)))
327 (lambdas (car extract-res-1))
328 (xform-prog (cdr extract-res-1)))
330 (emit "\t.globl _start")
332 ; (emit ".p2align 4,,15") is this needed?
334 (for-each codegen-lambda lambdas)
338 (codegen-expr xform-prog 0 '())
341 (emit "mov %rax, %rdi")
342 (emit "mov $60, %rax")
347 (for-each codegen-string-data strings)))
349 (define (compile-to-binary program output)
350 (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
351 (let ([tmp-path "/tmp/a.s"])
352 (when (file-exists? tmp-path) (delete-file tmp-path))
353 (with-output-to-file tmp-path
354 (lambda () (codegen program)))
355 (system (format "clang -nostdlib /tmp/a.s -o ~a" output))))