ADT codegen working for simple types

diff --git a/ast.scm b/ast.scm
index 6b546ac6f4214a2a9891e10da74ea8df7b5c1ed0..9af36531e7ef38bb1affc652eb09c5afa46a3dcc 100644 (file)
--- a/ast.scm
+++ b/ast.scm
@@ -118,18 +118,19 @@
      ,@(filter (lambda (x) (eqv? (statement-type x) 'expr))
               program)))
 
      ,@(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
                                        ; (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 (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)])
 
   (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 ([type-name (car data-layout)]
         [ctors (cdr data-layout)])


@@ -146,7 +147,7 @@
        (let* ([ctor-name (car ctor)]
              [products (cdr ctor)]
              
        (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
              
              [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
      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)
   (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 b90e7cdcefff689f56ce3b9cb911de408949b872..7a37097096882bc4c60d5262c6c81a4c3b9ba371 100644 (file)
--- a/codegen.scm
+++ b/codegen.scm
@@ -363,35 +363,81 @@
     (emit "~a:" exit-label)))
 
 (define (data-tor env e)
     (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)))))
 
       (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)
 (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)]
   
   (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))))
 
     (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)
 (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)))
 
     ('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"))))
 
 
     (else (error #f "don't know how to codegen this"))))
 

diff --git a/tests.scm b/tests.scm
index 648ce073fbb97526b1a70e8327842a905dae35fa..2b6e09a4c2c63207707f061f722ca4ca3c377a66 100644 (file)
--- a/tests.scm
+++ b/tests.scm
@@ -45,15 +45,14 @@
 
 (test (data-tors '(A . ((foo Int Bool)
                        (bar Bool))))
 
 (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)))
        '(A . ((foo Int Bool)
              (bar Bool))))
       '((foo . (abs Int (abs Bool A)))


@@ -227,7 +226,7 @@
 
                                        ; adts and pattern matching
 
 
                                        ; 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)
           42)

diff --git a/typecheck.scm b/typecheck.scm
index e3986062e358d763e99746f2ebdd26828337336f..35e818866df9603a3ecaa4cc721b548035d26abc 100644 (file)
--- a/typecheck.scm
+++ b/typecheck.scm
@@ -255,7 +255,7 @@
     res))
 
 (define (init-adts-env prog)
     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)
 
                                        ; we typecheck the lambda calculus only (only single arg lambdas)
 (define (typecheck prog)