[Chicken-hackers] [PATCH] slightly more optimistic copy-propagation

[Felix]

This patch improves copy-propagation in the compiler somewhat:

1) If a variable is known to be bound to a global variable which
   itself refers to an intrinsic function (one of the "standard-" or
   "extended" bindings, that get specifically treated in call position
   by the compiler), than references to the former variable will
   be replaced with the latter.

2) If a variable is bound to another variable that in "-local" mode
   has a known value, then references to the former will be replaced
   by the latter (this was previously done only for truely known
   variables, regardless of "-local" mode).


cheers,
felix

>From c0b090b36b4f40a5da1fe2a5a5012514d961ede5 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sat, 29 Sep 2012 15:30:20 +0200
Subject: [PATCH] Make copy-propagation slightly more optimistic.

1) If a variable is known to be bound to a global variable which
   itself refers to an intrinsic function (one of the "standard-" or
   "extended" bindings, that get specifically treated in call position
   by the compiler), than references to the former variable will
   be replaced with the latter.

2) If a variable is bound to another variable that in "-local" mode
   has a known value, then references to the former will be replaced
   by the latter (this was previously done only for truely known
   variables, regardless of "-local" mode).
---
 compiler.scm |   47 +++++++++++++++++++++++++++--------------------
 1 files changed, 27 insertions(+), 20 deletions(-)

diff --git a/compiler.scm b/compiler.scm
index 94d178d..7919f84 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1983,6 +1983,7 @@
             [value #f]
             [local-value #f]
             [pvalue #f]
+            (any-value #f)
             [references '()]
             [captured #f]
             [call-sites '()]
@@ -2019,6 +2020,7 @@
 
         (set! value (and (not unknown) value))
         (set! local-value (and (not unknown) local-value))
+        (set! any-value (or value local-value))
 
         ;; If this is the first analysis, register known local or potentially 
known global
         ;;  lambda-value id's along with their names:
@@ -2134,7 +2136,8 @@
                             (if (eq? '##core#variable (node-class value))
                                 (let ((varname (first (node-parameters 
value))))
                                   (or (not (get db varname 'global))
-                                      (variable-mark varname 
'##core#always-bound)))
+                                      (variable-mark varname 
'##core#always-bound)
+                                      (intrinsic? varname)))
                                 (not (expression-has-side-effects? value db)) 
))
                        undefined) )
           (quick-put! plist 'removable #t) )
@@ -2144,25 +2147,29 @@
         ;;  the source are never assigned and the source is non-global or we 
are in block-mode:
         ;;  - The target-variable is not allowed to be global.
         ;;  - The variable that can be substituted for the current one is 
marked as 'replacing.
-        ;;    This is done to prohibit beta-contraction of the replacing 
variable (It wouldn't be there, if
-        ;;    it was contracted).
-        (when (and value (not global))
-          (when (eq? '##core#variable (node-class value))
-            (let* ([name (first (node-parameters value))]
-                   [nrefs (get db name 'references)] )
-              (when (or (and (not (get db name 'unknown)) (get db name 'value))
-                        (and (not (get db name 'captured))
-                             nrefs
-                             (= 1 (length nrefs))
-                             (not assigned)
-                             (not (get db name 'assigned)) 
-                             (or (not (variable-visible? name))
-                                 (not (get db name 'global))) ) )
-                (quick-put! plist 'replacable name) 
-                (put! db name 'replacing #t) ) ) ) )
-
-        ;; Make 'replacable, if it has a known value of the form: '(lambda 
(<xvar>) (<kvar> <xvar>))' and
-        ;;  is an internally created procedure: (See above for 'replacing)
+        ;;    This is done to prohibit beta-contraction of the replacing 
variable (It wouldn't
+        ;;    be there, if it was contracted).
+        (when (and any-value
+                   (not global)
+                   (eq? '##core#variable (node-class any-value)))
+          (let* ([name (first (node-parameters any-value))]
+                 [nrefs (get db name 'references)] )
+            (when (or (and (not (get db name 'unknown))
+                           (or (get db name 'value)
+                               (get db name 'local-value)))
+                      (and (not (get db name 'captured))
+                           nrefs
+                           (= 1 (length nrefs))
+                           (not assigned)
+                           (not (get db name 'assigned)) 
+                           (or (not (variable-visible? name))
+                               (not (get db name 'global))) ) )
+              (quick-put! plist 'replacable name) 
+              (put! db name 'replacing #t) ) ) )
+
+        ;; Make 'replacable, if it has a known value of the form:
+        ;; '(lambda (<xvar>) (<kvar> <xvar>))' and
+        ;; is an internally created procedure: (See above for 'replacing)
         (when (and value (eq? '##core#lambda (node-class value)))
           (let ([params (node-parameters value)])
             (when (not (second params))
-- 
1.7.0.4