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): is does not understand that this
  41 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
  42
  43 ;;; BUGS:
  44 ;;;
  45 ;;; -- this code does not check whether SET appears between REF and a
  46 ;;; test (bug 233b)
  47
  48 (in-package "SB!C")
  49
  50 (deftype constraint-y () '(or ctype lvar lambda-var constant))
  51
  52 (defstruct (constraint
  53             (:include sset-element)
  54             (:constructor make-constraint (number kind x y not-p))
  55             (:copier nil))
  56   ;; the kind of constraint we have:
  57   ;;
  58   ;; TYPEP
  59   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
  60   ;;     constrained to be of type Y.
  61   ;;
  62   ;; > or <
  63   ;;     X is a lambda-var and Y is a CTYPE. The relation holds
  64   ;;     between X and some object of type Y.
  65   ;;
  66   ;; EQL
  67   ;;     X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
  68   ;;     The relation is asserted to hold.
  69   (kind nil :type (member typep < > eql))
  70   ;; The operands to the relation.
  71   (x nil :type lambda-var)
  72   (y nil :type constraint-y)
  73   ;; If true, negates the sense of the constraint, so the relation
  74   ;; does *not* hold.
  75   (not-p nil :type boolean))
  76
  77 (defvar *constraint-number*)
  78
  79 (defun find-constraint (kind x y not-p)
  80   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
  81   (etypecase y
  82     (ctype
  83      (do-sset-elements (con (lambda-var-constraints x) nil)
  84        (when (and (eq (constraint-kind con) kind)
  85                   (eq (constraint-not-p con) not-p)
  86                   (type= (constraint-y con) y))
  87          (return con))))
  88     ((or lvar constant)
  89      (do-sset-elements (con (lambda-var-constraints x) nil)
  90        (when (and (eq (constraint-kind con) kind)
  91                   (eq (constraint-not-p con) not-p)
  92                   (eq (constraint-y con) y))
  93          (return con))))
  94     (lambda-var
  95      (do-sset-elements (con (lambda-var-constraints x) nil)
  96        (when (and (eq (constraint-kind con) kind)
  97                   (eq (constraint-not-p con) not-p)
  98                   (let ((cx (constraint-x con)))
  99                     (eq (if (eq cx x)
 100                             (constraint-y con)
 101                             cx)
 102                         y)))
 103          (return con))))))
 104
 105 ;;; Return a constraint for the specified arguments. We only create a
 106 ;;; new constraint if there isn't already an equivalent old one,
 107 ;;; guaranteeing that all equivalent constraints are EQ. This
 108 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
 109 (defun find-or-create-constraint (kind x y not-p)
 110   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
 111   (or (find-constraint kind x y not-p)
 112       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
 113         (sset-adjoin new (lambda-var-constraints x))
 114         (when (lambda-var-p y)
 115           (sset-adjoin new (lambda-var-constraints y)))
 116         new)))
 117
 118 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
 119 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
 120 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
 121 (defun ok-ref-lambda-var (ref)
 122   (declare (type ref ref))
 123   (let ((leaf (ref-leaf ref)))
 124     (when (and (lambda-var-p leaf)
 125                (lambda-var-constraints leaf))
 126       leaf)))
 127
 128 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
 129 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
 130 (defun ok-lvar-lambda-var (lvar constraints)
 131   (declare (type lvar lvar))
 132   (let ((use (lvar-uses lvar)))
 133     (when (ref-p use)
 134       (let ((lambda-var (ok-ref-lambda-var use)))
 135         (when lambda-var
 136           (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
 137             (when (and constraint (sset-member constraint constraints))
 138               lambda-var)))))))
 139
 140 ;;;; Searching constraints
 141
 142 ;;; Add the indicated test constraint to BLOCK, marking the block as
 143 ;;; having a new assertion when the constriant was not already
 144 ;;; present. We don't add the constraint if the block has multiple
 145 ;;; predecessors, since it only holds on this particular path.
 146 (defun add-test-constraint (block fun x y not-p)
 147   (unless (rest (block-pred block))
 148     (let ((con (find-or-create-constraint fun x y not-p))
 149           (old (or (block-test-constraint block)
 150                    (setf (block-test-constraint block) (make-sset)))))
 151       (when (sset-adjoin con old)
 152         (setf (block-type-asserted block) t))))
 153   (values))
 154
 155 ;;; Add complementary constraints to the consequent and alternative
 156 ;;; blocks of IF. We do nothing if X is NIL.
 157 (defun add-complement-constraints (if fun x y not-p)
 158   (when (and x
 159              ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
 160              ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
 161              ;; that we can't guarantee that the optimization will be
 162              ;; done, so we still need to avoid barfing on this case.
 163              (not (eq (if-consequent if)
 164                       (if-alternative if))))
 165     (add-test-constraint (if-consequent if) fun x y not-p)
 166     (add-test-constraint (if-alternative if) fun x y (not not-p)))
 167   (values))
 168
 169 ;;; Add test constraints to the consequent and alternative blocks of
 170 ;;; the test represented by USE.
 171 (defun add-test-constraints (use if constraints)
 172   (declare (type node use) (type cif if))
 173   (typecase use
 174     (ref
 175      (add-complement-constraints if 'typep (ok-lvar-lambda-var (ref-lvar use)
 176                                                                constraints)
 177                                  (specifier-type 'null) t))
 178     (combination
 179      (unless (eq (combination-kind use)
 180                  :error)
 181        (let ((name (lvar-fun-name
 182                     (basic-combination-fun use)))
 183              (args (basic-combination-args use)))
 184          (case name
 185            ((%typep %instance-typep)
 186             (let ((type (second args)))
 187               (when (constant-lvar-p type)
 188                 (let ((val (lvar-value type)))
 189                   (add-complement-constraints if 'typep
 190                                               (ok-lvar-lambda-var (first args)
 191                                                                   constraints)
 192                                               (if (ctype-p val)
 193                                                   val
 194                                                   (specifier-type val))
 195                                               nil)))))
 196            ((eq eql)
 197             (let* ((var1 (ok-lvar-lambda-var (first args) constraints))
 198                    (arg2 (second args))
 199                    (var2 (ok-lvar-lambda-var arg2 constraints)))
 200               (cond ((not var1))
 201                     (var2
 202                      (add-complement-constraints if 'eql var1 var2 nil))
 203                     ((constant-lvar-p arg2)
 204                      (add-complement-constraints if 'eql var1
 205                                                  (ref-leaf
 206                                                   (principal-lvar-use arg2))
 207                                                  nil)))))
 208            ((< >)
 209             (let* ((arg1 (first args))
 210                    (var1 (ok-lvar-lambda-var arg1 constraints))
 211                    (arg2 (second args))
 212                    (var2 (ok-lvar-lambda-var arg2 constraints)))
 213               (when var1
 214                 (add-complement-constraints if name var1 (lvar-type arg2)
 215                                             nil))
 216               (when var2
 217                 (add-complement-constraints if (if (eq name '<) '> '<)
 218                                             var2 (lvar-type arg1)
 219                                             nil))))
 220            (t
 221             (let ((ptype (gethash name *backend-predicate-types*)))
 222               (when ptype
 223                 (add-complement-constraints if 'typep
 224                                             (ok-lvar-lambda-var (first args)
 225                                                                 constraints)
 226                                             ptype nil)))))))))
 227   (values))
 228
 229 ;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
 230 ;;; the condition it tests.
 231 (defun find-test-constraints (block)
 232   (declare (type cblock block))
 233   (let ((last (block-last block)))
 234     (when (if-p last)
 235       (let ((use (lvar-uses (if-test last))))
 236         (when (node-p use)
 237           ;; BLOCK-OUT contains the (EQL LAMBDA-VAR LVAR)
 238           ;; constraints valid at the end of the block. Since the
 239           ;; IF node is last node in its block, it can be used to
 240           ;; check LVAR LAMBDA-VAR equality.
 241           (add-test-constraints use last (block-out block))))))
 242   (values))
 243
 244 ;;;; Applying constraints
 245
 246 ;;; Return true if X is an integer NUMERIC-TYPE.
 247 (defun integer-type-p (x)
 248   (declare (type ctype x))
 249   (and (numeric-type-p x)
 250        (eq (numeric-type-class x) 'integer)
 251        (eq (numeric-type-complexp x) :real)))
 252
 253 ;;; Given that an inequality holds on values of type X and Y, return a
 254 ;;; new type for X. If GREATER is true, then X was greater than Y,
 255 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
 256 ;;; inclusive, i.e. >=.
 257 ;;;
 258 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
 259 ;;; bound into X and return that result. If not OR-EQUAL, we can go
 260 ;;; one greater (less) than Y's bound.
 261 (defun constrain-integer-type (x y greater or-equal)
 262   (declare (type numeric-type x y))
 263   (flet ((exclude (x)
 264            (cond ((not x) nil)
 265                  (or-equal x)
 266                  (greater (1+ x))
 267                  (t (1- x))))
 268          (bound (x)
 269            (if greater (numeric-type-low x) (numeric-type-high x))))
 270     (let* ((x-bound (bound x))
 271            (y-bound (exclude (bound y)))
 272            (new-bound (cond ((not x-bound) y-bound)
 273                             ((not y-bound) x-bound)
 274                             (greater (max x-bound y-bound))
 275                             (t (min x-bound y-bound)))))
 276       (if greater
 277           (modified-numeric-type x :low new-bound)
 278           (modified-numeric-type x :high new-bound)))))
 279
 280 ;;; Return true if X is a float NUMERIC-TYPE.
 281 (defun float-type-p (x)
 282   (declare (type ctype x))
 283   (and (numeric-type-p x)
 284        (eq (numeric-type-class x) 'float)
 285        (eq (numeric-type-complexp x) :real)))
 286
 287 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 288 (defun constrain-float-type (x y greater or-equal)
 289   (declare (type numeric-type x y))
 290   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
 291
 292   (aver (eql (numeric-type-class x) 'float))
 293   (aver (eql (numeric-type-class y) 'float))
 294   #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 295   x
 296   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 297   (labels ((exclude (x)
 298              (cond ((not x) nil)
 299                    (or-equal x)
 300                    (greater
 301                     (if (consp x)
 302                         (car x)
 303                         x))
 304                    (t
 305                     (if (consp x)
 306                         x
 307                         (list x)))))
 308            (bound (x)
 309              (if greater (numeric-type-low x) (numeric-type-high x)))
 310            (max-lower-bound (x y)
 311              ;; Both X and Y are not null. Find the max.
 312              (let ((res (max (type-bound-number x) (type-bound-number y))))
 313                ;; An open lower bound is greater than a close
 314                ;; lower bound because the open bound doesn't
 315                ;; contain the bound, so choose an open lower
 316                ;; bound.
 317                (set-bound res (or (consp x) (consp y)))))
 318            (min-upper-bound (x y)
 319              ;; Same as above, but for the min of upper bounds
 320              ;; Both X and Y are not null. Find the min.
 321              (let ((res (min (type-bound-number x) (type-bound-number y))))
 322                ;; An open upper bound is less than a closed
 323                ;; upper bound because the open bound doesn't
 324                ;; contain the bound, so choose an open lower
 325                ;; bound.
 326                (set-bound res (or (consp x) (consp y))))))
 327     (let* ((x-bound (bound x))
 328            (y-bound (exclude (bound y)))
 329            (new-bound (cond ((not x-bound)
 330                              y-bound)
 331                             ((not y-bound)
 332                              x-bound)
 333                             (greater
 334                              (max-lower-bound x-bound y-bound))
 335                             (t
 336                              (min-upper-bound x-bound y-bound)))))
 337       (if greater
 338           (modified-numeric-type x :low new-bound)
 339           (modified-numeric-type x :high new-bound)))))
 340
 341 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 342 ;;; restrictions from flow analysis IN, set the type for REF
 343 ;;; accordingly.
 344 (defun constrain-ref-type (ref constraints in)
 345   (declare (type ref ref) (type sset constraints in))
 346   (let ((var-cons (copy-sset constraints)))
 347     (sset-intersection var-cons in)
 348     (let ((res (single-value-type (node-derived-type ref)))
 349           (not-res *empty-type*)
 350           (leaf (ref-leaf ref)))
 351       (do-sset-elements (con var-cons)
 352         (let* ((x (constraint-x con))
 353                (y (constraint-y con))
 354                (not-p (constraint-not-p con))
 355                (other (if (eq x leaf) y x))
 356                (kind (constraint-kind con)))
 357           (case kind
 358             (typep
 359              (if not-p
 360                  (setq not-res (type-union not-res other))
 361                  (setq res (type-approx-intersection2 res other))))
 362             (eql
 363              (unless (lvar-p other)
 364                (let ((other-type (leaf-type other)))
 365                  (if not-p
 366                      (when (and (constant-p other)
 367                                 (member-type-p other-type))
 368                        (setq not-res (type-union not-res other-type)))
 369                      (let ((leaf-type (leaf-type leaf)))
 370                        (when (or (constant-p other)
 371                                  (and (leaf-refs other) ; protect from
 372                                                         ; deleted vars
 373                                       (csubtypep other-type leaf-type)
 374                                       (not (type= other-type leaf-type))))
 375                          (change-ref-leaf ref other)
 376                          (when (constant-p other) (return))))))))
 377             ((< >)
 378              (cond ((and (integer-type-p res) (integer-type-p y))
 379                     (let ((greater (eq kind '>)))
 380                       (let ((greater (if not-p (not greater) greater)))
 381                         (setq res
 382                               (constrain-integer-type res y greater not-p)))))
 383                    ((and (float-type-p res) (float-type-p y))
 384                     (let ((greater (eq kind '>)))
 385                       (let ((greater (if not-p (not greater) greater)))
 386                         (setq res
 387                               (constrain-float-type res y greater not-p)))))
 388                    )))))
 389
 390       (cond ((and (if-p (node-dest ref))
 391                   (csubtypep (specifier-type 'null) not-res))
 392              (setf (node-derived-type ref) *wild-type*)
 393              (change-ref-leaf ref (find-constant t)))
 394             (t
 395              (derive-node-type ref
 396                                (make-single-value-type
 397                                 (or (type-difference res not-res)
 398                                     res)))
 399              (maybe-terminate-block ref nil)))))
 400
 401   (values))
 402
 403 ;;;; Flow analysis
 404
 405 ;;; Local propagation
 406 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 407 ;;;    constraint.]
 408 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 409 ;;;    a type constraint based on the new value type.
 410 (declaim (ftype (function (cblock sset
 411                            &key (:ref-preprocessor function)
 412                                 (:set-preprocessor function))
 413                           sset)
 414                 constraint-propagate-in-block))
 415 (defun constraint-propagate-in-block
 416     (block gen &key ref-preprocessor set-preprocessor)
 417
 418   (let ((test (block-test-constraint block)))
 419     (when test
 420       (sset-union gen test)))
 421
 422   (do-nodes (node lvar block)
 423     (typecase node
 424       (bind
 425        (let ((fun (bind-lambda node)))
 426          (when (eq (functional-kind fun) :let)
 427            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
 428                  for var in (lambda-vars fun)
 429                  and val in (combination-args call)
 430                  when (and val
 431                            (lambda-var-constraints var)
 432                            ;; if VAR has no SETs, type inference is
 433                            ;; fully performed by IR1 optimizer
 434                            (lambda-var-sets var))
 435                  do (let* ((type (lvar-type val))
 436                            (con (find-or-create-constraint 'typep var type
 437                                                            nil)))
 438                       (sset-adjoin con gen))))))
 439       (ref
 440        (when (ok-ref-lambda-var node)
 441          (maybe-add-eql-constraint-for-lvar node gen)
 442          (when ref-preprocessor
 443            (funcall ref-preprocessor node gen))))
 444       (cast
 445        (let ((lvar (cast-value node)))
 446          (let ((var (ok-lvar-lambda-var lvar gen)))
 447              (when var
 448                (let* ((atype (single-value-type (cast-derived-type node))) ; FIXME
 449                       (con (find-or-create-constraint 'typep var atype nil)))
 450                  (sset-adjoin con gen))))))
 451       (cset
 452        (binding* ((var (set-var node))
 453                   (nil (lambda-var-p var) :exit-if-null)
 454                   (cons (lambda-var-constraints var) :exit-if-null))
 455          (when set-preprocessor
 456            (funcall set-preprocessor var))
 457          (sset-difference gen cons)
 458          (let* ((type (single-value-type (node-derived-type node)))
 459                 (con (find-or-create-constraint 'typep var type nil)))
 460            (sset-adjoin con gen))))))
 461
 462   gen)
 463
 464 ;;; BLOCK-KILL is just a list of the LAMBDA-VARs killed, so we must
 465 ;;; compute the kill set when there are any vars killed. We bum this a
 466 ;;; bit by special-casing when only one var is killed, and just using
 467 ;;; that var's constraints as the kill set. This set could possibly be
 468 ;;; precomputed, but it would have to be invalidated whenever any
 469 ;;; constraint is added, which would be a pain.
 470 (defun compute-block-out (block)
 471   (declare (type cblock block))
 472   (let ((in (block-in block))
 473         (kill (block-kill block))
 474         (out (copy-sset (block-gen block))))
 475     (cond ((null kill)
 476            (sset-union out in))
 477           ((null (rest kill))
 478            (let ((con (lambda-var-constraints (first kill))))
 479              (if con
 480                  (sset-union-of-difference out in con)
 481                  (sset-union out in))))
 482           (t
 483            (let ((kill-set (make-sset)))
 484              (dolist (var kill)
 485                (let ((con (lambda-var-constraints var)))
 486                  (when con
 487                    (sset-union kill-set con))))
 488              (sset-union-of-difference out in kill-set))))
 489     out))
 490
 491 ;; Add a (EQL LAMBDA-VAR LVAR) constraint, but only for LVAR's with a
 492 ;; DEST that's an IF or a test for an IF.
 493 (defun maybe-add-eql-constraint-for-lvar (ref gen)
 494   (let ((lvar (ref-lvar ref))
 495         (leaf (ref-leaf ref)))
 496     (when (and (lambda-var-p leaf) lvar
 497                ;; This test avoids generating constraints for an LVAR
 498                ;; for which EQLness to its referenced LAMBDA-VAR is
 499                ;; not important because OK-LVAR-LAMBDA-VAR won't need
 500                ;; it.
 501                (or (cast-p (lvar-dest lvar))
 502                    (if-p (lvar-dest lvar))
 503                    (and (valued-node-p (lvar-dest lvar))
 504                         (let ((lvar2 (node-lvar (lvar-dest lvar))))
 505                           (when lvar2
 506                             (if-p (lvar-dest lvar2)))))))
 507       (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
 508                    gen))))
 509
 510 ;;; Compute the initial flow analysis sets for BLOCK:
 511 ;;; -- Compute IN/OUT sets; if OUT of a predecessor is not yet
 512 ;;;    computed, assume it to be a universal set (this is only
 513 ;;;    possible in a loop)
 514 ;;;
 515 ;;; Return T if we have found a loop.
 516 (defun find-block-type-constraints (block)
 517   (declare (type cblock block))
 518   (collect ((kill nil adjoin))
 519     (let ((gen (constraint-propagate-in-block
 520                 block (make-sset)
 521                 :set-preprocessor (lambda (var)
 522                                     (kill var)))))
 523       (setf (block-gen block) gen)
 524       (setf (block-kill block) (kill))
 525       (setf (block-type-asserted block) nil)
 526       (let* ((n (block-number block))
 527              (pred (block-pred block))
 528              (in nil)
 529              (loop-p nil))
 530         (dolist (b pred)
 531           (cond ((> (block-number b) n)
 532                  (if in
 533                      (sset-intersection in (block-out b))
 534                      (setq in (copy-sset (block-out b)))))
 535                 (t (setq loop-p t))))
 536         (unless in
 537           (bug "Unreachable code is found or flow graph is not ~
 538                 properly depth-first ordered."))
 539         (setf (block-in block) in)
 540         (setf (block-out block) (compute-block-out block))
 541         loop-p))))
 542
 543 ;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
 544 ;;; Our OUT is:
 545 ;;;     gen U (in - kill)
 546 ;;;
 547 ;;; Return True if we have done something.
 548 (defun flow-propagate-constraints (block)
 549   (let* ((pred (block-pred block))
 550          (in (progn (aver pred)
 551                     (let ((res (copy-sset (block-out (first pred)))))
 552                       (dolist (b (rest pred))
 553                         (sset-intersection res (block-out b)))
 554                       res))))
 555     (setf (block-in block) in)
 556     (let ((out (compute-block-out block)))
 557       (if (sset= out (block-out block))
 558           nil
 559           (setf (block-out block) out)))))
 560
 561 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 562 ;;; During this pass, we also do local constraint propagation by
 563 ;;; adding in constraints as we seem them during the pass through the
 564 ;;; block.
 565 (defun use-result-constraints (block)
 566   (declare (type cblock block))
 567   (constraint-propagate-in-block
 568    block (block-in block)
 569    :ref-preprocessor (lambda (node cons)
 570                        (let* ((var (ref-leaf node))
 571                               (con (lambda-var-constraints var)))
 572                          (constrain-ref-type node con cons)))))
 573
 574 ;;; Give an empty constraints set to any var that doesn't have one and
 575 ;;; isn't a set closure var. Since a var that we previously rejected
 576 ;;; looks identical to one that is new, so we optimistically keep
 577 ;;; hoping that vars stop being closed over or lose their sets.
 578 (defun init-var-constraints (component)
 579   (declare (type component component))
 580   (dolist (fun (component-lambdas component))
 581     (flet ((frob (x)
 582              (dolist (var (lambda-vars x))
 583                (unless (lambda-var-constraints var)
 584                  (when (or (null (lambda-var-sets var))
 585                            (not (closure-var-p var)))
 586                    (setf (lambda-var-constraints var) (make-sset)))))))
 587       (frob fun)
 588       (dolist (let (lambda-lets fun))
 589         (frob let)))))
 590
 591 ;;; How many blocks does COMPONENT have?
 592 (defun component-n-blocks (component)
 593   (let ((result 0))
 594     (declare (type index result))
 595     (do-blocks (block component :both)
 596       (incf result))
 597     result))
 598
 599 (defun find-and-propagate-constraints (component)
 600   (let ((loop-p nil))
 601     (do-blocks (block component)
 602       (when (find-block-type-constraints block)
 603         (setq loop-p t)))
 604     (when loop-p
 605       ;; If we have to propagate changes more than this many times,
 606       ;; something is wrong.
 607       (let ((max-n-changes-remaining (component-n-blocks component)))
 608         (declare (type fixnum max-n-changes-remaining))
 609         (loop (aver (>= max-n-changes-remaining 0))
 610               (decf max-n-changes-remaining)
 611               (let ((did-something nil))
 612                 (do-blocks (block component)
 613                   (when (flow-propagate-constraints block)
 614                     (setq did-something t)))
 615                 (unless did-something
 616                   (return))))))))
 617
 618 (defun constraint-propagate (component)
 619   (declare (type component component))
 620   (init-var-constraints component)
 621
 622   (unless (block-out (component-head component))
 623     (setf (block-out (component-head component)) (make-sset)))
 624
 625   (find-and-propagate-constraints component)
 626
 627   (do-blocks (block component)
 628     (when (block-test-modified block)
 629       (find-test-constraints block)
 630       (setf (block-test-modified block) nil)))
 631
 632   (find-and-propagate-constraints component)
 633
 634   (do-blocks (block component)
 635     (unless (block-delete-p block)
 636       (use-result-constraints block)))
 637
 638   (values))