(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)
(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]))
+; 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
(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)
;; ))
;; (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)) relative-offsets)])
+ (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)))]
[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
(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)
+ ; copy over whatevers on the stack
+ (emit-stack-copy inner-si (get-offset name) size)
+ (emit "movq %rax, ~a(%rbp)" (get-offset name)))))
comps)
scc-env))
env
(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)
+ (emit-stack-copy stack-offset si stack-size)
+ (emit "movq ~a(%rbp), %rax" stack-offset))))
(define cur-lambda 0)
(define (fresh-lambda)
(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 dls (env-data-layouts env))
+
(define (codegen-destructor tor)
- (when (not (eqv? 'stack (ast-type (cadr e))))
- (error #f "expected stack value"))
- (let* ([stack-expr (cadr e)]
- [stack-body (caddr stack-expr)]
- [stack-type (cadr stack-expr)])
-
- (codegen-expr stack-body 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* ([res (codegen-expr (cadr e) si env)]
+ [info (cadr tor)]
+ [type (car 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")
+
+ (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 (car info)]
+ [sum (cadr info)]
+ [constructor (car e)]
+
+ [args (cdr e)]
+
+ [tag (data-sum-tag (env-data-layouts env)
+ type
+ sum)]
+
+ [inner-si (- si (type-size dls type))]
+
+ [product-types (cdr (assoc sum (cdr (assoc type dls))))]
+
+ [insert-product
+ (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)
+ ; generate products
+ (for-each insert-product args (range 0 (length args)) product-types)))
(let* ([tor (data-tor env e)]
- [constructor (eqv? 'constructor (cadr tor))])
+ [constructor (eqv? 'constructor (caddr (cadr tor)))])
(if constructor
(codegen-constructor tor)
(codegen-destructor tor))))
('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
(cadr e)))
- ('stack (error #f "stack value that needs explicit handling" 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"))))
+ (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
-(define (annotate-stack-values data-layout ann-e)
+(define (annotate-stack-values data-layouts ann-e)
(define (stack-type? type)
- (assoc type data-layout))
+ (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 ,(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-layout x))
+ (annotate-stack-values data-layouts x))
e))))
(define (free-vars prog)
(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)]
projects / scheme.git / blobdiff