From 1b7e2b53e68a39265fd7424910998d2607cc3815 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 14 Aug 2019 15:52:32 +0100 Subject: [PATCH] Flesh out stack values within ADTs --- ast.scm | 11 +++---- codegen.scm | 85 ++++++++++++++++++++++++++++++++++------------------- tests.scm | 6 ++-- 3 files changed, 64 insertions(+), 38 deletions(-) diff --git a/ast.scm b/ast.scm index b70317a..52e06bc 100644 --- a/ast.scm +++ b/ast.scm @@ -178,10 +178,10 @@ ; | ; v ; (foo . ((A foo constructor) . (abs Int (abs Bool A)))) - ; (foo~0 . ((A foo 0) . (abs A Int))) - ; (foo~1 . ((A foo 1) . (abs A Bool))) + ; (foo~0 . ((A foo 0 Int) . (abs A Int))) + ; (foo~1 . ((A foo 1 Bool) . (abs A Bool))) ; (bar . ((A bar constructor) . (abs Bool A))) - ; (bar~0 . ((A bar 0) . (abs A Bool))) + ; (bar~0 . ((A bar 0 Bool) . (abs A Bool))) ; ------+------------------------------------- ; tor | info | type @@ -190,8 +190,9 @@ (fold-right (lambda (x acc) `(abs ,x ,acc)) t products)) (define (destructor ctor-name prod-type part-type index) - (let ([name (dtor-name ctor-name index)]) - (cons name (cons (list prod-type ctor-name index) `(abs ,prod-type ,part-type))))) + (let* ([name (dtor-name ctor-name index)] + [info (list prod-type ctor-name index part-type)]) + (cons name (cons info `(abs ,prod-type ,part-type))))) (let ([type-name (car data-layout)] [ctors (cdr data-layout)]) diff --git a/codegen.scm b/codegen.scm index c514cd1..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) @@ -23,8 +27,8 @@ (apply max sizes))) (case type - ['int wordsize] - ['bool wordsize] + ['Int wordsize] + ['Bool wordsize] [else (let ([adt (assoc type data-layouts)]) (if adt @@ -42,6 +46,14 @@ ['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 @@ -207,13 +219,8 @@ (codegen-expr expr inner-si scc-env)) (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-stack-copy inner-si (get-offset name) size) (emit "movq %rax, ~a(%rbp)" (get-offset name))))) comps) scc-env)) @@ -232,11 +239,7 @@ (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-stack-copy stack-offset si stack-size) (emit "movq ~a(%rbp), %rax" stack-offset)))) (define cur-lambda 0) @@ -432,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)]) + [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") - (emit "movq ~a(%rbp), %rax" - (- si (data-product-offset (env-data-layouts env) type sum index))))) + + (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)] @@ -456,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 (on-stack? 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)))]) @@ -519,7 +542,8 @@ ['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 @@ -531,7 +555,8 @@ (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)) + `(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-layouts x)) e)))) diff --git a/tests.scm b/tests.scm index cdd60bd..b3e630b 100644 --- a/tests.scm +++ b/tests.scm @@ -70,10 +70,10 @@ (bar Bool)))) '((foo (A foo constructor) abs Int (abs Bool A)) - (foo~0 (A foo 0) abs A Int) - (foo~1 (A foo 1) abs A Bool) + (foo~0 (A foo 0 Int) abs A Int) + (foo~1 (A foo 1 Bool) abs A Bool) (bar (A bar constructor) abs Bool A) - (bar~0 (A bar 0) abs A Bool))) + (bar~0 (A bar 0 Bool) abs A Bool))) (test (data-tors-type-env '(A . ((foo Int Bool) -- 2.30.2