X-Git-Url: http://git.lukelau.me/?p=scheme.git;a=blobdiff_plain;f=codegen.scm;h=7a12fc2228795b588cfbf117d3f1e7712f282be6;hp=2d60c0aed64c22d3f1933544bf1a5df7101ce62c;hb=9d93b066cfd6505849dff12146159bedeadf96b9;hpb=d0e9f5296b7510fe057be4a2f9e2a31ed856652c

diff --git a/codegen.scm b/codegen.scm
index 2d60c0a..7a12fc2 100644
--- a/codegen.scm
+++ b/codegen.scm
@@ -1,7 +1,8 @@
 (load "typecheck.scm")
 (load "ast.scm")
+(load "platform.scm")
 
-(define target 'darwin)
+(define target host-os)
 
 (define (emit . s)
   (begin
@@ -45,9 +46,9 @@
   (codegen-expr a si env)
   (emit "movq %rax, ~a(%rbp)" si)
   (codegen-expr b (- si wordsize) env)
-  (emit "subq ~a(%rbp), %rax" si)
-  (emit "not %rax")
-  (emit "andq $1, %rax"))
+  (emit "## ~a = ~b" a b)
+  (emit "cmpq ~a(%rbp), %rax" si)
+  (emit "sete %al"))
 
 					; 'write file handle addr-string num-bytes
 
@@ -83,19 +84,48 @@
 (define wordsize 8)
 
 (define (codegen-let bindings body si env)
-  (let* ((stack-offsets (map (lambda (x) (- si (* x wordsize)))
+
+					; is this a closure that captures itself?
+					; e.g. (let ([x 3] [f (closure lambda0 (f x))]) (f))
+  (define (self-captive-closure? name expr)
+    (and (eqv? (ast-type expr) 'closure)
+	 (memv name (caddr expr))))
+  
+  (let* ((stack-offsets (map (lambda (name x) ; assoc map of binding name to offset
+			       (cons name (- si (* x wordsize))))
+			     (map car bindings)
 			     (range 0 (length bindings))))
 	 (inner-si (- si (* (length bindings) wordsize)))
-	 (names (map car bindings))
-	 (exprs (map cadr bindings))
-
-					; recursive let bindings: build environment as we go
-	 (inner-env (fold-left
-		     (lambda (env name expr offset)
-		       (codegen-expr expr inner-si env)
-		       (emit "movq %rax, ~a(%rbp)" offset)
-		       (cons (cons name offset) env))
-		     env names exprs stack-offsets)))
+
+	 (get-offset (lambda (n) (cdr (assoc n stack-offsets))))
+	 
+	 [inner-env
+	  (fold-left
+	   (lambda (env comps)
+	     (let ([scc-env
+		    (fold-left
+		     (lambda (acc name)
+		       (cons (cons name (get-offset name))
+			     acc))
+		     env
+		     comps)])
+	       (for-each 
+		(lambda (name)
+		  (let ([expr (cadr (assoc name bindings))])
+		    (emit "## generating ~a with scc-env ~a" name scc-env)
+		    (if (self-captive-closure? name expr)
+					; if self-captive, insert a flag into the environment to let
+					; codegen-closure realise this!
+			(codegen-expr expr
+				      inner-si
+				      (cons (cons name 'self-captive)
+					    scc-env))
+			(codegen-expr expr inner-si scc-env))
+		    (emit "movq %rax, ~a(%rbp)" (get-offset name))))
+		comps)
+	       scc-env))
+	   env (reverse (sccs (graph bindings))))])
+    
     (for-each (lambda (form)
 		(codegen-expr form inner-si inner-env))
 	      body)))
@@ -137,10 +167,16 @@
     (emit "## storing captives")
 					; store the captured vars
     (for-each
-     (lambda (var-name new-offset)
+     (lambda (var-name heap-offset)
+       (let ([stack-offset (cdr (assoc var-name env))])
+	 (emit "### captive ~a" var-name)
+	 (if (eqv? stack-offset 'self-captive)
+					; captive refers to this closure:
+					; move heap addr of this closure to stack! 
+	     (emit "movq %rax, ~a(%rax)" heap-offset)
 	     (begin
-	 (emit "movq ~a(%rbp), %rbx" (cdr (assoc var-name env)))
-	 (emit "movq %rbx, ~a(%rax)" new-offset)))
+	       (emit "movq ~a(%rbp), %rbx" stack-offset)
+	       (emit "movq %rbx, ~a(%rax)" heap-offset)))))
      captured
      heap-offsets)))
 
@@ -197,21 +233,21 @@
 (define (codegen-lambda l)
   (let* ((label (car l))
 	 (stuff (cdr l))
-	 (captured (car stuff))
+	 (captives (car stuff))
 	 (args (cadr stuff))
 	 (body (caddr stuff))
 					; params = what actually gets passed
-	 (params (append captured args))
+	 (params (append captives args))
 
 	 (stack-offsets (map (lambda (i)
-			       (* (- wordsize) i))
+			       (* (- wordsize) (+ 1 i)))
 			     (range 0 (length params))))
 
 	 (env (map cons params stack-offsets)))
     (emit "~a:" label)
 
     (display "## lambda captives: ")
-    (display captured)
+    (display captives)
     (newline)
     (display "## lambda args: ")
     (display args)
@@ -223,15 +259,15 @@
     (emit "push %rbp") ; preserve caller's base pointer
     
     (emit "movq %rsp, %rbp") ; set up our own base pointer
-    (emit "subq $8, %rbp")   
 
 					; load the captured vars onto the stack
     (for-each
      (lambda (i)
        (begin
-	 (emit "movq ~a(~a), %rbx" i (param-register 0))
-	 (emit "movq %rbx, ~a(%rbp)" (* (- wordsize) i))))
-     (range 0 (length captured)))
+	 (emit "# loading captive ~a" (list-ref captives i))
+	 (emit "movq ~a(~a), %rbx" (* wordsize i) (param-register 0))
+	 (emit "movq %rbx, ~a(%rbp)" (* (- wordsize) (+ 1 i)))))
+     (range 0 (length captives)))
 
 					; load the args onto the stack
     (for-each
@@ -240,7 +276,7 @@
 	 (emit "movq ~a, %rbx" (param-register (+ 1 i)))
 	 (emit "movq %rbx, ~a(%rbp)"
 	       (* (- wordsize)
-		  (+ (length captured) i)))))
+		  (+ 1 (length captives) i)))))
      (range 0 (length args)))
     
     (codegen-expr body (* (- wordsize) (+ 1 (length params))) env)
@@ -248,11 +284,6 @@
     (emit "pop %rbp") ; restore caller's base pointer
     (emit "ret")))
 
-(define (codegen-string label)
-  (case target
-    ('darwin (emit "movq ~a@GOTPCREL(%rip), %rax" label))
-    ('linux  (emit "lea $~a, %rax" label))))
-
 (define cur-label 0)
 (define (fresh-label)
   (set! cur-label (+ 1 cur-label))
@@ -271,6 +302,7 @@
     (emit "~a:" exit-label)))
 
 (define (codegen-expr e si env)
+  (emit "# ~a" e)
   (case (ast-type e)
     ('closure (codegen-closure (cadr e) (caddr e) si env))
     ('app
@@ -299,7 +331,8 @@
     ('bool-literal (emit "movq $~a, %rax" (if e 1 0)))
     ('int-literal (emit "movq $~a, %rax" e))
     
-    ('static-string (codegen-string (cadr e)))
+    ('static-string (emit "movq ~a@GOTPCREL(%rip), %rax"
+			  (cadr e)))
 
     (else (error #f "don't know how to codegen this"))))
 
@@ -310,19 +343,21 @@
   (define (collect e)
     (case (ast-type e)
       ('builtin '()) ; do nothing
-      ('var (if (memq e bound) '() (list e)))
+      ('var (if (memv e bound) '() (list e)))
       ('lambda
+	  (begin
 	    (set! bound (append (lambda-args e) bound))
-	(collect (lambda-body e)))
+	    (collect (lambda-body e))))
 
       ('app (fold-map collect e))
+      ('if (fold-map collect (cdr e)))
       ('let
-	  (let ((bind-fvs (fold-map (lambda (a)
-				      ((set! bound (cons (car a) bound))
+	  (let ([bind-fvs (fold-map (lambda (a)
+				      (begin
+					(set! bound (cons (car a) bound))
 					(collect (cdr a))))
-				    (let-bindings cadr)))
-		(body-fvs (fold-map collect (let-body e))))
-	    (append bind-fvs body-fvs)))
+				    (let-bindings e))])
+	    (append bind-fvs (fold-map collect (let-body e)))))
       (else '())))
   (collect prog))
 
@@ -380,7 +415,7 @@
   (define (extract e)
     (case (ast-type e)
       ('lambda (add-lambda e))
-      ('let `(let ,(map extract (let-bindings e))
+      ('let `(let ,(map (lambda (b) `(,(car b) ,@(extract (cdr b)))) (let-bindings e))
 	       ,@(map extract (let-body e))))
       ('app (append
 					; if a builtin is used as a function, don't generate lambda
@@ -486,6 +521,8 @@
     (emit "movq %rax, (%rsi)")))
 
 (define (codegen program)
+  (set! cur-label 0)
+  (set! cur-lambda 0)
   (let* ((extract-res-0 (extract-strings program))
 	 (strings (car extract-res-0))
 	 (extract-res-1 (extract-lambdas (cdr extract-res-0)))
@@ -503,7 +540,8 @@
     (initialize-heap)
 
     (emit "movq %rsp, %rbp")            ; set up the base pointer
-    (codegen-expr xform-prog 0 '())
+    
+    (codegen-expr xform-prog (- wordsize) '())
 
 					; exit syscall
     (emit "mov %rax, %rdi")