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 (in-package "SB!C")
  15
  16 (defstruct (constraint
  17             (:include sset-element)
  18             (:constructor make-constraint (number kind x y not-p))
  19             (:copier nil))
  20   ;; the kind of constraint we have:
  21   ;;
  22   ;; TYPEP
  23   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
  24   ;;     constrained to be of type Y.
  25   ;;
  26   ;; > or <
  27   ;;     X is a lambda-var and Y is a CTYPE. The relation holds
  28   ;;     between X and some object of type Y.
  29   ;;
  30   ;; EQL
  31   ;;     X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT. The
  32   ;;     relation is asserted to hold.
  33   (kind nil :type (member typep < > eql))
  34   ;; The operands to the relation.
  35   (x nil :type lambda-var)
  36   (y nil :type (or ctype lambda-var constant))
  37   ;; If true, negates the sense of the constraint, so the relation
  38   ;; does *not* hold.
  39   (not-p nil :type boolean))
  40
  41 (defvar *constraint-number*)
  42
  43 ;;; Return a constraint for the specified arguments. We only create a
  44 ;;; new constraint if there isn't already an equivalent old one,
  45 ;;; guaranteeing that all equivalent constraints are EQ. This
  46 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
  47 (defun find-constraint (kind x y not-p)
  48   (declare (type lambda-var x) (type (or constant lambda-var ctype) y)
  49            (type boolean not-p))
  50   (or (etypecase y
  51         (ctype
  52          (do-sset-elements (con (lambda-var-constraints x) nil)
  53            (when (and (eq (constraint-kind con) kind)
  54                       (eq (constraint-not-p con) not-p)
  55                       (type= (constraint-y con) y))
  56              (return con))))
  57         (constant
  58          (do-sset-elements (con (lambda-var-constraints x) nil)
  59            (when (and (eq (constraint-kind con) kind)
  60                       (eq (constraint-not-p con) not-p)
  61                       (eq (constraint-y con) y))
  62              (return con))))
  63         (lambda-var
  64          (do-sset-elements (con (lambda-var-constraints x) nil)
  65            (when (and (eq (constraint-kind con) kind)
  66                       (eq (constraint-not-p con) not-p)
  67                       (let ((cx (constraint-x con)))
  68                         (eq (if (eq cx x)
  69                                 (constraint-y con)
  70                                 cx)
  71                             y)))
  72              (return con)))))
  73       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
  74         (sset-adjoin new (lambda-var-constraints x))
  75         (when (lambda-var-p y)
  76           (sset-adjoin new (lambda-var-constraints y)))
  77         new)))
  78
  79 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
  80 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
  81 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
  82 (defun ok-ref-lambda-var (ref)
  83   (declare (type ref ref))
  84   (let ((leaf (ref-leaf ref)))
  85     (when (and (lambda-var-p leaf)
  86                (lambda-var-constraints leaf))
  87       leaf)))
  88
  89 ;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
  90 ;;; otherwise NIL.
  91 #!-sb-fluid (declaim (inline ok-cont-lambda-var))
  92 (defun ok-cont-lambda-var (cont)
  93   (declare (type continuation cont))
  94   (let ((use (continuation-use cont)))
  95     (when (ref-p use)
  96       (ok-ref-lambda-var use))))
  97
  98 ;;; Add the indicated test constraint to BLOCK, marking the block as
  99 ;;; having a new assertion when the constriant was not already
 100 ;;; present. We don't add the constraint if the block has multiple
 101 ;;; predecessors, since it only holds on this particular path.
 102 (defun add-test-constraint (block fun x y not-p)
 103   (unless (rest (block-pred block))
 104     (let ((con (find-constraint fun x y not-p))
 105           (old (or (block-test-constraint block)
 106                    (setf (block-test-constraint block) (make-sset)))))
 107       (when (sset-adjoin con old)
 108         (setf (block-type-asserted block) t))))
 109   (values))
 110
 111 ;;; Add complementary constraints to the consequent and alternative
 112 ;;; blocks of IF. We do nothing if X is NIL.
 113 #!-sb-fluid (declaim (inline add-complement-constraints))
 114 (defun add-complement-constraints (if fun x y not-p)
 115   (when x
 116     (add-test-constraint (if-consequent if) fun x y not-p)
 117     (add-test-constraint (if-alternative if) fun x y (not not-p)))
 118   (values))
 119
 120 ;;; Add test constraints to the consequent and alternative blocks of
 121 ;;; the test represented by USE.
 122 (defun add-test-constraints (use if)
 123   (declare (type node use) (type cif if))
 124   (typecase use
 125     (ref
 126      (add-complement-constraints if 'typep (ok-ref-lambda-var use)
 127                                  (specifier-type 'null) t))
 128     (combination
 129      (let ((name (continuation-function-name
 130                   (basic-combination-fun use)))
 131            (args (basic-combination-args use)))
 132        (case name
 133          ((%typep %instance-typep)
 134           (let ((type (second args)))
 135             (when (constant-continuation-p type)
 136               (let ((val (continuation-value type)))
 137               (add-complement-constraints if 'typep
 138                                           (ok-cont-lambda-var (first args))
 139                                           (if (ctype-p val)
 140                                               val
 141                                               (specifier-type val))
 142                                           nil)))))
 143          ((eq eql)
 144           (let* ((var1 (ok-cont-lambda-var (first args)))
 145                  (arg2 (second args))
 146                  (var2 (ok-cont-lambda-var arg2)))
 147             (cond ((not var1))
 148                   (var2
 149                    (add-complement-constraints if 'eql var1 var2 nil))
 150                   ((constant-continuation-p arg2)
 151                    (add-complement-constraints if 'eql var1
 152                                                (ref-leaf
 153                                                 (continuation-use arg2))
 154                                                nil)))))
 155          ((< >)
 156           (let* ((arg1 (first args))
 157                  (var1 (ok-cont-lambda-var arg1))
 158                  (arg2 (second args))
 159                  (var2 (ok-cont-lambda-var arg2)))
 160             (when var1
 161               (add-complement-constraints if name var1 (continuation-type arg2)
 162                                           nil))
 163             (when var2
 164               (add-complement-constraints if (if (eq name '<) '> '<)
 165                                           var2 (continuation-type arg1)
 166                                           nil))))
 167          (t
 168           (let ((ptype (gethash name *backend-predicate-types*)))
 169             (when ptype
 170               (add-complement-constraints if 'typep
 171                                           (ok-cont-lambda-var (first args))
 172                                           ptype nil))))))))
 173   (values))
 174
 175 ;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
 176 ;;; the condition it tests.
 177 (defun find-test-constraints (block)
 178   (declare (type cblock block))
 179   (let ((last (block-last block)))
 180     (when (if-p last)
 181       (let ((use (continuation-use (if-test last))))
 182         (when use
 183           (add-test-constraints use last)))))
 184
 185   (setf (block-test-modified block) nil)
 186   (values))
 187
 188 ;;; Compute the initial flow analysis sets for BLOCK:
 189 ;;; -- For any lambda-var ref with a type check, add that constraint.
 190 ;;; -- For any lambda-var set, delete all constraints on that var, and add
 191 ;;;    those constraints to the set nuked by this block.
 192 (defun find-block-type-constraints (block)
 193   (declare (type cblock block))
 194   (let ((gen (make-sset)))
 195     (collect ((kill nil adjoin))
 196
 197       (let ((test (block-test-constraint block)))
 198         (when test
 199           (sset-union gen test)))
 200
 201       (do-nodes (node cont block)
 202         (typecase node
 203           (ref
 204            (when (continuation-type-check cont)
 205              (let ((var (ok-ref-lambda-var node)))
 206                (when var
 207                  (let* ((atype (continuation-derived-type cont))
 208                         (con (find-constraint 'typep var atype nil)))
 209                    (sset-adjoin con gen))))))
 210           (cset
 211            (let ((var (set-var node)))
 212              (when (lambda-var-p var)
 213                (kill var)
 214                (let ((cons (lambda-var-constraints var)))
 215                  (when cons
 216                    (sset-difference gen cons))))))))
 217
 218       (setf (block-in block) nil)
 219       (setf (block-gen block) gen)
 220       (setf (block-kill block) (kill))
 221       (setf (block-out block) (copy-sset gen))
 222       (setf (block-type-asserted block) nil)
 223       (values))))
 224
 225 ;;; Return true if X is an integer NUMERIC-TYPE.
 226 (defun integer-type-p (x)
 227   (declare (type ctype x))
 228   (and (numeric-type-p x)
 229        (eq (numeric-type-class x) 'integer)
 230        (eq (numeric-type-complexp x) :real)))
 231
 232 ;;; Given that an inequality holds on values of type X and Y, return a
 233 ;;; new type for X. If GREATER is true, then X was greater than Y,
 234 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
 235 ;;; inclusive, i.e. >=.
 236 ;;;
 237 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
 238 ;;; bound into X and return that result. If not OR-EQUAL, we can go
 239 ;;; one greater (less) than Y's bound.
 240 (defun constrain-integer-type (x y greater or-equal)
 241   (declare (type numeric-type x y))
 242   (flet ((exclude (x)
 243            (cond ((not x) nil)
 244                  (or-equal x)
 245                  (greater (1+ x))
 246                  (t (1- x))))
 247          (bound (x)
 248            (if greater (numeric-type-low x) (numeric-type-high x))))
 249     (let* ((x-bound (bound x))
 250            (y-bound (exclude (bound y)))
 251            (new-bound (cond ((not x-bound) y-bound)
 252                             ((not y-bound) x-bound)
 253                             (greater (max x-bound y-bound))
 254                             (t (min x-bound y-bound)))))
 255       (if greater
 256           (modified-numeric-type x :low new-bound)
 257           (modified-numeric-type x :high new-bound)))))
 258
 259 ;;; Return true if X is a float NUMERIC-TYPE.
 260 (defun float-type-p (x)
 261   (declare (type ctype x))
 262   (and (numeric-type-p x)
 263        (eq (numeric-type-class x) 'float)
 264        (eq (numeric-type-complexp x) :real)))
 265
 266 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
 267 (defun constrain-float-type (x y greater or-equal)
 268   (declare (type numeric-type x y))
 269   (declare (ignorable x y)) ; for CROSS-FLOAT-INFINITY-KLUDGE
 270   (aver (eql (numeric-type-class x) 'float))
 271   (aver (eql (numeric-type-class y) 'float))
 272   #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 273   x
 274   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 275   (labels ((exclude (x)
 276              (cond ((not x) nil)
 277                    (or-equal x)
 278                    (greater
 279                     (if (consp x)
 280                         (car x)
 281                         x))
 282                    (t
 283                     (if (consp x)
 284                         x
 285                         (list x)))))
 286            (bound (x)
 287              (if greater (numeric-type-low x) (numeric-type-high x)))
 288            (max-lower-bound (x y)
 289              ;; Both X and Y are not null. Find the max.
 290              (let ((res (max (type-bound-number x) (type-bound-number y))))
 291                ;; An open lower bound is greater than a close
 292                ;; lower bound because the open bound doesn't
 293                ;; contain the bound, so choose an open lower
 294                ;; bound.
 295                (set-bound res (or (consp x) (consp y)))))
 296            (min-upper-bound (x y)
 297              ;; Same as above, but for the min of upper bounds
 298              ;; Both X and Y are not null. Find the min.
 299              (let ((res (min (type-bound-number x) (type-bound-number y))))
 300                ;; An open upper bound is less than a closed
 301                ;; upper bound because the open bound doesn't
 302                ;; contain the bound, so choose an open lower
 303                ;; bound.
 304                (set-bound res (or (consp x) (consp y))))))
 305     (let* ((x-bound (bound x))
 306            (y-bound (exclude (bound y)))
 307            (new-bound (cond ((not x-bound)
 308                              y-bound)
 309                             ((not y-bound)
 310                              x-bound)
 311                             (greater
 312                              (max-lower-bound x-bound y-bound))
 313                             (t
 314                              (min-upper-bound x-bound y-bound)))))
 315       (if greater
 316           (modified-numeric-type x :low new-bound)
 317           (modified-numeric-type x :high new-bound)))))
 318
 319 ;;; Given the set of CONSTRAINTS for a variable and the current set of
 320 ;;; restrictions from flow analysis IN, set the type for REF
 321 ;;; accordingly.
 322 (defun constrain-ref-type (ref constraints in)
 323   (declare (type ref ref) (type sset constraints in))
 324   (let ((var-cons (copy-sset constraints)))
 325     (sset-intersection var-cons in)
 326     (let ((res (single-value-type (node-derived-type ref)))
 327           (not-res *empty-type*)
 328           (leaf (ref-leaf ref)))
 329       (do-sset-elements (con var-cons)
 330         (let* ((x (constraint-x con))
 331                (y (constraint-y con))
 332                (not-p (constraint-not-p con))
 333                (other (if (eq x leaf) y x))
 334                (kind (constraint-kind con)))
 335           (case kind
 336             (typep
 337              (if not-p
 338                  (setq not-res (type-union not-res other))
 339                  (setq res (type-approx-intersection2 res other))))
 340             (eql
 341              (let ((other-type (leaf-type other)))
 342                (if not-p
 343                    (when (and (constant-p other)
 344                               (member-type-p other-type))
 345                      (setq not-res (type-union not-res other-type)))
 346                    (let ((leaf-type (leaf-type leaf)))
 347                      (when (or (constant-p other)
 348                                (and (csubtypep other-type leaf-type)
 349                                     (not (type= other-type leaf-type))))
 350                        (change-ref-leaf ref other)
 351                        (when (constant-p other) (return)))))))
 352             ((< >)
 353              (cond ((and (integer-type-p res) (integer-type-p y))
 354                     (let ((greater (eq kind '>)))
 355                       (let ((greater (if not-p (not greater) greater)))
 356                         (setq res
 357                               (constrain-integer-type res y greater not-p)))))
 358                    #!+sb-constrain-float-type
 359                    ((and (float-type-p res) (float-type-p y))
 360                     (let ((greater (eq kind '>)))
 361                       (let ((greater (if not-p (not greater) greater)))
 362                         (setq res
 363                               (constrain-float-type res y greater not-p)))))
 364                    )))))
 365
 366       (let* ((cont (node-cont ref))
 367              (dest (continuation-dest cont)))
 368         (cond ((and (if-p dest)
 369                     (csubtypep (specifier-type 'null) not-res)
 370                     (eq (continuation-asserted-type cont) *wild-type*))
 371                (setf (node-derived-type ref) *wild-type*)
 372                (change-ref-leaf ref (find-constant t)))
 373               (t
 374                (derive-node-type ref (or (type-difference res not-res)
 375                                          res)))))))
 376
 377   (values))
 378
 379 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
 380 ;;; During this pass, we also do local constraint propagation by
 381 ;;; adding in constraints as we seem them during the pass through the
 382 ;;; block.
 383 (defun use-result-constraints (block)
 384   (declare (type cblock block))
 385   (let ((in (block-in block)))
 386
 387     (let ((test (block-test-constraint block)))
 388       (when test
 389         (sset-union in test)))
 390
 391     (do-nodes (node cont block)
 392       (typecase node
 393         (ref
 394          (let ((var (ref-leaf node)))
 395            (when (lambda-var-p var)
 396              (let ((con (lambda-var-constraints var)))
 397                (when con
 398                  (constrain-ref-type node con in)
 399                  (when (continuation-type-check cont)
 400                    (sset-adjoin
 401                     (find-constraint 'typep var
 402                                      (continuation-asserted-type cont)
 403                                      nil)
 404                     in)))))))
 405         (cset
 406          (let ((var (set-var node)))
 407            (when (lambda-var-p var)
 408              (let ((cons (lambda-var-constraints var)))
 409                (when cons
 410                  (sset-difference in cons))))))))))
 411
 412 ;;; Return true if VAR would have to be closed over if environment
 413 ;;; analysis ran now (i.e. if there are any uses that have a different
 414 ;;; home lambda than VAR's home.)
 415 (defun closure-var-p (var)
 416   (declare (type lambda-var var))
 417   (let ((home (lambda-home (lambda-var-home var))))
 418     (flet ((frob (l)
 419              (dolist (node l nil)
 420                (unless (eq (node-home-lambda node) home)
 421                  (return t)))))
 422       (or (frob (leaf-refs var))
 423           (frob (basic-var-sets var))))))
 424
 425 ;;; Give an empty constraints set to any var that doesn't have one and
 426 ;;; isn't a set closure var. Since a var that we previously rejected
 427 ;;; looks identical to one that is new, so we optimistically keep
 428 ;;; hoping that vars stop being closed over or lose their sets.
 429 (defun init-var-constraints (component)
 430   (declare (type component component))
 431   (dolist (fun (component-lambdas component))
 432     (flet ((frob (x)
 433              (dolist (var (lambda-vars x))
 434                (unless (lambda-var-constraints var)
 435                  (when (or (null (lambda-var-sets var))
 436                            (not (closure-var-p var)))
 437                    (setf (lambda-var-constraints var) (make-sset)))))))
 438       (frob fun)
 439       (dolist (let (lambda-lets fun))
 440         (frob let)))))
 441
 442 ;;; BLOCK-IN becomes the intersection of the OUT of the prececessors.
 443 ;;; Our OUT is:
 444 ;;;     out U (in - kill)
 445 ;;;
 446 ;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must
 447 ;;; compute the kill set when there are any vars killed. We bum this a
 448 ;;; bit by special-casing when only one var is killed, and just using
 449 ;;; that var's constraints as the kill set. This set could possibly be
 450 ;;; precomputed, but it would have to be invalidated whenever any
 451 ;;; constraint is added, which would be a pain.
 452 (defun flow-propagate-constraints (block)
 453   (let* ((pred (block-pred block))
 454          (in (cond (pred
 455                     (let ((res (copy-sset (block-out (first pred)))))
 456                       (dolist (b (rest pred))
 457                         (sset-intersection res (block-out b)))
 458                       res))
 459                    (t
 460                     (when *check-consistency*
 461                       (let ((*compiler-error-context* (block-last block)))
 462                         (compiler-warning
 463                          "*** Unreachable code in constraint ~
 464                           propagation... Bug?")))
 465                     (make-sset))))
 466          (kill (block-kill block))
 467          (out (block-out block)))
 468
 469     (setf (block-in block) in)
 470     (cond ((null kill)
 471            (sset-union (block-out block) in))
 472           ((null (rest kill))
 473            (let ((con (lambda-var-constraints (first kill))))
 474              (if con
 475                  (sset-union-of-difference out in con)
 476                  (sset-union out in))))
 477           (t
 478            (let ((kill-set (make-sset)))
 479              (dolist (var kill)
 480                (let ((con (lambda-var-constraints var)))
 481                  (when con
 482                    (sset-union kill-set con))))
 483              (sset-union-of-difference (block-out block) in kill-set))))))
 484
 485 (defun constraint-propagate (component)
 486   (declare (type component component))
 487   (init-var-constraints component)
 488
 489   (do-blocks (block component)
 490     (when (block-test-modified block)
 491       (find-test-constraints block)))
 492
 493   (do-blocks (block component)
 494     (cond ((block-type-asserted block)
 495            (find-block-type-constraints block))
 496           (t
 497            (setf (block-in block) nil)
 498            (setf (block-out block) (copy-sset (block-gen block))))))
 499
 500   (setf (block-out (component-head component)) (make-sset))
 501
 502   (let ((did-something nil))
 503     (loop
 504       (do-blocks (block component)
 505         (when (flow-propagate-constraints block)
 506           (setq did-something t)))
 507
 508       (unless did-something (return))
 509       (setq did-something nil)))
 510
 511   (do-blocks (block component)
 512     (use-result-constraints block))
 513
 514   (values))
 515