~ chicken-core (chicken-5) fb423c06afa0a30c1be8040785f0769c459d180b

commit fb423c06afa0a30c1be8040785f0769c459d180b
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jan 13 21:53:18 2010 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jan 13 21:53:18 2010 +0100

    toplevel-alias detection for simple cases

diff --git a/compiler.scm b/compiler.scm
index d12c7cb6..1ec72225 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -90,6 +90,7 @@
 ;   ##compiler#profile -> BOOL
 ;   ##compiler#unused -> BOOL
 ;   ##compiler#foldable -> BOOL
+;   ##compiler#toplevel-alias -> SYMBOL
 
 ; - Source language:
 ;
diff --git a/optimizer.scm b/optimizer.scm
index 150246ea..3b087977 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -85,8 +85,9 @@
 	  [(##core#call) (touch)]
 
 	  [(set!)
-	   (let ([var (first params)])
-	     (scan (first subs) e)
+	   (let ((var (first params))
+		 (val (first subs)))
+	     (scan val e)
 	     (let ((p (alist-ref var previous)))
 	       (when (and p (not (memq var unsafe)))
 		 (compiler-warning 
@@ -96,6 +97,14 @@
 		 (copy-node!
 		  (make-node '##core#undefined '() '())
 		  p))
+	       (when (and (not escaped)
+			  (not (memq var e))
+			  (not (memq var unsafe))
+			  (eq? '##core#variable (node-class val)))
+		 (let ((valname (first (node-parameters val))))
+		   (unless (memq valname e)
+		     (debugging 'x (sprintf "toplevel-alias: ~s -> ~s" var valname))
+		     (##sys#put! var '##compiler#toplevel-alias valname))))
 	       (unless (memq var e) (mark var))
 	       (remember var n) ) ) ]
 
@@ -214,6 +223,7 @@
 		    (touch)
 		    (debugging 'o "substituted constant variable" var)
 		    (qnode (car (node-parameters (test var 'value)))) )
+		   ((##sys#get var '##compiler#toplevel-alias) => replace)
 		   (else
 		    (if (not (eq? var (first params)))
 			(begin