X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=dd7950765c9ef375d443a110788a9146079fad20;hp=dededbec01e0856b19703d8945e096e49b316aa5;hb=d6b60d54bc90e5ebdc643d05d0b806ae7fd8aa7c;hpb=006b94f5a24a794665788737fec8d54086284317 diff --git a/codegen.scm b/codegen.scm index dededbe..dd79507 100644 --- a/codegen.scm +++ b/codegen.scm @@ -11,6 +11,10 @@ (define wordsize 8) +(define (stack-type? data-layouts type) + (if (assoc type data-layouts) #t #f)) + + (define (type-size data-layouts type) (define (adt-size adt) @@ -31,11 +35,25 @@ (adt-size adt) (error #f "unknown size" type)))])) + ; returns the size of an expression's result in bytes +(define (expr-size e) + (if (eqv? (ast-type e) 'stack) + (cadr e) + wordsize)) + (define (on-stack? expr) (case (ast-type expr) ['stack (cadr expr)] [else #f])) +; does a movsq for something on the stack +(define (emit-stack-copy src dst size) + (emit "leaq ~a(%rbp), %rsi" (- src size)) + (emit "leaq ~a(%rbp), %rdi" (- dst size)) + (emit "movq $~a, %rcx" (/ size wordsize)) + (emit "rep movsq")) + + ; an environment consists of adt layouts in scope, ; and any bound variables. ; bound variables are an assoc list with their stack offset @@ -118,7 +136,6 @@ (and (eqv? (ast-type expr) 'closure) (memv name (caddr expr)))) - ;; (define (emit-scc scc env) ;; ; acc is a pair of the env and list of touchups ;; (define (emit-binding acc binding) @@ -146,12 +163,31 @@ ;; )) ;; (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))] + ; assoc map of binding name to size + (define stack-sizes + (map (lambda (binding) (cons (car binding) (expr-size (cadr binding)))) + bindings)) + + ; assoc map of binding name to offset + (define stack-offsets + ; 2 4 2 8 6 + (let* ([totals ; 2 6 8 16 22 + (reverse (fold-left (lambda (acc x) + (if (null? acc) + (list x) + (cons (+ x (car acc)) acc))) + '() + (map cdr stack-sizes)))] + ; 0 2 6 8 16 + [relative-offsets (map - totals (map cdr stack-sizes))] + [absolute-offsets (map (lambda (x) (- si x)) relative-offsets)]) + (map cons (map car stack-sizes) absolute-offsets))) + + (let* ( + ; the stack index used when codegening binding body and main body + ; -> stack -> + ; [stack-offsets | inner-si] + [inner-si (- si (fold-left + 0 (map cdr stack-sizes)))] [get-offset (lambda (n) (cdr (assoc n stack-offsets)))] @@ -168,7 +204,8 @@ [scc-env (make-env (env-data-layouts env) scc-binding-offsets)]) (for-each (lambda (name) - (let ([expr (cadr (assoc name bindings))]) + (let* ([expr (cadr (assoc name bindings))] + [size (expr-size expr)]) (emit "## generating ~a with scc-env ~a" name scc-env) (if (self-captive-closure? name expr) ; if self-captive, insert a flag into the environment to let @@ -180,7 +217,11 @@ (cons (cons name 'self-captive) (env-bindings scc-env)))) (codegen-expr expr inner-si scc-env)) - (emit "movq %rax, ~a(%rbp)" (get-offset name)))) + + (if (on-stack? expr) + ; copy over whatevers on the stack + (emit-stack-copy inner-si (get-offset name) size) + (emit "movq %rax, ~a(%rbp)" (get-offset name))))) comps) scc-env)) env @@ -190,11 +231,16 @@ (codegen-expr form inner-si inner-env)) body))) -(define (codegen-var name si env) - (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 (codegen-var e si env) + (let* ([stack-size (on-stack? e)] + [name (if (on-stack? e) (caddr e) e)] + [stack-offset (cdr (assoc name (env-bindings env)))]) + (when (not stack-offset) + (error #f (format "Variable ~a is not bound" name))) + + (if (on-stack? e) + (emit-stack-copy stack-offset si stack-size) + (emit "movq ~a(%rbp), %rax" stack-offset)))) (define cur-lambda 0) (define (fresh-lambda) @@ -389,17 +435,34 @@ (define (codegen-data-tor e si env) + (define dls (env-data-layouts env)) + (define (codegen-destructor tor) (let* ([res (codegen-expr (cadr e) si env)] [info (cadr tor)] - [index (caddr info)] [type (car info)] - [sum (cadr info)]) - (when (not (stack-expr? res)) - (error #f "codegened something that wasn't a stack expression")) - ;TODO handle stack types - (emit "movq ~a(%rbp), %rax" - (- si (data-product-offset (env-data-layouts env) type sum index))))) + [sum (cadr info)] + [index (caddr info)] + [product-type (cadddr info)] + [product-type-size (type-size dls product-type)] + + [safe-space-offset (- si (type-size dls type))] + + [inner-offset (- si (data-product-offset dls type sum index))]) + + (when (not (on-stack? (cadr e))) + (error #f "trying to destruct something that isn't a stack expression")) + (emit "# deconstructing") + + (if (stack-type? (env-data-layouts env) product-type) + ; if copying from the stack, need to first copy + ; to a safe space above to avoid overwriting + ; the original result on the stack + ; this is bad. please remove this in the rewrite. + (begin + (emit-stack-copy inner-offset safe-space-offset product-type-size) + (emit-stack-copy safe-space-offset si product-type-size)) + (emit "movq ~a(%rbp), %rax" inner-offset)))) (define (codegen-constructor tor) (let* ([info (cadr tor)] @@ -413,21 +476,24 @@ type sum)] + [inner-si (- si (type-size dls type))] + + [product-types (cdr (assoc sum (cdr (assoc type dls))))] + [insert-product - (lambda (expr i) - (let ([res (codegen-expr expr si env)] - [stack-offset (- si (data-product-offset (env-data-layouts env) - type sum - i))]) - (if (stack-expr? res) - (error #f "todo: handle stack-exprs in stack exprs") - (emit "movq %rax, ~a(%rbp)" stack-offset))))]) + (lambda (expr i product-type) + (let ([dest-offset + (- si (data-product-offset dls type sum i))] + [product-size (type-size dls product-type)]) + (codegen-expr expr inner-si env) + (if (on-stack? expr) + (emit-stack-copy inner-si dest-offset product-size) + (emit "movq %rax, ~a(%rbp)" dest-offset))))]) ; emit the tag (emit "movq $~a, ~a(%rbp)" tag si) - - (for-each insert-product args (range 0 (length args))) - (type-size (env-data-layouts env) type))) + ; generate products + (for-each insert-product args (range 0 (length args)) product-types))) (let* ([tor (data-tor env e)] [constructor (eqv? 'constructor (caddr (cadr tor)))]) @@ -435,9 +501,6 @@ (codegen-constructor tor) (codegen-destructor tor)))) -(define stack-expr? number?) - - ; returns a number if result was stored on stack (define (codegen-expr e si env) (emit "# ~a" e) (case (ast-type e) @@ -475,23 +538,27 @@ ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax" (cadr e))) - ('stack (codegen-expr (caddr e) si env)) + ('stack (case (ast-type (caddr e)) + ['var (codegen-var e si env)] + [else (codegen-expr (caddr e) si env)])) - (else (error #f "don't know how to codegen this")))) + (else (error #f "don't know how to codegen this"))) + (emit "# done ~a" e)) ; takes in a expr annotated with types and returns a type-less AST ; with stack values wrapped -(define (annotate-stack-values data-layout ann-e) +(define (annotate-stack-values data-layouts ann-e) (define (stack-type? type) - (assoc type data-layout)) + (assoc type data-layouts)) (define (strip e) (ast-traverse strip (ann-expr e))) (let* ([e (ann-expr ann-e)] [type (ann-type ann-e)]) (if (stack-type? type) - `(stack ,type ,(ast-traverse strip e)) + `(stack ,(type-size data-layouts type) + ,(ast-traverse (lambda (x) (annotate-stack-values data-layouts x)) e)) (ast-traverse (lambda (x) - (annotate-stack-values data-layout x)) + (annotate-stack-values data-layouts x)) e)))) (define (free-vars prog)