src/compiler/constraint.lisp

   1 ;;;; This file implements the constraint propagation phase of the
   2 ;;;; compiler, which uses global flow analysis to obtain dynamic type
   3 ;;;; information.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 ;;; TODO:
  15 ;;;
  16 ;;; -- documentation
  17 ;;;
  18 ;;; -- MV-BIND, :ASSIGNMENT
  19
  20 ;;; Problems:
  21 ;;;
  22 ;;; -- Constraint propagation badly interacts with bottom-up type
  23 ;;; inference. Consider
  24 ;;;
  25 ;;; (defun foo (n &aux (i 42))
  26 ;;;   (declare (optimize speed))
  27 ;;;   (declare (fixnum n)
  28 ;;;            #+nil (type (integer 0) i))
  29 ;;;   (tagbody
  30 ;;;      (setq i 0)
  31 ;;;    :loop
  32 ;;;      (when (>= i n) (go :exit))
  33 ;;;      (setq i (1+ i))
  34 ;;;      (go :loop)
  35 ;;;    :exit))
  36 ;;;
  37 ;;; In this case CP cannot even infer that I is of class INTEGER.
  38 ;;;
  39 ;;; -- In the above example if we place the check after SETQ, CP will
  40 ;;; fail to infer (< I FIXNUM): it does not understand that this
  41 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
  42
  43 (in-package "SB!C")
  44
  45 (deftype constraint-y () '(or ctype lvar lambda-var constant))
  46
  47 (defstruct (constraint
  48             (:include sset-element)
  49             (:constructor make-constraint (number kind x y not-p))
  50             (:copier nil))
  51   ;; the kind of constraint we have:
  52   ;;
  53   ;; TYPEP
  54   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
  55   ;;     constrained to be of type Y.
  56   ;;
  57   ;; > or <
  58   ;;     X is a lambda-var and Y is a CTYPE. The relation holds
  59   ;;     between X and some object of type Y.
  60   ;;
  61   ;; EQL
  62   ;;     X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
  63   ;;     The relation is asserted to hold.
  64   (kind nil :type (member typep < > eql))
  65   ;; The operands to the relation.
  66   (x nil :type lambda-var)
  67   (y nil :type constraint-y)
  68   ;; If true, negates the sense of the constraint, so the relation
  69   ;; does *not* hold.
  70   (not-p nil :type boolean))
  71
  72 (defvar *constraint-number*)
  73 (declaim (type (integer 0) *constraint-number*))
  74
  75 (defun find-constraint (kind x y not-p)
  76   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
  77   (etypecase y
  78     (ctype
  79      (do-sset-elements (con (lambda-var-constraints x) nil)
  80        (when (and (eq (constraint-kind con) kind)
  81                   (eq (constraint-not-p con) not-p)
  82                   (type= (constraint-y con) y))
  83          (return con))))
  84     ((or lvar constant)
  85      (do-sset-elements (con (lambda-var-constraints x) nil)
  86        (when (and (eq (constraint-kind con) kind)
  87                   (eq (constraint-not-p con) not-p)
  88                   (eq (constraint-y con) y))
  89          (return con))))
  90     (lambda-var
  91      (do-sset-elements (con (lambda-var-constraints x) nil)
  92        (when (and (eq (constraint-kind con) kind)
  93                   (eq (constraint-not-p con) not-p)
  94                   (let ((cx (constraint-x con)))
  95                     (eq (if (eq cx x)
  96                             (constraint-y con)
  97                             cx)
  98                         y)))
  99          (return con))))))
 100
 101 ;;; Return a constraint for the specified arguments. We only create a
 102 ;;; new constraint if there isn't already an equivalent old one,
 103 ;;; guaranteeing that all equivalent constraints are EQ. This
 104 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
 105 (defun find-or-create-constraint (kind x y not-p)
 106   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
 107   (or (find-constraint kind x y not-p)
 108       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
 109         (sset-adjoin new (lambda-var-constraints x))
 110         (when (lambda-var-p y)
 111           (sset-adjoin new (lambda-var-constraints y)))
 112         new)))
 113
 114 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
 115 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
 116 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
 117 (defun ok-ref-lambda-var (ref)
 118   (declare (type ref ref))
 119   (let ((leaf (ref-leaf ref)))
 120     (when (and (lambda-var-p leaf)
 121                (lambda-var-constraints leaf))
 122       leaf)))
 123
 124 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
 125 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
 126 (defun ok-lvar-lambda-var (lvar constraints)
 127   (declare (type lvar lvar))
 128   (let ((use (lvar-uses lvar)))
 129     (cond ((ref-p use)
 130            (let ((lambda-var (ok-ref-lambda-var use)))
 131              (when lambda-var
 132                (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
 133                  (when (and constraint (sset-member constraint constraints))
 134                    lambda-var)))))
 135           ((cast-p use)
 136            (ok-lvar-lambda-var (cast-value use) constraints)))))
 137
 138 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
 139   (once-only ((var var))
 140     `(let ((,symbol ,var))
 141        (flet ((body-fun ()
 142                 ,@body))
 143          (body-fun)
 144          (do-sset-elements (con ,constraints ,result)
 145            (let ((other (and (eq (constraint-kind con) 'eql)
 146                              (eq (constraint-not-p con) nil)
 147                              (cond ((eq ,var (constraint-x con))
 148                                     (constraint-y con))
 149                                    ((eq ,var (constraint-y con))
 150                                     (constraint-x con))
 151                                    (t
 152                                     nil)))))
 153              (when other
 154                (setq ,symbol other)
 155                (when (lambda-var-p ,symbol)
 156                  (body-fun)))))))))
 157
 158 ;;;; Searching constraints
 159
 160 ;;; Add the indicated test constraint to BLOCK. We don't add the
 161 ;;; constraint if the block has multiple predecessors, since it only
 162 ;;; holds on this particular path.
 163 (defun add-test-constraint (fun x y not-p constraints target)
 164   (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
 165          (add-eql-var-var-constraint x y constraints target))
 166         (t
 167          (do-eql-vars (x (x constraints))
 168            (let ((con (find-or-create-constraint fun x y not-p)))
 169              (sset-adjoin con target)))))
 170   (values))
 171
 172 ;;; Add complementary constraints to the consequent and alternative
 173 ;;; blocks of IF. We do nothing if X is NIL.
 174 (defun add-complement-constraints (fun x y not-p constraints
 175                                    consequent-constraints
 176                                    alternative-constraints)
 177   (when x
 178     (add-test-constraint fun x y not-p constraints
 179                          consequent-constraints)
 180     (add-test-constraint fun x y (not not-p) constraints
 181                          alternative-constraints))
 182   (values))
 183
 184 ;;; Add test constraints to the consequent and alternative blocks of
 185 ;;; the test represented by USE.
 186 (defun add-test-constraints (use if constraints)
 187   (declare (type node use) (type cif if))
 188   ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
 189   ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
 190   ;; can't guarantee that the optimization will be done, so we still
 191   ;; need to avoid barfing on this case.
 192   (unless (eq (if-consequent if) (if-alternative if))
 193     (let ((consequent-constraints (make-sset))
 194           (alternative-constraints (make-sset)))
 195       (macrolet ((add (fun x y not-p)
 196                    `(add-complement-constraints ,fun ,x ,y ,not-p
 197                      constraints
 198                      consequent-constraints
 199                      alternative-constraints)))
 200         (typecase use
 201           (ref
 202            (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
 203                 (specifier-type 'null) t))
 204           (combination
 205            (unless (eq (combination-kind use)
 206                        :error)
 207              (let ((name (lvar-fun-name
 208                           (basic-combination-fun use)))
 209                    (args (basic-combination-args use)))
 210                (case name
 211                  ((%typep %instance-typep)
 212                   (let ((type (second args)))
 213                     (when (constant-lvar-p type)
 214                       (let ((val (lvar-value type)))
 215                         (add 'typep
 216                              (ok-lvar-lambda-var (first args) constraints)
 217                              (if (ctype-p val)
 218                                  val
 219                                  (specifier-type val))
 220                              nil)))))
 221                  ((eq eql)
 222                   (let* ((arg1 (first args))
 223                          (var1 (ok-lvar-lambda-var arg1 constraints))
 224                          (arg2 (second args))
 225                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 226                     ;; The code below assumes that the constant is the
 227                     ;; second argument in case of variable to constant
 228                     ;; comparision which is sometimes true (see source
 229                     ;; transformations for EQ, EQL and CHAR=). Fixing
 230                     ;; that would result in more constant substitutions
 231                     ;; which is not a universally good thing, thus the
 232                     ;; unnatural asymmetry of the tests.
 233                     (cond ((not var1)
 234                            (when var2
 235                              (add-test-constraint 'typep var2 (lvar-type arg1)
 236                                                   nil constraints
 237                                                   consequent-constraints)))
 238                           (var2
 239                            (add 'eql var1 var2 nil))
 240                           ((constant-lvar-p arg2)
 241                            (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
 242                                 nil))
 243                           (t
 244                            (add-test-constraint 'typep var1 (lvar-type arg2)
 245                                                 nil constraints
 246                                                 consequent-constraints)))))
 247                  ((< >)
 248                   (let* ((arg1 (first args))
 249                          (var1 (ok-lvar-lambda-var arg1 constraints))
 250                          (arg2 (second args))
 251                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 252                     (when var1
 253                       (add name var1 (lvar-type arg2) nil))
 254                     (when var2
 255                       (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
 256                  (t
 257                   (let ((ptype (gethash name *backend-predicate-types*)))
 258                     (when ptype
 259                       (add 'typep (ok-lvar-lambda-var (first args) constraints)
 260                            ptype nil))))))))))
 261       (values consequent-constraints alternative-constraints))))
 262
 263 ;;;; Applying constraints
 264
 265 ;;; Return true if X is an integer NUMERIC-TYPE.
 266 (defun integer-type-p (x)
 267   (declare (type ctype x))
 268   (and (numeric-type-p x)
 269        (eq (numeric-type-class x) 'integer)
 270        (eq (numeric-type-complexp x) :real)))
 271
 272 ;;; Given that an inequality holds on values of type X and Y, return a
 273 ;;; new type for X. If GREATER is true, then X was greater than Y,
 274 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
 275 ;;; inclusive, i.e. >=.
 276 ;;;
 277 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
 278 ;;; bound into X and return that result. If not OR-EQUAL, we can go
 279 ;;; one greater (less) than Y's bound.
 280 (defun constrain-integer-type (x y greater or-equal)
 281   (declare (type numeric-type x y))
 282   (flet ((exclude (x)
 283            (cond ((not x) nil)
 284                  (or-equal x)
 285                  (greater (1+ x))
 286                  (t (1- x))))
 287          (bound (x)
 288            (if greater (numeric-type-low x) (numeric-type-high x))))
 289     (let* ((x-bound (bound x))
 290            (y-bound (exclude (bound y)))
 291            (new-bound (cond ((not x-bound) y-bound)
 292                             ((not y-bound) x-bound)
 293                             (greater (max x-bound y-bound))
 294                             (t (min x-bound y-bound)))))
 295       (if greater
 296           (modified-numeric-type x :low new-bound)
 297           (modified-numeric-type x :high new-bound)))))
 298
 299 ;;; Return true if X is a float NUMERIC-TYPE.
 300 (defun float-type-p (x)
 301   (declare (type ctype x))
 302   (and (numeric-type-p x)
 303        (eq (numeric-type-class x) 'float)
 304        (eq (numeric-type-complexp x) :real)))
 305
 306 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 307 (defun constrain-float-type (x y greater or-equal)
 308   (declare (type numeric-type x y))
 309   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
 310
 311   (aver (eql (numeric-type-class x) 'float))
 312   (aver (eql (numeric-type-class y) 'float))
 313   #+sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 314   x
 315   #-sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 316   (labels ((exclude (x)
 317              (cond ((not x) nil)
 318                    (or-equal x)
 319                    (t
 320                     (if (consp x)
 321                         x
 322                         (list x)))))
 323            (bound (x)
 324              (if greater (numeric-type-low x) (numeric-type-high x)))
 325            (tighter-p (x ref)
 326              (cond ((null x) nil)
 327                    ((null ref) t)
 328                    ((and or-equal
 329                          (= (type-bound-number x) (type-bound-number ref)))
 330                     ;; X is tighter if REF is not an open bound and X is
 331                     (and (not (consp ref)) (consp x)))
 332                    (greater
 333                     (< (type-bound-number ref) (type-bound-number x)))
 334                    (t
 335                     (> (type-bound-number ref) (type-bound-number x))))))
 336     (let* ((x-bound (bound x))
 337            (y-bound (exclude (bound y)))
 338            (new-bound (cond ((not x-bound)
 339                              y-bound)
 340                             ((not y-bound)
 341                              x-bound)
 342                             ((tighter-p y-bound x-bound)
 343                              y-bound)
 344                             (t
 345                              x-bound))))
 346       (if greater
 347           (modified-numeric-type x :low new-bound)
 348           (modified-numeric-type x :high new-bound)))))
 349
 350 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 351 ;;; restrictions from flow analysis IN, set the type for REF
 352 ;;; accordingly.
 353 (defun constrain-ref-type (ref constraints in)
 354   (declare (type ref ref) (type sset constraints in))
 355   (let ((res (single-value-type (node-derived-type ref)))
 356         (not-res *empty-type*)
 357         (leaf (ref-leaf ref)))
 358     (do-sset-elements (con constraints)
 359       (when (sset-member con in)
 360         (let* ((x (constraint-x con))
 361                (y (constraint-y con))
 362                (not-p (constraint-not-p con))
 363                (other (if (eq x leaf) y x))
 364                (kind (constraint-kind con)))
 365           (case kind
 366             (typep
 367              (if not-p
 368                  (setq not-res (type-union not-res other))
 369                  (setq res (type-approx-intersection2 res other))))
 370             (eql
 371              (unless (lvar-p other)
 372                (let ((other-type (leaf-type other)))
 373                  (if not-p
 374                      (when (and (constant-p other)
 375                                 (member-type-p other-type))
 376                        (setq not-res (type-union not-res other-type)))
 377                      (let ((leaf-type (leaf-type leaf)))
 378                        (cond
 379                          ((or (constant-p other)
 380                               (and (leaf-refs other) ; protect from
 381                                         ; deleted vars
 382                                    (csubtypep other-type leaf-type)
 383                                    (not (type= other-type leaf-type))))
 384                           (change-ref-leaf ref other)
 385                           (when (constant-p other) (return)))
 386                          (t
 387                           (setq res (type-approx-intersection2
 388                                      res other-type)))))))))
 389             ((< >)
 390              (cond
 391                ((and (integer-type-p res) (integer-type-p y))
 392                 (let ((greater (eq kind '>)))
 393                   (let ((greater (if not-p (not greater) greater)))
 394                     (setq res
 395                           (constrain-integer-type res y greater not-p)))))
 396                ((and (float-type-p res) (float-type-p y))
 397                 (let ((greater (eq kind '>)))
 398                   (let ((greater (if not-p (not greater) greater)))
 399                     (setq res
 400                           (constrain-float-type res y greater not-p)))))))))))
 401     (cond ((and (if-p (node-dest ref))
 402                 (csubtypep (specifier-type 'null) not-res))
 403            (setf (node-derived-type ref) *wild-type*)
 404            (change-ref-leaf ref (find-constant t)))
 405           (t
 406            (derive-node-type ref
 407                              (make-single-value-type
 408                               (or (type-difference res not-res)
 409                                   res)))
 410            (maybe-terminate-block ref nil))))
 411   (values))
 412
 413 ;;;; Flow analysis
 414
 415 (defun maybe-add-eql-var-lvar-constraint (ref gen)
 416   (let ((lvar (ref-lvar ref))
 417         (leaf (ref-leaf ref)))
 418     (when (and (lambda-var-p leaf) lvar)
 419       (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
 420                    gen))))
 421
 422 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
 423 ;;; LVAR) ones - to all of the variables in the VARS list.
 424 (defun inherit-constraints (vars from-var constraints target)
 425   (do-sset-elements (con constraints)
 426     ;; Constant substitution is controversial.
 427     (unless (constant-p (constraint-y con))
 428       (dolist (var vars)
 429         (let ((eq-x (eq from-var (constraint-x con)))
 430               (eq-y (eq from-var (constraint-y con))))
 431           (when (or (and eq-x (not (lvar-p (constraint-y con))))
 432                     eq-y)
 433             (sset-adjoin (find-or-create-constraint
 434                           (constraint-kind con)
 435                           (if eq-x var (constraint-x con))
 436                           (if eq-y var (constraint-y con))
 437                           (constraint-not-p con))
 438                          target)))))))
 439
 440 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
 441 ;; inherit each other's constraints.
 442 (defun add-eql-var-var-constraint (var1 var2 constraints
 443                                    &optional (target constraints))
 444   (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
 445     (when (sset-adjoin con target)
 446       (collect ((eql1) (eql2))
 447         (do-eql-vars (var1 (var1 constraints))
 448           (eql1 var1))
 449         (do-eql-vars (var2 (var2 constraints))
 450           (eql2 var2))
 451         (inherit-constraints (eql1) var2 constraints target)
 452         (inherit-constraints (eql2) var1 constraints target))
 453       t)))
 454
 455 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
 456 ;; LAMBDA-VAR if possible.
 457 (defun maybe-add-eql-var-var-constraint (var lvar constraints
 458                                          &optional (target constraints))
 459   (declare (type lambda-var var) (type lvar lvar))
 460   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
 461     (when lambda-var
 462       (add-eql-var-var-constraint var lambda-var constraints target))))
 463
 464 ;;; Local propagation
 465 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 466 ;;;    constraint.]
 467 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 468 ;;;    a type constraint based on the new value type.
 469 (declaim (ftype (function (cblock sset
 470                            &key (:ref-preprocessor (or null function))
 471                                 (:set-preprocessor (or null function)))
 472                           sset)
 473                 constraint-propagate-in-block))
 474 (defun constraint-propagate-in-block (block gen &key
 475                                             ref-preprocessor set-preprocessor)
 476   (do-nodes (node lvar block)
 477     (typecase node
 478       (bind
 479        (let ((fun (bind-lambda node)))
 480          (when (eq (functional-kind fun) :let)
 481            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
 482                  for var in (lambda-vars fun)
 483                  and val in (combination-args call)
 484                  when (and val (lambda-var-constraints var))
 485                  do (let* ((type (lvar-type val))
 486                            (con (find-or-create-constraint 'typep var type
 487                                                            nil)))
 488                       (sset-adjoin con gen))
 489                  (maybe-add-eql-var-var-constraint var val gen)))))
 490       (ref
 491        (when (ok-ref-lambda-var node)
 492          (maybe-add-eql-var-lvar-constraint node gen)
 493          (when ref-preprocessor
 494            (funcall ref-preprocessor node gen))))
 495       (cast
 496        (let ((lvar (cast-value node)))
 497          (let ((var (ok-lvar-lambda-var lvar gen)))
 498            (when var
 499              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
 500                (do-eql-vars (var (var gen))
 501                  (let ((con (find-or-create-constraint 'typep var atype nil)))
 502                    (sset-adjoin con gen))))))))
 503       (cset
 504        (binding* ((var (set-var node))
 505                   (nil (lambda-var-p var) :exit-if-null)
 506                   (cons (lambda-var-constraints var) :exit-if-null))
 507          (when set-preprocessor
 508            (funcall set-preprocessor var))
 509          (sset-difference gen cons)
 510          (let* ((type (single-value-type (node-derived-type node)))
 511                 (con (find-or-create-constraint 'typep var type nil)))
 512            (sset-adjoin con gen))
 513          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
 514   gen)
 515
 516 (defun constraint-propagate-if (block gen)
 517   (let ((node (block-last block)))
 518     (when (if-p node)
 519       (let ((use (lvar-uses (if-test node))))
 520         (when (node-p use)
 521           (add-test-constraints use node gen))))))
 522
 523 (defun constrain-node (node cons)
 524   (let* ((var (ref-leaf node))
 525          (con (lambda-var-constraints var)))
 526     (constrain-ref-type node con cons)))
 527
 528 ;;; Starting from IN compute OUT and (consequent/alternative
 529 ;;; constraints if the block ends with and IF). Return the list of
 530 ;;; successors that may need to be recomputed.
 531 (defun find-block-type-constraints (block &key final-pass-p)
 532   (declare (type cblock block))
 533   (let ((gen (constraint-propagate-in-block
 534               block
 535               (if final-pass-p
 536                   (block-in block)
 537                   (copy-sset (block-in block)))
 538               :ref-preprocessor (if final-pass-p #'constrain-node nil))))
 539     (setf (block-gen block) gen)
 540     (multiple-value-bind (consequent-constraints alternative-constraints)
 541         (constraint-propagate-if block gen)
 542       (if consequent-constraints
 543           (let* ((node (block-last block))
 544                  (old-consequent-constraints (if-consequent-constraints node))
 545                  (old-alternative-constraints (if-alternative-constraints node))
 546                  (succ ()))
 547             ;; Add the consequent and alternative constraints to GEN.
 548             (cond ((sset-empty consequent-constraints)
 549                    (setf (if-consequent-constraints node) gen)
 550                    (setf (if-alternative-constraints node) gen))
 551                   (t
 552                    (setf (if-consequent-constraints node) (copy-sset gen))
 553                    (sset-union (if-consequent-constraints node)
 554                                consequent-constraints)
 555                    (setf (if-alternative-constraints node) gen)
 556                    (sset-union (if-alternative-constraints node)
 557                                alternative-constraints)))
 558             ;; Has the consequent been changed?
 559             (unless (and old-consequent-constraints
 560                          (sset= (if-consequent-constraints node)
 561                                 old-consequent-constraints))
 562               (push (if-consequent node) succ))
 563             ;; Has the alternative been changed?
 564             (unless (and old-alternative-constraints
 565                          (sset= (if-alternative-constraints node)
 566                                 old-alternative-constraints))
 567               (push (if-alternative node) succ))
 568             succ)
 569           ;; There is no IF.
 570           (unless (and (block-out block)
 571                        (sset= gen (block-out block)))
 572             (setf (block-out block) gen)
 573             (block-succ block))))))
 574
 575 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 576 ;;; During this pass, we also do local constraint propagation by
 577 ;;; adding in constraints as we see them during the pass through the
 578 ;;; block.
 579 (defun use-result-constraints (block)
 580   (declare (type cblock block))
 581   (constraint-propagate-in-block block (block-in block)
 582                                  :ref-preprocessor #'constrain-node))
 583
 584 ;;; Give an empty constraints set to any var that doesn't have one and
 585 ;;; isn't a set closure var. Since a var that we previously rejected
 586 ;;; looks identical to one that is new, so we optimistically keep
 587 ;;; hoping that vars stop being closed over or lose their sets.
 588 (defun init-var-constraints (component)
 589   (declare (type component component))
 590   (dolist (fun (component-lambdas component))
 591     (flet ((frob (x)
 592              (dolist (var (lambda-vars x))
 593                (unless (lambda-var-constraints var)
 594                  (when (or (null (lambda-var-sets var))
 595                            (not (closure-var-p var)))
 596                    (setf (lambda-var-constraints var) (make-sset)))))))
 597       (frob fun)
 598       (dolist (let (lambda-lets fun))
 599         (frob let)))))
 600
 601 ;;; Return the constraints that flow from PRED to SUCC. This is
 602 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
 603 ;;; added.
 604 (defun block-out-for-successor (pred succ)
 605   (declare (type cblock pred succ))
 606   (let ((last (block-last pred)))
 607     (or (when (if-p last)
 608           (cond ((eq succ (if-consequent last))
 609                  (if-consequent-constraints last))
 610                 ((eq succ (if-alternative last))
 611                  (if-alternative-constraints last))))
 612         (block-out pred))))
 613
 614 (defun compute-block-in (block)
 615   (let ((in nil))
 616     (dolist (pred (block-pred block))
 617       ;; If OUT has not been calculated, assume it to be the universal
 618       ;; set.
 619       (let ((out (block-out-for-successor pred block)))
 620         (when out
 621           (if in
 622               (sset-intersection in out)
 623               (setq in (copy-sset out))))))
 624     (or in (make-sset))))
 625
 626 (defun update-block-in (block)
 627   (let ((in (compute-block-in block)))
 628     (cond ((and (block-in block) (sset= in (block-in block)))
 629            nil)
 630           (t
 631            (setf (block-in block) in)))))
 632
 633 ;;; Return two lists: one of blocks that precede all loops and
 634 ;;; therefore require only one constraint propagation pass and the
 635 ;;; rest. This implementation does not find all such blocks.
 636 ;;;
 637 ;;; A more complete implementation would be:
 638 ;;;
 639 ;;;     (do-blocks (block component)
 640 ;;;       (if (every #'(lambda (pred)
 641 ;;;                      (or (member pred leading-blocks)
 642 ;;;                          (eq pred head)))
 643 ;;;                  (block-pred block))
 644 ;;;           (push block leading-blocks)
 645 ;;;           (push block rest-of-blocks)))
 646 ;;;
 647 ;;; Trailing blocks that succeed all loops could be found and handled
 648 ;;; similarly. In practice though, these more complex solutions are
 649 ;;; slightly worse performancewise.
 650 (defun leading-component-blocks (component)
 651   (declare (type component component))
 652   (flet ((loopy-p (block)
 653            (let ((n (block-number block)))
 654              (dolist (pred (block-pred block))
 655                (unless (< n (block-number pred))
 656                  (return t))))))
 657     (let ((leading-blocks ())
 658           (rest-of-blocks ())
 659           (seen-loop-p ()))
 660       (do-blocks (block component)
 661         (when (and (not seen-loop-p) (loopy-p block))
 662           (setq seen-loop-p t))
 663         (if seen-loop-p
 664             (push block rest-of-blocks)
 665             (push block leading-blocks)))
 666       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
 667
 668 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
 669 ;;; a member already.
 670 (defun nconc-new (obj list)
 671   (do ((x list (cdr x))
 672        (prev nil x))
 673       ((endp x) (if prev
 674                     (progn
 675                       (setf (cdr prev) (list obj))
 676                       list)
 677                     (list obj)))
 678     (when (eql (car x) obj)
 679       (return-from nconc-new list))))
 680
 681 (defun find-and-propagate-constraints (component)
 682   (let ((blocks-to-process ()))
 683     (flet ((enqueue (blocks)
 684              (dolist (block blocks)
 685                (setq blocks-to-process (nconc-new block blocks-to-process)))))
 686       (multiple-value-bind (leading-blocks rest-of-blocks)
 687           (leading-component-blocks component)
 688         ;; Update every block once to account for changes in the
 689         ;; IR1. The constraints of the lead blocks cannot be changed
 690         ;; after the first pass so we might as well use them and skip
 691         ;; USE-RESULT-CONSTRAINTS later.
 692         (dolist (block leading-blocks)
 693           (setf (block-in block) (compute-block-in block))
 694           (find-block-type-constraints block :final-pass-p t))
 695         (setq blocks-to-process (copy-list rest-of-blocks))
 696         ;; The rest of the blocks.
 697         (dolist (block rest-of-blocks)
 698           (aver (eq block (pop blocks-to-process)))
 699           (setf (block-in block) (compute-block-in block))
 700           (enqueue (find-block-type-constraints block)))
 701         ;; Propagate constraints
 702         (loop for block = (pop blocks-to-process)
 703               while block do
 704               (unless (eq block (component-tail component))
 705                 (when (update-block-in block)
 706                   (enqueue (find-block-type-constraints block)))))
 707         rest-of-blocks))))
 708
 709 (defun constraint-propagate (component)
 710   (declare (type component component))
 711   (init-var-constraints component)
 712
 713   (unless (block-out (component-head component))
 714     (setf (block-out (component-head component)) (make-sset)))
 715
 716   (dolist (block (find-and-propagate-constraints component))
 717     (unless (block-delete-p block)
 718       (use-result-constraints block)))
 719
 720   (values))