X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=codegen.scm;h=968a428cd2f442bf820ea37c0a01a3e92047e4b5;hb=9ee429534c3011b0ed413dc01e81db13f71ac884;hp=04816ab75d533b6b950ff7fe17813cfce1880383;hpb=43f8c4631ae0a3163c780e7511a96f6b05054544;p=scheme.git diff --git a/codegen.scm b/codegen.scm index 04816ab..968a428 100644 --- a/codegen.scm +++ b/codegen.scm @@ -38,6 +38,14 @@ (emit "notq %rax") (emit "andq $1, %rax")) +(define (codegen-eq a b si env) + (codegen-expr a si env) + (emit "movq %rax, ~a(%rsp)" si) + (codegen-expr b (- si wordsize) env) + (emit "subq ~a(%rsp), %rax" si) + (emit "not %rax") + (emit "andq $1, %rax")) + (define (range s n) (if (= 0 n) '() (append (range s (- n 1)) @@ -51,14 +59,21 @@ (inner-si (- si (* (length bindings) wordsize))) (names (map car bindings)) (exprs (map cadr bindings)) - (inner-env (append (map cons names stack-offsets) env))) - (for-each (lambda (expr offset) + + ; recursive let bindings: build environment as we go + (inner-env (fold-left + (lambda (env name expr offset) (codegen-expr expr inner-si env) - (emit "movq %rax, ~a(%rsp)" offset)) - exprs stack-offsets) - (for-each (lambda (form) (codegen-expr form inner-si inner-env)) body))) + (emit "movq %rax, ~a(%rsp)" offset) + (cons (cons name offset) env)) + env names exprs stack-offsets))) + (for-each (lambda (form) + (codegen-expr form inner-si inner-env)) + body))) (define (codegen-var name si env) + (when (not (assoc name env)) + (error #f (format "Variable ~a is not bound" name))) (let ((offset (cdr (assoc name env)))) (emit "movq ~a(%rsp), %rax" offset))) @@ -69,6 +84,8 @@ ; for now we can only call closures (define (codegen-call closure args si env) + (when (not (eq? (ast-type closure) 'closure)) + (error #f (format "~a is not a closure" closure))) (let* ((captured (caddr closure)) (label (cadr closure)) (argument-start (length captured))) @@ -128,43 +145,68 @@ (codegen-expr body (* (- wordsize) (length vars)) env) )))) ; move args and capture vars to stack -(define (codegen-expr e si env) - (cond ((builtin? e) e) - ((closure? e) e) +(define cur-label 0) +(define (fresh-label) + (set! cur-label (+ 1 cur-label)) + (format "label~a" (- cur-label 1))) + +(define (codegen-if cond then else si env) + (codegen-expr cond si env) + (emit "cmpq $0, %rax") + (let ((exit-label (fresh-label)) + (else-label (fresh-label))) + (emit "je ~a" else-label) + (codegen-expr then si env) + (emit "jmp ~a" exit-label) + (emit "~a:" else-label) + (codegen-expr else si env) + (emit "~a:" exit-label))) - ((app? e) +(define (codegen-expr e si env) + (case (ast-type e) + ('builtin e) + ('closure e) + ('app (let ((callee (codegen-expr (car e) si env))) (case callee ('+ (codegen-add (cdr e) si env)) ('- (codegen-sub (cadr e) (caddr e) si env)) ('* (codegen-mul (cadr e) (caddr e) si env)) ('! (codegen-not (cadr e) si env)) + ('= (codegen-eq (cadr e) (caddr e) si env)) ('bool->int (codegen-expr (cadr e) si env)) (else (codegen-call callee (cdr e) si env))))) - ((let? e) (codegen-let - (let-bindings e) + ('let (codegen-let (let-bindings e) (let-body e) si env)) - ((var? e) (codegen-var e si env)) - ((boolean? e) (emit "movq $~a, %rax" (if e 1 0))) - (else (emit "movq $~a, %rax" e)))) + + ('var (codegen-var e si env)) + + ('if (codegen-if (cadr e) (caddr e) (cadddr e) si env)) + + ('string-literal (emit "movq ~a, %rax" label)) + ('bool-literal (emit "movq $~a, %rax" (if e 1 0))) + ('int-literal (emit "movq $~a, %rax" e)) + + (else (error #f "don't know how to codegen this")))) + (define (fold-map f x) (fold-left append '() (map f x))) (define (free-vars prog) (define bound '()) (define (collect e) - (cond - ((builtin? e) '()) ; do nothing - ((var? e) (if (memq e bound) '() (list e))) - ((lambda? e) + (case (ast-type e) + ('builtin '()) ; do nothing + ('var (if (memq e bound) '() (list e))) + ('lambda (set! bound (append (lambda-args e) bound)) (collect (lambda-body e))) - ((app? e) (fold-map collect e)) - ((let? e) + ('app (fold-map collect e)) + ('let (let ((bind-fvs (fold-map (lambda (a) ((set! bound (cons (car a) bound)) (collect (cdr a)))) @@ -174,9 +216,6 @@ (else '()))) (collect prog)) -(define (closure? e) - (and (list? e) (eqv? (car e) 'closure))) - ; ((lambda (x) (+ x 1)) 42) => {lambda0: (x) (+ x 1)}, (@lambda0 42) (define (extract-lambdas program) (define lambdas '()) @@ -189,17 +228,18 @@ (set! lambdas (cons new-lambda lambdas)) `(closure ,label ,captured))) ; todo: should we string->symbol? (define (extract e) - (cond - ((lambda? e) (add-lambda e)) - ((let? e) `(let - ,(map extract (let-bindings e)) + (case (ast-type e) + ('lambda (add-lambda e)) + ('let `(let ,(map extract (let-bindings e)) ,@(map extract (let-body e)))) - ((app? e) (append (list (extract (car e))) + ('app (append (list (extract (car e))) (map extract (cdr e)))) - (else e))) + (else (ast-traverse extract e)))) (let ((transformed (extract program))) (cons lambdas transformed))) +;(define (extract-strings program)) + (define (amd64-abi f) ; preserve registers (emit "push %rbp") @@ -241,8 +281,6 @@ (else (error #f "need to test out the below")) (else (format "~a(%rsp)" (- n 6))))) - - (define (codegen program) (let* ((extract-result (extract-lambdas program)) (lambdas (car extract-result)) @@ -252,17 +290,19 @@ (for-each codegen-lambda lambdas) - (emit ".globl _scheme_entry") - (emit "_scheme_entry:") + (emit ".globl _start") + (emit "_start:") + (codegen-expr xform-prog 0 '()) + ; exit syscall + (emit "mov %rax, %rdi") + (emit "mov $60, %rax") + (emit "syscall"))) - (amd64-abi - (lambda () (codegen-expr xform-prog 0 '()))))) - -(define (compile-to-binary program) +(define (compile-to-binary program output) (when (not (eq? (typecheck program) 'int)) (error #f "not an int")) (let ([tmp-path "/tmp/a.s"]) (when (file-exists? tmp-path) (delete-file tmp-path)) (with-output-to-file tmp-path (lambda () (codegen program))) - (system "clang -fomit-frame-pointer /tmp/a.s rts.c"))) + (system (format "clang -nostdlib /tmp/a.s -o ~a" output))))