src/compiler/constraint.lisp

   1 ;;;; This file implements the constraint propagation phase of the
   2 ;;;; compiler, which uses global flow analysis to obtain dynamic type
   3 ;;;; information.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 ;;; TODO:
  15 ;;;
  16 ;;; -- documentation
  17 ;;;
  18 ;;; -- MV-BIND, :ASSIGNMENT
  19
  20 ;;; Problems:
  21 ;;;
  22 ;;; -- Constraint propagation badly interacts with bottom-up type
  23 ;;; inference. Consider
  24 ;;;
  25 ;;; (defun foo (n &aux (i 42))
  26 ;;;   (declare (optimize speed))
  27 ;;;   (declare (fixnum n)
  28 ;;;            #+nil (type (integer 0) i))
  29 ;;;   (tagbody
  30 ;;;      (setq i 0)
  31 ;;;    :loop
  32 ;;;      (when (>= i n) (go :exit))
  33 ;;;      (setq i (1+ i))
  34 ;;;      (go :loop)
  35 ;;;    :exit))
  36 ;;;
  37 ;;; In this case CP cannot even infer that I is of class INTEGER.
  38 ;;;
  39 ;;; -- In the above example if we place the check after SETQ, CP will
  40 ;;; fail to infer (< I FIXNUM): it does not understand that this
  41 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
  42
  43 (in-package "SB!C")
  44
  45 (deftype constraint-y () '(or ctype lvar lambda-var constant))
  46
  47 (defstruct (constraint
  48             (:include sset-element)
  49             (:constructor make-constraint (number kind x y not-p))
  50             (:copier nil))
  51   ;; the kind of constraint we have:
  52   ;;
  53   ;; TYPEP
  54   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
  55   ;;     constrained to be of type Y.
  56   ;;
  57   ;; > or <
  58   ;;     X is a lambda-var and Y is a CTYPE. The relation holds
  59   ;;     between X and some object of type Y.
  60   ;;
  61   ;; EQL
  62   ;;     X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
  63   ;;     The relation is asserted to hold.
  64   (kind nil :type (member typep < > eql))
  65   ;; The operands to the relation.
  66   (x nil :type lambda-var)
  67   (y nil :type constraint-y)
  68   ;; If true, negates the sense of the constraint, so the relation
  69   ;; does *not* hold.
  70   (not-p nil :type boolean))
  71
  72 (defvar *constraint-number*)
  73 (declaim (type (integer 0) *constraint-number*))
  74
  75 (defun find-constraint (kind x y not-p)
  76   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
  77   (etypecase y
  78     (ctype
  79      (do-sset-elements (con (lambda-var-constraints x) nil)
  80        (when (and (eq (constraint-kind con) kind)
  81                   (eq (constraint-not-p con) not-p)
  82                   (type= (constraint-y con) y))
  83          (return con))))
  84     ((or lvar constant)
  85      (do-sset-elements (con (lambda-var-constraints x) nil)
  86        (when (and (eq (constraint-kind con) kind)
  87                   (eq (constraint-not-p con) not-p)
  88                   (eq (constraint-y con) y))
  89          (return con))))
  90     (lambda-var
  91      (do-sset-elements (con (lambda-var-constraints x) nil)
  92        (when (and (eq (constraint-kind con) kind)
  93                   (eq (constraint-not-p con) not-p)
  94                   (let ((cx (constraint-x con)))
  95                     (eq (if (eq cx x)
  96                             (constraint-y con)
  97                             cx)
  98                         y)))
  99          (return con))))))
 100
 101 ;;; Return a constraint for the specified arguments. We only create a
 102 ;;; new constraint if there isn't already an equivalent old one,
 103 ;;; guaranteeing that all equivalent constraints are EQ. This
 104 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
 105 (defun find-or-create-constraint (kind x y not-p)
 106   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
 107   (or (find-constraint kind x y not-p)
 108       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
 109         (sset-adjoin new (lambda-var-constraints x))
 110         (when (lambda-var-p y)
 111           (sset-adjoin new (lambda-var-constraints y)))
 112         new)))
 113
 114 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
 115 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
 116 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
 117 (defun ok-ref-lambda-var (ref)
 118   (declare (type ref ref))
 119   (let ((leaf (ref-leaf ref)))
 120     (when (and (lambda-var-p leaf)
 121                (lambda-var-constraints leaf))
 122       leaf)))
 123
 124 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
 125 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
 126 (defun ok-lvar-lambda-var (lvar constraints)
 127   (declare (type lvar lvar))
 128   (let ((use (lvar-uses lvar)))
 129     (cond ((ref-p use)
 130            (let ((lambda-var (ok-ref-lambda-var use)))
 131              (when lambda-var
 132                (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
 133                  (when (and constraint (sset-member constraint constraints))
 134                    lambda-var)))))
 135           ((cast-p use)
 136            (ok-lvar-lambda-var (cast-value use) constraints)))))
 137
 138 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
 139   (once-only ((var var))
 140     `(let ((,symbol ,var))
 141        (flet ((body-fun ()
 142                 ,@body))
 143          (body-fun)
 144          (do-sset-elements (con ,constraints ,result)
 145            (let ((other (and (eq (constraint-kind con) 'eql)
 146                              (eq (constraint-not-p con) nil)
 147                              (cond ((eq ,var (constraint-x con))
 148                                     (constraint-y con))
 149                                    ((eq ,var (constraint-y con))
 150                                     (constraint-x con))
 151                                    (t
 152                                     nil)))))
 153              (when other
 154                (setq ,symbol other)
 155                (when (lambda-var-p ,symbol)
 156                  (body-fun)))))))))
 157
 158 ;;;; Searching constraints
 159
 160 ;;; Add the indicated test constraint to BLOCK. We don't add the
 161 ;;; constraint if the block has multiple predecessors, since it only
 162 ;;; holds on this particular path.
 163 (defun add-test-constraint (fun x y not-p constraints target)
 164   (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
 165          (add-eql-var-var-constraint x y constraints target))
 166         (t
 167          (do-eql-vars (x (x constraints))
 168            (let ((con (find-or-create-constraint fun x y not-p)))
 169              (sset-adjoin con target)))))
 170   (values))
 171
 172 ;;; Add complementary constraints to the consequent and alternative
 173 ;;; blocks of IF. We do nothing if X is NIL.
 174 (defun add-complement-constraints (fun x y not-p constraints
 175                                    consequent-constraints
 176                                    alternative-constraints)
 177   (when x
 178     (add-test-constraint fun x y not-p constraints
 179                          consequent-constraints)
 180     (add-test-constraint fun x y (not not-p) constraints
 181                          alternative-constraints))
 182   (values))
 183
 184 ;;; Add test constraints to the consequent and alternative blocks of
 185 ;;; the test represented by USE.
 186 (defun add-test-constraints (use if constraints)
 187   (declare (type node use) (type cif if))
 188   ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
 189   ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
 190   ;; can't guarantee that the optimization will be done, so we still
 191   ;; need to avoid barfing on this case.
 192   (unless (eq (if-consequent if) (if-alternative if))
 193     (let ((consequent-constraints (make-sset))
 194           (alternative-constraints (make-sset)))
 195       (macrolet ((add (fun x y not-p)
 196                    `(add-complement-constraints ,fun ,x ,y ,not-p
 197                      constraints
 198                      consequent-constraints
 199                      alternative-constraints)))
 200         (typecase use
 201           (ref
 202            (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
 203                 (specifier-type 'null) t))
 204           (combination
 205            (unless (eq (combination-kind use)
 206                        :error)
 207              (let ((name (lvar-fun-name
 208                           (basic-combination-fun use)))
 209                    (args (basic-combination-args use)))
 210                (case name
 211                  ((%typep %instance-typep)
 212                   (let ((type (second args)))
 213                     (when (constant-lvar-p type)
 214                       (let ((val (lvar-value type)))
 215                         (add 'typep
 216                              (ok-lvar-lambda-var (first args) constraints)
 217                              (if (ctype-p val)
 218                                  val
 219                                  (specifier-type val))
 220                              nil)))))
 221                  ((eq eql)
 222                   (let* ((arg1 (first args))
 223                          (var1 (ok-lvar-lambda-var arg1 constraints))
 224                          (arg2 (second args))
 225                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 226                     ;; The code below assumes that the constant is the
 227                     ;; second argument in case of variable to constant
 228                     ;; comparision which is sometimes true (see source
 229                     ;; transformations for EQ, EQL and CHAR=). Fixing
 230                     ;; that would result in more constant substitutions
 231                     ;; which is not a universally good thing, thus the
 232                     ;; unnatural asymmetry of the tests.
 233                     (cond ((not var1)
 234                            (when var2
 235                              (add-test-constraint 'typep var2 (lvar-type arg1)
 236                                                   nil constraints
 237                                                   consequent-constraints)))
 238                           (var2
 239                            (add 'eql var1 var2 nil))
 240                           ((constant-lvar-p arg2)
 241                            (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
 242                                 nil))
 243                           (t
 244                            (add-test-constraint 'typep var1 (lvar-type arg2)
 245                                                 nil constraints
 246                                                 consequent-constraints)))))
 247                  ((< >)
 248                   (let* ((arg1 (first args))
 249                          (var1 (ok-lvar-lambda-var arg1 constraints))
 250                          (arg2 (second args))
 251                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 252                     (when var1
 253                       (add name var1 (lvar-type arg2) nil))
 254                     (when var2
 255                       (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
 256                  (t
 257                   (let ((ptype (gethash name *backend-predicate-types*)))
 258                     (when ptype
 259                       (add 'typep (ok-lvar-lambda-var (first args) constraints)
 260                            ptype nil))))))))))
 261       (values consequent-constraints alternative-constraints))))
 262
 263 ;;;; Applying constraints
 264
 265 ;;; Return true if X is an integer NUMERIC-TYPE.
 266 (defun integer-type-p (x)
 267   (declare (type ctype x))
 268   (and (numeric-type-p x)
 269        (eq (numeric-type-class x) 'integer)
 270        (eq (numeric-type-complexp x) :real)))
 271
 272 ;;; Given that an inequality holds on values of type X and Y, return a
 273 ;;; new type for X. If GREATER is true, then X was greater than Y,
 274 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
 275 ;;; inclusive, i.e. >=.
 276 ;;;
 277 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
 278 ;;; bound into X and return that result. If not OR-EQUAL, we can go
 279 ;;; one greater (less) than Y's bound.
 280 (defun constrain-integer-type (x y greater or-equal)
 281   (declare (type numeric-type x y))
 282   (flet ((exclude (x)
 283            (cond ((not x) nil)
 284                  (or-equal x)
 285                  (greater (1+ x))
 286                  (t (1- x))))
 287          (bound (x)
 288            (if greater (numeric-type-low x) (numeric-type-high x))))
 289     (let* ((x-bound (bound x))
 290            (y-bound (exclude (bound y)))
 291            (new-bound (cond ((not x-bound) y-bound)
 292                             ((not y-bound) x-bound)
 293                             (greater (max x-bound y-bound))
 294                             (t (min x-bound y-bound)))))
 295       (if greater
 296           (modified-numeric-type x :low new-bound)
 297           (modified-numeric-type x :high new-bound)))))
 298
 299 ;;; Return true if X is a float NUMERIC-TYPE.
 300 (defun float-type-p (x)
 301   (declare (type ctype x))
 302   (and (numeric-type-p x)
 303        (eq (numeric-type-class x) 'float)
 304        (eq (numeric-type-complexp x) :real)))
 305
 306 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 307 (defun constrain-float-type (x y greater or-equal)
 308   (declare (type numeric-type x y))
 309   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
 310
 311   (aver (eql (numeric-type-class x) 'float))
 312   (aver (eql (numeric-type-class y) 'float))
 313   #+sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 314   x
 315   #-sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 316   (labels ((exclude (x)
 317              (cond ((not x) nil)
 318                    (or-equal x)
 319                    (t
 320                     (if (consp x)
 321                         x
 322                         (list x)))))
 323            (bound (x)
 324              (if greater (numeric-type-low x) (numeric-type-high x)))
 325            (tighter-p (x ref)
 326              (cond ((null x) nil)
 327                    ((null ref) t)
 328                    ((and or-equal
 329                          (= (type-bound-number x) (type-bound-number ref)))
 330                     ;; X is tighter if REF is not an open bound and X is
 331                     (and (not (consp ref)) (consp x)))
 332                    (greater
 333                     (< (type-bound-number ref) (type-bound-number x)))
 334                    (t
 335                     (> (type-bound-number ref) (type-bound-number x))))))
 336     (let* ((x-bound (bound x))
 337            (y-bound (exclude (bound y)))
 338            (new-bound (cond ((not x-bound)
 339                              y-bound)
 340                             ((not y-bound)
 341                              x-bound)
 342                             ((tighter-p y-bound x-bound)
 343                              y-bound)
 344                             (t
 345                              x-bound))))
 346       (if greater
 347           (modified-numeric-type x :low new-bound)
 348           (modified-numeric-type x :high new-bound)))))
 349
 350 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 351 ;;; restrictions from flow analysis IN, set the type for REF
 352 ;;; accordingly.
 353 (defun constrain-ref-type (ref constraints in)
 354   (declare (type ref ref) (type sset constraints in))
 355   ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
 356   ;; cons up endless union types when propagating large number of EQL
 357   ;; constraints -- eg. from large CASE forms -- instead we just
 358   ;; directly accumulate one XSET, and a set of fp zeroes, which we at
 359   ;; the end turn into a MEMBER-TYPE.
 360   ;;
 361   ;; Since massive symbol cases are an especially atrocious pattern
 362   ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
 363   ;; a more useful type, don't propagate their negation except for NIL
 364   ;; unless SPEED > COMPILATION-SPEED.
 365   (let ((res (single-value-type (node-derived-type ref)))
 366         (constrain-symbols (policy ref (> speed compilation-speed)))
 367         (not-set (alloc-xset))
 368         (not-fpz nil)
 369         (not-res *empty-type*)
 370         (leaf (ref-leaf ref)))
 371     (flet ((note-not (x)
 372              (if (fp-zero-p x)
 373                  (push x not-fpz)
 374                  (when (or constrain-symbols (null x) (not (symbolp x)))
 375                    (add-to-xset x not-set)))))
 376       (do-sset-elements (con constraints)
 377         (when (sset-member con in)
 378           (let* ((x (constraint-x con))
 379                  (y (constraint-y con))
 380                  (not-p (constraint-not-p con))
 381                  (other (if (eq x leaf) y x))
 382                  (kind (constraint-kind con)))
 383             (case kind
 384               (typep
 385                (if not-p
 386                    (if (member-type-p other)
 387                        (mapc-member-type-members #'note-not other)
 388                        (setq not-res (type-union not-res other)))
 389                    (setq res (type-approx-intersection2 res other))))
 390               (eql
 391                (unless (lvar-p other)
 392                  (let ((other-type (leaf-type other)))
 393                    (if not-p
 394                        (when (and (constant-p other)
 395                                   (member-type-p other-type))
 396                          (note-not (constant-value other)))
 397                        (let ((leaf-type (leaf-type leaf)))
 398                          (cond
 399                            ((or (constant-p other)
 400                                 (and (leaf-refs other) ; protect from
 401                                         ; deleted vars
 402                                      (csubtypep other-type leaf-type)
 403                                      (not (type= other-type leaf-type))))
 404                             (change-ref-leaf ref other)
 405                             (when (constant-p other) (return)))
 406                            (t
 407                             (setq res (type-approx-intersection2
 408                                        res other-type)))))))))
 409               ((< >)
 410                (cond
 411                  ((and (integer-type-p res) (integer-type-p y))
 412                   (let ((greater (eq kind '>)))
 413                     (let ((greater (if not-p (not greater) greater)))
 414                       (setq res
 415                             (constrain-integer-type res y greater not-p)))))
 416                  ((and (float-type-p res) (float-type-p y))
 417                   (let ((greater (eq kind '>)))
 418                     (let ((greater (if not-p (not greater) greater)))
 419                       (setq res
 420                             (constrain-float-type res y greater not-p))))))))))))
 421     (cond ((and (if-p (node-dest ref))
 422                 (or (xset-member-p nil not-set)
 423                     (csubtypep (specifier-type 'null) not-res)))
 424            (setf (node-derived-type ref) *wild-type*)
 425            (change-ref-leaf ref (find-constant t)))
 426           (t
 427            (setf not-res
 428                  (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
 429            (derive-node-type ref
 430                              (make-single-value-type
 431                               (or (type-difference res not-res)
 432                                   res)))
 433            (maybe-terminate-block ref nil))))
 434   (values))
 435
 436 ;;;; Flow analysis
 437
 438 (defun maybe-add-eql-var-lvar-constraint (ref gen)
 439   (let ((lvar (ref-lvar ref))
 440         (leaf (ref-leaf ref)))
 441     (when (and (lambda-var-p leaf) lvar)
 442       (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
 443                    gen))))
 444
 445 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
 446 ;;; LVAR) ones - to all of the variables in the VARS list.
 447 (defun inherit-constraints (vars from-var constraints target)
 448   (do-sset-elements (con constraints)
 449     ;; Constant substitution is controversial.
 450     (unless (constant-p (constraint-y con))
 451       (dolist (var vars)
 452         (let ((eq-x (eq from-var (constraint-x con)))
 453               (eq-y (eq from-var (constraint-y con))))
 454           (when (or (and eq-x (not (lvar-p (constraint-y con))))
 455                     eq-y)
 456             (sset-adjoin (find-or-create-constraint
 457                           (constraint-kind con)
 458                           (if eq-x var (constraint-x con))
 459                           (if eq-y var (constraint-y con))
 460                           (constraint-not-p con))
 461                          target)))))))
 462
 463 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
 464 ;; inherit each other's constraints.
 465 (defun add-eql-var-var-constraint (var1 var2 constraints
 466                                    &optional (target constraints))
 467   (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
 468     (when (sset-adjoin con target)
 469       (collect ((eql1) (eql2))
 470         (do-eql-vars (var1 (var1 constraints))
 471           (eql1 var1))
 472         (do-eql-vars (var2 (var2 constraints))
 473           (eql2 var2))
 474         (inherit-constraints (eql1) var2 constraints target)
 475         (inherit-constraints (eql2) var1 constraints target))
 476       t)))
 477
 478 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
 479 ;; LAMBDA-VAR if possible.
 480 (defun maybe-add-eql-var-var-constraint (var lvar constraints
 481                                          &optional (target constraints))
 482   (declare (type lambda-var var) (type lvar lvar))
 483   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
 484     (when lambda-var
 485       (add-eql-var-var-constraint var lambda-var constraints target))))
 486
 487 ;;; Local propagation
 488 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 489 ;;;    constraint.]
 490 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 491 ;;;    a type constraint based on the new value type.
 492 (declaim (ftype (function (cblock sset
 493                            &key (:ref-preprocessor (or null function))
 494                                 (:set-preprocessor (or null function)))
 495                           sset)
 496                 constraint-propagate-in-block))
 497 (defun constraint-propagate-in-block (block gen &key
 498                                             ref-preprocessor set-preprocessor)
 499   (do-nodes (node lvar block)
 500     (typecase node
 501       (bind
 502        (let ((fun (bind-lambda node)))
 503          (when (eq (functional-kind fun) :let)
 504            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
 505                  for var in (lambda-vars fun)
 506                  and val in (combination-args call)
 507                  when (and val (lambda-var-constraints var))
 508                  do (let* ((type (lvar-type val))
 509                            (con (find-or-create-constraint 'typep var type
 510                                                            nil)))
 511                       (sset-adjoin con gen))
 512                  (maybe-add-eql-var-var-constraint var val gen)))))
 513       (ref
 514        (when (ok-ref-lambda-var node)
 515          (maybe-add-eql-var-lvar-constraint node gen)
 516          (when ref-preprocessor
 517            (funcall ref-preprocessor node gen))))
 518       (cast
 519        (let ((lvar (cast-value node)))
 520          (let ((var (ok-lvar-lambda-var lvar gen)))
 521            (when var
 522              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
 523                (do-eql-vars (var (var gen))
 524                  (let ((con (find-or-create-constraint 'typep var atype nil)))
 525                    (sset-adjoin con gen))))))))
 526       (cset
 527        (binding* ((var (set-var node))
 528                   (nil (lambda-var-p var) :exit-if-null)
 529                   (cons (lambda-var-constraints var) :exit-if-null))
 530          (when set-preprocessor
 531            (funcall set-preprocessor var))
 532          (sset-difference gen cons)
 533          (let* ((type (single-value-type (node-derived-type node)))
 534                 (con (find-or-create-constraint 'typep var type nil)))
 535            (sset-adjoin con gen))
 536          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
 537   gen)
 538
 539 (defun constraint-propagate-if (block gen)
 540   (let ((node (block-last block)))
 541     (when (if-p node)
 542       (let ((use (lvar-uses (if-test node))))
 543         (when (node-p use)
 544           (add-test-constraints use node gen))))))
 545
 546 (defun constrain-node (node cons)
 547   (let* ((var (ref-leaf node))
 548          (con (lambda-var-constraints var)))
 549     (constrain-ref-type node con cons)))
 550
 551 ;;; Starting from IN compute OUT and (consequent/alternative
 552 ;;; constraints if the block ends with and IF). Return the list of
 553 ;;; successors that may need to be recomputed.
 554 (defun find-block-type-constraints (block &key final-pass-p)
 555   (declare (type cblock block))
 556   (let ((gen (constraint-propagate-in-block
 557               block
 558               (if final-pass-p
 559                   (block-in block)
 560                   (copy-sset (block-in block)))
 561               :ref-preprocessor (if final-pass-p #'constrain-node nil))))
 562     (setf (block-gen block) gen)
 563     (multiple-value-bind (consequent-constraints alternative-constraints)
 564         (constraint-propagate-if block gen)
 565       (if consequent-constraints
 566           (let* ((node (block-last block))
 567                  (old-consequent-constraints (if-consequent-constraints node))
 568                  (old-alternative-constraints (if-alternative-constraints node))
 569                  (succ ()))
 570             ;; Add the consequent and alternative constraints to GEN.
 571             (cond ((sset-empty consequent-constraints)
 572                    (setf (if-consequent-constraints node) gen)
 573                    (setf (if-alternative-constraints node) gen))
 574                   (t
 575                    (setf (if-consequent-constraints node) (copy-sset gen))
 576                    (sset-union (if-consequent-constraints node)
 577                                consequent-constraints)
 578                    (setf (if-alternative-constraints node) gen)
 579                    (sset-union (if-alternative-constraints node)
 580                                alternative-constraints)))
 581             ;; Has the consequent been changed?
 582             (unless (and old-consequent-constraints
 583                          (sset= (if-consequent-constraints node)
 584                                 old-consequent-constraints))
 585               (push (if-consequent node) succ))
 586             ;; Has the alternative been changed?
 587             (unless (and old-alternative-constraints
 588                          (sset= (if-alternative-constraints node)
 589                                 old-alternative-constraints))
 590               (push (if-alternative node) succ))
 591             succ)
 592           ;; There is no IF.
 593           (unless (and (block-out block)
 594                        (sset= gen (block-out block)))
 595             (setf (block-out block) gen)
 596             (block-succ block))))))
 597
 598 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 599 ;;; During this pass, we also do local constraint propagation by
 600 ;;; adding in constraints as we see them during the pass through the
 601 ;;; block.
 602 (defun use-result-constraints (block)
 603   (declare (type cblock block))
 604   (constraint-propagate-in-block block (block-in block)
 605                                  :ref-preprocessor #'constrain-node))
 606
 607 ;;; Give an empty constraints set to any var that doesn't have one and
 608 ;;; isn't a set closure var. Since a var that we previously rejected
 609 ;;; looks identical to one that is new, so we optimistically keep
 610 ;;; hoping that vars stop being closed over or lose their sets.
 611 (defun init-var-constraints (component)
 612   (declare (type component component))
 613   (dolist (fun (component-lambdas component))
 614     (flet ((frob (x)
 615              (dolist (var (lambda-vars x))
 616                (unless (lambda-var-constraints var)
 617                  (when (or (null (lambda-var-sets var))
 618                            (not (closure-var-p var)))
 619                    (setf (lambda-var-constraints var) (make-sset)))))))
 620       (frob fun)
 621       (dolist (let (lambda-lets fun))
 622         (frob let)))))
 623
 624 ;;; Return the constraints that flow from PRED to SUCC. This is
 625 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
 626 ;;; added.
 627 (defun block-out-for-successor (pred succ)
 628   (declare (type cblock pred succ))
 629   (let ((last (block-last pred)))
 630     (or (when (if-p last)
 631           (cond ((eq succ (if-consequent last))
 632                  (if-consequent-constraints last))
 633                 ((eq succ (if-alternative last))
 634                  (if-alternative-constraints last))))
 635         (block-out pred))))
 636
 637 (defun compute-block-in (block)
 638   (let ((in nil))
 639     (dolist (pred (block-pred block))
 640       ;; If OUT has not been calculated, assume it to be the universal
 641       ;; set.
 642       (let ((out (block-out-for-successor pred block)))
 643         (when out
 644           (if in
 645               (sset-intersection in out)
 646               (setq in (copy-sset out))))))
 647     (or in (make-sset))))
 648
 649 (defun update-block-in (block)
 650   (let ((in (compute-block-in block)))
 651     (cond ((and (block-in block) (sset= in (block-in block)))
 652            nil)
 653           (t
 654            (setf (block-in block) in)))))
 655
 656 ;;; Return two lists: one of blocks that precede all loops and
 657 ;;; therefore require only one constraint propagation pass and the
 658 ;;; rest. This implementation does not find all such blocks.
 659 ;;;
 660 ;;; A more complete implementation would be:
 661 ;;;
 662 ;;;     (do-blocks (block component)
 663 ;;;       (if (every #'(lambda (pred)
 664 ;;;                      (or (member pred leading-blocks)
 665 ;;;                          (eq pred head)))
 666 ;;;                  (block-pred block))
 667 ;;;           (push block leading-blocks)
 668 ;;;           (push block rest-of-blocks)))
 669 ;;;
 670 ;;; Trailing blocks that succeed all loops could be found and handled
 671 ;;; similarly. In practice though, these more complex solutions are
 672 ;;; slightly worse performancewise.
 673 (defun leading-component-blocks (component)
 674   (declare (type component component))
 675   (flet ((loopy-p (block)
 676            (let ((n (block-number block)))
 677              (dolist (pred (block-pred block))
 678                (unless (< n (block-number pred))
 679                  (return t))))))
 680     (let ((leading-blocks ())
 681           (rest-of-blocks ())
 682           (seen-loop-p ()))
 683       (do-blocks (block component)
 684         (when (and (not seen-loop-p) (loopy-p block))
 685           (setq seen-loop-p t))
 686         (if seen-loop-p
 687             (push block rest-of-blocks)
 688             (push block leading-blocks)))
 689       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
 690
 691 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
 692 ;;; a member already.
 693 (defun nconc-new (obj list)
 694   (do ((x list (cdr x))
 695        (prev nil x))
 696       ((endp x) (if prev
 697                     (progn
 698                       (setf (cdr prev) (list obj))
 699                       list)
 700                     (list obj)))
 701     (when (eql (car x) obj)
 702       (return-from nconc-new list))))
 703
 704 (defun find-and-propagate-constraints (component)
 705   (let ((blocks-to-process ()))
 706     (flet ((enqueue (blocks)
 707              (dolist (block blocks)
 708                (setq blocks-to-process (nconc-new block blocks-to-process)))))
 709       (multiple-value-bind (leading-blocks rest-of-blocks)
 710           (leading-component-blocks component)
 711         ;; Update every block once to account for changes in the
 712         ;; IR1. The constraints of the lead blocks cannot be changed
 713         ;; after the first pass so we might as well use them and skip
 714         ;; USE-RESULT-CONSTRAINTS later.
 715         (dolist (block leading-blocks)
 716           (setf (block-in block) (compute-block-in block))
 717           (find-block-type-constraints block :final-pass-p t))
 718         (setq blocks-to-process (copy-list rest-of-blocks))
 719         ;; The rest of the blocks.
 720         (dolist (block rest-of-blocks)
 721           (aver (eq block (pop blocks-to-process)))
 722           (setf (block-in block) (compute-block-in block))
 723           (enqueue (find-block-type-constraints block)))
 724         ;; Propagate constraints
 725         (loop for block = (pop blocks-to-process)
 726               while block do
 727               (unless (eq block (component-tail component))
 728                 (when (update-block-in block)
 729                   (enqueue (find-block-type-constraints block)))))
 730         rest-of-blocks))))
 731
 732 (defun constraint-propagate (component)
 733   (declare (type component component))
 734   (init-var-constraints component)
 735
 736   (unless (block-out (component-head component))
 737     (setf (block-out (component-head component)) (make-sset)))
 738
 739   (dolist (block (find-and-propagate-constraints component))
 740     (unless (block-delete-p block)
 741       (use-result-constraints block)))
 742
 743   (values))