~ chicken-core (chicken-5) 0d4149ed2d0c44ecd1c50ffbb106f6d8f10db149

commit 0d4149ed2d0c44ecd1c50ffbb106f6d8f10db149
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Jul 12 20:28:30 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Jul 12 20:28:30 2011 +0200

    Revert "fixed closure conversion, nice speedup"
    
    This reverts commit 2560f00518d4b9456ddf3fa014394c81b38c2611.
    
    Not working yet (as reported by Kon) - "expand.scm" compiled
    with this change will result in csi failing syntax-tests.scm.

diff --git a/batch-driver.scm b/batch-driver.scm
index 744866e8..7e99fca7 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -149,8 +149,7 @@
 
     (define (end-time pass)
       (when time-breakdown
-	(printf "milliseconds needed for ~a: \t~s~%" pass
-		(inexact->exact (round (- (cputime) time0)) ) )))
+	(printf "milliseconds needed for ~a: \t~s~%" pass (- (cputime) time0)) ) )
 
     (define (analyze pass node . args)
       (let-optionals args ((no 0) (contf #t))
diff --git a/compiler.scm b/compiler.scm
index 973795b2..64f9bcd9 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -2103,6 +2103,7 @@
 (define (perform-closure-conversion node db)
   (let ((direct-calls 0)
 	(customizable '())
+	(captured '())
 	(lexicals '()))
 
     (define (test sym item) (get db sym item))
@@ -2115,36 +2116,35 @@
       (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)
-    (define (gather n here locals)
+    (define (gather n here env)
       (let ((subs (node-subexpressions n))
 	    (params (node-parameters n)) )
 	(case (node-class n)
 
 	  ((##core#variable)
 	   (let ((var (first params)))
-	     (if (memq var lexicals)
-		 (list var)
-		 '())))
+	     (when (memq var lexicals)
+	       (capture var))))
 
 	  ((quote ##core#undefined ##core#proc ##core#primitive ##core#global-ref)
-	   '())
+	   #f)
 
 	  ((let)
-	   ;;XXX remove this test later, shouldn't be needed:
+	   ;;XXX remove this test later:
 	   (when (pair? (cdr params)) (bomb "let-node has invalid format" params))
-	   (let ((c (gather (first subs) here locals))
-		 (var (first params)))
-	     (append c (delete var (gather (second subs) here (cons var locals)) eq?))))
+	   (gather (first subs) here env)
+	   (gather (second subs) here (cons (first params) env)))
 
 	  ((set!)
-	   (let ((var (first params))
-		 (c (gather (first subs) here locals)))
-	     (if (memq var lexicals) 
-		 (cons var c)
-		 c)))
+	   (let ((var (first params)))
+	     (when (memq var lexicals) (capture var))
+	     (gather (first subs) here env)))
 
 	  ((##core#call)
 	   (let* ([fn (first subs)]
@@ -2188,20 +2188,24 @@
 					'() ) )
 				  '() ) )
 			'() ) ) )
-	     (concatenate (map (cut gather <> here locals) 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)))
-		(fluid-let ((lexicals (append locals lexicals)))
-		  (let ((c (gather (first subs) id vars)))
-		    (put! db id 'closure-size (length c))
-		    (put! db id 'captured-variables c)
-		    (lset-difference eq? c locals vars)))))))
+	      (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 (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
+	  (else (for-each (lambda (n) (gather n here env)) subs)) ) ) )
 
     ;; Create explicit closures:
     (define (transform n here closure)