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   (defmacro do-conset-elements ((constraint conset &optional result) &body body)
 157     (with-unique-names (vector index start end
 158                                #-sb-xc-host ignore
 159                                #-sb-xc-host constraint-universe-end)
 160       (let* ((constraint-universe #+sb-xc-host '*constraint-universe*
 161                                   #-sb-xc-host (sb!xc:gensym "UNIVERSE"))
 162              (with-array-data
 163                 #+sb-xc-host '(progn)
 164                 #-sb-xc-host `(with-array-data
 165                                   ((,constraint-universe *constraint-universe*)
 166                                    (,ignore 0) (,constraint-universe-end nil)
 167                                    :check-fill-pointer t)
 168                                 (declare (ignore ,ignore))
 169                                 (aver (<= ,end ,constraint-universe-end)))))
 170         `(let* ((,vector (conset-vector ,conset))
 171                (,start (conset-min ,conset))
 172                (,end (min (conset-max ,conset) (length ,vector))))
 173           (,@with-array-data
 174             (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
 175               (when (plusp (sbit ,vector ,index))
 176                 (let ((,constraint (elt ,constraint-universe ,index)))
 177                   ,@body))))))))
 178
 179   ;; Oddly, iterating just between the maximum of the two sets' minima
 180   ;; and the minimum of the sets' maxima slowed down CP.
 181   (defmacro do-conset-intersection
 182       ((constraint conset1 conset2 &optional result) &body body)
 183     `(do-conset-elements (,constraint ,conset1 ,result)
 184        (when (conset-member ,constraint ,conset2)
 185          ,@body)))
 186
 187   (defun conset-empty (conset)
 188     (or (= (conset-min conset) (conset-max conset))
 189         ;; TODO: I bet FIND on bit-vectors can be optimized, if it
 190         ;; isn't.
 191         (not (find 1 (conset-vector conset)
 192                    :start (conset-min conset)
 193                    ;; By inspection, supplying :END here breaks the
 194                    ;; build with a "full call to
 195                    ;; DATA-VECTOR-REF-WITH-OFFSET" in the
 196                    ;; cross-compiler.  If that should change, add
 197                    ;; :end (conset-max conset)
 198                    ))))
 199
 200   (defun copy-conset (conset)
 201     (let ((ret (%copy-conset conset)))
 202       (setf (conset-vector ret) (copy-seq (conset-vector conset)))
 203       ret))
 204
 205   (defun %conset-grow (conset new-size)
 206     (declare (type index new-size))
 207     (setf (conset-vector conset)
 208           (replace (the simple-bit-vector
 209                      (make-array
 210                       (ash 1 (integer-length (1- new-size)))
 211                       :element-type 'bit
 212                       :initial-element 0))
 213                    (the simple-bit-vector
 214                      (conset-vector conset)))))
 215
 216   (declaim (inline conset-grow))
 217   (defun conset-grow (conset new-size)
 218     (declare (type index new-size))
 219     (when (< (length (conset-vector conset)) new-size)
 220       (%conset-grow conset new-size))
 221     (values))
 222
 223   (defun conset-member (constraint conset)
 224     (let ((number (%constraint-number constraint))
 225           (vector (conset-vector conset)))
 226       (when (< number (length vector))
 227         (plusp (sbit vector number)))))
 228
 229   (defun conset-adjoin (constraint conset)
 230     (prog1
 231       (not (conset-member constraint conset))
 232       (let ((number (%constraint-number constraint)))
 233         (conset-grow conset (1+ number))
 234         (setf (sbit (conset-vector conset) number) 1)
 235         (setf (conset-min conset) (min number (conset-min conset)))
 236         (when (>= number (conset-max conset))
 237           (setf (conset-max conset) (1+ number))))))
 238
 239   (defun conset= (conset1 conset2)
 240     (let* ((vector1 (conset-vector conset1))
 241            (vector2 (conset-vector conset2))
 242            (length1 (length vector1))
 243            (length2 (length vector2)))
 244       (if (= length1 length2)
 245           ;; When the lengths are the same, we can rely on EQUAL being
 246           ;; nicely optimized on bit-vectors.
 247           (equal vector1 vector2)
 248           (multiple-value-bind (shorter longer)
 249               (if (< length1 length2)
 250                   (values vector1 vector2)
 251                   (values vector2 vector1))
 252             ;; FIXME: make MISMATCH fast on bit-vectors.
 253             (dotimes (index (length shorter))
 254               (when (/= (sbit vector1 index) (sbit vector2 index))
 255                 (return-from conset= nil)))
 256             (if (find 1 longer :start (length shorter))
 257                 nil
 258                 t)))))
 259
 260   (macrolet
 261       ((defconsetop (name bit-op)
 262            `(defun ,name (conset-1 conset-2)
 263               (declare (optimize (speed 3) (safety 0)))
 264               (let* ((size-1 (length (conset-vector conset-1)))
 265                      (size-2 (length (conset-vector conset-2)))
 266                      (new-size (max size-1 size-2)))
 267                 (conset-grow conset-1 new-size)
 268                 (conset-grow conset-2 new-size))
 269               (let ((vector1 (conset-vector conset-1))
 270                     (vector2 (conset-vector conset-2)))
 271                 (declare (simple-bit-vector vector1 vector2))
 272                 (setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
 273                 ;; Update the extrema.
 274                 ,(ecase name
 275                    ((conset-union)
 276                     `(setf (conset-min conset-1)
 277                            (min (conset-min conset-1)
 278                                 (conset-min conset-2))
 279                            (conset-max conset-1)
 280                            (max (conset-max conset-1)
 281                                 (conset-max conset-2))))
 282                    ((conset-intersection)
 283                     `(let ((start (max (conset-min conset-1)
 284                                        (conset-min conset-2)))
 285                            (end (min (conset-max conset-1)
 286                                      (conset-max conset-2))))
 287                        (setf (conset-min conset-1)
 288                              (if (> start end)
 289                                  0
 290                                  (or (position 1 (conset-vector conset-1)
 291                                                :start start :end end)
 292                                      0))
 293                              (conset-max conset-1)
 294                              (if (> start end)
 295                                  0
 296                                  (let ((position
 297                                         (position
 298                                          1 (conset-vector conset-1)
 299                                          :start start :end end :from-end t)))
 300                                    (if position
 301                                        (1+ position)
 302                                        0))))))
 303                    ((conset-difference)
 304                     `(setf (conset-min conset-1)
 305                            (or (position 1 (conset-vector conset-1)
 306                                          :start (conset-min conset-1)
 307                                          :end (conset-max conset-1))
 308                                0)
 309                            (conset-max conset-1)
 310                            (let ((position
 311                                   (position
 312                                    1 (conset-vector conset-1)
 313                                    :start (conset-min conset-1)
 314                                    :end (conset-max conset-1)
 315                                    :from-end t)))
 316                              (if position
 317                                  (1+ position)
 318                                  0))))))
 319               (values))))
 320     (defconsetop conset-union bit-ior)
 321     (defconsetop conset-intersection bit-and)
 322     (defconsetop conset-difference bit-andc2)))
 323 \f
 324 ;;; Constraints are hash-consed. Unfortunately, types aren't, so we have
 325 ;;; to over-approximate and then linear search through the potential hits.
 326 ;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant
 327 ;;; and lambda-vars can only be found in EQL constraints.
 328
 329 (defun find-constraint (kind x y not-p)
 330   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
 331   (etypecase y
 332     (ctype
 333        (awhen (lambda-var-ctype-constraints x)
 334          (dolist (con (gethash (sb!kernel::type-class-info y) it) nil)
 335            (when (and (eq (constraint-kind con) kind)
 336                       (eq (constraint-not-p con) not-p)
 337                       (type= (constraint-y con) y))
 338              (return-from find-constraint con)))
 339          nil))
 340     (lvar
 341        (awhen (lambda-var-eq-constraints x)
 342          (gethash y it)))
 343     ((or constant lambda-var)
 344        (awhen (lambda-var-eq-constraints x)
 345          (let ((cache (gethash y it)))
 346            (declare (type list cache))
 347            (if not-p (cdr cache) (car cache)))))))
 348
 349 (defun register-constraint (x con y)
 350   (declare (type lambda-var x) (type constraint con) (type constraint-y y))
 351   (conset-adjoin con (lambda-var-constraints x))
 352   (macrolet ((ensuref (place default)
 353                `(or ,place (setf ,place ,default))))
 354     (etypecase y
 355       (ctype
 356          (let ((index (ensuref (lambda-var-ctype-constraints x)
 357                                (make-hash-table))))
 358            (push con (gethash (sb!kernel::type-class-info y) index))))
 359       (lvar
 360          (let ((index (ensuref (lambda-var-eq-constraints x)
 361                                (make-hash-table))))
 362            (setf (gethash y index) con)))
 363       ((or constant lambda-var)
 364          (let* ((index (ensuref (lambda-var-eq-constraints x)
 365                                 (make-hash-table)))
 366                 (cons  (ensuref (gethash y index) (list nil))))
 367            (if (constraint-not-p con)
 368                (setf (cdr cons) con)
 369                (setf (car cons) con))))))
 370   nil)
 371
 372 ;;; Return a constraint for the specified arguments. We only create a
 373 ;;; new constraint if there isn't already an equivalent old one,
 374 ;;; guaranteeing that all equivalent constraints are EQ. This
 375 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
 376 (defun find-or-create-constraint (kind x y not-p)
 377   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
 378   (or (find-constraint kind x y not-p)
 379       (let ((new (make-constraint (length *constraint-universe*)
 380                                   kind x y not-p)))
 381         (vector-push-extend new *constraint-universe*
 382                             (1+ (length *constraint-universe*)))
 383         (register-constraint x new y)
 384         (when (lambda-var-p y)
 385           (register-constraint y new x))
 386         new)))
 387
 388 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
 389 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
 390 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
 391 (defun ok-ref-lambda-var (ref)
 392   (declare (type ref ref))
 393   (let ((leaf (ref-leaf ref)))
 394     (when (and (lambda-var-p leaf)
 395                (lambda-var-constraints leaf))
 396       leaf)))
 397
 398 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
 399 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
 400 (defun ok-lvar-lambda-var (lvar constraints)
 401   (declare (type lvar lvar))
 402   (let ((use (lvar-uses lvar)))
 403     (cond ((ref-p use)
 404            (let ((lambda-var (ok-ref-lambda-var use)))
 405              (when lambda-var
 406                (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
 407                  (when (and constraint (conset-member constraint constraints))
 408                    lambda-var)))))
 409           ((cast-p use)
 410            (ok-lvar-lambda-var (cast-value use) constraints)))))
 411
 412 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
 413   (once-only ((var var))
 414     `(let ((,symbol ,var))
 415        (flet ((body-fun ()
 416                 ,@body))
 417          (body-fun)
 418          (do-conset-elements (con ,constraints ,result)
 419            (let ((other (and (eq (constraint-kind con) 'eql)
 420                              (eq (constraint-not-p con) nil)
 421                              (cond ((eq ,var (constraint-x con))
 422                                     (constraint-y con))
 423                                    ((eq ,var (constraint-y con))
 424                                     (constraint-x con))
 425                                    (t
 426                                     nil)))))
 427              (when other
 428                (setq ,symbol other)
 429                (when (lambda-var-p ,symbol)
 430                  (body-fun)))))))))
 431
 432 ;;;; Searching constraints
 433
 434 ;;; Add the indicated test constraint to BLOCK. We don't add the
 435 ;;; constraint if the block has multiple predecessors, since it only
 436 ;;; holds on this particular path.
 437 (defun add-test-constraint (fun x y not-p constraints target)
 438   (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
 439          (add-eql-var-var-constraint x y constraints target))
 440         (t
 441          (do-eql-vars (x (x constraints))
 442            (let ((con (find-or-create-constraint fun x y not-p)))
 443              (conset-adjoin con target)))))
 444   (values))
 445
 446 ;;; Add complementary constraints to the consequent and alternative
 447 ;;; blocks of IF. We do nothing if X is NIL.
 448 (defun add-complement-constraints (fun x y not-p constraints
 449                                    consequent-constraints
 450                                    alternative-constraints)
 451   (when x
 452     (add-test-constraint fun x y not-p constraints
 453                          consequent-constraints)
 454     (add-test-constraint fun x y (not not-p) constraints
 455                          alternative-constraints))
 456   (values))
 457
 458 ;;; Add test constraints to the consequent and alternative blocks of
 459 ;;; the test represented by USE.
 460 (defun add-test-constraints (use if constraints)
 461   (declare (type node use) (type cif if))
 462   ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
 463   ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
 464   ;; can't guarantee that the optimization will be done, so we still
 465   ;; need to avoid barfing on this case.
 466   (unless (eq (if-consequent if) (if-alternative if))
 467     (let ((consequent-constraints (make-conset))
 468           (alternative-constraints (make-conset)))
 469       (macrolet ((add (fun x y not-p)
 470                    `(add-complement-constraints ,fun ,x ,y ,not-p
 471                                                 constraints
 472                                                 consequent-constraints
 473                                                 alternative-constraints)))
 474         (typecase use
 475           (ref
 476            (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
 477                 (specifier-type 'null) t))
 478           (combination
 479            (unless (eq (combination-kind use)
 480                        :error)
 481              (let ((name (lvar-fun-name
 482                           (basic-combination-fun use)))
 483                    (args (basic-combination-args use)))
 484                (case name
 485                  ((%typep %instance-typep)
 486                   (let ((type (second args)))
 487                     (when (constant-lvar-p type)
 488                       (let ((val (lvar-value type)))
 489                         (add 'typep
 490                              (ok-lvar-lambda-var (first args) constraints)
 491                              (if (ctype-p val)
 492                                  val
 493                                  (let ((*compiler-error-context* use))
 494                                    (specifier-type val)))
 495                              nil)))))
 496                  ((eq eql)
 497                   (let* ((arg1 (first args))
 498                          (var1 (ok-lvar-lambda-var arg1 constraints))
 499                          (arg2 (second args))
 500                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 501                     ;; The code below assumes that the constant is the
 502                     ;; second argument in case of variable to constant
 503                     ;; comparision which is sometimes true (see source
 504                     ;; transformations for EQ, EQL and CHAR=). Fixing
 505                     ;; that would result in more constant substitutions
 506                     ;; which is not a universally good thing, thus the
 507                     ;; unnatural asymmetry of the tests.
 508                     (cond ((not var1)
 509                            (when var2
 510                              (add-test-constraint 'typep var2 (lvar-type arg1)
 511                                                   nil constraints
 512                                                   consequent-constraints)))
 513                           (var2
 514                            (add 'eql var1 var2 nil))
 515                           ((constant-lvar-p arg2)
 516                            (add 'eql var1
 517                                 (let ((use (principal-lvar-use arg2)))
 518                                   (if (ref-p use)
 519                                       (ref-leaf use)
 520                                       (find-constant (lvar-value arg2))))
 521                                 nil))
 522                           (t
 523                            (add-test-constraint 'typep var1 (lvar-type arg2)
 524                                                 nil constraints
 525                                                 consequent-constraints)))))
 526                  ((< >)
 527                   (let* ((arg1 (first args))
 528                          (var1 (ok-lvar-lambda-var arg1 constraints))
 529                          (arg2 (second args))
 530                          (var2 (ok-lvar-lambda-var arg2 constraints)))
 531                     (when var1
 532                       (add name var1 (lvar-type arg2) nil))
 533                     (when var2
 534                       (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
 535                  (t
 536                   (let ((ptype (gethash name *backend-predicate-types*)))
 537                     (when ptype
 538                       (add 'typep (ok-lvar-lambda-var (first args) constraints)
 539                            ptype nil))))))))))
 540       (values consequent-constraints alternative-constraints))))
 541
 542 ;;;; Applying constraints
 543
 544 ;;; Return true if X is an integer NUMERIC-TYPE.
 545 (defun integer-type-p (x)
 546   (declare (type ctype x))
 547   (and (numeric-type-p x)
 548        (eq (numeric-type-class x) 'integer)
 549        (eq (numeric-type-complexp x) :real)))
 550
 551 ;;; Given that an inequality holds on values of type X and Y, return a
 552 ;;; new type for X. If GREATER is true, then X was greater than Y,
 553 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
 554 ;;; inclusive, i.e. >=.
 555 ;;;
 556 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
 557 ;;; bound into X and return that result. If not OR-EQUAL, we can go
 558 ;;; one greater (less) than Y's bound.
 559 (defun constrain-integer-type (x y greater or-equal)
 560   (declare (type numeric-type x y))
 561   (flet ((exclude (x)
 562            (cond ((not x) nil)
 563                  (or-equal x)
 564                  (greater (1+ x))
 565                  (t (1- x))))
 566          (bound (x)
 567            (if greater (numeric-type-low x) (numeric-type-high x))))
 568     (let* ((x-bound (bound x))
 569            (y-bound (exclude (bound y)))
 570            (new-bound (cond ((not x-bound) y-bound)
 571                             ((not y-bound) x-bound)
 572                             (greater (max x-bound y-bound))
 573                             (t (min x-bound y-bound)))))
 574       (if greater
 575           (modified-numeric-type x :low new-bound)
 576           (modified-numeric-type x :high new-bound)))))
 577
 578 ;;; Return true if X is a float NUMERIC-TYPE.
 579 (defun float-type-p (x)
 580   (declare (type ctype x))
 581   (and (numeric-type-p x)
 582        (eq (numeric-type-class x) 'float)
 583        (eq (numeric-type-complexp x) :real)))
 584
 585 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 586 (defun constrain-float-type (x y greater or-equal)
 587   (declare (type numeric-type x y))
 588   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
 589
 590   (aver (eql (numeric-type-class x) 'float))
 591   (aver (eql (numeric-type-class y) 'float))
 592   #+sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 593   x
 594   #-sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 595   (labels ((exclude (x)
 596              (cond ((not x) nil)
 597                    (or-equal x)
 598                    (t
 599                     (if (consp x)
 600                         x
 601                         (list x)))))
 602            (bound (x)
 603              (if greater (numeric-type-low x) (numeric-type-high x)))
 604            (tighter-p (x ref)
 605              (cond ((null x) nil)
 606                    ((null ref) t)
 607                    ((and or-equal
 608                          (= (type-bound-number x) (type-bound-number ref)))
 609                     ;; X is tighter if REF is not an open bound and X is
 610                     (and (not (consp ref)) (consp x)))
 611                    (greater
 612                     (< (type-bound-number ref) (type-bound-number x)))
 613                    (t
 614                     (> (type-bound-number ref) (type-bound-number x))))))
 615     (let* ((x-bound (bound x))
 616            (y-bound (exclude (bound y)))
 617            (new-bound (cond ((not x-bound)
 618                              y-bound)
 619                             ((not y-bound)
 620                              x-bound)
 621                             ((tighter-p y-bound x-bound)
 622                              y-bound)
 623                             (t
 624                              x-bound))))
 625       (if greater
 626           (modified-numeric-type x :low new-bound)
 627           (modified-numeric-type x :high new-bound)))))
 628
 629 ;;; Return true if LEAF is "visible" from NODE.
 630 (defun leaf-visible-from-node-p (leaf node)
 631   (cond
 632    ((lambda-var-p leaf)
 633     ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an
 634     ;; ancestor for NODE.
 635     (let ((leaf-lambda (lambda-var-home leaf)))
 636       (loop for lambda = (node-home-lambda node)
 637             then (lambda-parent lambda)
 638             while lambda
 639             when (eq lambda leaf-lambda)
 640             return t)))
 641    ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes),
 642    ;; not just LAMBDA-VARs.
 643    (t
 644     ;; Assume everything else is globally visible.
 645     t)))
 646
 647 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 648 ;;; restrictions from flow analysis IN, set the type for REF
 649 ;;; accordingly.
 650 (defun constrain-ref-type (ref constraints in)
 651   (declare (type ref ref) (type conset constraints in))
 652   ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
 653   ;; cons up endless union types when propagating large number of EQL
 654   ;; constraints -- eg. from large CASE forms -- instead we just
 655   ;; directly accumulate one XSET, and a set of fp zeroes, which we at
 656   ;; the end turn into a MEMBER-TYPE.
 657   ;;
 658   ;; Since massive symbol cases are an especially atrocious pattern
 659   ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
 660   ;; a more useful type, don't propagate their negation except for NIL
 661   ;; unless SPEED > COMPILATION-SPEED.
 662   (let ((res (single-value-type (node-derived-type ref)))
 663         (constrain-symbols (policy ref (> speed compilation-speed)))
 664         (not-set (alloc-xset))
 665         (not-fpz nil)
 666         (not-res *empty-type*)
 667         (leaf (ref-leaf ref)))
 668     (flet ((note-not (x)
 669              (if (fp-zero-p x)
 670                  (push x not-fpz)
 671                  (when (or constrain-symbols (null x) (not (symbolp x)))
 672                    (add-to-xset x not-set)))))
 673       ;; KLUDGE: the implementations of DO-CONSET-INTERSECTION will
 674       ;; probably run faster when the smaller set comes first, so
 675       ;; don't change the order here.
 676       (do-conset-intersection (con constraints in)
 677         (let* ((x (constraint-x con))
 678                (y (constraint-y con))
 679                (not-p (constraint-not-p con))
 680                (other (if (eq x leaf) y x))
 681                (kind (constraint-kind con)))
 682           (case kind
 683             (typep
 684              (if not-p
 685                  (if (member-type-p other)
 686                      (mapc-member-type-members #'note-not other)
 687                      (setq not-res (type-union not-res other)))
 688                  (setq res (type-approx-intersection2 res other))))
 689             (eql
 690              (unless (lvar-p other)
 691                (let ((other-type (leaf-type other)))
 692                  (if not-p
 693                      (when (and (constant-p other)
 694                                 (member-type-p other-type))
 695                        (note-not (constant-value other)))
 696                      (let ((leaf-type (leaf-type leaf)))
 697                        (cond
 698                          ((or (constant-p other)
 699                               (and (leaf-refs other) ; protect from
 700                                         ; deleted vars
 701                                    (csubtypep other-type leaf-type)
 702                                    (not (type= other-type leaf-type))
 703                                    ;; Don't change to a LEAF not visible here.
 704                                    (leaf-visible-from-node-p other ref)))
 705                           (change-ref-leaf ref other)
 706                           (when (constant-p other) (return)))
 707                          (t
 708                           (setq res (type-approx-intersection2
 709                                      res other-type)))))))))
 710             ((< >)
 711              (cond
 712                ((and (integer-type-p res) (integer-type-p y))
 713                 (let ((greater (eq kind '>)))
 714                   (let ((greater (if not-p (not greater) greater)))
 715                     (setq res
 716                           (constrain-integer-type res y greater not-p)))))
 717                ((and (float-type-p res) (float-type-p y))
 718                 (let ((greater (eq kind '>)))
 719                   (let ((greater (if not-p (not greater) greater)))
 720                     (setq res
 721                           (constrain-float-type res y greater not-p)))))))))))
 722     (cond ((and (if-p (node-dest ref))
 723                 (or (xset-member-p nil not-set)
 724                     (csubtypep (specifier-type 'null) not-res)))
 725            (setf (node-derived-type ref) *wild-type*)
 726            (change-ref-leaf ref (find-constant t)))
 727           (t
 728            (setf not-res
 729                  (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
 730            (derive-node-type ref
 731                              (make-single-value-type
 732                               (or (type-difference res not-res)
 733                                   res)))
 734            (maybe-terminate-block ref nil))))
 735   (values))
 736
 737 ;;;; Flow analysis
 738
 739 (defun maybe-add-eql-var-lvar-constraint (ref gen)
 740   (let ((lvar (ref-lvar ref))
 741         (leaf (ref-leaf ref)))
 742     (when (and (lambda-var-p leaf) lvar)
 743       (conset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
 744                      gen))))
 745
 746 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
 747 ;;; LVAR) ones - to all of the variables in the VARS list.
 748 (defun inherit-constraints (vars from-var constraints target)
 749   (do-conset-elements (con constraints)
 750     ;; Constant substitution is controversial.
 751     (unless (constant-p (constraint-y con))
 752       (dolist (var vars)
 753         (let ((eq-x (eq from-var (constraint-x con)))
 754               (eq-y (eq from-var (constraint-y con))))
 755           (when (or (and eq-x (not (lvar-p (constraint-y con))))
 756                     eq-y)
 757             (conset-adjoin (find-or-create-constraint
 758                             (constraint-kind con)
 759                             (if eq-x var (constraint-x con))
 760                             (if eq-y var (constraint-y con))
 761                             (constraint-not-p con))
 762                            target)))))))
 763
 764 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
 765 ;; inherit each other's constraints.
 766 (defun add-eql-var-var-constraint (var1 var2 constraints
 767                                    &optional (target constraints))
 768   (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
 769     (when (conset-adjoin con target)
 770       (collect ((eql1) (eql2))
 771         (do-eql-vars (var1 (var1 constraints))
 772           (eql1 var1))
 773         (do-eql-vars (var2 (var2 constraints))
 774           (eql2 var2))
 775         (inherit-constraints (eql1) var2 constraints target)
 776         (inherit-constraints (eql2) var1 constraints target))
 777       t)))
 778
 779 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
 780 ;; LAMBDA-VAR if possible.
 781 (defun maybe-add-eql-var-var-constraint (var lvar constraints
 782                                          &optional (target constraints))
 783   (declare (type lambda-var var) (type lvar lvar))
 784   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
 785     (when lambda-var
 786       (add-eql-var-var-constraint var lambda-var constraints target))))
 787
 788 ;;; Local propagation
 789 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
 790 ;;;    constraint.]
 791 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
 792 ;;;    a type constraint based on the new value type.
 793 (declaim (ftype (function (cblock conset boolean)
 794                           conset)
 795                 constraint-propagate-in-block))
 796 (defun constraint-propagate-in-block (block gen preprocess-refs-p)
 797   (do-nodes (node lvar block)
 798     (typecase node
 799       (bind
 800        (let ((fun (bind-lambda node)))
 801          (when (eq (functional-kind fun) :let)
 802            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
 803                  for var in (lambda-vars fun)
 804                  and val in (combination-args call)
 805                  when (and val (lambda-var-constraints var))
 806                  do (let ((type (lvar-type val)))
 807                       (unless (eq type *universal-type*)
 808                         (let ((con (find-or-create-constraint 'typep var type nil)))
 809                           (conset-adjoin con gen))))
 810                     (maybe-add-eql-var-var-constraint var val gen)))))
 811       (ref
 812        (when (ok-ref-lambda-var node)
 813          (maybe-add-eql-var-lvar-constraint node gen)
 814          (when preprocess-refs-p
 815            (let* ((var (ref-leaf node))
 816                   (con (lambda-var-constraints var)))
 817              (constrain-ref-type node con gen)))))
 818       (cast
 819        (let ((lvar (cast-value node)))
 820          (let ((var (ok-lvar-lambda-var lvar gen)))
 821            (when var
 822              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
 823                (unless (eq atype *universal-type*)
 824                  (do-eql-vars (var (var gen))
 825                    (let ((con (find-or-create-constraint 'typep var atype nil)))
 826                      (conset-adjoin con gen)))))))))
 827       (cset
 828        (binding* ((var (set-var node))
 829                   (nil (lambda-var-p var) :exit-if-null)
 830                   (cons (lambda-var-constraints var) :exit-if-null))
 831          (conset-difference gen cons)
 832          (let ((type (single-value-type (node-derived-type node))))
 833            (unless (eq type *universal-type*)
 834              (let ((con (find-or-create-constraint 'typep var type nil)))
 835                (conset-adjoin con gen))))
 836          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
 837   gen)
 838
 839 (defun constraint-propagate-if (block gen)
 840   (let ((node (block-last block)))
 841     (when (if-p node)
 842       (let ((use (lvar-uses (if-test node))))
 843         (when (node-p use)
 844           (add-test-constraints use node gen))))))
 845
 846 ;;; Starting from IN compute OUT and (consequent/alternative
 847 ;;; constraints if the block ends with and IF). Return the list of
 848 ;;; successors that may need to be recomputed.
 849 (defun find-block-type-constraints (block final-pass-p)
 850   (declare (type cblock block))
 851   (let ((gen (constraint-propagate-in-block
 852               block
 853               (if final-pass-p
 854                   (block-in block)
 855                   (copy-conset (block-in block)))
 856               final-pass-p)))
 857     (setf (block-gen block) gen)
 858     (multiple-value-bind (consequent-constraints alternative-constraints)
 859         (constraint-propagate-if block gen)
 860       (if consequent-constraints
 861           (let* ((node (block-last block))
 862                  (old-consequent-constraints (if-consequent-constraints node))
 863                  (old-alternative-constraints (if-alternative-constraints node))
 864                  (succ ()))
 865             ;; Add the consequent and alternative constraints to GEN.
 866             (cond ((conset-empty consequent-constraints)
 867                    (setf (if-consequent-constraints node) gen)
 868                    (setf (if-alternative-constraints node) gen))
 869                   (t
 870                    (setf (if-consequent-constraints node) (copy-conset gen))
 871                    (conset-union (if-consequent-constraints node)
 872                                  consequent-constraints)
 873                    (setf (if-alternative-constraints node) gen)
 874                    (conset-union (if-alternative-constraints node)
 875                                  alternative-constraints)))
 876             ;; Has the consequent been changed?
 877             (unless (and old-consequent-constraints
 878                          (conset= (if-consequent-constraints node)
 879                                   old-consequent-constraints))
 880               (push (if-consequent node) succ))
 881             ;; Has the alternative been changed?
 882             (unless (and old-alternative-constraints
 883                          (conset= (if-alternative-constraints node)
 884                                   old-alternative-constraints))
 885               (push (if-alternative node) succ))
 886             succ)
 887           ;; There is no IF.
 888           (unless (and (block-out block)
 889                        (conset= gen (block-out block)))
 890             (setf (block-out block) gen)
 891             (block-succ block))))))
 892
 893 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 894 ;;; During this pass, we also do local constraint propagation by
 895 ;;; adding in constraints as we see them during the pass through the
 896 ;;; block.
 897 (defun use-result-constraints (block)
 898   (declare (type cblock block))
 899   (constraint-propagate-in-block block (block-in block) t))
 900
 901 ;;; Give an empty constraints set to any var that doesn't have one and
 902 ;;; isn't a set closure var. Since a var that we previously rejected
 903 ;;; looks identical to one that is new, so we optimistically keep
 904 ;;; hoping that vars stop being closed over or lose their sets.
 905 (defun init-var-constraints (component)
 906   (declare (type component component))
 907   (dolist (fun (component-lambdas component))
 908     (flet ((frob (x)
 909              (dolist (var (lambda-vars x))
 910                (unless (lambda-var-constraints var)
 911                  (when (or (null (lambda-var-sets var))
 912                            (not (closure-var-p var)))
 913                    (setf (lambda-var-constraints var) (make-conset)))))))
 914       (frob fun)
 915       (dolist (let (lambda-lets fun))
 916         (frob let)))))
 917
 918 ;;; Return the constraints that flow from PRED to SUCC. This is
 919 ;;; BLOCK-OUT unless PRED ends with an IF and test constraints were
 920 ;;; added.
 921 (defun block-out-for-successor (pred succ)
 922   (declare (type cblock pred succ))
 923   (let ((last (block-last pred)))
 924     (or (when (if-p last)
 925           (cond ((eq succ (if-consequent last))
 926                  (if-consequent-constraints last))
 927                 ((eq succ (if-alternative last))
 928                  (if-alternative-constraints last))))
 929         (block-out pred))))
 930
 931 (defun compute-block-in (block)
 932   (let ((in nil))
 933     (dolist (pred (block-pred block))
 934       ;; If OUT has not been calculated, assume it to be the universal
 935       ;; set.
 936       (let ((out (block-out-for-successor pred block)))
 937         (when out
 938           (if in
 939               (conset-intersection in out)
 940               (setq in (copy-conset out))))))
 941     (or in (make-conset))))
 942
 943 (defun update-block-in (block)
 944   (let ((in (compute-block-in block)))
 945     (cond ((and (block-in block) (conset= in (block-in block)))
 946            nil)
 947           (t
 948            (setf (block-in block) in)))))
 949
 950 ;;; Return two lists: one of blocks that precede all loops and
 951 ;;; therefore require only one constraint propagation pass and the
 952 ;;; rest. This implementation does not find all such blocks.
 953 ;;;
 954 ;;; A more complete implementation would be:
 955 ;;;
 956 ;;;     (do-blocks (block component)
 957 ;;;       (if (every #'(lambda (pred)
 958 ;;;                      (or (member pred leading-blocks)
 959 ;;;                          (eq pred head)))
 960 ;;;                  (block-pred block))
 961 ;;;           (push block leading-blocks)
 962 ;;;           (push block rest-of-blocks)))
 963 ;;;
 964 ;;; Trailing blocks that succeed all loops could be found and handled
 965 ;;; similarly. In practice though, these more complex solutions are
 966 ;;; slightly worse performancewise.
 967 (defun leading-component-blocks (component)
 968   (declare (type component component))
 969   (flet ((loopy-p (block)
 970            (let ((n (block-number block)))
 971              (dolist (pred (block-pred block))
 972                (unless (< n (block-number pred))
 973                  (return t))))))
 974     (let ((leading-blocks ())
 975           (rest-of-blocks ())
 976           (seen-loop-p ()))
 977       (do-blocks (block component)
 978         (when (and (not seen-loop-p) (loopy-p block))
 979           (setq seen-loop-p t))
 980         (if seen-loop-p
 981             (push block rest-of-blocks)
 982             (push block leading-blocks)))
 983       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
 984
 985 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
 986 ;;; a member already.
 987 (defun nconc-new (obj list)
 988   (do ((x list (cdr x))
 989        (prev nil x))
 990       ((endp x) (if prev
 991                     (progn
 992                       (setf (cdr prev) (list obj))
 993                       list)
 994                     (list obj)))
 995     (when (eql (car x) obj)
 996       (return-from nconc-new list))))
 997
 998 (defun find-and-propagate-constraints (component)
 999   (let ((blocks-to-process ()))
1000     (flet ((enqueue (blocks)
1001              (dolist (block blocks)
1002                (setq blocks-to-process (nconc-new block blocks-to-process)))))
1003       (multiple-value-bind (leading-blocks rest-of-blocks)
1004           (leading-component-blocks component)
1005         ;; Update every block once to account for changes in the
1006         ;; IR1. The constraints of the lead blocks cannot be changed
1007         ;; after the first pass so we might as well use them and skip
1008         ;; USE-RESULT-CONSTRAINTS later.
1009         (dolist (block leading-blocks)
1010           (setf (block-in block) (compute-block-in block))
1011           (find-block-type-constraints block t))
1012         (setq blocks-to-process (copy-list rest-of-blocks))
1013         ;; The rest of the blocks.
1014         (dolist (block rest-of-blocks)
1015           (aver (eq block (pop blocks-to-process)))
1016           (setf (block-in block) (compute-block-in block))
1017           (enqueue (find-block-type-constraints block nil)))
1018         ;; Propagate constraints
1019         (loop for block = (pop blocks-to-process)
1020               while block do
1021               (unless (eq block (component-tail component))
1022                 (when (update-block-in block)
1023                   (enqueue (find-block-type-constraints block nil)))))
1024         rest-of-blocks))))
1025
1026 (defun constraint-propagate (component)
1027   (declare (type component component))
1028   (init-var-constraints component)
1029
1030   (unless (block-out (component-head component))
1031     (setf (block-out (component-head component)) (make-conset)))
1032
1033   (dolist (block (find-and-propagate-constraints component))
1034     (unless (block-delete-p block)
1035       (use-result-constraints block)))
1036
1037   (values))