[Sbcl-commits] master: Smarter FIND-CONSTRAINT during constraint propagation

[Paul K. <pk...@us...>]

The branch "master" has been updated in SBCL:
       via  d2e1e27f0d424a22926bcfa1d831641529073bc3 (commit)
      from  5896b1fd29648a6cc4beef194ab3c3d075983c66 (commit)

- Log -----------------------------------------------------------------
commit d2e1e27f0d424a22926bcfa1d831641529073bc3
Author: Paul Khuong <pv...@pv...>
Date:   Sat Jun 11 23:43:28 2011 -0400

    Smarter FIND-CONSTRAINT during constraint propagation
    
     Use hash tables instead of pure linear search for hash
     consing of constraints. Significantly reduces the pressure
     on conset iteration performance, and improves compilation
     speed of large functions.
    
     Improves lp#792363 and lp#394206.
---
 src/compiler/constraint.lisp |   68 +++++++++++++++++++++++++++--------------
 src/compiler/node.lisp       |    4 ++
 2 files changed, 49 insertions(+), 23 deletions(-)

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 812976e..0e65e06 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -321,31 +321,53 @@
     (defconsetop conset-intersection bit-and)
     (defconsetop conset-difference bit-andc2)))
 
+;;; Constraints are hash-consed. Unfortunately, types aren't, so we have
+;;; to over-approximate and then linear search through the potential hits.
+;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant
+;;; and lambda-vars can only be found in EQL constraints.
+
 (defun find-constraint (kind x y not-p)
   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
   (etypecase y
     (ctype
-     (do-conset-elements (con (lambda-var-constraints x) nil)
-       (when (and (eq (constraint-kind con) kind)
-                  (eq (constraint-not-p con) not-p)
-                  (type= (constraint-y con) y))
-         (return con))))
-    ((or lvar constant)
-     (do-conset-elements (con (lambda-var-constraints x) nil)
-       (when (and (eq (constraint-kind con) kind)
-                  (eq (constraint-not-p con) not-p)
-                  (eq (constraint-y con) y))
-         (return con))))
-    (lambda-var
-     (do-conset-elements (con (lambda-var-constraints x) nil)
-       (when (and (eq (constraint-kind con) kind)
-                  (eq (constraint-not-p con) not-p)
-                  (let ((cx (constraint-x con)))
-                    (eq (if (eq cx x)
-                            (constraint-y con)
-                            cx)
-                        y)))
-         (return con))))))
+       (awhen (lambda-var-ctype-constraints x)
+         (dolist (con (gethash (sb!kernel::type-class-info y) it) nil)
+           (when (and (eq (constraint-kind con) kind)
+                      (eq (constraint-not-p con) not-p)
+                      (type= (constraint-y con) y))
+             (return-from find-constraint con)))
+         nil))
+    (lvar
+       (awhen (lambda-var-eq-constraints x)
+         (gethash y it)))
+    ((or constant lambda-var)
+       (awhen (lambda-var-eq-constraints x)
+         (let ((cache (gethash y it)))
+           (declare (type list cache))
+           (if not-p (cdr cache) (car cache)))))))
+
+(defun register-constraint (x con y)
+  (declare (type lambda-var x) (type constraint con) (type constraint-y y))
+  (conset-adjoin con (lambda-var-constraints x))
+  (macrolet ((ensuref (place default)
+               `(or ,place (setf ,place ,default))))
+    (etypecase y
+      (ctype
+         (let ((index (ensuref (lambda-var-ctype-constraints x)
+                               (make-hash-table))))
+           (push con (gethash (sb!kernel::type-class-info y) index))))
+      (lvar
+         (let ((index (ensuref (lambda-var-eq-constraints x)
+                               (make-hash-table))))
+           (setf (gethash y index) con)))
+      ((or constant lambda-var)
+         (let* ((index (ensuref (lambda-var-eq-constraints x)
+                                (make-hash-table)))
+                (cons  (ensuref (gethash y index) (list nil))))
+           (if (constraint-not-p con)
+               (setf (cdr cons) con)
+               (setf (car cons) con))))))
+  nil)
 
 ;;; Return a constraint for the specified arguments. We only create a
 ;;; new constraint if there isn't already an equivalent old one,
@@ -358,9 +380,9 @@
                                   kind x y not-p)))
         (vector-push-extend new *constraint-universe*
                             (1+ (length *constraint-universe*)))
-        (conset-adjoin new (lambda-var-constraints x))
+        (register-constraint x new y)
         (when (lambda-var-p y)
-          (conset-adjoin new (lambda-var-constraints y)))
+          (register-constraint y new x))
         new)))
 
 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index c8ac71e..2f61cb8 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -1140,6 +1140,10 @@
   ;; determine that this is a set closure variable, and is thus not a
   ;; good subject for flow analysis.
   (constraints nil :type (or null t #| FIXME: conset |#))
+  ;; Content-addressed indices for the CONSTRAINTs on this variable.
+  ;; These are solely used by FIND-CONSTRAINT
+  (ctype-constraints nil :type (or null hash-table))
+  (eq-constraints    nil :type (or null hash-table))
   ;; 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

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL