From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 18 Feb 2008 19:25:22 +0000 (+0000)
Subject: 1.0.14.36: faster PROPAGATE-FROM-SETS
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6d3b9d5de8a28cd92e280f3451b60ce412260c19;p=sbcl.git

1.0.14.36: faster PROPAGATE-FROM-SETS

 20-25% improvement for the test-case in bug 188.

 * New slot in LAMBDA-VAR: LAST-INITIAL-TYPE, which holds the last
   initial-type for that variable seen by PROPAGATE-FROM-SETS.

 * Be lazy, and don't PROPAGATE-TO-REFS unless something of
   interest has happened, to wit:

    -- One of the CSET nodes has a new, more specific type.

    -- INITIAL-TYPE has become more specific.

   This also allows us elide TYPE-UNION computation in the
   uninteresting cases.

 * Requires having NODE-REOPTIMIZE set when IR1-OPTIMIZE-SET
   is called.
---

diff --git a/BUGS b/BUGS
index 4c64490..298e43a 100644
--- a/BUGS
+++ b/BUGS
@@ -479,6 +479,11 @@ WORKAROUND:
                (print (incf start 22))
                (print (incf start 26))))))
 
+  [ Update: 1.0.14.36 improved this quite a bit (20-25%) by
+    eliminating useless work from PROPAGATE-FROM-SETS -- but as alluded
+    below, maybe we should be smarter about when to decide a derived
+    type is "good enough". ]
+
   This example could be solved with clever enough constraint
   propagation or with SSA, but consider
 
diff --git a/NEWS b/NEWS
index 6c04c72..10c3bb2 100644
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,10 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14:
     when SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS* is NIL.
   * unreadably printed representation of hash-tables now includes
     weakness if any.
+  * bug fix: partially fixed #188: type propagation from assignments
+    is now more efficient.
+  * bug fix: fixed #407: (COERCE X 'SINGLE-FLOAT) and (COERCE X
+    'DOUBLE-FLOAT) are not flushable.
   * bug fix: on x86 and x86-64 pointer based EQ-hashing now uses the
     full address of the object, and none of the tag bits.
   * bug fix: readably printing hash-tables now respects other printer
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index d574148..548c1c9 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -306,6 +306,9 @@
            (when value
              (derive-node-type node (lvar-derived-type value)))))
         (cset
+         ;; PROPAGATE-FROM-SETS can do a better job if NODE-REOPTIMIZE
+         ;; is accurate till the node actually has been reoptimized.
+         (setf (node-reoptimize node) t)
          (ir1-optimize-set node))
         (cast
          (ir1-optimize-cast node)))))
@@ -1342,17 +1345,22 @@
 ;;; the union of the INITIAL-TYPE and the types of all the set
 ;;; values and to a PROPAGATE-TO-REFS with this type.
 (defun propagate-from-sets (var initial-type)
-  (collect ((res initial-type type-union))
-    (dolist (set (basic-var-sets var))
+  (let ((changes (not (csubtypep (lambda-var-last-initial-type var) initial-type)))
+        (types nil))
+    (dolist (set (lambda-var-sets var))
       (let ((type (lvar-type (set-value set))))
-        (res type)
+        (push type types)
         (when (node-reoptimize set)
-          (derive-node-type set (make-single-value-type type))
+          (let ((old-type (node-derived-type set)))
+            (unless (values-subtypep old-type type)
+              (derive-node-type set (make-single-value-type type))
+              (setf changes t)))
           (setf (node-reoptimize set) nil))))
-    (let ((res (res)))
-      (awhen (maybe-infer-iteration-var-type var initial-type)
-        (setq res it))
-      (propagate-to-refs var res)))
+    (when changes
+      (setf (lambda-var-last-initial-type var) initial-type)
+      (let ((res-type (or (maybe-infer-iteration-var-type var initial-type)
+                          (apply #'type-union initial-type types))))
+        (propagate-to-refs var res-type))))
   (values))
 
 ;;; If a LET variable, find the initial value's type and do
@@ -1368,9 +1376,9 @@
                  (initial-type (lvar-type initial-value)))
             (setf (lvar-reoptimize initial-value) nil)
             (propagate-from-sets var initial-type))))))
-
   (derive-node-type node (make-single-value-type
                           (lvar-type (set-value node))))
+  (setf (node-reoptimize node) nil)
   (values))
 
 ;;; Return true if the value of REF will always be the same (and is
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index cb88d83..ac17c72 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -1114,6 +1114,8 @@
   ;; determine that this is a set closure variable, and is thus not a
   ;; good subject for flow analysis.
   (constraints nil :type (or sset null))
+  ;; Initial type of a LET variable as last seen by PROPAGATE-FROM-SETS.
+  (last-initial-type *universal-type* :type ctype)
   ;; The FOP handle of the lexical variable represented by LAMBDA-VAR
   ;; in the fopcompiler.
   (fop-value nil))
diff --git a/version.lisp-expr b/version.lisp-expr
index 7a7f7b3..eb8296e 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.14.35"
+"1.0.14.36"