1 ;;;; This file implements the constraint propagation phase of the
2 ;;;; compiler, which uses global flow analysis to obtain dynamic type
5 ;;;; This software is part of the SBCL system. See the README file for
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.
18 ;;; -- MV-BIND, :ASSIGNMENT
22 ;;; -- Constraint propagation badly interacts with bottom-up type
23 ;;; inference. Consider
25 ;;; (defun foo (n &aux (i 42))
26 ;;; (declare (optimize speed))
27 ;;; (declare (fixnum n)
28 ;;; #+nil (type (integer 0) i))
32 ;;; (when (>= i n) (go :exit))
37 ;;; In this case CP cannot even infer that I is of class INTEGER.
39 ;;; -- In the above example if we place the check after SETQ, CP will
40 ;;; fail to infer (< I FIXNUM): is does not understand that this
41 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
45 ;;; -- this code does not check whether SET appears between REF and a
50 (defstruct (constraint
51 (:include sset-element)
52 (:constructor make-constraint (number kind x y not-p))
54 ;; the kind of constraint we have:
57 ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
58 ;; constrained to be of type Y.
61 ;; X is a lambda-var and Y is a CTYPE. The relation holds
62 ;; between X and some object of type Y.
65 ;; X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT. The
66 ;; relation is asserted to hold.
67 (kind nil :type (member typep < > eql))
68 ;; The operands to the relation.
69 (x nil :type lambda-var)
70 (y nil :type (or ctype lambda-var constant))
71 ;; If true, negates the sense of the constraint, so the relation
73 (not-p nil :type boolean))
75 (defvar *constraint-number*)
77 ;;; Return a constraint for the specified arguments. We only create a
78 ;;; new constraint if there isn't already an equivalent old one,
79 ;;; guaranteeing that all equivalent constraints are EQ. This
80 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
81 (defun find-constraint (kind x y not-p)
82 (declare (type lambda-var x) (type (or constant lambda-var ctype) y)
86 (do-sset-elements (con (lambda-var-constraints x) nil)
87 (when (and (eq (constraint-kind con) kind)
88 (eq (constraint-not-p con) not-p)
89 (type= (constraint-y con) y))
92 (do-sset-elements (con (lambda-var-constraints x) nil)
93 (when (and (eq (constraint-kind con) kind)
94 (eq (constraint-not-p con) not-p)
95 (eq (constraint-y con) y))
98 (do-sset-elements (con (lambda-var-constraints x) nil)
99 (when (and (eq (constraint-kind con) kind)
100 (eq (constraint-not-p con) not-p)
101 (let ((cx (constraint-x con)))
107 (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
108 (sset-adjoin new (lambda-var-constraints x))
109 (when (lambda-var-p y)
110 (sset-adjoin new (lambda-var-constraints y)))
113 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
114 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
115 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
116 (defun ok-ref-lambda-var (ref)
117 (declare (type ref ref))
118 (let ((leaf (ref-leaf ref)))
119 (when (and (lambda-var-p leaf)
120 (lambda-var-constraints leaf))
123 ;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
125 #!-sb-fluid (declaim (inline ok-cont-lambda-var))
126 (defun ok-cont-lambda-var (cont)
127 (declare (type continuation cont))
128 (let ((use (continuation-use cont)))
130 (ok-ref-lambda-var use))))
132 ;;;; Searching constraints
134 ;;; Add the indicated test constraint to BLOCK, marking the block as
135 ;;; having a new assertion when the constriant was not already
136 ;;; present. We don't add the constraint if the block has multiple
137 ;;; predecessors, since it only holds on this particular path.
138 (defun add-test-constraint (block fun x y not-p)
139 (unless (rest (block-pred block))
140 (let ((con (find-constraint fun x y not-p))
141 (old (or (block-test-constraint block)
142 (setf (block-test-constraint block) (make-sset)))))
143 (when (sset-adjoin con old)
144 (setf (block-type-asserted block) t))))
147 ;;; Add complementary constraints to the consequent and alternative
148 ;;; blocks of IF. We do nothing if X is NIL.
149 (defun add-complement-constraints (if fun x y not-p)
151 ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
152 ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
153 ;; that we can't guarantee that the optimization will be
154 ;; done, so we still need to avoid barfing on this case.
155 (not (eq (if-consequent if)
156 (if-alternative if))))
157 (add-test-constraint (if-consequent if) fun x y not-p)
158 (add-test-constraint (if-alternative if) fun x y (not not-p)))
161 ;;; Add test constraints to the consequent and alternative blocks of
162 ;;; the test represented by USE.
163 (defun add-test-constraints (use if)
164 (declare (type node use) (type cif if))
167 (add-complement-constraints if 'typep (ok-ref-lambda-var use)
168 (specifier-type 'null) t))
170 (unless (eq (combination-kind use)
172 (let ((name (continuation-fun-name
173 (basic-combination-fun use)))
174 (args (basic-combination-args use)))
176 ((%typep %instance-typep)
177 (let ((type (second args)))
178 (when (constant-continuation-p type)
179 (let ((val (continuation-value type)))
180 (add-complement-constraints if 'typep
181 (ok-cont-lambda-var (first args))
184 (specifier-type val))
187 (let* ((var1 (ok-cont-lambda-var (first args)))
189 (var2 (ok-cont-lambda-var arg2)))
192 (add-complement-constraints if 'eql var1 var2 nil))
193 ((constant-continuation-p arg2)
194 (add-complement-constraints if 'eql var1
196 (continuation-use arg2))
199 (let* ((arg1 (first args))
200 (var1 (ok-cont-lambda-var arg1))
202 (var2 (ok-cont-lambda-var arg2)))
204 (add-complement-constraints if name var1 (continuation-type arg2)
207 (add-complement-constraints if (if (eq name '<) '> '<)
208 var2 (continuation-type arg1)
211 (let ((ptype (gethash name *backend-predicate-types*)))
213 (add-complement-constraints if 'typep
214 (ok-cont-lambda-var (first args))
218 ;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
219 ;;; the condition it tests.
220 (defun find-test-constraints (block)
221 (declare (type cblock block))
222 (let ((last (block-last block)))
224 (let ((use (continuation-use (if-test last))))
226 (add-test-constraints use last)))))
228 (setf (block-test-modified block) nil)
231 ;;;; Applying constraints
233 ;;; Return true if X is an integer NUMERIC-TYPE.
234 (defun integer-type-p (x)
235 (declare (type ctype x))
236 (and (numeric-type-p x)
237 (eq (numeric-type-class x) 'integer)
238 (eq (numeric-type-complexp x) :real)))
240 ;;; Given that an inequality holds on values of type X and Y, return a
241 ;;; new type for X. If GREATER is true, then X was greater than Y,
242 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
243 ;;; inclusive, i.e. >=.
245 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
246 ;;; bound into X and return that result. If not OR-EQUAL, we can go
247 ;;; one greater (less) than Y's bound.
248 (defun constrain-integer-type (x y greater or-equal)
249 (declare (type numeric-type x y))
256 (if greater (numeric-type-low x) (numeric-type-high x))))
257 (let* ((x-bound (bound x))
258 (y-bound (exclude (bound y)))
259 (new-bound (cond ((not x-bound) y-bound)
260 ((not y-bound) x-bound)
261 (greater (max x-bound y-bound))
262 (t (min x-bound y-bound)))))
264 (modified-numeric-type x :low new-bound)
265 (modified-numeric-type x :high new-bound)))))
267 ;;; Return true if X is a float NUMERIC-TYPE.
268 (defun float-type-p (x)
269 (declare (type ctype x))
270 (and (numeric-type-p x)
271 (eq (numeric-type-class x) 'float)
272 (eq (numeric-type-complexp x) :real)))
274 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
275 (defun constrain-float-type (x y greater or-equal)
276 (declare (type numeric-type x y))
277 (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
279 (aver (eql (numeric-type-class x) 'float))
280 (aver (eql (numeric-type-class y) 'float))
281 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
283 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
284 (labels ((exclude (x)
296 (if greater (numeric-type-low x) (numeric-type-high x)))
297 (max-lower-bound (x y)
298 ;; Both X and Y are not null. Find the max.
299 (let ((res (max (type-bound-number x) (type-bound-number y))))
300 ;; An open lower bound is greater than a close
301 ;; lower bound because the open bound doesn't
302 ;; contain the bound, so choose an open lower
304 (set-bound res (or (consp x) (consp y)))))
305 (min-upper-bound (x y)
306 ;; Same as above, but for the min of upper bounds
307 ;; Both X and Y are not null. Find the min.
308 (let ((res (min (type-bound-number x) (type-bound-number y))))
309 ;; An open upper bound is less than a closed
310 ;; upper bound because the open bound doesn't
311 ;; contain the bound, so choose an open lower
313 (set-bound res (or (consp x) (consp y))))))
314 (let* ((x-bound (bound x))
315 (y-bound (exclude (bound y)))
316 (new-bound (cond ((not x-bound)
321 (max-lower-bound x-bound y-bound))
323 (min-upper-bound x-bound y-bound)))))
325 (modified-numeric-type x :low new-bound)
326 (modified-numeric-type x :high new-bound)))))
328 ;;; Given the set of CONSTRAINTS for a variable and the current set of
329 ;;; restrictions from flow analysis IN, set the type for REF
331 (defun constrain-ref-type (ref constraints in)
332 (declare (type ref ref) (type sset constraints in))
333 (let ((var-cons (copy-sset constraints)))
334 (sset-intersection var-cons in)
335 (let ((res (single-value-type (node-derived-type ref)))
336 (not-res *empty-type*)
337 (leaf (ref-leaf ref)))
338 (do-sset-elements (con var-cons)
339 (let* ((x (constraint-x con))
340 (y (constraint-y con))
341 (not-p (constraint-not-p con))
342 (other (if (eq x leaf) y x))
343 (kind (constraint-kind con)))
347 (setq not-res (type-union not-res other))
348 (setq res (type-approx-intersection2 res other))))
350 (let ((other-type (leaf-type other)))
352 (when (and (constant-p other)
353 (member-type-p other-type))
354 (setq not-res (type-union not-res other-type)))
355 (let ((leaf-type (leaf-type leaf)))
356 (when (or (constant-p other)
357 (and (csubtypep other-type leaf-type)
358 (not (type= other-type leaf-type))))
359 (change-ref-leaf ref other)
360 (when (constant-p other) (return)))))))
362 (cond ((and (integer-type-p res) (integer-type-p y))
363 (let ((greater (eq kind '>)))
364 (let ((greater (if not-p (not greater) greater)))
366 (constrain-integer-type res y greater not-p)))))
367 ((and (float-type-p res) (float-type-p y))
368 (let ((greater (eq kind '>)))
369 (let ((greater (if not-p (not greater) greater)))
371 (constrain-float-type res y greater not-p)))))
374 (let* ((cont (node-cont ref))
375 (dest (continuation-dest cont)))
376 (cond ((and (if-p dest)
377 (csubtypep (specifier-type 'null) not-res))
378 (setf (node-derived-type ref) *wild-type*)
379 (change-ref-leaf ref (find-constant t)))
381 (derive-node-type ref
382 (make-single-value-type
383 (or (type-difference res not-res)
390 ;;; Local propagation
391 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
393 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
394 ;;; a type constraint based on the new value type.
395 (declaim (ftype (function (cblock sset
396 &key (:ref-preprocessor function)
397 (:set-preprocessor function))
399 constraint-propagate-in-block))
400 (defun constraint-propagate-in-block
401 (block gen &key ref-preprocessor set-preprocessor)
403 (let ((test (block-test-constraint block)))
405 (sset-union gen test)))
407 (do-nodes (node cont block)
410 (let ((fun (bind-lambda node)))
411 (when (eq (functional-kind fun) :let)
412 (loop with call = (continuation-dest
413 (node-cont (first (lambda-refs fun))))
414 for var in (lambda-vars fun)
415 and val in (combination-args call)
417 (lambda-var-constraints var)
418 ;; if VAR has no SETs, type inference is
419 ;; fully performed by IR1 optimizer
420 (lambda-var-sets var))
421 do (let* ((type (continuation-type val))
422 (con (find-constraint 'typep var type nil)))
423 (sset-adjoin con gen))))))
425 (let ((var (ok-ref-lambda-var node)))
427 (when ref-preprocessor
428 (funcall ref-preprocessor node gen))
429 (let ((dest (continuation-dest cont)))
431 (let* ((atype (single-value-type (cast-derived-type dest))) ; FIXME
432 (con (find-constraint 'typep var atype nil)))
433 (sset-adjoin con gen)))))))
435 (binding* ((var (set-var node))
436 (nil (lambda-var-p var) :exit-if-null)
437 (cons (lambda-var-constraints var) :exit-if-null))
438 (when set-preprocessor
439 (funcall set-preprocessor var))
440 (sset-difference gen cons)
441 (let* ((type (single-value-type (node-derived-type node)))
442 (con (find-constraint 'typep var type nil)))
443 (sset-adjoin con gen))))))
447 ;;; BLOCK-KILL is just a list of the LAMBDA-VARs killed, so we must
448 ;;; compute the kill set when there are any vars killed. We bum this a
449 ;;; bit by special-casing when only one var is killed, and just using
450 ;;; that var's constraints as the kill set. This set could possibly be
451 ;;; precomputed, but it would have to be invalidated whenever any
452 ;;; constraint is added, which would be a pain.
453 (defun compute-block-out (block)
454 (declare (type cblock block))
455 (let ((in (block-in block))
456 (kill (block-kill block))
457 (out (copy-sset (block-gen block))))
461 (let ((con (lambda-var-constraints (first kill))))
463 (sset-union-of-difference out in con)
464 (sset-union out in))))
466 (let ((kill-set (make-sset)))
468 (let ((con (lambda-var-constraints var)))
470 (sset-union kill-set con))))
471 (sset-union-of-difference out in kill-set))))
474 ;;; Compute the initial flow analysis sets for BLOCK:
475 ;;; -- Compute IN/OUT sets; if OUT of a predecessor is not yet
476 ;;; computed, assume it to be a universal set (this is only
477 ;;; possible in a loop)
479 ;;; Return T if we have found a loop.
480 (defun find-block-type-constraints (block)
481 (declare (type cblock block))
482 (collect ((kill nil adjoin))
483 (let ((gen (constraint-propagate-in-block
485 :set-preprocessor (lambda (var)
487 (setf (block-gen block) gen)
488 (setf (block-kill block) (kill))
489 (setf (block-type-asserted block) nil)
490 (let* ((n (block-number block))
491 (pred (block-pred block))
495 (cond ((> (block-number b) n)
497 (sset-intersection in (block-out b))
498 (setq in (copy-sset (block-out b)))))
499 (t (setq loop-p t))))
501 (bug "Unreachable code is found or flow graph is not ~
502 properly depth-first ordered."))
503 (setf (block-in block) in)
504 (setf (block-out block) (compute-block-out block))
507 ;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
509 ;;; gen U (in - kill)
511 ;;; Return True if we have done something.
512 (defun flow-propagate-constraints (block)
513 (let* ((pred (block-pred block))
514 (in (progn (aver pred)
515 (let ((res (copy-sset (block-out (first pred)))))
516 (dolist (b (rest pred))
517 (sset-intersection res (block-out b)))
519 (setf (block-in block) in)
520 (let ((out (compute-block-out block)))
521 (if (sset= out (block-out block))
523 (setf (block-out block) out)))))
525 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
526 ;;; During this pass, we also do local constraint propagation by
527 ;;; adding in constraints as we seem them during the pass through the
529 (defun use-result-constraints (block)
530 (declare (type cblock block))
531 (constraint-propagate-in-block
532 block (block-in block)
533 :ref-preprocessor (lambda (node cons)
534 (let* ((var (ref-leaf node))
535 (con (lambda-var-constraints var)))
536 (constrain-ref-type node con cons)))))
538 ;;; Give an empty constraints set to any var that doesn't have one and
539 ;;; isn't a set closure var. Since a var that we previously rejected
540 ;;; looks identical to one that is new, so we optimistically keep
541 ;;; hoping that vars stop being closed over or lose their sets.
542 (defun init-var-constraints (component)
543 (declare (type component component))
544 (dolist (fun (component-lambdas component))
546 (dolist (var (lambda-vars x))
547 (unless (lambda-var-constraints var)
548 (when (or (null (lambda-var-sets var))
549 (not (closure-var-p var)))
550 (setf (lambda-var-constraints var) (make-sset)))))))
552 (dolist (let (lambda-lets fun))
555 ;;; How many blocks does COMPONENT have?
556 (defun component-n-blocks (component)
558 (declare (type index result))
559 (do-blocks (block component :both)
563 (defun constraint-propagate (component &aux (loop-p nil))
564 (declare (type component component))
565 (init-var-constraints component)
567 (do-blocks (block component)
568 (when (block-test-modified block)
569 (find-test-constraints block)))
571 (unless (block-out (component-head component))
572 (setf (block-out (component-head component)) (make-sset)))
574 (do-blocks (block component)
575 (when (find-block-type-constraints block)
579 (let (;; If we have to propagate changes more than this many times,
580 ;; something is wrong.
581 (max-n-changes-remaining (component-n-blocks component)))
582 (declare (type fixnum max-n-changes-remaining))
583 (loop (aver (>= max-n-changes-remaining 0))
584 (decf max-n-changes-remaining)
585 (let ((did-something nil))
586 (do-blocks (block component)
587 (when (flow-propagate-constraints block)
588 (setq did-something t)))
589 (unless did-something
592 (do-blocks (block component)
593 (use-result-constraints block))