X-Git-Url: http://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=2d5f4ac2731800dba6e4041162bc7693be62f90a;hp=10e005f8ad90e840aad396da4a0cdb5032163f6c;hb=89ef32141732e6d0bbfc7484b465844b62d8d139;hpb=844dcd052c6f551d9936693c2b4c49cf920c7051 diff --git a/codegen.scm b/codegen.scm index 10e005f..2d5f4ac 100644 --- a/codegen.scm +++ b/codegen.scm @@ -9,6 +9,35 @@ (apply printf s) (display "\n"))) +(define wordsize 8) + +(define (type-size type env) + + (define (adt-size adt) + (let ([sizes + (map (lambda (sum) + (fold-left (lambda (acc x) (+ acc (type-size x))) + wordsize ; one word needed to store tag + (cdr sum))) + (cdr adt))]) + (apply max sizes))) + + (case type + ['Int wordsize] + ['Bool wordsize] + [else + (let ([adt (assoc type (env-adts env))]) + (if adt + (adt-size adt) + (error #f "unknown size" type)))])) + + ; an environment consists of adt layouts in scope, + ; and any bound variables. + ; bound variables are an assoc list with their stack offset +(define make-env list) +(define env-adts car) +(define env-bindings cadr) + (define (codegen-add xs si env) (define (go ys) (if (null? ys) @@ -76,8 +105,6 @@ ('linux (emit "mov $1, %rax"))) ; syscall 1 (write) (emit "syscall")) -(define wordsize 8) - (define (codegen-let bindings body si env) ; is this a closure that captures itself? @@ -86,24 +113,54 @@ (and (eqv? (ast-type expr) 'closure) (memv name (caddr expr)))) - (let* ((stack-offsets (map (lambda (name x) ; assoc map of binding name to offset + + ;; (define (emit-scc scc env) + ;; ; acc is a pair of the env and list of touchups + ;; (define (emit-binding acc binding) + ;; (let ([binding-name (car binding)] + ;; [binding-body (cadr binding)] + + ;; [other-bindings (filter + ;; (lambda (x) (not (eqv? binding-name x))) + ;; scc)] + ;; [mutually-recursives + ;; (filter + ;; (lambda (other-binding) + ;; (memv other-binding (references binding-body))) + ;; other-bindings)] + + ;; [new-touchups (append touchups (cdr acc))]) + + ;; ; TODO: assert that the only mutually recursives are closures + ;; (for-each + ;; (lambda (binding) + ;; (when (not (eqv? (ast-type (cadr binding)) + + ;; (emit "asdf") + ;; (cons new-env new-touchups) + ;; )) + + ;; (fold-left emit-binding (cons env '()) scc)))) + + (let* ([stack-offsets (map (lambda (name x) ; assoc map of binding name to offset (cons name (- si (* x wordsize)))) (map car bindings) - (range 0 (length bindings)))) - (inner-si (- si (* (length bindings) wordsize))) + (range 0 (length bindings)))] + [inner-si (- si (* (length bindings) wordsize))] - (get-offset (lambda (n) (cdr (assoc n stack-offsets)))) + [get-offset (lambda (n) (cdr (assoc n stack-offsets)))] [inner-env (fold-left (lambda (env comps) - (let ([scc-env + (let* ([scc-binding-offsets (fold-left (lambda (acc name) (cons (cons name (get-offset name)) acc)) - env - comps)]) + (env-bindings env) + comps)] + [scc-env (make-env (env-adts env) scc-binding-offsets)]) (for-each (lambda (name) (let ([expr (cadr (assoc name bindings))]) @@ -113,23 +170,26 @@ ; codegen-closure realise this! (codegen-expr expr inner-si + (make-env + (env-adts scc-env) (cons (cons name 'self-captive) - scc-env)) + (env-bindings scc-env)))) (codegen-expr expr inner-si scc-env)) (emit "movq %rax, ~a(%rbp)" (get-offset name)))) comps) scc-env)) - env (reverse (sccs (graph bindings))))]) + env + (reverse (sccs (graph bindings))))]) (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(%rbp), %rax" offset))) + (let ([binding (assoc name (env-bindings env))]) + (if (not binding) + (error #f (format "Variable ~a is not bound" name)) + (emit "movq ~a(%rbp), %rax" (cdr binding))))) (define cur-lambda 0) (define (fresh-lambda) @@ -163,7 +223,7 @@ ; store the captured vars (for-each (lambda (var-name heap-offset) - (let ([stack-offset (cdr (assoc var-name env))]) + (let ([stack-offset (cdr (assoc var-name (env-bindings env)))]) (emit "### captive ~a" var-name) (if (eqv? stack-offset 'self-captive) ; captive refers to this closure: @@ -238,7 +298,8 @@ (* (- wordsize) (+ 1 i))) (range 0 (length params)))) - (env (map cons params stack-offsets))) + [bindings (map cons params stack-offsets)] + [env (make-env '() bindings)]) (emit "~a:" label) (display "## lambda captives: ") @@ -296,6 +357,30 @@ (codegen-expr else si env) (emit "~a:" exit-label))) +(define (data-tor env e) + (and (list? e) + (assoc (car e) (flat-map data-tors (env-adts env))))) + +(define (codegen-data-tor e si env) + + (define (codegen-destructor tor) + (codegen-expr (cadr e) si env) + (let ([index (cadr tor)] + [products 2] + [to-traverse (list-head products index)] + [offset (fold-left + (lambda (acc t) (+ acc (type-size t))) + wordsize ; skip tag in first word + to-traverse)]) + 3 + )) + + (let ([tor (data-tor env e)] + [constructor (eqv? 'constructor (cadr tor))]) + (if constructor + (codegen-constructor tor) + (codegen-destructor tor)))) + (define (codegen-expr e si env) (emit "# ~a" e) (case (ast-type e) @@ -309,7 +394,10 @@ ('= (codegen-eq (cadr e) (caddr e) si env)) ('bool->int (codegen-expr (cadr e) si env)) ('print (codegen-print (cadr e) si env)) - (else (codegen-call (car e) (cdr e) si env)))) + (else + (if (data-tor env e) + (codegen-data-tor e si env) + (codegen-call (car e) (cdr e) si env))))) ; this is a builtin being passed around as a variable ('builtin (emit "movq $~a, %rax" (builtin-id e))) @@ -449,29 +537,6 @@ (emit "~a:" (car s)) (emit "\t.string \"~a\"" (cdr s))) -;; (define (amd64-abi f) -;; ; preserve registers -;; (emit "push %rbp") -;; ;; (emit "push %rbx") -;; ;; (for-each (lambda (i) -;; ;; (emit (string-append -;; ;; "push %r" -;; ;; (number->string i)))) -;; ;; '(12 13 14 15)) - -;; (emit "movq %rsp, %rbp") ; set up the base pointer - -;; (f) ; call stuff -;; ; restore preserved registers -;; ;; (for-each (lambda (i) -;; ;; (emit (string-append -;; ;; "pop %r" -;; ;; (number->string i)))) -;; ;; '(15 14 13 12)) -;; ;; (emit "pop %rbx") -;; (emit "pop %rbp") -;; (emit "ret")) - ; 24(%rbp) mem arg 1 ; 16(%rbp) mem arg 0 prev frame ; ----------------------- @@ -520,6 +585,8 @@ (set! cur-lambda 0) (let* ([body (program-body program)] + [data-layouts (map data-layout (program-datas program))] + (extract-res-0 (extract-strings body)) (strings (car extract-res-0)) (extract-res-1 (extract-lambdas (cdr extract-res-0))) @@ -538,7 +605,7 @@ (emit "movq %rsp, %rbp") ; set up the base pointer - (codegen-expr xform-prog (- wordsize) '()) + (codegen-expr xform-prog (- wordsize) (make-env data-layouts '())) ; exit syscall (emit "mov %rax, %rdi")