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