From 86531822ef58c5b29751976f5b41d1c631bdd459 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 12 Aug 2019 13:54:44 +0100 Subject: [PATCH] ADT codegen working for simple types --- ast.scm | 23 +++++++------- codegen.scm | 84 +++++++++++++++++++++++++++++++++++++++------------ tests.scm | 23 +++++++------- typecheck.scm | 2 +- 4 files changed, 89 insertions(+), 43 deletions(-) diff --git a/ast.scm b/ast.scm index 6b546ac..9af3653 100644 --- a/ast.scm +++ b/ast.scm @@ -118,18 +118,19 @@ ,@(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) @@ -137,7 +138,7 @@ (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)]) @@ -146,7 +147,7 @@ (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 @@ -156,7 +157,7 @@ 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) diff --git a/codegen.scm b/codegen.scm index b90e7cd..7a37097 100644 --- a/codegen.scm +++ b/codegen.scm @@ -363,35 +363,81 @@ (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) @@ -429,7 +475,7 @@ ('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")))) diff --git a/tests.scm b/tests.scm index 648ce07..2b6e09a 100644 --- a/tests.scm +++ b/tests.scm @@ -45,15 +45,14 @@ (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))) @@ -227,7 +226,7 @@ ; 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) diff --git a/typecheck.scm b/typecheck.scm index e398606..35e8188 100644 --- a/typecheck.scm +++ b/typecheck.scm @@ -255,7 +255,7 @@ res)) (define (init-adts-env prog) - (flat-map data-tors-env (program-data-layouts prog))) + (flat-map data-tors-type-env (program-data-layouts prog))) ; we typecheck the lambda calculus only (only single arg lambdas) (define (typecheck prog) -- 2.30.2