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