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                    (greater
 320                     (if (consp x)
 321                         (car x)
 322                         x))
 323                    (t
 324                     (if (consp x)
 325                         x
 326                         (list x)))))
 327            (bound (x)
 328              (if greater (numeric-type-low x) (numeric-type-high x)))
 329            (max-lower-bound (x y)
 330              ;; Both X and Y are not null. Find the max.
 331              (let ((res (max (type-bound-number x) (type-bound-number y))))
 332                ;; An open lower bound is greater than a close
 333                ;; lower bound because the open bound doesn't
 334                ;; contain the bound, so choose an open lower
 335                ;; bound.
 336                (set-bound res (or (consp x) (consp y)))))
 337            (min-upper-bound (x y)
 338              ;; Same as above, but for the min of upper bounds
 339              ;; Both X and Y are not null. Find the min.
 340              (let ((res (min (type-bound-number x) (type-bound-number y))))
 341                ;; An open upper bound is less than a closed
 342                ;; upper bound because the open bound doesn't
 343                ;; contain the bound, so choose an open lower
 344                ;; bound.
 345                (set-bound res (or (consp x) (consp y))))))
 346     (let* ((x-bound (bound x))
 347            (y-bound (exclude (bound y)))
 348            (new-bound (cond ((not x-bound)
 349                              y-bound)
 350                             ((not y-bound)
 351                              x-bound)
 352                             (greater
 353                              (max-lower-bound x-bound y-bound))
 354                             (t
 355                              (min-upper-bound x-bound y-bound)))))
 356       (if greater
 357           (modified-numeric-type x :low new-bound)
 358           (modified-numeric-type x :high new-bound)))))
 359
 360 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 361 ;;; restrictions from flow analysis IN, set the type for REF
 362 ;;; accordingly.
 363 (defun constrain-ref-type (ref constraints in)
 364   (declare (type ref ref) (type sset constraints in))
 365   (let ((var-cons (copy-sset constraints)))
 366     (sset-intersection var-cons in)
 367     (let ((res (single-value-type (node-derived-type ref)))
 368           (not-res *empty-type*)
 369           (leaf (ref-leaf ref)))
 370       (do-sset-elements (con var-cons)
 371         (let* ((x (constraint-x con))
 372                (y (constraint-y con))
 373                (not-p (constraint-not-p con))
 374                (other (if (eq x leaf) y x))
 375                (kind (constraint-kind con)))
 376           (case kind
 377             (typep
 378              (if not-p
 379                  (setq not-res (type-union not-res other))
 380                  (setq res (type-approx-intersection2 res other))))
 381             (eql
 382              (unless (lvar-p other)
 383                (let ((other-type (leaf-type other)))
 384                  (if not-p
 385                      (when (and (constant-p other)
 386                                 (member-type-p other-type))
 387                        (setq not-res (type-union not-res other-type)))
 388                      (let ((leaf-type (leaf-type leaf)))
 389                        (cond
 390                          ((or (constant-p other)
 391                               (and (leaf-refs other) ; protect from
 392                                         ; deleted vars
 393                                    (csubtypep other-type leaf-type)
 394                                    (not (type= other-type leaf-type))))
 395                           (change-ref-leaf ref other)
 396                           (when (constant-p other) (return)))
 397                          (t
 398                           (setq res (type-approx-intersection2
 399                                      res other-type)))))))))
 400             ((< >)
 401              (cond
 402                ((and (integer-type-p res) (integer-type-p y))
 403                 (let ((greater (eq kind '>)))
 404                   (let ((greater (if not-p (not greater) greater)))
 405                     (setq res
 406                           (constrain-integer-type res y greater not-p)))))
 407                ((and (float-type-p res) (float-type-p y))
 408                 (let ((greater (eq kind '>)))
 409                   (let ((greater (if not-p (not greater) greater)))
 410                     (setq res
 411                           (constrain-float-type res y greater not-p))))))))))
 412       (cond ((and (if-p (node-dest ref))
 413                   (csubtypep (specifier-type 'null) not-res))
 414              (setf (node-derived-type ref) *wild-type*)
 415              (change-ref-leaf ref (find-constant t)))
 416             (t
 417              (derive-node-type ref
 418                                (make-single-value-type
 419                                 (or (type-difference res not-res)
 420                                     res)))
 421              (maybe-terminate-block ref nil)))))
 422
 423   (values))
 424
 425 ;;;; Flow analysis
 426
 427 (defun maybe-add-eql-var-lvar-constraint (ref gen)
 428   (let ((lvar (ref-lvar ref))
 429         (leaf (ref-leaf ref)))
 430     (when (and (lambda-var-p leaf) lvar)
 431       (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
 432                    gen))))
 433
 434 ;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR
 435 ;;; LVAR) ones.
 436 (defun inherit-constraints (var from-var constraints target)
 437   (do-sset-elements (con constraints)
 438     (let ((eq-x (eq from-var (constraint-x con)))
 439           (eq-y (eq from-var (constraint-y con))))
 440       ;; Constant substitution is controversial.
 441       (unless (constant-p (constraint-y con))
 442         (when (or (and eq-x (not (lvar-p (constraint-y con))))
 443                   eq-y)
 444           (sset-adjoin (find-or-create-constraint
 445                         (constraint-kind con)
 446                         (if eq-x var (constraint-x con))
 447                         (if eq-y var (constraint-y con))
 448                         (constraint-not-p con))
 449                        target))))))
 450
 451 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
 452 ;; inherit each other's constraints.
 453 (defun add-eql-var-var-constraint (var1 var2 constraints
 454                                    &optional (target constraints))
 455   (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
 456     (when (sset-adjoin con target)
 457       (do-eql-vars (var2 (var2 constraints))
 458         (inherit-constraints var1 var2 constraints target))
 459       (do-eql-vars (var1 (var1 constraints))
 460         (inherit-constraints var1 var2 constraints target))
 461       t)))
 462
 463 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
 464 ;; LAMBDA-VAR if possible.
 465 (defun maybe-add-eql-var-var-constraint (var lvar constraints
 466                                          &optional (target constraints))
 467   (declare (type lambda-var var) (type lvar lvar))
 468   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
 469     (when lambda-var
 470       (add-eql-var-var-constraint var lambda-var constraints target))))
 471
 472 ;;; Local propagation
 473 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 474 ;;;    constraint.]
 475 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 476 ;;;    a type constraint based on the new value type.
 477 (declaim (ftype (function (cblock sset
 478                            &key (:ref-preprocessor (or null function))
 479                                 (:set-preprocessor (or null function)))
 480                           sset)
 481                 constraint-propagate-in-block))
 482 (defun constraint-propagate-in-block
 483     (block gen &key ref-preprocessor set-preprocessor)
 484
 485   (do-nodes (node lvar block)
 486     (typecase node
 487       (bind
 488        (let ((fun (bind-lambda node)))
 489          (when (eq (functional-kind fun) :let)
 490            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
 491                  for var in (lambda-vars fun)
 492                  and val in (combination-args call)
 493                  when (and val (lambda-var-constraints var))
 494                  do (let* ((type (lvar-type val))
 495                            (con (find-or-create-constraint 'typep var type
 496                                                            nil)))
 497                       (sset-adjoin con gen))
 498                  (maybe-add-eql-var-var-constraint var val gen)))))
 499       (ref
 500        (when (ok-ref-lambda-var node)
 501          (maybe-add-eql-var-lvar-constraint node gen)
 502          (when ref-preprocessor
 503            (funcall ref-preprocessor node gen))))
 504       (cast
 505        (let ((lvar (cast-value node)))
 506          (let ((var (ok-lvar-lambda-var lvar gen)))
 507            (when var
 508              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
 509                (do-eql-vars (var (var gen))
 510                  (let ((con (find-or-create-constraint 'typep var atype nil)))
 511                    (sset-adjoin con gen))))))))
 512       (cset
 513        (binding* ((var (set-var node))
 514                   (nil (lambda-var-p var) :exit-if-null)
 515                   (cons (lambda-var-constraints var) :exit-if-null))
 516          (when set-preprocessor
 517            (funcall set-preprocessor var))
 518          (sset-difference gen cons)
 519          (let* ((type (single-value-type (node-derived-type node)))
 520                 (con (find-or-create-constraint 'typep var type nil)))
 521            (sset-adjoin con gen))
 522          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
 523
 524   gen)
 525
 526 (defun constraint-propagate-if (block gen)
 527   (let ((node (block-last block)))
 528     (when (if-p node)
 529       (let ((use (lvar-uses (if-test node))))
 530         (when (node-p use)
 531           (add-test-constraints use node gen))))))
 532
 533 (defun constrain-node (node cons)
 534   (let* ((var (ref-leaf node))
 535          (con (lambda-var-constraints var)))
 536     (constrain-ref-type node con cons)))
 537
 538 ;;; Starting from IN compute OUT and (consequent/alternative
 539 ;;; constraints if the block ends with and IF). Return the list of
 540 ;;; successors that may need to be recomputed.
 541 (defun find-block-type-constraints (block &key final-pass-p)
 542   (declare (type cblock block))
 543   (let ((gen (constraint-propagate-in-block
 544               block
 545               (if final-pass-p
 546                   (block-in block)
 547                   (copy-sset (block-in block)))
 548               :ref-preprocessor (if final-pass-p #'constrain-node nil))))
 549     (setf (block-gen block) gen)
 550     (multiple-value-bind (consequent-constraints alternative-constraints)
 551         (constraint-propagate-if block gen)
 552       (if consequent-constraints
 553           (let* ((node (block-last block))
 554                  (old-consequent-constraints (if-consequent-constraints node))
 555                  (old-alternative-constraints (if-alternative-constraints node))
 556                  (succ ()))
 557             ;; Add the consequent and alternative constraints to GEN.
 558             (cond ((sset-empty consequent-constraints)
 559                    (setf (if-consequent-constraints node) gen)
 560                    (setf (if-alternative-constraints node) gen))
 561                   (t
 562                    (setf (if-consequent-constraints node) (copy-sset gen))
 563                    (sset-union (if-consequent-constraints node)
 564                                consequent-constraints)
 565                    (setf (if-alternative-constraints node) gen)
 566                    (sset-union (if-alternative-constraints node)
 567                                alternative-constraints)))
 568             ;; Has the consequent been changed?
 569             (unless (and old-consequent-constraints
 570                          (sset= (if-consequent-constraints node)
 571                                 old-consequent-constraints))
 572               (push (if-consequent node) succ))
 573             ;; Has the alternative been changed?
 574             (unless (and old-alternative-constraints
 575                          (sset= (if-alternative-constraints node)
 576                                 old-alternative-constraints))
 577               (push (if-alternative node) succ))
 578             succ)
 579           ;; There is no IF.
 580           (unless (and (block-out block)
 581                        (sset= gen (block-out block)))
 582             (setf (block-out block) gen)
 583             (block-succ block))))))
 584
 585 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 586 ;;; During this pass, we also do local constraint propagation by
 587 ;;; adding in constraints as we see them during the pass through the
 588 ;;; block.
 589 (defun use-result-constraints (block)
 590   (declare (type cblock block))
 591   (constraint-propagate-in-block block (block-in block)
 592                                  :ref-preprocessor #'constrain-node))
 593
 594 ;;; Give an empty constraints set to any var that doesn't have one and
 595 ;;; isn't a set closure var. Since a var that we previously rejected
 596 ;;; looks identical to one that is new, so we optimistically keep
 597 ;;; hoping that vars stop being closed over or lose their sets.
 598 (defun init-var-constraints (component)
 599   (declare (type component component))
 600   (dolist (fun (component-lambdas component))
 601     (flet ((frob (x)
 602              (dolist (var (lambda-vars x))
 603                (unless (lambda-var-constraints var)
 604                  (when (or (null (lambda-var-sets var))
 605                            (not (closure-var-p var)))
 606                    (setf (lambda-var-constraints var) (make-sset)))))))
 607       (frob fun)
 608       (dolist (let (lambda-lets fun))
 609         (frob let)))))
 610
 611 ;;; Return the constraints that flow from PRED to SUCC. This is
 612 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
 613 ;;; added.
 614 (defun block-out-for-successor (pred succ)
 615   (declare (type cblock pred succ))
 616   (let ((last (block-last pred)))
 617     (or (when (if-p last)
 618           (cond ((eq succ (if-consequent last))
 619                  (if-consequent-constraints last))
 620                 ((eq succ (if-alternative last))
 621                  (if-alternative-constraints last))))
 622         (block-out pred))))
 623
 624 (defun compute-block-in (block)
 625   (let ((in nil))
 626     (dolist (pred (block-pred block))
 627       ;; If OUT has not been calculated, assume it to be the universal
 628       ;; set.
 629       (let ((out (block-out-for-successor pred block)))
 630         (when out
 631           (if in
 632               (sset-intersection in out)
 633               (setq in (copy-sset out))))))
 634     (or in (make-sset))))
 635
 636 (defun update-block-in (block)
 637   (let ((in (compute-block-in block)))
 638     (cond ((and (block-in block) (sset= in (block-in block)))
 639            nil)
 640           (t
 641            (setf (block-in block) in)))))
 642
 643 ;;; Return two lists: one of blocks that precede all loops and
 644 ;;; therefore require only one constraint propagation pass and the
 645 ;;; rest. This implementation does not find all such blocks.
 646 ;;;
 647 ;;; A more complete implementation would be:
 648 ;;;
 649 ;;;     (do-blocks (block component)
 650 ;;;       (if (every #'(lambda (pred)
 651 ;;;                      (or (member pred leading-blocks)
 652 ;;;                          (eq pred head)))
 653 ;;;                  (block-pred block))
 654 ;;;           (push block leading-blocks)
 655 ;;;           (push block rest-of-blocks)))
 656 ;;;
 657 ;;; Trailing blocks that succeed all loops could be found and handled
 658 ;;; similarly. In practice though, these more complex solutions are
 659 ;;; slightly worse performancewise.
 660 (defun leading-component-blocks (component)
 661   (declare (type component component))
 662   (flet ((loopy-p (block)
 663            (let ((n (block-number block)))
 664              (dolist (pred (block-pred block))
 665                (unless (< n (block-number pred))
 666                  (return t))))))
 667     (let ((leading-blocks ())
 668           (rest-of-blocks ())
 669           (seen-loop-p ()))
 670       (do-blocks (block component)
 671         (when (and (not seen-loop-p) (loopy-p block))
 672           (setq seen-loop-p t))
 673         (if seen-loop-p
 674             (push block rest-of-blocks)
 675             (push block leading-blocks)))
 676       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
 677
 678 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
 679 ;;; a member already.
 680 (defun nconc-new (obj list)
 681   (do ((x list (cdr x))
 682        (prev nil x))
 683       ((endp x) (if prev
 684                     (progn
 685                       (setf (cdr prev) (list obj))
 686                       list)
 687                     (list obj)))
 688     (when (eql (car x) obj)
 689       (return-from nconc-new list))))
 690
 691 (defun find-and-propagate-constraints (component)
 692   (let ((blocks-to-process ()))
 693     (flet ((enqueue (blocks)
 694              (dolist (block blocks)
 695                (setq blocks-to-process (nconc-new block blocks-to-process)))))
 696       (multiple-value-bind (leading-blocks rest-of-blocks)
 697           (leading-component-blocks component)
 698         ;; Update every block once to account for changes in the
 699         ;; IR1. The constraints of the lead blocks cannot be changed
 700         ;; after the first pass so we might as well use them and skip
 701         ;; USE-RESULT-CONSTRAINTS later.
 702         (dolist (block leading-blocks)
 703           (setf (block-in block) (compute-block-in block))
 704           (find-block-type-constraints block :final-pass-p t))
 705         (setq blocks-to-process (copy-list rest-of-blocks))
 706         ;; The rest of the blocks.
 707         (dolist (block rest-of-blocks)
 708           (aver (eq block (pop blocks-to-process)))
 709           (setf (block-in block) (compute-block-in block))
 710           (enqueue (find-block-type-constraints block)))
 711         ;; Propagate constraints
 712         (loop for block = (pop blocks-to-process)
 713               while block do
 714               (unless (eq block (component-tail component))
 715                 (when (update-block-in block)
 716                   (enqueue (find-block-type-constraints block)))))
 717         rest-of-blocks))))
 718
 719 (defun constraint-propagate (component)
 720   (declare (type component component))
 721   (init-var-constraints component)
 722
 723   (unless (block-out (component-head component))
 724     (setf (block-out (component-head component)) (make-sset)))
 725
 726   (dolist (block (find-and-propagate-constraints component))
 727     (unless (block-delete-p block)
 728       (use-result-constraints block)))
 729
 730   (values))