; |
; 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
(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)])
(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)
(apply max sizes)))
(case type
- ['int wordsize]
- ['bool wordsize]
+ ['Int wordsize]
+ ['Bool wordsize]
[else
(let ([adt (assoc type data-layouts)])
(if adt
['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
(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))
(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)
(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)]
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)))])
['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
(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))))
projects / scheme.git / commitdiff