X-Git-Url: https://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=dededbec01e0856b19703d8945e096e49b316aa5;hp=55189cf6db556dc21bb3c294dc7cdba85491c4fb;hb=8e106ca13666680051f91ab3f49ce2bd7e19ead7;hpb=7be98b67cbad421a0b041d20e0f4620e70bd4cd6

diff --git a/codegen.scm b/codegen.scm
index 55189cf..dededbe 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -363,29 +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)
-    (codegen-expr (cadr e) 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 ([tor (data-tor env e)]
-	[constructor (eqv? 'constructor (cadr tor))])
+    (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 (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)
@@ -423,19 +475,21 @@
     ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
 			  (cadr e)))
 
+    ('stack (codegen-expr (caddr e) si env))
+
     (else (error #f "don't know how to codegen this"))))
 
 					; 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 (struct-type? type)
+  (define (stack-type? type)
     (assoc type data-layout))
   (define (strip e)
     (ast-traverse strip (ann-expr e)))
   (let* ([e (ann-expr ann-e)]
 	 [type (ann-type ann-e)])
-    (if (struct-type? type)
-	`(struct ,(type-size data-layout type) ,(ast-traverse strip e))
+    (if (stack-type? type)
+	`(stack ,type ,(ast-traverse strip e))
 	(ast-traverse (lambda (x)
 			(annotate-stack-values data-layout x))
 		      e))))
@@ -604,7 +658,8 @@
   (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)]