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 (if fun x y not-p constraints
 175                                       consequent-constraints
 176                                       alternative-constraints)
 177   (when (and x
 178              ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
 179              ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
 180              ;; that we can't guarantee that the optimization will be
 181              ;; done, so we still need to avoid barfing on this case.
 182              (not (eq (if-consequent if)
 183                       (if-alternative if))))
 184     (add-test-constraint fun x y not-p constraints
 185                          consequent-constraints)
 186     (add-test-constraint fun x y (not not-p) constraints
 187                          alternative-constraints))
 188   (values))
 189
 190 ;;; Add test constraints to the consequent and alternative blocks of
 191 ;;; the test represented by USE.
 192 (defun add-test-constraints (use if constraints)
 193   (declare (type node use) (type cif if))
 194   (let ((consequent-constraints (make-sset))
 195         (alternative-constraints (make-sset)))
 196     (macrolet ((add (fun x y not-p)
 197                  `(add-complement-constraints if ,fun ,x ,y ,not-p
 198                    constraints
 199                    consequent-constraints
 200                    alternative-constraints)))
 201       (typecase use
 202         (ref
 203          (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
 204               (specifier-type 'null) t))
 205         (combination
 206          (unless (eq (combination-kind use)
 207                      :error)
 208            (let ((name (lvar-fun-name
 209                         (basic-combination-fun use)))
 210                  (args (basic-combination-args use)))
 211              (case name
 212                ((%typep %instance-typep)
 213                 (let ((type (second args)))
 214                   (when (constant-lvar-p type)
 215                     (let ((val (lvar-value type)))
 216                       (add 'typep (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* ((var1 (ok-lvar-lambda-var (first args) constraints))
 223                        (arg2 (second args))
 224                        (var2 (ok-lvar-lambda-var arg2 constraints)))
 225                   (cond ((not var1))
 226                         (var2
 227                          (add 'eql var1 var2 nil))
 228                         ((constant-lvar-p arg2)
 229                          (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
 230                               nil)))))
 231                ((< >)
 232                 (let* ((arg1 (first args))
 233                        (var1 (ok-lvar-lambda-var arg1 constraints))
 234                        (arg2 (second args))
 235                        (var2 (ok-lvar-lambda-var arg2 constraints)))
 236                   (when var1
 237                     (add name var1 (lvar-type arg2) nil))
 238                   (when var2
 239                     (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
 240                (t
 241                 (let ((ptype (gethash name *backend-predicate-types*)))
 242                   (when ptype
 243                     (add 'typep (ok-lvar-lambda-var (first args) constraints)
 244                          ptype nil))))))))))
 245     (values consequent-constraints alternative-constraints)))
 246
 247 ;;;; Applying constraints
 248
 249 ;;; Return true if X is an integer NUMERIC-TYPE.
 250 (defun integer-type-p (x)
 251   (declare (type ctype x))
 252   (and (numeric-type-p x)
 253        (eq (numeric-type-class x) 'integer)
 254        (eq (numeric-type-complexp x) :real)))
 255
 256 ;;; Given that an inequality holds on values of type X and Y, return a
 257 ;;; new type for X. If GREATER is true, then X was greater than Y,
 258 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
 259 ;;; inclusive, i.e. >=.
 260 ;;;
 261 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
 262 ;;; bound into X and return that result. If not OR-EQUAL, we can go
 263 ;;; one greater (less) than Y's bound.
 264 (defun constrain-integer-type (x y greater or-equal)
 265   (declare (type numeric-type x y))
 266   (flet ((exclude (x)
 267            (cond ((not x) nil)
 268                  (or-equal x)
 269                  (greater (1+ x))
 270                  (t (1- x))))
 271          (bound (x)
 272            (if greater (numeric-type-low x) (numeric-type-high x))))
 273     (let* ((x-bound (bound x))
 274            (y-bound (exclude (bound y)))
 275            (new-bound (cond ((not x-bound) y-bound)
 276                             ((not y-bound) x-bound)
 277                             (greater (max x-bound y-bound))
 278                             (t (min x-bound y-bound)))))
 279       (if greater
 280           (modified-numeric-type x :low new-bound)
 281           (modified-numeric-type x :high new-bound)))))
 282
 283 ;;; Return true if X is a float NUMERIC-TYPE.
 284 (defun float-type-p (x)
 285   (declare (type ctype x))
 286   (and (numeric-type-p x)
 287        (eq (numeric-type-class x) 'float)
 288        (eq (numeric-type-complexp x) :real)))
 289
 290 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 291 (defun constrain-float-type (x y greater or-equal)
 292   (declare (type numeric-type x y))
 293   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
 294
 295   (aver (eql (numeric-type-class x) 'float))
 296   (aver (eql (numeric-type-class y) 'float))
 297   #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 298   x
 299   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 300   (labels ((exclude (x)
 301              (cond ((not x) nil)
 302                    (or-equal x)
 303                    (greater
 304                     (if (consp x)
 305                         (car x)
 306                         x))
 307                    (t
 308                     (if (consp x)
 309                         x
 310                         (list x)))))
 311            (bound (x)
 312              (if greater (numeric-type-low x) (numeric-type-high x)))
 313            (max-lower-bound (x y)
 314              ;; Both X and Y are not null. Find the max.
 315              (let ((res (max (type-bound-number x) (type-bound-number y))))
 316                ;; An open lower bound is greater than a close
 317                ;; lower bound because the open bound doesn't
 318                ;; contain the bound, so choose an open lower
 319                ;; bound.
 320                (set-bound res (or (consp x) (consp y)))))
 321            (min-upper-bound (x y)
 322              ;; Same as above, but for the min of upper bounds
 323              ;; Both X and Y are not null. Find the min.
 324              (let ((res (min (type-bound-number x) (type-bound-number y))))
 325                ;; An open upper bound is less than a closed
 326                ;; upper bound because the open bound doesn't
 327                ;; contain the bound, so choose an open lower
 328                ;; bound.
 329                (set-bound res (or (consp x) (consp y))))))
 330     (let* ((x-bound (bound x))
 331            (y-bound (exclude (bound y)))
 332            (new-bound (cond ((not x-bound)
 333                              y-bound)
 334                             ((not y-bound)
 335                              x-bound)
 336                             (greater
 337                              (max-lower-bound x-bound y-bound))
 338                             (t
 339                              (min-upper-bound x-bound y-bound)))))
 340       (if greater
 341           (modified-numeric-type x :low new-bound)
 342           (modified-numeric-type x :high new-bound)))))
 343
 344 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 345 ;;; restrictions from flow analysis IN, set the type for REF
 346 ;;; accordingly.
 347 (defun constrain-ref-type (ref constraints in)
 348   (declare (type ref ref) (type sset constraints in))
 349   (let ((var-cons (copy-sset constraints)))
 350     (sset-intersection var-cons in)
 351     (let ((res (single-value-type (node-derived-type ref)))
 352           (not-res *empty-type*)
 353           (leaf (ref-leaf ref)))
 354       (do-sset-elements (con var-cons)
 355         (let* ((x (constraint-x con))
 356                (y (constraint-y con))
 357                (not-p (constraint-not-p con))
 358                (other (if (eq x leaf) y x))
 359                (kind (constraint-kind con)))
 360           (case kind
 361             (typep
 362              (if not-p
 363                  (setq not-res (type-union not-res other))
 364                  (setq res (type-approx-intersection2 res other))))
 365             (eql
 366              (unless (lvar-p other)
 367                (let ((other-type (leaf-type other)))
 368                  (if not-p
 369                      (when (and (constant-p other)
 370                                 (member-type-p other-type))
 371                        (setq not-res (type-union not-res other-type)))
 372                      (let ((leaf-type (leaf-type leaf)))
 373                        (cond
 374                          ((or (constant-p other)
 375                               (and (leaf-refs other) ; protect from
 376                                         ; deleted vars
 377                                    (csubtypep other-type leaf-type)
 378                                    (not (type= other-type leaf-type))))
 379                           (change-ref-leaf ref other)
 380                           (when (constant-p other) (return)))
 381                          (t
 382                           (setq res (type-approx-intersection2
 383                                      res other-type)))))))))
 384             ((< >)
 385              (cond
 386                ((and (integer-type-p res) (integer-type-p y))
 387                 (let ((greater (eq kind '>)))
 388                   (let ((greater (if not-p (not greater) greater)))
 389                     (setq res
 390                           (constrain-integer-type res y greater not-p)))))
 391                ((and (float-type-p res) (float-type-p y))
 392                 (let ((greater (eq kind '>)))
 393                   (let ((greater (if not-p (not greater) greater)))
 394                     (setq res
 395                           (constrain-float-type res y greater not-p))))))))))
 396       (cond ((and (if-p (node-dest ref))
 397                   (csubtypep (specifier-type 'null) not-res))
 398              (setf (node-derived-type ref) *wild-type*)
 399              (change-ref-leaf ref (find-constant t)))
 400             (t
 401              (derive-node-type ref
 402                                (make-single-value-type
 403                                 (or (type-difference res not-res)
 404                                     res)))
 405              (maybe-terminate-block ref nil)))))
 406
 407   (values))
 408
 409 ;;;; Flow analysis
 410
 411 (defun maybe-add-eql-var-lvar-constraint (ref gen)
 412   (let ((lvar (ref-lvar ref))
 413         (leaf (ref-leaf ref)))
 414     (when (and (lambda-var-p leaf) lvar)
 415       (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
 416                    gen))))
 417
 418 ;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR
 419 ;;; LVAR) ones.
 420 (defun inherit-constraints (var from-var constraints target)
 421   (do-sset-elements (con constraints)
 422     (let ((eq-x (eq from-var (constraint-x con)))
 423           (eq-y (eq from-var (constraint-y con))))
 424       ;; Constant substitution is controversial.
 425       (unless (constant-p (constraint-y con))
 426         (when (or (and eq-x (not (lvar-p (constraint-y con))))
 427                   eq-y)
 428           (sset-adjoin (find-or-create-constraint
 429                         (constraint-kind con)
 430                         (if eq-x var (constraint-x con))
 431                         (if eq-y var (constraint-y con))
 432                         (constraint-not-p con))
 433                        target))))))
 434
 435 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
 436 ;; inherit each other's constraints.
 437 (defun add-eql-var-var-constraint (var1 var2 constraints
 438                                    &optional (target constraints))
 439   (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
 440     (when (sset-adjoin con target)
 441       (do-eql-vars (var2 (var2 constraints))
 442         (inherit-constraints var1 var2 constraints target))
 443       (do-eql-vars (var1 (var1 constraints))
 444         (inherit-constraints var1 var2 constraints target))
 445       t)))
 446
 447 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
 448 ;; LAMBDA-VAR if possible.
 449 (defun maybe-add-eql-var-var-constraint (var lvar constraints
 450                                          &optional (target constraints))
 451   (declare (type lambda-var var) (type lvar lvar))
 452   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
 453     (when lambda-var
 454       (add-eql-var-var-constraint var lambda-var constraints target))))
 455
 456 ;;; Local propagation
 457 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 458 ;;;    constraint.]
 459 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 460 ;;;    a type constraint based on the new value type.
 461 (declaim (ftype (function (cblock sset
 462                            &key (:ref-preprocessor (or null function))
 463                                 (:set-preprocessor (or null function)))
 464                           sset)
 465                 constraint-propagate-in-block))
 466 (defun constraint-propagate-in-block
 467     (block gen &key ref-preprocessor set-preprocessor)
 468
 469   (do-nodes (node lvar block)
 470     (typecase node
 471       (bind
 472        (let ((fun (bind-lambda node)))
 473          (when (eq (functional-kind fun) :let)
 474            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
 475                  for var in (lambda-vars fun)
 476                  and val in (combination-args call)
 477                  when (and val (lambda-var-constraints var))
 478                  do (let* ((type (lvar-type val))
 479                            (con (find-or-create-constraint 'typep var type
 480                                                            nil)))
 481                       (sset-adjoin con gen))
 482                  (maybe-add-eql-var-var-constraint var val gen)))))
 483       (ref
 484        (when (ok-ref-lambda-var node)
 485          (maybe-add-eql-var-lvar-constraint node gen)
 486          (when ref-preprocessor
 487            (funcall ref-preprocessor node gen))))
 488       (cast
 489        (let ((lvar (cast-value node)))
 490          (let ((var (ok-lvar-lambda-var lvar gen)))
 491            (when var
 492              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
 493                (do-eql-vars (var (var gen))
 494                  (let ((con (find-or-create-constraint 'typep var atype nil)))
 495                    (sset-adjoin con gen))))))))
 496       (cset
 497        (binding* ((var (set-var node))
 498                   (nil (lambda-var-p var) :exit-if-null)
 499                   (cons (lambda-var-constraints var) :exit-if-null))
 500          (when set-preprocessor
 501            (funcall set-preprocessor var))
 502          (sset-difference gen cons)
 503          (let* ((type (single-value-type (node-derived-type node)))
 504                 (con (find-or-create-constraint 'typep var type nil)))
 505            (sset-adjoin con gen))
 506          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
 507
 508   gen)
 509
 510 (defun constraint-propagate-if (block gen)
 511   (let ((node (block-last block)))
 512     (when (if-p node)
 513       (let ((use (lvar-uses (if-test node))))
 514         (when (node-p use)
 515           (add-test-constraints use node gen))))))
 516
 517 (defun constrain-node (node cons)
 518   (let* ((var (ref-leaf node))
 519          (con (lambda-var-constraints var)))
 520     (constrain-ref-type node con cons)))
 521
 522 ;;; Starting from IN compute OUT and (consequent/alternative
 523 ;;; constraints if the block ends with and IF). Return the list of
 524 ;;; successors that may need to be recomputed.
 525 (defun find-block-type-constraints (block &key final-pass-p)
 526   (declare (type cblock block))
 527   (let ((gen (constraint-propagate-in-block
 528               block
 529               (if final-pass-p
 530                   (block-in block)
 531                   (copy-sset (block-in block)))
 532               :ref-preprocessor (if final-pass-p #'constrain-node nil))))
 533     (setf (block-gen block) gen)
 534     (multiple-value-bind (consequent-constraints alternative-constraints)
 535         (constraint-propagate-if block gen)
 536       (if consequent-constraints
 537           (let* ((node (block-last block))
 538                  (old-consequent-constraints (if-consequent-constraints node))
 539                  (old-alternative-constraints (if-alternative-constraints node))
 540                  (succ ()))
 541             ;; Add the consequent and alternative constraints to GEN.
 542             (cond ((sset-empty consequent-constraints)
 543                    (setf (if-consequent-constraints node) gen)
 544                    (setf (if-alternative-constraints node) gen))
 545                   (t
 546                    (setf (if-consequent-constraints node) (copy-sset gen))
 547                    (sset-union (if-consequent-constraints node)
 548                                consequent-constraints)
 549                    (setf (if-alternative-constraints node) gen)
 550                    (sset-union (if-alternative-constraints node)
 551                                alternative-constraints)))
 552             ;; Has the consequent been changed?
 553             (unless (and old-consequent-constraints
 554                          (sset= (if-consequent-constraints node)
 555                                 old-consequent-constraints))
 556               (push (if-consequent node) succ))
 557             ;; Has the alternative been changed?
 558             (unless (and old-alternative-constraints
 559                          (sset= (if-alternative-constraints node)
 560                                 old-alternative-constraints))
 561               (push (if-alternative node) succ))
 562             succ)
 563           ;; There is no IF.
 564           (unless (and (block-out block)
 565                        (sset= gen (block-out block)))
 566             (setf (block-out block) gen)
 567             (block-succ block))))))
 568
 569 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 570 ;;; During this pass, we also do local constraint propagation by
 571 ;;; adding in constraints as we see them during the pass through the
 572 ;;; block.
 573 (defun use-result-constraints (block)
 574   (declare (type cblock block))
 575   (constraint-propagate-in-block block (block-in block)
 576                                  :ref-preprocessor #'constrain-node))
 577
 578 ;;; Give an empty constraints set to any var that doesn't have one and
 579 ;;; isn't a set closure var. Since a var that we previously rejected
 580 ;;; looks identical to one that is new, so we optimistically keep
 581 ;;; hoping that vars stop being closed over or lose their sets.
 582 (defun init-var-constraints (component)
 583   (declare (type component component))
 584   (dolist (fun (component-lambdas component))
 585     (flet ((frob (x)
 586              (dolist (var (lambda-vars x))
 587                (unless (lambda-var-constraints var)
 588                  (when (or (null (lambda-var-sets var))
 589                            (not (closure-var-p var)))
 590                    (setf (lambda-var-constraints var) (make-sset)))))))
 591       (frob fun)
 592       (dolist (let (lambda-lets fun))
 593         (frob let)))))
 594
 595 ;;; Return the constraints that flow from PRED to SUCC. This is
 596 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
 597 ;;; added.
 598 (defun block-out-for-successor (pred succ)
 599   (declare (type cblock pred succ))
 600   (let ((last (block-last pred)))
 601     (or (when (if-p last)
 602           (cond ((eq succ (if-consequent last))
 603                  (if-consequent-constraints last))
 604                 ((eq succ (if-alternative last))
 605                  (if-alternative-constraints last))))
 606         (block-out pred))))
 607
 608 (defun compute-block-in (block)
 609   (let ((in nil))
 610     (dolist (pred (block-pred block))
 611       ;; If OUT has not been calculated, assume it to be the universal
 612       ;; set.
 613       (let ((out (block-out-for-successor pred block)))
 614         (when out
 615           (if in
 616               (sset-intersection in out)
 617               (setq in (copy-sset out))))))
 618     (or in (make-sset))))
 619
 620 (defun update-block-in (block)
 621   (let ((in (compute-block-in block)))
 622     (cond ((and (block-in block) (sset= in (block-in block)))
 623            nil)
 624           (t
 625            (setf (block-in block) in)))))
 626
 627 ;;; Return two lists: one of blocks that precede all loops and
 628 ;;; therefore require only one constraint propagation pass and the
 629 ;;; rest. This implementation does not find all such blocks.
 630 ;;;
 631 ;;; A more complete implementation would be:
 632 ;;;
 633 ;;;     (do-blocks (block component)
 634 ;;;       (if (every #'(lambda (pred)
 635 ;;;                      (or (member pred leading-blocks)
 636 ;;;                          (eq pred head)))
 637 ;;;                  (block-pred block))
 638 ;;;           (push block leading-blocks)
 639 ;;;           (push block rest-of-blocks)))
 640 ;;;
 641 ;;; Trailing blocks that succeed all loops could be found and handled
 642 ;;; similarly. In practice though, these more complex solutions are
 643 ;;; slightly worse performancewise.
 644 (defun leading-component-blocks (component)
 645   (declare (type component component))
 646   (flet ((loopy-p (block)
 647            (let ((n (block-number block)))
 648              (dolist (pred (block-pred block))
 649                (unless (< n (block-number pred))
 650                  (return t))))))
 651     (let ((leading-blocks ())
 652           (rest-of-blocks ())
 653           (seen-loop-p ()))
 654       (do-blocks (block component)
 655         (when (and (not seen-loop-p) (loopy-p block))
 656           (setq seen-loop-p t))
 657         (if seen-loop-p
 658             (push block rest-of-blocks)
 659             (push block leading-blocks)))
 660       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
 661
 662 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
 663 ;;; a member already.
 664 (defun nconc-new (obj list)
 665   (do ((x list (cdr x))
 666        (prev nil x))
 667       ((endp x) (if prev
 668                     (progn
 669                       (setf (cdr prev) (list obj))
 670                       list)
 671                     (list obj)))
 672     (when (eql (car x) obj)
 673       (return-from nconc-new list))))
 674
 675 (defun find-and-propagate-constraints (component)
 676   (let ((blocks-to-process ()))
 677     (flet ((enqueue (blocks)
 678              (dolist (block blocks)
 679                (setq blocks-to-process (nconc-new block blocks-to-process)))))
 680       (multiple-value-bind (leading-blocks rest-of-blocks)
 681           (leading-component-blocks component)
 682         ;; Update every block once to account for changes in the
 683         ;; IR1. The constraints of the lead blocks cannot be changed
 684         ;; after the first pass so we might as well use them and skip
 685         ;; USE-RESULT-CONSTRAINTS later.
 686         (dolist (block leading-blocks)
 687           (setf (block-in block) (compute-block-in block))
 688           (find-block-type-constraints block :final-pass-p t))
 689         (setq blocks-to-process (copy-list rest-of-blocks))
 690         ;; The rest of the blocks.
 691         (dolist (block rest-of-blocks)
 692           (aver (eq block (pop blocks-to-process)))
 693           (setf (block-in block) (compute-block-in block))
 694           (enqueue (find-block-type-constraints block)))
 695         ;; Propagate constraints
 696         (loop for block = (pop blocks-to-process)
 697               while block do
 698               (unless (eq block (component-tail component))
 699                 (when (update-block-in block)
 700                   (enqueue (find-block-type-constraints block)))))
 701         rest-of-blocks))))
 702
 703 (defun constraint-propagate (component)
 704   (declare (type component component))
 705   (init-var-constraints component)
 706
 707   (unless (block-out (component-head component))
 708     (setf (block-out (component-head component)) (make-sset)))
 709
 710   (dolist (block (find-and-propagate-constraints component))
 711     (unless (block-delete-p block)
 712       (use-result-constraints block)))
 713
 714   (values))