~ chicken-core (chicken-5) 80708c08b4da846879ccd2b320fe1525931f211f

commit 80708c08b4da846879ccd2b320fe1525931f211f
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jul 10 14:35:02 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jul 10 14:35:02 2011 +0200

    trying to do sensible closure-conversion

diff --git a/compiler.scm b/compiler.scm
index 1779d6f4..64f9bcd9 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -4,7 +4,7 @@
 ; "This is insane. What we clearly want to do is not exactly clear, and is rooted in NCOMPLR."
 ;
 ;
-;--------------------------------------------------------------------------------------------------
+;--------------------------------------------------------------------------------------------
 ; Copyright (c) 2008-2011, The Chicken Team
 ; Copyright (c) 2000-2007, Felix L. Winkelmann
 ; All rights reserved.
@@ -2097,11 +2097,14 @@
 
 ;;; Collect unsafe global procedure calls that are assigned:
 
-;;; Convert closures to explicit data structures (effectively flattens function-binding structure):
+;;; Convert closures to explicit data structures (effectively flattens function-binding 
+;   structure):
 
 (define (perform-closure-conversion node db)
-  (let ([direct-calls 0]
-	[customizable '()] )
+  (let ((direct-calls 0)
+	(customizable '())
+	(captured '())
+	(lexicals '()))
 
     (define (test sym item) (get db sym item))
   
@@ -2113,6 +2116,9 @@
       (set! direct-calls (add1 direct-calls))
       (set! direct-call-ids (lset-adjoin eq? direct-call-ids id)) )
 
+    (define (capture var)
+      (set! captured (lset-adjoin eq? captured var)))
+
     ;; Gather free-variable information:
     ;; (and: - register direct calls
     ;;       - update (by mutation) call information in "##core#call" nodes)
@@ -2121,12 +2127,24 @@
 	    (params (node-parameters n)) )
 	(case (node-class n)
 
-	  ((quote ##core#variable ##core#undefined ##core#proc ##core#primitive ##core#global-ref) #f)
+	  ((##core#variable)
+	   (let ((var (first params)))
+	     (when (memq var lexicals)
+	       (capture var))))
+
+	  ((quote ##core#undefined ##core#proc ##core#primitive ##core#global-ref)
+	   #f)
 
 	  ((let)
-	   (receive (vals body) (split-at subs (length params))
-	     (for-each (lambda (n) (gather n here env)) vals)
-	     (gather (first body) here (append params env)) ) )
+	   ;;XXX remove this test later:
+	   (when (pair? (cdr params)) (bomb "let-node has invalid format" params))
+	   (gather (first subs) here env)
+	   (gather (second subs) here (cons (first params) env)))
+
+	  ((set!)
+	   (let ((var (first params)))
+	     (when (memq var lexicals) (capture var))
+	     (gather (first subs) here env)))
 
 	  ((##core#call)
 	   (let* ([fn (first subs)]
@@ -2170,18 +2188,22 @@
 					'() ) )
 				  '() ) )
 			'() ) ) )
-	     (for-each (lambda (n) (gather n here env)) subs) ) )
+	     (for-each (cut gather <> here env) subs) ) )
 
 	  ((##core#lambda ##core#direct_lambda)
 	   (decompose-lambda-list
 	    (third params)
 	    (lambda (vars argc rest)
-	      (let* ([id (if here (first params) 'toplevel)]
-		     [capturedvars (captured-variables (car subs) env)]
-		     [csize (length capturedvars)] )
-		(put! db id 'closure-size csize)
-		(put! db id 'captured-variables capturedvars)
-		(gather (car subs) id (append vars env)) ) ) ) )
+	      (let* ((id (if here (first params) 'toplevel))
+		     (cap0 captured)
+		     (n (length cap0)))
+		(fluid-let ((lexicals env))
+		  (gather (first subs) id (append vars env))
+		  (let* ((n2 (length captured))
+			 (capt (take captured (- n2 n))))
+		    (print "captured: " capt " of " lexicals)
+		    (put! db id 'closure-size n2)
+		    (put! db id 'captured-variables capt)))))))
 	
 	  (else (for-each (lambda (n) (gather n here env)) subs)) ) ) )
 
@@ -2331,24 +2353,6 @@
 			       (list (varnode here)) ) ) )
 	      (else n) ) ) )
 
-    (define (captured-variables node env)
-      (let ([vars '()])
-	(let walk ([n node])
-	  (let ((subs (node-subexpressions n))
-		(params (node-parameters n)) )
-	    (case (node-class n)
-	      ((##core#variable)
-	       (let ([var (first params)])
-		 (when (memq var env)
-		   (set! vars (lset-adjoin eq? vars var)) ) ) )
-	      ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref ##core#global-ref) #f)
-	      ((set!) 
-	       (let ([var (first params)])
-		 (when (memq var env) (set! vars (lset-adjoin eq? vars var)))
-		 (walk (car subs)) ) )
-	      (else (for-each walk subs)) ) ) )
-	vars) )
-
     (debugging 'p "closure conversion gathering phase...")
     (gather node #f '())
     (when (pair? customizable)