X-Git-Url: http://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;fp=codegen.scm;h=dd7950765c9ef375d443a110788a9146079fad20;hp=c514cd1b4d34853523928c00314a0ffdb5825b90;hb=1b7e2b53e68a39265fd7424910998d2607cc3815;hpb=277cd3c8e4ad4c727e041bf870a79862640c39b3

diff --git a/codegen.scm b/codegen.scm
index c514cd1..dd79507 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -11,6 +11,10 @@
 
 (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)
@@ -23,8 +27,8 @@
       (apply max sizes)))
   
   (case type
-    ['int wordsize]
-    ['bool wordsize]
+    ['Int wordsize]
+    ['Bool wordsize]
     [else
      (let ([adt (assoc type data-layouts)])
        (if adt
@@ -42,6 +46,14 @@
     ['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
@@ -207,13 +219,8 @@
 			(codegen-expr expr inner-si scc-env))
 
 		    (if (on-stack? expr)
-			(begin
 						  ; copy over whatevers on the stack
-			  (emit "leaq ~a(%rbp), %rsi" (- inner-si size))
-			  (emit "leaq ~a(%rbp), %rdi" (- (get-offset name) size))
-			  (emit "movq $~a, %rcx" (/ size wordsize))
-			  (emit "rep movsq"))
-			
+			(emit-stack-copy inner-si (get-offset name) size)
 			(emit "movq %rax, ~a(%rbp)" (get-offset name)))))
 		comps)
 	       scc-env))
@@ -232,11 +239,7 @@
       (error #f (format "Variable ~a is not bound" name)))
 
     (if (on-stack? e)
-	(begin
-	  (emit "leaq ~a(%rbp), %rsi" (- stack-offset stack-size))
-	  (emit "leaq ~a(%rbp), %rdi" (- si stack-size))
-	  (emit "movq $~a, %rcx" (/ stack-size wordsize))
-	  (emit "rep movsq"))
+	(emit-stack-copy stack-offset si stack-size)
 	(emit "movq ~a(%rbp), %rax" stack-offset))))
 
 (define cur-lambda 0)
@@ -432,17 +435,34 @@
 
 (define (codegen-data-tor e si env)
 
+  (define dls (env-data-layouts env))
+
   (define (codegen-destructor tor)
     (let* ([res (codegen-expr (cadr e) si env)]
 	   [info (cadr tor)]
-	   [index (caddr info)]
 	   [type (car info)]
-	   [sum (cadr 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")
-      (emit "movq ~a(%rbp), %rax"
-	    (- si (data-product-offset (env-data-layouts env) type sum index)))))				      
+
+      (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)]
@@ -456,21 +476,24 @@
 			      type
 			      sum)]
 
+	   [inner-si (- si (type-size dls type))]
+
+	   [product-types (cdr (assoc sum (cdr (assoc type dls))))]
+	   
 	   [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 (on-stack? res)
-		    (error #f "todo: handle stack-exprs in stack exprs")
-		    (emit "movq %rax, ~a(%rbp)" stack-offset))))])
+	    (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)     
-      
-      (for-each insert-product args (range 0 (length args)))
-      (type-size (env-data-layouts env) type)))
+					; generate products
+      (for-each insert-product args (range 0 (length args)) product-types)))
   
   (let* ([tor (data-tor env e)]
 	 [constructor (eqv? 'constructor (caddr (cadr tor)))])
@@ -519,7 +542,8 @@
 	      ['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
@@ -531,7 +555,8 @@
   (let* ([e (ann-expr ann-e)]
 	 [type (ann-type ann-e)])
     (if (stack-type? type)
-	`(stack ,(type-size data-layouts 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-layouts x))
 		      e))))