From d2e1e27f0d424a22926bcfa1d831641529073bc3 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Sat, 11 Jun 2011 23:43:28 -0400
Subject: [PATCH] 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
-- 
1.7.10.4