X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=dededbec01e0856b19703d8945e096e49b316aa5;hp=2d5f4ac2731800dba6e4041162bc7693be62f90a;hb=8e106ca13666680051f91ab3f49ce2bd7e19ead7;hpb=89ef32141732e6d0bbfc7484b465844b62d8d139 diff --git a/codegen.scm b/codegen.scm index 2d5f4ac..dededbe 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,21 @@ ['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)))])) +(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) @@ -160,7 +165,7 @@ 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))]) @@ -171,7 +176,7 @@ (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)) @@ -358,29 +363,81 @@ (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 (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))))) + + (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 (stack-expr? 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)))) +(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) @@ -400,7 +457,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 +475,24 @@ ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax" (cadr e))) - (else (error #f "don't know how to codegen this")))) + ('stack (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 (stack-type? type) + (assoc type data-layout)) + (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)) + (ast-traverse (lambda (x) + (annotate-stack-values data-layout x)) + e)))) (define (free-vars prog) (define bound '()) @@ -583,15 +656,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 +723,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