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