X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=9c692e7c1835c337fa9b9fc66812345e36e89c08;hp=2d5f4ac2731800dba6e4041162bc7693be62f90a;hb=b1fae591d1981a511bd19218a6c85872344915c6;hpb=89ef32141732e6d0bbfc7484b465844b62d8d139 diff --git a/codegen.scm b/codegen.scm index 2d5f4ac..9c692e7 100644 --- a/codegen.scm +++ b/codegen.scm @@ -11,12 +11,12 @@ (define wordsize 8) -(define (type-size type env) +(define (type-size data-layouts type) (define (adt-size adt) (let ([sizes (map (lambda (sum) - (fold-left (lambda (acc x) (+ acc (type-size x))) + (fold-left (lambda (acc x) (+ acc (type-size data-layouts x))) wordsize ; one word needed to store tag (cdr sum))) (cdr adt))]) @@ -26,16 +26,27 @@ ['Int wordsize] ['Bool wordsize] [else - (let ([adt (assoc type (env-adts env))]) + (let ([adt (assoc type data-layouts)]) (if adt (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])) + ; 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-data-layouts car) (define env-bindings cadr) (define (codegen-add xs si env) @@ -113,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) @@ -141,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)))] @@ -160,10 +189,11 @@ acc)) (env-bindings env) comps)] - [scc-env (make-env (env-adts env) scc-binding-offsets)]) + [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 @@ -171,11 +201,20 @@ (codegen-expr expr inner-si (make-env - (env-adts scc-env) + (env-data-layouts scc-env) (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 @@ -185,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) @@ -358,25 +406,74 @@ (emit "~a:" exit-label))) (define (data-tor env e) - (and (list? e) - (assoc (car e) (flat-map data-tors (env-adts env))))) + (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)))) @@ -400,7 +497,8 @@ (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))) + ; this should have been converted to a closure! + ('builtin (error #f "passing about a builtin!" e)) ('let (codegen-let (let-bindings e) (let-body e) @@ -417,9 +515,26 @@ ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax" (cadr e))) - (else (error #f "don't know how to codegen this")))) + ('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-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 (stack-type? type) + `(stack ,(type-size data-layouts type) ,(ast-traverse strip e)) + (ast-traverse (lambda (x) + (annotate-stack-values data-layouts x)) + e)))) (define (free-vars prog) (define bound '()) @@ -583,15 +698,18 @@ (define (codegen program) (set! cur-label 0) (set! cur-lambda 0) - (let* ([body (program-body program)] + (let* ([data-layouts (program-data-layouts program)] - [data-layouts (map data-layout (program-datas program))] + [pattern-matched (expand-pattern-matches program)] + [type-annotated (annotate-types pattern-matched)] + [stack-annotated (annotate-stack-values data-layouts + type-annotated)] - (extract-res-0 (extract-strings body)) - (strings (car extract-res-0)) - (extract-res-1 (extract-lambdas (cdr extract-res-0))) - (lambdas (car extract-res-1)) - (xform-prog (cdr extract-res-1))) + (strings-res (extract-strings stack-annotated)) + (strings (car strings-res)) + (lambdas-res (extract-lambdas (cdr strings-res))) + (lambdas (car lambdas-res)) + (xform-prog (cdr lambdas-res))) (emit "\t.global _start") (emit "\t.text") @@ -647,6 +765,6 @@ ; %r8 = 5th arg ; %r9 = 6th arg -; on darwin, the syscall is offset by 0x2000000 +; on darwin, unix/posix syscalls are offset by 0x2000000 (syscall classes) ; https://opensource.apple.com/source/xnu/xnu-2782.20.48/bsd/kern/syscalls.master ; documentation for most syscalls: /Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/usr/include/sys