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 (let ((offset (cdr (assoc name env))))
63 (emit "movq ~a(%rsp), %rax" offset)))
66 (define (fresh-lambda)
67 (set! cur-lambda (+ 1 cur-lambda))
68 (format "_lambda~a" (- cur-lambda 1)))
70 ; for now we can only call closures
71 (define (codegen-call closure args si env)
72 (let* ((captured (caddr closure))
73 (label (cadr closure))
74 (argument-start (length captured)))
76 ; first move the captured variables into param registers
79 (emit "movq ~a(%rsp), ~a"
80 (cdr (assoc e env)) ; offset of the var
82 captured (range 0 (length captured)))
85 ; then codegen the arguments and move them into the next param registers
89 (codegen-expr e si env)
90 ; move result to correct param register
91 (emit "movq %rax, ~a" (param-register i))))
92 args (range argument-start (length args)))
95 (emit "callq ~a" label)))
98 (define (codegen-lambda l)
99 (let* ((label (car l))
103 ; captured, then args
104 (vars (append captured args))
106 (param-registers (map param-register
107 (range 0 (length vars))))
108 (stack-offsets (map (lambda (i)
110 (range 0 (length vars))))
112 (copy-insts (map (lambda (r o)
113 (format "movq ~a, ~a(%rsp)"
115 param-registers stack-offsets))
117 (env (map cons vars stack-offsets)))
119 (display "## lambda body: ")
122 (display "## environment: ")
127 (for-each emit copy-insts)
128 (codegen-expr body (* (- wordsize) (length vars)) env)
129 )))) ; move args and capture vars to stack
131 (define (codegen-expr e si env)
132 (cond ((builtin? e) e)
136 (let ((callee (codegen-expr (car e) si env)))
138 ('+ (codegen-add (cdr e) si env))
139 ('- (codegen-sub (cadr e) (caddr e) si env))
140 ('* (codegen-mul (cadr e) (caddr e) si env))
141 ('! (codegen-not (cadr e) si env))
142 ('bool->int (codegen-expr (cadr e) si env))
143 (else (codegen-call callee (cdr e) si env)))))
145 ((let? e) (codegen-let
150 ((var? e) (codegen-var e si env))
151 ((boolean? e) (emit "movq $~a, %rax" (if e 1 0)))
152 (else (emit "movq $~a, %rax" e))))
154 (define (fold-map f x) (fold-left append '() (map f x)))
156 (define (free-vars prog)
160 ((builtin? e) '()) ; do nothing
161 ((var? e) (if (memq e bound) '() (list e)))
163 (set! bound (append (lambda-args e) bound))
164 (collect (lambda-body e)))
166 ((app? e) (fold-map collect e))
168 (let ((bind-fvs (fold-map (lambda (a)
169 ((set! bound (cons (car a) bound))
171 (let-bindings cadr)))
172 (body-fvs (fold-map collect (let-body e))))
173 (append bind-fvs body-fvs)))
178 (and (list? e) (eqv? (car e) 'closure)))
180 ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42)
181 (define (extract-lambdas program)
183 (define (add-lambda e)
184 (let* ((label (fresh-lambda))
185 (args (lambda-args e))
186 (captured (free-vars e))
187 (body (extract (lambda-body e)))
188 (new-lambda (list label args captured body)))
189 (set! lambdas (cons new-lambda lambdas))
190 `(closure ,label ,captured))) ; todo: should we string->symbol?
193 ((lambda? e) (add-lambda e))
195 ,(map extract (let-bindings e))
196 ,@(map extract (let-body e))))
197 ((app? e) (append (list (extract (car e)))
198 (map extract (cdr e))))
200 (let ((transformed (extract program)))
201 (cons lambdas transformed)))
203 (define (amd64-abi f)
207 (for-each (lambda (i)
210 (number->string i))))
214 ; restore preserved registers
215 (for-each (lambda (i)
218 (number->string i))))
225 ; 16(%rbp) mem arg 0 prev frame
226 ; -----------------------
227 ; 8(%rbp) return address cur frame
229 ; -8(%rbp) do what you want
230 ; ... do what you want
231 ; 0(%rsp) do what you want
233 (define (param-register n)
241 (else (error #f "need to test out the below"))
242 (else (format "~a(%rsp)" (- n 6)))))
246 (define (codegen program)
247 (let* ((extract-result (extract-lambdas program))
248 (lambdas (car extract-result))
249 (xform-prog (cdr extract-result)))
251 (emit ".p2align 4,,15")
253 (for-each codegen-lambda lambdas)
255 (emit ".globl _scheme_entry")
256 (emit "_scheme_entry:")
260 (lambda () (codegen-expr xform-prog 0 '())))))
262 (define (compile-to-binary program)
263 (when (not (eq? (typecheck program) 'int)) (error #f "not an int"))
264 (let ([tmp-path "/tmp/a.s"])
265 (when (file-exists? tmp-path) (delete-file tmp-path))
266 (with-output-to-file tmp-path
267 (lambda () (codegen program)))
268 (system "clang -fomit-frame-pointer /tmp/a.s rts.c")))