X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=9c692e7c1835c337fa9b9fc66812345e36e89c08;hp=55189cf6db556dc21bb3c294dc7cdba85491c4fb;hb=b1fae591d1981a511bd19218a6c85872344915c6;hpb=7be98b67cbad421a0b041d20e0f4620e70bd4cd6 diff --git a/codegen.scm b/codegen.scm index 55189cf..9c692e7 100644 --- a/codegen.scm +++ b/codegen.scm @@ -31,6 +31,12 @@ (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)] @@ -118,7 +124,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 +151,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)) b)]) + (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 +192,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 +205,16 @@ (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) + (begin + ; copy over whatevers on the stack + (emit "leaq ~a(%rbp), %rsi" (- inner-si size)) + (emit "leaq ~a(%rbp), %rdi" (- (get-offset name) size)) + (emit "movq $~a, %rcx" (/ size wordsize)) + (emit "rep movsq")) + + (emit "movq %rax, ~a(%rbp)" (get-offset name))))) comps) scc-env)) env @@ -190,11 +224,20 @@ (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) + (begin + (emit "leaq ~a(%rbp), %rsi" (- stack-offset stack-size)) + (emit "leaq ~a(%rbp), %rdi" (- si stack-size)) + (emit "movq $~a, %rcx" (/ stack-size wordsize)) + (emit "rep movsq")) + (emit "movq ~a(%rbp), %rax" stack-offset)))) (define cur-lambda 0) (define (fresh-lambda) @@ -363,25 +406,74 @@ (emit "~a:" exit-label))) (define (data-tor env e) - (and (list? e) + (if (not (list? e)) #f (assoc (car e) (flat-map data-tors (env-data-layouts env))))) + ; returns the internal offset in bytes of a product within an ADT + ; given the constructor layout + ; constructor-layout: (foo (Int Bool)) +(define (data-product-offset data-layouts type sum index) + (let* ([products (cdr (assoc sum (cdr (assoc type data-layouts))))] + [to-traverse (list-head products index)]) + (fold-left + (lambda (acc t) (+ acc (type-size data-layouts t))) + wordsize ; skip the tag in the first word + to-traverse))) + +(define (data-sum-tag data-layouts type sum) + + (define (go acc sums) + (when (null? sums) (error #f "data-sum-tag no sum for type" sum type)) + (if (eqv? sum (car sums)) + acc + (go (+ 1 acc) (cdr sums)))) + (let* ([type-sums (cdr (assoc type data-layouts))]) + (go 0 (map car type-sums)))) + (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))]) + (let* ([res (codegen-expr (cadr e) si env)] + [info (cadr tor)] + [index (caddr info)] + [type (car info)] + [sum (cadr info)]) + (when (not (on-stack? (cadr e))) + (error #f "trying to destruct something that isn't a stack expression")) + (emit "# deconstructing") + (emit "movq ~a(%rbp), %rax" + (- si (data-product-offset (env-data-layouts env) type sum index))))) + + (define (codegen-constructor tor) + (let* ([info (cadr tor)] + [type (car info)] + [sum (cadr info)] + [constructor (car e)] + + [args (cdr e)] + + [tag (data-sum-tag (env-data-layouts env) + type + sum)] + + [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 (on-stack? res) + (error #f "todo: handle stack-exprs in stack exprs") + (emit "movq %rax, ~a(%rbp)" stack-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))) + + (let* ([tor (data-tor env e)] + [constructor (eqv? 'constructor (caddr (cadr tor)))]) (if constructor (codegen-constructor tor) (codegen-destructor tor)))) @@ -423,21 +515,25 @@ ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax" (cadr e))) + ('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")))) ; 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 (struct-type? type) - (assoc type data-layout)) +(define (annotate-stack-values data-layouts ann-e) + (define (stack-type? type) + (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 (struct-type? type) - `(struct ,(type-size data-layout type) ,(ast-traverse strip e)) + (if (stack-type? type) + `(stack ,(type-size data-layouts type) ,(ast-traverse strip e)) (ast-traverse (lambda (x) - (annotate-stack-values data-layout x)) + (annotate-stack-values data-layouts x)) e)))) (define (free-vars prog) @@ -604,7 +700,8 @@ (set! cur-lambda 0) (let* ([data-layouts (program-data-layouts program)] - [type-annotated (annotate-types program)] + [pattern-matched (expand-pattern-matches program)] + [type-annotated (annotate-types pattern-matched)] [stack-annotated (annotate-stack-values data-layouts type-annotated)]