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