4 (define target 'darwin)
11 (define (codegen-add xs si env)
14 (emit "movq ~a(%rbp), %rax" si)
18 (emit "addq $~a, ~a(%rbp)" y si)
20 (codegen-expr y (- si wordsize) env)
21 (emit "addq %rax, ~a(%rbp)" si))))
24 ; use si(%rbp) as the accumulator
25 (emit "movq $0, ~a(%rbp)" si)
28 (define (codegen-binop opcode)
30 (codegen-expr b si env)
31 (emit "movq %rax, ~a(%rbp)" si)
32 (codegen-expr a (- si wordsize) env)
33 (emit "~a ~a(%rbp), %rax" opcode si)))
35 (define codegen-sub (codegen-binop "sub"))
37 (define codegen-mul (codegen-binop "imul"))
39 (define (codegen-not x si env)
40 (codegen-expr x si env)
42 (emit "andq $1, %rax"))
44 (define (codegen-eq a b si env)
45 (codegen-expr a si env)
46 (emit "movq %rax, ~a(%rbp)" si)
47 (codegen-expr b (- si wordsize) env)
48 (emit "subq ~a(%rbp), %rax" si)
50 (emit "andq $1, %rax"))
52 ; 'write file handle addr-string num-bytes
54 (define (codegen-print x si env)
55 (codegen-expr x si env) ; x should be a static-string, producing a label
57 ; get the length of the null terminated string
58 (emit "mov %rax, %rdi")
59 (emit "xor %al, %al") ; set %al to 0
60 (emit "mov $-1, %rcx") ; max search length = max int = -1
61 (emit "cld") ; clear direction flag, search up in memory
62 (emit "repne scasb") ; scan string, %rcx = -strlen - 1 - 1
64 (emit "not %rcx") ; -%rcx = strlen + 1
69 (emit "movq %rax, %rsi") ; string addr
70 (emit "movq %rcx, %rdx") ; num bytes
71 (emit "movq $1, %rdi") ; file handle (stdout)
72 (emit "movq $0x2000004, %rax")) ; syscall 4 (write)
74 (emit "mov %rax, %rsi") ; string addr
75 (emit "mov %rcx, %rdx") ; num bytes
76 (emit "mov $1, %rax") ; file handle (stdout)
77 (emit "mov $1, %rdi"))) ; syscall 1 (write)
82 (append (range s (- n 1))
83 (list (+ s (- n 1))))))
87 (define (codegen-let bindings body si env)
88 (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize)))
89 (range 0 (length bindings))))
90 (inner-si (- si (* (length bindings) wordsize)))
91 (names (map car bindings))
92 (exprs (map cadr bindings))
94 ; recursive let bindings: build environment as we go
96 (lambda (env name expr offset)
97 (codegen-expr expr inner-si env)
98 (emit "movq %rax, ~a(%rbp)" offset)
99 (cons (cons name offset) env))
100 env names exprs stack-offsets)))
101 (for-each (lambda (form)
102 (codegen-expr form inner-si inner-env))
105 (define (codegen-var name si env)
106 (when (not (assoc name env))
107 (error #f (format "Variable ~a is not bound" name)))
108 (let ((offset (cdr (assoc name env))))
109 (emit "movq ~a(%rbp), %rax" offset)))
111 (define cur-lambda 0)
112 (define (fresh-lambda)
113 (set! cur-lambda (+ 1 cur-lambda))
114 (format "_lambda~a" (- cur-lambda 1)))
116 ; for now we can only call closures
117 (define (codegen-call closure args si env)
118 (when (not (eq? (ast-type closure) 'closure))
119 (error #f (format "~a is not a closure" closure)))
120 (let* ((captured (caddr closure))
121 (label (cadr closure))
122 (argument-start (length captured)))
124 ; first move the captured variables into param registers
127 (emit "movq ~a(%rbp), ~a"
128 (cdr (assoc e env)) ; offset of the var
130 captured (range 0 (length captured)))
133 ; then codegen the arguments and move them into the next param registers
137 (codegen-expr e si env)
138 ; move result to correct param register
139 (emit "movq %rax, ~a" (param-register i))))
140 args (range argument-start (length args)))
142 (emit "addq $~a, %rsp" si) ; adjust the stack pointer to account all the stuff we put in the env
143 (emit "callq ~a" label)
144 (emit "subq $~a, %rsp" si)))
146 (define (codegen-lambda l)
147 (let* ((label (car l))
151 ; params = what actually gets passed
152 (params (append captured args))
154 (param-registers (map param-register
155 (range 0 (length params))))
156 (stack-offsets (map (lambda (i)
158 (range 1 (length params))))
160 (copy-insts (map (lambda (r o)
161 (format "movq ~a, ~a(%rbp)" r o))
162 param-registers stack-offsets))
164 (env (map cons params stack-offsets)))
166 (display "## lambda body: ")
169 (display "## environment: ")
173 (emit "push %rbp") ; preserve caller's base pointer
174 (emit "movq %rsp, %rbp") ; set up our own base pointer
176 (for-each emit copy-insts)
177 (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
179 (emit "pop %rbp") ; restore caller's base pointer
182 (define (codegen-string label)
184 ('darwin (emit "movq ~a@GOTPCREL(%rip), %rax" label))
185 ('linux (emit "movq $~a, %rax" label))))
188 (define (fresh-label)
189 (set! cur-label (+ 1 cur-label))
190 (format "label~a" (- cur-label 1)))
192 (define (codegen-if cond then else si env)
193 (codegen-expr cond si env)
194 (emit "cmpq $0, %rax")
195 (let ((exit-label (fresh-label))
196 (else-label (fresh-label)))
197 (emit "je ~a" else-label)
198 (codegen-expr then si env)
199 (emit "jmp ~a" exit-label)
200 (emit "~a:" else-label)
201 (codegen-expr else si env)
202 (emit "~a:" exit-label)))
204 (define (codegen-expr e si env)
209 (let ((callee (codegen-expr (car e) si env)))
211 ('+ (codegen-add (cdr e) si env))
212 ('- (codegen-sub (cadr e) (caddr e) si env))
213 ('* (codegen-mul (cadr e) (caddr e) si env))
214 ('! (codegen-not (cadr e) si env))
215 ('= (codegen-eq (cadr e) (caddr e) si env))
216 ('bool->int (codegen-expr (cadr e) si env))
217 ('print (codegen-print (cadr e) si env))
218 (else (codegen-call callee (cdr e) si env)))))
220 ('let (codegen-let (let-bindings e)
225 ('var (codegen-var e si env))
227 ('if (codegen-if (cadr e) (caddr e) (cadddr e) si env))
229 ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
230 ('int-literal (emit "movq $~a, %rax" e))
232 ('static-string (codegen-string (cadr e)))
234 (else (error #f "don't know how to codegen this"))))
237 (define (fold-map f x) (fold-left append '() (map f x)))
239 (define (free-vars prog)
243 ('builtin '()) ; do nothing
244 ('var (if (memq e bound) '() (list e)))
246 (set! bound (append (lambda-args e) bound))
247 (collect (lambda-body e)))
249 ('app (fold-map collect e))
251 (let ((bind-fvs (fold-map (lambda (a)
252 ((set! bound (cons (car a) bound))
254 (let-bindings cadr)))
255 (body-fvs (fold-map collect (let-body e))))
256 (append bind-fvs body-fvs)))
260 ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
261 (define (extract-lambdas program)
263 (define (add-lambda e)
264 (let* ((label (fresh-lambda))
265 (args (lambda-args e))
266 (captured (free-vars e))
267 (body (extract (lambda-body e)))
268 (new-lambda (list label args captured body)))
269 (set! lambdas (cons new-lambda lambdas))
270 `(closure ,label ,captured))) ; todo: should we string->symbol?
273 ('lambda (add-lambda e))
274 ('let `(let ,(map extract (let-bindings e))
275 ,@(map extract (let-body e))))
276 ('app (append (list (extract (car e)))
277 (map extract (cdr e))))
278 (else (ast-traverse extract e))))
279 (let ((transformed (extract program)))
280 (cons lambdas transformed)))
282 (define (extract-strings program)
284 (strings '())) ; assoc list of labels -> string
285 (define (fresh-string)
286 (set! cur-string (+ cur-string 1))
287 (format "string~a" (- cur-string 1)))
291 (let ((label (fresh-string)))
292 (set! strings (cons (cons label e) strings))
293 `(static-string ,label)))
294 (else (ast-traverse extract e))))
295 (let ((transformed (extract program)))
296 (cons strings transformed))))
298 (define (codegen-string-data s)
300 (emit "\t.string \"~a\"" (cdr s)))
302 ;; (define (amd64-abi f)
303 ;; ; preserve registers
304 ;; (emit "push %rbp")
305 ;; ;; (emit "push %rbx")
306 ;; ;; (for-each (lambda (i)
307 ;; ;; (emit (string-append
309 ;; ;; (number->string i))))
310 ;; ;; '(12 13 14 15))
312 ;; (emit "movq %rsp, %rbp") ; set up the base pointer
315 ;; ; restore preserved registers
316 ;; ;; (for-each (lambda (i)
317 ;; ;; (emit (string-append
319 ;; ;; (number->string i))))
320 ;; ;; '(15 14 13 12))
321 ;; ;; (emit "pop %rbx")
326 ; 16(%rbp) mem arg 0 prev frame
327 ; -----------------------
328 ; 8(%rbp) return address cur frame
330 ; -8(%rbp) do what you want
331 ; ... do what you want
332 ; 0(%rsp) do what you want
334 (define (param-register n)
342 (else (error #f "need to test out the below"))
343 (else (format "~a(%rsp)" (- n 6)))))
345 (define (codegen program)
346 (let* ((extract-res-0 (extract-strings program))
347 (strings (car extract-res-0))
348 (extract-res-1 (extract-lambdas (cdr extract-res-0)))
349 (lambdas (car extract-res-1))
350 (xform-prog (cdr extract-res-1)))
352 (emit "\t.global _start")
354 ; (emit ".p2align 4,,15") is this needed?
356 (for-each codegen-lambda lambdas)
359 (emit "movq %rsp, %rbp") ; set up the base pointer
360 (codegen-expr xform-prog 0 '())
363 (emit "mov %rax, %rdi")
365 ('darwin (emit "movq $0x2000001, %rax"))
366 ('linux (emit "mov $60, %rax")))
371 (for-each codegen-string-data strings)))
373 (define (compile-to-binary program output t)
375 (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
376 (let ([tmp-path "/tmp/a.s"])
377 (when (file-exists? tmp-path) (delete-file tmp-path))
378 (with-output-to-file tmp-path
379 (lambda () (codegen program)))
383 (system "as /tmp/a.s -o /tmp/a.o")
384 (system (format "ld /tmp/a.o -e _start -macosx_version_min 10.14 -static -o ~a" output)))
386 (system "as /tmp/a.s -o /tmp/a.o")
387 (system (format "ld /tmp/a.o -o ~a" output))))))