,@(filter (lambda (x) (eqv? (statement-type x) 'expr))
program)))
-
-
- ; gets both constructors and destructors
+ ; a data tor is either a constructor or destructor for an ADT
+ ; data-tors returns constructors and destructors for a data-layout
; (data A (foo Int Bool)
; (bar Bool))
; |
; v
- ; (foo . (constructor . (abs Int (abs Bool A))))
- ; (foo~0 . (0 . (abs A Int)))
- ; (foo~1 . (1 . (abs A Bool)))
- ; (bar . (constructor . (abs Bool A)))
- ; (bar~0 . (0 . (abs A 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)))
+ ; (bar . ((A bar constructor) . (abs Bool A)))
+ ; (bar~0 . ((A bar 0) . (abs A Bool)))
+ ; ------+-------------------------------------
+ ; tor | info | type
(define (data-tors data-layout)
(define (constructor-type t products)
(define (destructor ctor-name prod-type part-type index)
(let ([name (dtor-name ctor-name index)])
- (cons name (cons index `(abs ,prod-type ,part-type)))))
+ (cons name (cons (list prod-type ctor-name index) `(abs ,prod-type ,part-type)))))
(let ([type-name (car data-layout)]
[ctors (cdr data-layout)])
(let* ([ctor-name (car ctor)]
[products (cdr ctor)]
- [maker (cons ctor-name (cons 'constructor (constructor-type type-name products)))]
+ [maker (cons ctor-name (cons (list type-name ctor-name 'constructor) (constructor-type type-name products)))]
[dtors (map (lambda (t i) (destructor ctor-name type-name t i))
products
ctors)))
; creates a type environment for a given adt definition
-(define (data-tors-env data-layout)
+(define (data-tors-type-env data-layout)
(map (lambda (x) (cons (car x) (cddr x))) (data-tors data-layout)))
(define (dtor-name ctor-name index)
(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 (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)]
+ [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 (cadr tor))])
+ [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)
('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
(cadr e)))
- ('stack (error #f "stack value that needs explicit handling" e))
+ ('stack (codegen-expr (caddr e) si env))
(else (error #f "don't know how to codegen this"))))
(test (data-tors '(A . ((foo Int Bool)
(bar Bool))))
- '((foo . (constructor . (abs Int (abs Bool A))))
- (foo~0 . (0 . (abs A Int)))
- (foo~1 . (1 . (abs A Bool)))
- (bar . (constructor . (abs Bool A)))
- (bar~0 . (0 . (
-
- abs A Bool)))))
-
-(test (data-tors-env
+ '((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)
+ (bar (A bar constructor) abs Bool A)
+ (bar~0 (A bar 0) abs A Bool)))
+
+(test (data-tors-type-env
'(A . ((foo Int Bool)
(bar Bool))))
'((foo . (abs Int (abs Bool A)))
; adts and pattern matching
-(test-prog '((data A [foo Int])
- (let ([(foo x) (foo 42)])
- x))
+(test-prog '((data A [foo Bool Int])
+ (let ([(foo x y) (foo (= 3 3) 42)])
+ y))
42)