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 ;;; *CONSTRAINT-UNIVERSE* gets bound in IR1-PHASES to a fresh,
  52 ;;; zero-length, non-zero-total-size vector-with-fill-pointer.
  53 (declaim (type (and vector (not simple-vector)) *constraint-universe*))
  54 (defvar *constraint-universe*)
  55
  56 (deftype constraint-y () '(or ctype lvar lambda-var constant))
  57
  58 (defstruct (constraint
  59             (:include sset-element)
  60             (:constructor make-constraint (number kind x y not-p))
  61             (:copier nil))
  62   ;; the kind of constraint we have:
  63   ;;
  64   ;; TYPEP
  65   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
  66   ;;     constrained to be of type Y.
  67   ;;
  68   ;; > or <
  69   ;;     X is a lambda-var and Y is a CTYPE. The relation holds
  70   ;;     between X and some object of type Y.
  71   ;;
  72   ;; EQL
  73   ;;     X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
  74   ;;     The relation is asserted to hold.
  75   (kind nil :type (member typep < > eql))
  76   ;; The operands to the relation.
  77   (x nil :type lambda-var)
  78   (y nil :type constraint-y)
  79   ;; If true, negates the sense of the constraint, so the relation
  80   ;; does *not* hold.
  81   (not-p nil :type boolean))
  82 \f
  83 ;;; Historically, CMUCL and SBCL have used a sparse set implementation
  84 ;;; for which most operations are O(n) (see sset.lisp), but at the
  85 ;;; cost of at least a full word of pointer for each constraint set
  86 ;;; element.  Using bit-vectors instead of pointer structures saves a
  87 ;;; lot of space and thus GC time (particularly on 64-bit machines),
  88 ;;; and saves time on copy, union, intersection, and difference
  89 ;;; operations; but makes iteration slower.  Circa September 2008,
  90 ;;; switching to bit-vectors gave a modest (5-10%) improvement in real
  91 ;;; compile time for most Lisp systems, and as much as 20-30% for some
  92 ;;; particularly CP-dependent systems.
  93
  94 ;;; It's bad to leave commented code in files, but if some clever
  95 ;;; person comes along and makes SSETs better than bit-vectors as sets
  96 ;;; for constraint propagation, or if bit-vectors on some XC host
  97 ;;; really lose compared to SSETs, here's the conset API as a wrapper
  98 ;;; around SSETs:
  99 #+nil
 100 (progn
 101   (deftype conset () 'sset)
 102   (declaim (ftype (sfunction (conset) boolean) conset-empty))
 103   (declaim (ftype (sfunction (conset) conset) copy-conset))
 104   (declaim (ftype (sfunction (constraint conset) boolean) conset-member))
 105   (declaim (ftype (sfunction (constraint conset) boolean) conset-adjoin))
 106   (declaim (ftype (sfunction (conset conset) boolean) conset=))
 107   (declaim (ftype (sfunction (conset conset) (values)) conset-union))
 108   (declaim (ftype (sfunction (conset conset) (values)) conset-intersection))
 109   (declaim (ftype (sfunction (conset conset) (values)) conset-difference))
 110   (defun make-conset () (make-sset))
 111   (defmacro do-conset-elements ((constraint conset &optional result) &body body)
 112     `(do-sset-elements (,constraint ,conset ,result) ,@body))
 113   (defmacro do-conset-intersection
 114       ((constraint conset1 conset2 &optional result) &body body)
 115     `(do-conset-elements (,constraint ,conset1 ,result)
 116        (when (conset-member ,constraint ,conset2)
 117          ,@body)))
 118   (defun conset-empty (conset) (sset-empty conset))
 119   (defun copy-conset (conset) (copy-sset conset))
 120   (defun conset-member (constraint conset) (sset-member constraint conset))
 121   (defun conset-adjoin (constraint conset) (sset-adjoin constraint conset))
 122   (defun conset= (conset1 conset2) (sset= conset1 conset2))
 123   ;; Note: CP doesn't ever care whether union, intersection, and
 124   ;; difference change the first set.  (This is an important degree of
 125   ;; freedom, since some ways of implementing sets lose a great deal
 126   ;; when these operations are required to track changes.)
 127   (defun conset-union (conset1 conset2)
 128     (sset-union conset1 conset2) (values))
 129   (defun conset-intersection (conset1 conset2)
 130     (sset-intersection conset1 conset2) (values))
 131   (defun conset-difference (conset1 conset2)
 132     (sset-difference conset1 conset2) (values)))
 133
 134 (locally
 135     ;; This is performance critical for the compiler, and benefits
 136     ;; from the following declarations.  Probably you'll want to
 137     ;; disable these declarations when debugging consets.
 138     (declare #-sb-xc-host (optimize (speed 3) (safety 0) (space 0)))
 139   (declaim (inline %constraint-number))
 140   (defun %constraint-number (constraint)
 141     (sset-element-number constraint))
 142   (defstruct (conset
 143               (:constructor make-conset ())
 144               (:copier %copy-conset))
 145     (vector (make-array
 146              ;; FIXME: make POWER-OF-TWO-CEILING available earlier?
 147              (ash 1 (integer-length (1- (length *constraint-universe*))))
 148              :element-type 'bit :initial-element 0)
 149             :type simple-bit-vector)
 150     ;; Bit-vectors win over lightweight hashes for copy, union,
 151     ;; intersection, difference, but lose for iteration if you iterate
 152     ;; over the whole vector.  Tracking extrema helps a bit.
 153     (min 0 :type fixnum)
 154     (max 0 :type fixnum))
 155
 156   (defun conset-empty (conset)
 157     (or (= (conset-min conset) (conset-max conset))
 158         ;; TODO: I bet FIND on bit-vectors can be optimized, if it
 159         ;; isn't.
 160         (not (find 1 (conset-vector conset)
 161                    :start (conset-min conset)
 162                    ;; By inspection, supplying :END here breaks the
 163                    ;; build with a "full call to
 164                    ;; DATA-VECTOR-REF-WITH-OFFSET" in the
 165                    ;; cross-compiler.  If that should change, add
 166                    ;; :end (conset-max conset)
 167                    ))))
 168
 169   (defun copy-conset (conset)
 170     (let ((ret (%copy-conset conset)))
 171       (setf (conset-vector ret) (copy-seq (conset-vector conset)))
 172       ret))
 173
 174   (defun %conset-grow (conset new-size)
 175     (declare (type index new-size))
 176     (setf (conset-vector conset)
 177           (replace (the simple-bit-vector
 178                      (make-array
 179                       (ash 1 (integer-length (1- new-size)))
 180                       :element-type 'bit
 181                       :initial-element 0))
 182                    (the simple-bit-vector
 183                      (conset-vector conset)))))
 184
 185   (declaim (inline conset-grow))
 186   (defun conset-grow (conset new-size)
 187     (declare (type index new-size))
 188     (when (< (length (conset-vector conset)) new-size)
 189       (%conset-grow conset new-size))
 190     (values))
 191
 192   (defun conset-member (constraint conset)
 193     (let ((number (%constraint-number constraint))
 194           (vector (conset-vector conset)))
 195       (when (< number (length vector))
 196         (plusp (sbit vector number)))))
 197
 198   (defun conset-adjoin (constraint conset)
 199     (let ((number (%constraint-number constraint)))
 200       (conset-grow conset (1+ number))
 201       (setf (sbit (conset-vector conset) number) 1)
 202       (setf (conset-min conset) (min number (conset-min conset)))
 203       (when (>= number (conset-max conset))
 204         (setf (conset-max conset) (1+ number))))
 205     conset)
 206
 207   (defun conset= (conset1 conset2)
 208     (let* ((vector1 (conset-vector conset1))
 209            (vector2 (conset-vector conset2))
 210            (length1 (length vector1))
 211            (length2 (length vector2)))
 212       (if (= length1 length2)
 213           ;; When the lengths are the same, we can rely on EQUAL being
 214           ;; nicely optimized on bit-vectors.
 215           (equal vector1 vector2)
 216           (multiple-value-bind (shorter longer)
 217               (if (< length1 length2)
 218                   (values vector1 vector2)
 219                   (values vector2 vector1))
 220             ;; FIXME: make MISMATCH fast on bit-vectors.
 221             (dotimes (index (length shorter))
 222               (when (/= (sbit vector1 index) (sbit vector2 index))
 223                 (return-from conset= nil)))
 224             (if (find 1 longer :start (length shorter))
 225                 nil
 226                 t)))))
 227
 228   (macrolet
 229       ((defconsetop (name bit-op)
 230            `(defun ,name (conset-1 conset-2)
 231               (declare (optimize (speed 3) (safety 0)))
 232               (let* ((size-1 (length (conset-vector conset-1)))
 233                      (size-2 (length (conset-vector conset-2)))
 234                      (new-size (max size-1 size-2)))
 235                 (conset-grow conset-1 new-size)
 236                 (conset-grow conset-2 new-size))
 237               (let ((vector1 (conset-vector conset-1))
 238                     (vector2 (conset-vector conset-2)))
 239                 (declare (simple-bit-vector vector1 vector2))
 240                 (setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
 241                 ;; Update the extrema.
 242                 ,(ecase name
 243                    ((conset-union)
 244                     `(setf (conset-min conset-1)
 245                            (min (conset-min conset-1)
 246                                 (conset-min conset-2))
 247                            (conset-max conset-1)
 248                            (max (conset-max conset-1)
 249                                 (conset-max conset-2))))
 250                    ((conset-intersection)
 251                     `(let ((start (max (conset-min conset-1)
 252                                        (conset-min conset-2)))
 253                            (end (min (conset-max conset-1)
 254                                      (conset-max conset-2))))
 255                        (setf (conset-min conset-1)
 256                              (if (> start end)
 257                                  0
 258                                  (or (position 1 (conset-vector conset-1)
 259                                                :start start :end end)
 260                                      0))
 261                              (conset-max conset-1)
 262                              (if (> start end)
 263                                  0
 264                                  (let ((position
 265                                         (position
 266                                          1 (conset-vector conset-1)
 267                                          :start start :end end :from-end t)))
 268                                    (if position
 269                                        (1+ position)
 270                                        0))))))
 271                    ((conset-difference)
 272                     `(setf (conset-min conset-1)
 273                            (or (position 1 (conset-vector conset-1)
 274                                          :start (conset-min conset-1)
 275                                          :end (conset-max conset-1))
 276                                0)
 277                            (conset-max conset-1)
 278                            (let ((position
 279                                   (position
 280                                    1 (conset-vector conset-1)
 281                                    :start (conset-min conset-1)
 282                                    :end (conset-max conset-1)
 283                                    :from-end t)))
 284                              (if position
 285                                  (1+ position)
 286                                  0))))))
 287               (values))))
 288     (defconsetop conset-union bit-ior)
 289     (defconsetop conset-intersection bit-and)
 290     (defconsetop conset-difference bit-andc2)))
 291 \f
 292 ;;; Constraints are hash-consed. Unfortunately, types aren't, so we have
 293 ;;; to over-approximate and then linear search through the potential hits.
 294 ;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant
 295 ;;; and lambda-vars can only be found in EQL constraints.
 296 (defun find-constraint (kind x y not-p)
 297   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
 298   (etypecase y
 299     (ctype
 300        (awhen (lambda-var-ctype-constraints x)
 301          (dolist (con (gethash (sb!kernel::type-class-info y) it) nil)
 302            (when (and (eq (constraint-kind con) kind)
 303                       (eq (constraint-not-p con) not-p)
 304                       (type= (constraint-y con) y))
 305              (return-from find-constraint con)))
 306          nil))
 307     (lvar
 308        (awhen (lambda-var-eq-constraints x)
 309          (gethash y it)))
 310     ((or constant lambda-var)
 311        (awhen (lambda-var-eq-constraints x)
 312          (let ((cache (gethash y it)))
 313            (declare (type list cache))
 314            (if not-p (cdr cache) (car cache)))))))
 315
 316 ;;; The most common operations on consets are iterating through the constraints
 317 ;;; that are related to a certain variable in a given conset.  Storing the
 318 ;;; constraints related to each variable in vectors allows us to easily iterate
 319 ;;; through the intersection of such constraints and the constraints in a conset.
 320 ;;;
 321 ;;; EQL-var constraints assert that two lambda-vars are EQL.
 322 ;;; Private constraints assert that a lambda-var is EQL or not EQL to a constant.
 323 ;;; Inheritable constraints are constraints that may be propagated to EQL
 324 ;;; lambda-vars (along with EQL-var constraints).
 325 ;;;
 326 ;;; Lambda-var -- lvar EQL constraints only serve one purpose: remember whether
 327 ;;; an lvar is (only) written to by a ref to that lambda-var, and aren't ever
 328 ;;; propagated.
 329 ;;;
 330 ;;; Finally, the lambda-var conset is only used to track the whole set of
 331 ;;; constraints associated with a given lambda-var, and thus easily delete
 332 ;;; such constraints from a conset.
 333 (defun register-constraint (x con y)
 334   (declare (type lambda-var x) (type constraint con) (type constraint-y y))
 335   (conset-adjoin con (lambda-var-constraints x))
 336   (macrolet ((ensuref (place default)
 337                `(or ,place (setf ,place ,default)))
 338              (ensure-hash (place)
 339                `(ensuref ,place (make-hash-table)))
 340              (ensure-vec (place)
 341                `(ensuref ,place (make-array 8 :adjustable t :fill-pointer 0))))
 342     (etypecase y
 343       (ctype
 344        (let ((index (ensure-hash (lambda-var-ctype-constraints x)))
 345              (vec   (ensure-vec  (lambda-var-inheritable-constraints x))))
 346          (push con (gethash (sb!kernel::type-class-info y) index))
 347          (vector-push-extend con vec)))
 348       (lvar
 349        (let ((index (ensure-hash (lambda-var-eq-constraints x))))
 350          (setf (gethash y index) con)))
 351       ((or constant lambda-var)
 352        (let* ((index (ensure-hash (lambda-var-eq-constraints x)))
 353               (cons  (ensuref (gethash y index) (list nil))))
 354          (if (constraint-not-p con)
 355              (setf (cdr cons) con)
 356              (setf (car cons) con)))
 357        (typecase y
 358          (constant
 359           (let ((vec (ensure-vec (lambda-var-private-constraints x))))
 360             (vector-push-extend con vec)))
 361          (lambda-var
 362           (let ((vec (if (constraint-not-p con)
 363                          (ensure-vec (lambda-var-inheritable-constraints x))
 364                          (ensure-vec (lambda-var-eql-var-constraints x)))))
 365             (vector-push-extend con vec)))))))
 366   nil)
 367
 368 ;;; Return a constraint for the specified arguments. We only create a
 369 ;;; new constraint if there isn't already an equivalent old one,
 370 ;;; guaranteeing that all equivalent constraints are EQ. This
 371 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
 372 (defun find-or-create-constraint (kind x y not-p)
 373   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
 374   (or (find-constraint kind x y not-p)
 375       (let ((new (make-constraint (length *constraint-universe*)
 376                                   kind x y not-p)))
 377         (vector-push-extend new *constraint-universe*
 378                             (1+ (length *constraint-universe*)))
 379         (register-constraint x new y)
 380         (when (lambda-var-p y)
 381           (register-constraint y new x))
 382         new)))
 383 \f
 384 ;;; Actual conset interface
 385 ;;;
 386 ;;; Constraint propagation needs to iterate over the set of lambda-vars known to
 387 ;;; be EQL to a given variable (including itself), via DO-EQL-VARS.
 388 ;;;
 389 ;;; It also has to iterate through constraints that are inherited by EQL variables
 390 ;;; (DO-INHERITABLE-CONSTRAINTS), and through constraints used by
 391 ;;; CONSTRAIN-REF-TYPE (to derive the type of a REF to a lambda-var).
 392 ;;;
 393 ;;; Consets must keep track of which lvars are EQL to a given lambda-var (result
 394 ;;; from a REF to the lambda-var): CONSET-LVAR-LAMBDA-VAR-EQL-P and
 395 ;;; CONSET-ADD-LVAR-LAMBDA-VAR-EQL.  This, as all other constraints, must of
 396 ;;; course be cleared when a lambda-var's constraints are dropped because of
 397 ;;; assignment.
 398 ;;;
 399 ;;; Consets must be able to add constraints to a given lambda-var
 400 ;;; (CONSET-ADD-CONSTRAINT), and to the set of variables EQL to a given
 401 ;;; lambda-var (CONSET-ADD-CONSTRAINT-TO-EQL).
 402 ;;;
 403 ;;; When a lambda-var is assigned to, all the constraints involving that variable
 404 ;;; must be dropped: constraint propagation is flow-sensitive, so the constraints
 405 ;;; relate to the variable at a given range of program point.  In such cases,
 406 ;;; constraint propagation calls CONSET-CLEAR-LAMBDA-VAR.
 407 ;;;
 408 ;;; Finally, one of the main strengths of constraint propagation in SBCL is the
 409 ;;; tracking of EQL variables to help constraint propagation.  When two variables
 410 ;;; are known to be EQL (e.g. after a branch), ADD-EQL-VAR-VAR-CONSTRAINT is
 411 ;;; called to add the EQL constraint, but also have each equality class inherit
 412 ;;; the other's (inheritable) constraints.
 413 ;;;
 414 ;;; On top of that, we have the usual bulk set operations: intersection, copy,
 415 ;;; equality or emptiness testing.  There's also union, but that's only an
 416 ;;; optimisation to avoid useless copies in ADD-TEST-CONSTRAINTS and
 417 ;;; FIND-BLOCK-TYPE-CONSTRAINTS.
 418 (defmacro do-conset-constraints-intersection ((symbol (conset constraints) &optional result)
 419                                               &body body)
 420   (let ((min (gensym "MIN"))
 421         (max (gensym "MAX")))
 422     (once-only ((conset conset)
 423                 (constraints constraints))
 424       `(flet ((body (,symbol)
 425                 (declare (type constraint ,symbol))
 426                 ,@body))
 427          (when ,constraints
 428            (let ((,min (conset-min ,conset))
 429                  (,max (conset-max ,conset)))
 430              (declare (optimize speed))
 431              (map nil (lambda (constraint)
 432                         (declare (type constraint constraint))
 433                         (let ((number (constraint-number constraint)))
 434                           (when (and (<= ,min number)
 435                                      (< number ,max)
 436                                      (conset-member constraint ,conset))
 437                             (body constraint))))
 438                   ,constraints)))
 439          ,result))))
 440
 441 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
 442   (once-only ((var         var)
 443               (constraints constraints))
 444     `(flet ((body-fun (,symbol)
 445               ,@body))
 446        (body-fun ,var)
 447        (do-conset-constraints-intersection
 448            (con (,constraints (lambda-var-eql-var-constraints ,var)) ,result)
 449          (let ((x (constraint-x con))
 450                (y (constraint-y con)))
 451            (body-fun (if (eq ,var x) y x)))))))
 452
 453 (defmacro do-inheritable-constraints ((symbol (conset variable) &optional result)
 454                                       &body body)
 455   (once-only ((conset   conset)
 456               (variable variable))
 457     `(block nil
 458        (flet ((body-fun (,symbol)
 459                 ,@body))
 460          (do-conset-constraints-intersection
 461              (con (,conset (lambda-var-inheritable-constraints ,variable)))
 462            (body-fun con))
 463          (do-conset-constraints-intersection
 464              (con (,conset (lambda-var-eql-var-constraints ,variable)) ,result)
 465            (body-fun con))))))
 466
 467 (defmacro do-propagatable-constraints ((symbol (conset variable) &optional result)
 468                                        &body body)
 469   (once-only ((conset conset)
 470               (variable variable))
 471     `(block nil
 472        (flet ((body-fun (,symbol)
 473                 ,@body))
 474          (do-conset-constraints-intersection
 475              (con (,conset (lambda-var-private-constraints ,variable)))
 476            (body-fun con))
 477          (do-conset-constraints-intersection
 478              (con (,conset (lambda-var-eql-var-constraints ,variable)))
 479            (body-fun con))
 480          (do-conset-constraints-intersection
 481              (con (,conset (lambda-var-inheritable-constraints ,variable)) ,result)
 482            (body-fun con))))))
 483
 484 (declaim (inline conset-lvar-lambda-var-eql-p conset-add-lvar-lambda-var-eql))
 485 (defun conset-lvar-lambda-var-eql-p (conset lvar lambda-var)
 486   (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
 487     (and constraint
 488          (conset-member constraint conset))))
 489
 490 (defun conset-add-lvar-lambda-var-eql (conset lvar lambda-var)
 491   (let ((constraint (find-or-create-constraint 'eql lambda-var lvar nil)))
 492     (conset-adjoin constraint conset)))
 493
 494 (declaim (inline conset-add-constraint conset-add-constraint-to-eql))
 495 (defun conset-add-constraint (conset kind x y not-p)
 496   (declare (type conset conset)
 497            (type lambda-var x))
 498   (conset-adjoin (find-or-create-constraint kind x y not-p)
 499                  conset))
 500
 501 (defun conset-add-constraint-to-eql (conset kind x y not-p &optional (target conset))
 502   (declare (type conset target conset)
 503            (type lambda-var x))
 504   (do-eql-vars (x (x conset))
 505     (conset-add-constraint target kind x y not-p)))
 506
 507 (declaim (inline conset-clear-lambda-var))
 508 (defun conset-clear-lambda-var (conset var)
 509   (conset-difference conset (lambda-var-constraints var)))
 510
 511 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
 512 ;;; LVAR) ones - to all of the variables in the VARS list.
 513 (defun inherit-constraints (vars from-var constraints target)
 514   (do-inheritable-constraints (con (constraints from-var))
 515     (let ((eq-x (eq from-var (constraint-x con)))
 516           (eq-y (eq from-var (constraint-y con))))
 517       (dolist (var vars)
 518         (conset-add-constraint target
 519                                (constraint-kind con)
 520                                (if eq-x var (constraint-x con))
 521                                (if eq-y var (constraint-y con))
 522                                (constraint-not-p con))))))
 523
 524 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
 525 ;; inherit each other's constraints.
 526 (defun add-eql-var-var-constraint (var1 var2 constraints
 527                                    &optional (target constraints))
 528   (let ((constraint (find-or-create-constraint 'eql var1 var2 nil)))
 529     (unless (conset-member constraint target)
 530       (conset-adjoin constraint target)
 531       (collect ((eql1) (eql2))
 532         (do-eql-vars (var1 (var1 constraints))
 533           (eql1 var1))
 534         (do-eql-vars (var2 (var2 constraints))
 535           (eql2 var2))
 536         (inherit-constraints (eql1) var2 constraints target)
 537         (inherit-constraints (eql2) var1 constraints target))
 538       t)))
 539 \f
 540 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
 541 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
 542 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
 543 (defun ok-ref-lambda-var (ref)
 544   (declare (type ref ref))
 545   (let ((leaf (ref-leaf ref)))
 546     (when (and (lambda-var-p leaf)
 547                (lambda-var-constraints leaf))
 548       leaf)))
 549
 550 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
 551 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
 552 (defun ok-lvar-lambda-var (lvar constraints)
 553   (declare (type lvar lvar))
 554   (let ((use (lvar-uses lvar)))
 555     (cond ((ref-p use)
 556            (let ((lambda-var (ok-ref-lambda-var use)))
 557              (and lambda-var
 558                   (conset-lvar-lambda-var-eql-p constraints lvar lambda-var)
 559                   lambda-var)))
 560           ((cast-p use)
 561            (ok-lvar-lambda-var (cast-value use) constraints)))))
 562 ;;;; Searching constraints
 563
 564 ;;; Add the indicated test constraint to TARGET.
 565 (defun precise-add-test-constraint (fun x y not-p constraints target)
 566   (if (and (eq 'eql fun) (lambda-var-p y) (not not-p))
 567       (add-eql-var-var-constraint x y constraints target)
 568       (conset-add-constraint-to-eql constraints fun x y not-p target))
 569   (values))
 570
 571 (defun add-test-constraint (quick-p fun x y not-p constraints target)
 572   (cond (quick-p
 573          (conset-add-constraint target fun x y not-p))
 574         (t
 575          (precise-add-test-constraint fun x y not-p constraints target))))
 576 ;;; Add complementary constraints to the consequent and alternative
 577 ;;; blocks of IF. We do nothing if X is NIL.
 578 (declaim (inline precise-add-test-constraint quick-add-complement-constraints))
 579 (defun precise-add-complement-constraints (fun x y not-p constraints
 580                                            consequent-constraints
 581                                            alternative-constraints)
 582   (when x
 583     (precise-add-test-constraint fun x y not-p constraints
 584                                 consequent-constraints)
 585     (precise-add-test-constraint fun x y (not not-p) constraints
 586                                  alternative-constraints))
 587   (values))
 588
 589 (defun quick-add-complement-constraints (fun x y not-p
 590                                          consequent-constraints
 591                                          alternative-constraints)
 592   (when x
 593     (conset-add-constraint consequent-constraints fun x y not-p)
 594     (conset-add-constraint alternative-constraints fun x y (not not-p)))
 595   (values))
 596
 597 (defun add-complement-constraints (quick-p fun x y not-p constraints
 598                                    consequent-constraints
 599                                    alternative-constraints)
 600   (if quick-p
 601       (quick-add-complement-constraints fun x y not-p
 602                                         consequent-constraints
 603                                         alternative-constraints)
 604       (precise-add-complement-constraints fun x y not-p constraints
 605                                           consequent-constraints
 606                                           alternative-constraints)))
 607
 608 (defun add-combination-test-constraints (use constraints
 609                                          consequent-constraints
 610                                          alternative-constraints
 611                                          quick-p)
 612   (flet ((add (fun x y not-p)
 613            (add-complement-constraints quick-p
 614                                        fun x y not-p
 615                                        constraints
 616                                        consequent-constraints
 617                                        alternative-constraints))
 618          (prop (triples target)
 619            (map nil (lambda (constraint)
 620                       (destructuring-bind (kind x y &optional not-p)
 621                           constraint
 622                         (when (and kind x y)
 623                           (add-test-constraint quick-p
 624                                                kind x y
 625                                                not-p constraints
 626                                                target))))
 627                 triples)))
 628     (when (eq (combination-kind use) :known)
 629       (binding* ((info (combination-fun-info use) :exit-if-null)
 630                  (propagate (fun-info-constraint-propagate-if
 631                              info)
 632                             :exit-if-null))
 633         (multiple-value-bind (lvar type if else)
 634             (funcall propagate use constraints)
 635           (prop if consequent-constraints)
 636           (prop else alternative-constraints)
 637           (when (and lvar type)
 638             (add 'typep (ok-lvar-lambda-var lvar constraints)
 639                  type nil)
 640             (return-from add-combination-test-constraints)))))
 641     (let* ((name (lvar-fun-name
 642                   (basic-combination-fun use)))
 643            (args (basic-combination-args use))
 644            (ptype (gethash name *backend-predicate-types*)))
 645       (when ptype
 646         (add 'typep (ok-lvar-lambda-var (first args)
 647                                         constraints)
 648              ptype nil)))))
 649
 650 ;;; Add test constraints to the consequent and alternative blocks of
 651 ;;; the test represented by USE.
 652 (defun add-test-constraints (use if constraints)
 653   (declare (type node use) (type cif if))
 654   ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
 655   ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
 656   ;; can't guarantee that the optimization will be done, so we still
 657   ;; need to avoid barfing on this case.
 658   (unless (eq (if-consequent if) (if-alternative if))
 659     (let ((consequent-constraints (make-conset))
 660           (alternative-constraints (make-conset))
 661           (quick-p (policy if (> compilation-speed speed))))
 662       (macrolet ((add (fun x y not-p)
 663                    `(add-complement-constraints quick-p
 664                                                 ,fun ,x ,y ,not-p
 665                                                 constraints
 666                                                 consequent-constraints
 667                                                 alternative-constraints)))
 668         (typecase use
 669           (ref
 670            (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
 671                 (specifier-type 'null) t))
 672           (combination
 673            (unless (eq (combination-kind use)
 674                        :error)
 675              (let ((name (lvar-fun-name
 676                           (basic-combination-fun use)))
 677                    (args (basic-combination-args use)))
 678                (case name
 679                  ((%typep %instance-typep)
 680                   (let ((type (second args)))
 681                     (when (constant-lvar-p type)
 682                       (let ((val (lvar-value type)))
 683                         (add 'typep
 684                              (ok-lvar-lambda-var (first args) constraints)
 685                              (if (ctype-p val)
 686                                  val
 687                                  (let ((*compiler-error-context* use))
 688                                    (specifier-type val)))
 689                              nil)))))
 690                  ((eq eql)
 691                   (let* ((arg1 (first args))
 692                          (var1 (ok-lvar-lambda-var arg1 constraints))
 693                          (arg2 (second args))
 694                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 695                     ;; The code below assumes that the constant is the
 696                     ;; second argument in case of variable to constant
 697                     ;; comparison which is sometimes true (see source
 698                     ;; transformations for EQ, EQL and CHAR=). Fixing
 699                     ;; that would result in more constant substitutions
 700                     ;; which is not a universally good thing, thus the
 701                     ;; unnatural asymmetry of the tests.
 702                     (cond ((not var1)
 703                            (when var2
 704                              (add-test-constraint quick-p
 705                                                   'typep var2 (lvar-type arg1)
 706                                                   nil constraints
 707                                                   consequent-constraints)))
 708                           (var2
 709                            (add 'eql var1 var2 nil))
 710                           ((constant-lvar-p arg2)
 711                            (add 'eql var1
 712                                 (find-constant (lvar-value arg2))
 713                                 nil))
 714                           (t
 715                            (add-test-constraint quick-p
 716                                                 'typep var1 (lvar-type arg2)
 717                                                 nil constraints
 718                                                 consequent-constraints)))))
 719                  ((< >)
 720                   (let* ((arg1 (first args))
 721                          (var1 (ok-lvar-lambda-var arg1 constraints))
 722                          (arg2 (second args))
 723                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 724                     (when var1
 725                       (add name var1 (lvar-type arg2) nil))
 726                     (when var2
 727                       (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
 728                  (t
 729                   (add-combination-test-constraints use constraints
 730                                                     consequent-constraints
 731                                                     alternative-constraints
 732                                                     quick-p))))))))
 733       (values consequent-constraints alternative-constraints))))
 734
 735 ;;;; Applying constraints
 736
 737 ;;; Return true if X is an integer NUMERIC-TYPE.
 738 (defun integer-type-p (x)
 739   (declare (type ctype x))
 740   (and (numeric-type-p x)
 741        (eq (numeric-type-class x) 'integer)
 742        (eq (numeric-type-complexp x) :real)))
 743
 744 ;;; Given that an inequality holds on values of type X and Y, return a
 745 ;;; new type for X. If GREATER is true, then X was greater than Y,
 746 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
 747 ;;; inclusive, i.e. >=.
 748 ;;;
 749 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
 750 ;;; bound into X and return that result. If not OR-EQUAL, we can go
 751 ;;; one greater (less) than Y's bound.
 752 (defun constrain-integer-type (x y greater or-equal)
 753   (declare (type numeric-type x y))
 754   (flet ((exclude (x)
 755            (cond ((not x) nil)
 756                  (or-equal x)
 757                  (greater (1+ x))
 758                  (t (1- x))))
 759          (bound (x)
 760            (if greater (numeric-type-low x) (numeric-type-high x))))
 761     (let* ((x-bound (bound x))
 762            (y-bound (exclude (bound y)))
 763            (new-bound (cond ((not x-bound) y-bound)
 764                             ((not y-bound) x-bound)
 765                             (greater (max x-bound y-bound))
 766                             (t (min x-bound y-bound)))))
 767       (if greater
 768           (modified-numeric-type x :low new-bound)
 769           (modified-numeric-type x :high new-bound)))))
 770
 771 ;;; Return true if X is a float NUMERIC-TYPE.
 772 (defun float-type-p (x)
 773   (declare (type ctype x))
 774   (and (numeric-type-p x)
 775        (eq (numeric-type-class x) 'float)
 776        (eq (numeric-type-complexp x) :real)))
 777
 778 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 779 ;;;
 780 ;;; In contrast to the integer version, here the input types can have
 781 ;;; open bounds in addition to closed ones and we don't increment or
 782 ;;; decrement a bound to honor OR-EQUAL being NIL but put an open bound
 783 ;;; into the result instead, if appropriate.
 784 (defun constrain-float-type (x y greater or-equal)
 785   (declare (type numeric-type x y))
 786   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
 787
 788   (aver (eql (numeric-type-class x) 'float))
 789   (aver (eql (numeric-type-class y) 'float))
 790   #+sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 791   x
 792   #-sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 793   (labels ((exclude (x)
 794              (cond ((not x) nil)
 795                    (or-equal x)
 796                    (t
 797                     (if (consp x)
 798                         x
 799                         (list x)))))
 800            (bound (x)
 801              (if greater (numeric-type-low x) (numeric-type-high x)))
 802            (tighter-p (x ref)
 803              (cond ((null x) nil)
 804                    ((null ref) t)
 805                    ((= (type-bound-number x) (type-bound-number ref))
 806                     ;; X is tighter if X is an open bound and REF is not
 807                     (and (consp x) (not (consp ref))))
 808                    (greater
 809                     (< (type-bound-number ref) (type-bound-number x)))
 810                    (t
 811                     (> (type-bound-number ref) (type-bound-number x))))))
 812     (let* ((x-bound (bound x))
 813            (y-bound (exclude (bound y)))
 814            (new-bound (cond ((not x-bound)
 815                              y-bound)
 816                             ((not y-bound)
 817                              x-bound)
 818                             ((tighter-p y-bound x-bound)
 819                              y-bound)
 820                             (t
 821                              x-bound))))
 822       (if greater
 823           (modified-numeric-type x :low new-bound)
 824           (modified-numeric-type x :high new-bound)))))
 825
 826 ;;; Return true if LEAF is "visible" from NODE.
 827 (defun leaf-visible-from-node-p (leaf node)
 828   (cond
 829    ((lambda-var-p leaf)
 830     ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an
 831     ;; ancestor for NODE.
 832     (let ((leaf-lambda (lambda-var-home leaf)))
 833       (loop for lambda = (node-home-lambda node)
 834             then (lambda-parent lambda)
 835             while lambda
 836             when (eq lambda leaf-lambda)
 837             return t)))
 838    ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes),
 839    ;; not just LAMBDA-VARs.
 840    (t
 841     ;; Assume everything else is globally visible.
 842     t)))
 843
 844 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 845 ;;; restrictions from flow analysis IN, set the type for REF
 846 ;;; accordingly.
 847 (defun constrain-ref-type (ref in)
 848   (declare (type ref ref) (type conset in))
 849   ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
 850   ;; cons up endless union types when propagating large number of EQL
 851   ;; constraints -- eg. from large CASE forms -- instead we just
 852   ;; directly accumulate one XSET, and a set of fp zeroes, which we at
 853   ;; the end turn into a MEMBER-TYPE.
 854   ;;
 855   ;; Since massive symbol cases are an especially atrocious pattern
 856   ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
 857   ;; a more useful type, don't propagate their negation except for NIL
 858   ;; unless SPEED > COMPILATION-SPEED.
 859   (let ((res (single-value-type (node-derived-type ref)))
 860         (constrain-symbols (policy ref (> speed compilation-speed)))
 861         (not-set (alloc-xset))
 862         (not-fpz nil)
 863         (not-res *empty-type*)
 864         (leaf (ref-leaf ref)))
 865     (declare (type lambda-var leaf))
 866     (flet ((note-not (x)
 867              (if (fp-zero-p x)
 868                  (push x not-fpz)
 869                  (when (or constrain-symbols (null x) (not (symbolp x)))
 870                    (add-to-xset x not-set)))))
 871       (do-propagatable-constraints (con (in leaf))
 872         (let* ((x (constraint-x con))
 873                (y (constraint-y con))
 874                (not-p (constraint-not-p con))
 875                (other (if (eq x leaf) y x))
 876                (kind (constraint-kind con)))
 877           (case kind
 878             (typep
 879              (if not-p
 880                  (if (member-type-p other)
 881                      (mapc-member-type-members #'note-not other)
 882                      (setq not-res (type-union not-res other)))
 883                  (setq res (type-approx-intersection2 res other))))
 884             (eql
 885              (let ((other-type (leaf-type other)))
 886                (if not-p
 887                    (when (and (constant-p other)
 888                               (member-type-p other-type))
 889                      (note-not (constant-value other)))
 890                    (let ((leaf-type (leaf-type leaf)))
 891                      (cond
 892                        ((or (constant-p other)
 893                             (and (leaf-refs other) ; protect from
 894                                         ; deleted vars
 895                                  (csubtypep other-type leaf-type)
 896                                  (not (type= other-type leaf-type))
 897                                  ;; Don't change to a LEAF not visible here.
 898                                  (leaf-visible-from-node-p other ref)))
 899                         (change-ref-leaf ref other)
 900                         (when (constant-p other) (return)))
 901                        (t
 902                         (setq res (type-approx-intersection2
 903                                    res other-type))))))))
 904             ((< >)
 905              (cond
 906                ((and (integer-type-p res) (integer-type-p y))
 907                 (let ((greater (eq kind '>)))
 908                   (let ((greater (if not-p (not greater) greater)))
 909                     (setq res
 910                           (constrain-integer-type res y greater not-p)))))
 911                ((and (float-type-p res) (float-type-p y))
 912                 (let ((greater (eq kind '>)))
 913                   (let ((greater (if not-p (not greater) greater)))
 914                     (setq res
 915                           (constrain-float-type res y greater not-p)))))))))))
 916     (cond ((and (if-p (node-dest ref))
 917                 (or (xset-member-p nil not-set)
 918                     (csubtypep (specifier-type 'null) not-res)))
 919            (setf (node-derived-type ref) *wild-type*)
 920            (change-ref-leaf ref (find-constant t)))
 921           (t
 922            (setf not-res
 923                  (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
 924            (derive-node-type ref
 925                              (make-single-value-type
 926                               (or (type-difference res not-res)
 927                                   res)))
 928            (maybe-terminate-block ref nil))))
 929   (values))
 930
 931 ;;;; Flow analysis
 932
 933 (defun maybe-add-eql-var-lvar-constraint (ref gen)
 934   (let ((lvar (ref-lvar ref))
 935         (leaf (ref-leaf ref)))
 936     (when (and (lambda-var-p leaf) lvar)
 937       (conset-add-lvar-lambda-var-eql gen lvar leaf))))
 938
 939 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
 940 ;; LAMBDA-VAR if possible.
 941 (defun maybe-add-eql-var-var-constraint (var lvar constraints
 942                                          &optional (target constraints))
 943   (declare (type lambda-var var) (type lvar lvar))
 944   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
 945     (when lambda-var
 946       (add-eql-var-var-constraint var lambda-var constraints target))))
 947
 948 ;;; Local propagation
 949 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 950 ;;;    constraint.]
 951 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 952 ;;;    a type constraint based on the new value type.
 953 (declaim (ftype (function (cblock conset boolean)
 954                           conset)
 955                 constraint-propagate-in-block))
 956 (defun constraint-propagate-in-block (block gen preprocess-refs-p)
 957   (do-nodes (node lvar block)
 958     (typecase node
 959       (bind
 960        (let ((fun (bind-lambda node)))
 961          (when (eq (functional-kind fun) :let)
 962            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
 963                  for var in (lambda-vars fun)
 964                  and val in (combination-args call)
 965                  when (and val (lambda-var-constraints var))
 966                  do (let ((type (lvar-type val)))
 967                       (unless (eq type *universal-type*)
 968                         (conset-add-constraint gen 'typep var type nil)))
 969                     (maybe-add-eql-var-var-constraint var val gen)))))
 970       (ref
 971        (when (ok-ref-lambda-var node)
 972          (maybe-add-eql-var-lvar-constraint node gen)
 973          (when preprocess-refs-p
 974            (constrain-ref-type node gen))))
 975       (cast
 976        (let ((lvar (cast-value node)))
 977          (let ((var (ok-lvar-lambda-var lvar gen)))
 978            (when var
 979              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
 980                (unless (eq atype *universal-type*)
 981                  (conset-add-constraint-to-eql gen 'typep var atype nil)))))))
 982       (cset
 983        (binding* ((var (set-var node))
 984                   (nil (lambda-var-p var) :exit-if-null)
 985                   (nil (lambda-var-constraints var) :exit-if-null))
 986          (when (policy node (and (= speed 3) (> speed compilation-speed)))
 987            (let ((type (lambda-var-type var)))
 988              (unless (eql *universal-type* type)
 989                (do-eql-vars (other (var gen))
 990                  (unless (eql other var)
 991                    (conset-add-constraint gen 'typep other type nil))))))
 992          (conset-clear-lambda-var gen var)
 993          (let ((type (single-value-type (node-derived-type node))))
 994            (unless (eq type *universal-type*)
 995              (conset-add-constraint gen 'typep var type nil)))
 996          (unless (policy node (> compilation-speed speed))
 997            (maybe-add-eql-var-var-constraint var (set-value node) gen))))
 998       (combination
 999        (when (eq (combination-kind node) :known)
1000          (binding* ((info (combination-fun-info node) :exit-if-null)
1001                     (propagate (fun-info-constraint-propagate info)
1002                                :exit-if-null)
1003                     (constraints (funcall propagate node gen))
1004                     (register (if (policy node
1005                                           (> compilation-speed speed))
1006                                   #'conset-add-constraint
1007                                   #'conset-add-constraint-to-eql)))
1008            (map nil (lambda (constraint)
1009                       (destructuring-bind (kind x y &optional not-p)
1010                           constraint
1011                         (when (and kind x y)
1012                           (funcall register gen
1013                                    kind x y
1014                                    not-p))))
1015                 constraints))))))
1016   gen)
1017
1018 (defun constraint-propagate-if (block gen)
1019   (let ((node (block-last block)))
1020     (when (if-p node)
1021       (let ((use (lvar-uses (if-test node))))
1022         (when (node-p use)
1023           (add-test-constraints use node gen))))))
1024
1025 ;;; Starting from IN compute OUT and (consequent/alternative
1026 ;;; constraints if the block ends with an IF). Return the list of
1027 ;;; successors that may need to be recomputed.
1028 (defun find-block-type-constraints (block final-pass-p)
1029   (declare (type cblock block))
1030   (let ((gen (constraint-propagate-in-block
1031               block
1032               (if final-pass-p
1033                   (block-in block)
1034                   (copy-conset (block-in block)))
1035               final-pass-p)))
1036     (setf (block-gen block) gen)
1037     (multiple-value-bind (consequent-constraints alternative-constraints)
1038         (constraint-propagate-if block gen)
1039       (if consequent-constraints
1040           (let* ((node (block-last block))
1041                  (old-consequent-constraints (if-consequent-constraints node))
1042                  (old-alternative-constraints (if-alternative-constraints node))
1043                  (succ ()))
1044             ;; Add the consequent and alternative constraints to GEN.
1045             (cond ((conset-empty consequent-constraints)
1046                    (setf (if-consequent-constraints node) gen)
1047                    (setf (if-alternative-constraints node) gen))
1048                   (t
1049                    (setf (if-consequent-constraints node) (copy-conset gen))
1050                    (conset-union (if-consequent-constraints node)
1051                                  consequent-constraints)
1052                    (setf (if-alternative-constraints node) gen)
1053                    (conset-union (if-alternative-constraints node)
1054                                  alternative-constraints)))
1055             ;; Has the consequent been changed?
1056             (unless (and old-consequent-constraints
1057                          (conset= (if-consequent-constraints node)
1058                                   old-consequent-constraints))
1059               (push (if-consequent node) succ))
1060             ;; Has the alternative been changed?
1061             (unless (and old-alternative-constraints
1062                          (conset= (if-alternative-constraints node)
1063                                   old-alternative-constraints))
1064               (push (if-alternative node) succ))
1065             succ)
1066           ;; There is no IF.
1067           (unless (and (block-out block)
1068                        (conset= gen (block-out block)))
1069             (setf (block-out block) gen)
1070             (block-succ block))))))
1071
1072 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
1073 ;;; During this pass, we also do local constraint propagation by
1074 ;;; adding in constraints as we see them during the pass through the
1075 ;;; block.
1076 (defun use-result-constraints (block)
1077   (declare (type cblock block))
1078   (constraint-propagate-in-block block (block-in block) t))
1079
1080 ;;; Give an empty constraints set to any var that doesn't have one and
1081 ;;; isn't a set closure var. Since a var that we previously rejected
1082 ;;; looks identical to one that is new, so we optimistically keep
1083 ;;; hoping that vars stop being closed over or lose their sets.
1084 (defun init-var-constraints (component)
1085   (declare (type component component))
1086   (dolist (fun (component-lambdas component))
1087     (flet ((frob (x)
1088              (dolist (var (lambda-vars x))
1089                (unless (lambda-var-constraints var)
1090                  (when (or (null (lambda-var-sets var))
1091                            (not (closure-var-p var)))
1092                    (setf (lambda-var-constraints var) (make-conset)))))))
1093       (frob fun)
1094       (dolist (let (lambda-lets fun))
1095         (frob let)))))
1096
1097 ;;; Return the constraints that flow from PRED to SUCC. This is
1098 ;;; BLOCK-OUT unless PRED ends with an IF and test constraints were
1099 ;;; added.
1100 (defun block-out-for-successor (pred succ)
1101   (declare (type cblock pred succ))
1102   (let ((last (block-last pred)))
1103     (or (when (if-p last)
1104           (cond ((eq succ (if-consequent last))
1105                  (if-consequent-constraints last))
1106                 ((eq succ (if-alternative last))
1107                  (if-alternative-constraints last))))
1108         (block-out pred))))
1109
1110 (defun compute-block-in (block)
1111   (let ((in nil))
1112     (dolist (pred (block-pred block))
1113       ;; If OUT has not been calculated, assume it to be the universal
1114       ;; set.
1115       (let ((out (block-out-for-successor pred block)))
1116         (when out
1117           (if in
1118               (conset-intersection in out)
1119               (setq in (copy-conset out))))))
1120     (or in (make-conset))))
1121
1122 (defun update-block-in (block)
1123   (let ((in (compute-block-in block)))
1124     (cond ((and (block-in block) (conset= in (block-in block)))
1125            nil)
1126           (t
1127            (setf (block-in block) in)))))
1128
1129 ;;; Return two lists: one of blocks that precede all loops and
1130 ;;; therefore require only one constraint propagation pass and the
1131 ;;; rest. This implementation does not find all such blocks.
1132 ;;;
1133 ;;; A more complete implementation would be:
1134 ;;;
1135 ;;;     (do-blocks (block component)
1136 ;;;       (if (every #'(lambda (pred)
1137 ;;;                      (or (member pred leading-blocks)
1138 ;;;                          (eq pred head)))
1139 ;;;                  (block-pred block))
1140 ;;;           (push block leading-blocks)
1141 ;;;           (push block rest-of-blocks)))
1142 ;;;
1143 ;;; Trailing blocks that succeed all loops could be found and handled
1144 ;;; similarly. In practice though, these more complex solutions are
1145 ;;; slightly worse performancewise.
1146 (defun leading-component-blocks (component)
1147   (declare (type component component))
1148   (flet ((loopy-p (block)
1149            (let ((n (block-number block)))
1150              (dolist (pred (block-pred block))
1151                (unless (< n (block-number pred))
1152                  (return t))))))
1153     (let ((leading-blocks ())
1154           (rest-of-blocks ())
1155           (seen-loop-p ()))
1156       (do-blocks (block component)
1157         (when (and (not seen-loop-p) (loopy-p block))
1158           (setq seen-loop-p t))
1159         (if seen-loop-p
1160             (push block rest-of-blocks)
1161             (push block leading-blocks)))
1162       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
1163
1164 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
1165 ;;; a member already.
1166 (defun nconc-new (obj list)
1167   (do ((x list (cdr x))
1168        (prev nil x))
1169       ((endp x) (if prev
1170                     (progn
1171                       (setf (cdr prev) (list obj))
1172                       list)
1173                     (list obj)))
1174     (when (eql (car x) obj)
1175       (return-from nconc-new list))))
1176
1177 (defun find-and-propagate-constraints (component)
1178   (let ((blocks-to-process ()))
1179     (flet ((enqueue (blocks)
1180              (dolist (block blocks)
1181                (setq blocks-to-process (nconc-new block blocks-to-process)))))
1182       (multiple-value-bind (leading-blocks rest-of-blocks)
1183           (leading-component-blocks component)
1184         ;; Update every block once to account for changes in the
1185         ;; IR1. The constraints of the lead blocks cannot be changed
1186         ;; after the first pass so we might as well use them and skip
1187         ;; USE-RESULT-CONSTRAINTS later.
1188         (dolist (block leading-blocks)
1189           (setf (block-in block) (compute-block-in block))
1190           (find-block-type-constraints block t))
1191         (setq blocks-to-process (copy-list rest-of-blocks))
1192         ;; The rest of the blocks.
1193         (dolist (block rest-of-blocks)
1194           (aver (eq block (pop blocks-to-process)))
1195           (setf (block-in block) (compute-block-in block))
1196           (enqueue (find-block-type-constraints block nil)))
1197         ;; Propagate constraints
1198         (loop for block = (pop blocks-to-process)
1199               while block do
1200               (unless (eq block (component-tail component))
1201                 (when (update-block-in block)
1202                   (enqueue (find-block-type-constraints block nil)))))
1203         rest-of-blocks))))
1204
1205 (defun constraint-propagate (component)
1206   (declare (type component component))
1207   (init-var-constraints component)
1208
1209   (unless (block-out (component-head component))
1210     (setf (block-out (component-head component)) (make-conset)))
1211
1212   (dolist (block (find-and-propagate-constraints component))
1213     (unless (block-delete-p block)
1214       (use-result-constraints block)))
1215
1216   (values))