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.
16 (defstruct (constraint
17 (:include sset-element)
18 (:constructor make-constraint (number kind x y not-p))
20 ;; the kind of constraint we have:
23 ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
24 ;; constrained to be of type Y.
27 ;; X is a lambda-var and Y is a CTYPE. The relation holds
28 ;; between X and some object of type Y.
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
39 (not-p nil :type boolean))
41 (defvar *constraint-number*)
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)
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))
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))
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)))
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)))
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))
89 ;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
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)))
96 (ok-ref-lambda-var use))))
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))))
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)
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)))
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))
126 (add-complement-constraints if 'typep (ok-ref-lambda-var use)
127 (specifier-type 'null) t))
129 (let ((name (continuation-function-name
130 (basic-combination-fun use)))
131 (args (basic-combination-args use)))
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))
141 (specifier-type val))
144 (let* ((var1 (ok-cont-lambda-var (first args)))
146 (var2 (ok-cont-lambda-var arg2)))
149 (add-complement-constraints if 'eql var1 var2 nil))
150 ((constant-continuation-p arg2)
151 (add-complement-constraints if 'eql var1
153 (continuation-use arg2))
156 (let* ((arg1 (first args))
157 (var1 (ok-cont-lambda-var arg1))
159 (var2 (ok-cont-lambda-var arg2)))
161 (add-complement-constraints if name var1 (continuation-type arg2)
164 (add-complement-constraints if (if (eq name '<) '> '<)
165 var2 (continuation-type arg1)
168 (let ((ptype (gethash name *backend-predicate-types*)))
170 (add-complement-constraints if 'typep
171 (ok-cont-lambda-var (first args))
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)))
181 (let ((use (continuation-use (if-test last))))
183 (add-test-constraints use last)))))
185 (setf (block-test-modified block) nil)
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))
197 (let ((test (block-test-constraint block)))
199 (sset-union gen test)))
201 (do-nodes (node cont block)
204 (when (continuation-type-check cont)
205 (let ((var (ok-ref-lambda-var node)))
207 (let* ((atype (continuation-derived-type cont))
208 (con (find-constraint 'typep var atype nil)))
209 (sset-adjoin con gen))))))
211 (let ((var (set-var node)))
212 (when (lambda-var-p var)
214 (let ((cons (lambda-var-constraints var)))
216 (sset-difference gen cons))))))))
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)
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)))
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. >=.
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))
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)))))
256 (modified-numeric-type x :low new-bound)
257 (modified-numeric-type x :high new-bound)))))
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)))
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 ;; FIXME: The comment here used to say
270 ;; Unless #!+SB-PROPAGATE-FLOAT-TYPE, then SB!C::BOUND-VALUE (used in
271 ;; the code below) is not defined, so we just return X without
272 ;; trying to calculate additional constraints.
273 ;; But as of sbcl-0.6.11.26, SB!C::BOUND-VALUE has been renamed to
274 ;; SB!INT:TYPE-BOUND-NUMBER and is always defined, so probably the
275 ;; conditionalization should go away.
276 #!-sb-propagate-float-type (declare (ignore greater or-equal))
277 (aver (eql (numeric-type-class x) 'float))
278 (aver (eql (numeric-type-class y) 'float))
279 #!-sb-propagate-float-type x
280 #!+sb-propagate-float-type
281 (labels ((exclude (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 (type-bound-number x) (type-bound-number 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
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 (type-bound-number x) (type-bound-number 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
310 (set-bound res (or (consp x) (consp y))))))
311 (let* ((x-bound (bound x))
312 (y-bound (exclude (bound y)))
313 (new-bound (cond ((not x-bound)
318 (max-lower-bound x-bound y-bound))
320 (min-upper-bound x-bound y-bound)))))
322 (modified-numeric-type x :low new-bound)
323 (modified-numeric-type x :high new-bound)))))
325 ;;; Given the set of CONSTRAINTS for a variable and the current set of
326 ;;; restrictions from flow analysis IN, set the type for REF
328 (defun constrain-ref-type (ref constraints in)
329 (declare (type ref ref) (type sset constraints in))
330 (let ((var-cons (copy-sset constraints)))
331 (sset-intersection var-cons in)
332 (let ((res (single-value-type (node-derived-type ref)))
333 (not-res *empty-type*)
334 (leaf (ref-leaf ref)))
335 (do-sset-elements (con var-cons)
336 (let* ((x (constraint-x con))
337 (y (constraint-y con))
338 (not-p (constraint-not-p con))
339 (other (if (eq x leaf) y x))
340 (kind (constraint-kind con)))
344 (setq not-res (type-union not-res other))
345 (setq res (type-approx-intersection2 res other))))
347 (let ((other-type (leaf-type other)))
349 (when (and (constant-p other)
350 (member-type-p other-type))
351 (setq not-res (type-union not-res other-type)))
352 (let ((leaf-type (leaf-type leaf)))
353 (when (or (constant-p other)
354 (and (csubtypep other-type leaf-type)
355 (not (type= other-type leaf-type))))
356 (change-ref-leaf ref other)
357 (when (constant-p other) (return)))))))
359 (cond ((and (integer-type-p res) (integer-type-p y))
360 (let ((greater (eq kind '>)))
361 (let ((greater (if not-p (not greater) greater)))
363 (constrain-integer-type res y greater not-p)))))
364 #!+sb-constrain-float-type
365 ((and (float-type-p res) (float-type-p y))
366 (let ((greater (eq kind '>)))
367 (let ((greater (if not-p (not greater) greater)))
369 (constrain-float-type res y greater not-p)))))
372 (let* ((cont (node-cont ref))
373 (dest (continuation-dest cont)))
374 (cond ((and (if-p dest)
375 (csubtypep (specifier-type 'null) not-res)
376 (eq (continuation-asserted-type cont) *wild-type*))
377 (setf (node-derived-type ref) *wild-type*)
378 (change-ref-leaf ref (find-constant t)))
380 (derive-node-type ref (or (type-difference res not-res)
385 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
386 ;;; During this pass, we also do local constraint propagation by
387 ;;; adding in constraints as we seem them during the pass through the
389 (defun use-result-constraints (block)
390 (declare (type cblock block))
391 (let ((in (block-in block)))
393 (let ((test (block-test-constraint block)))
395 (sset-union in test)))
397 (do-nodes (node cont block)
400 (let ((var (ref-leaf node)))
401 (when (lambda-var-p var)
402 (let ((con (lambda-var-constraints var)))
404 (constrain-ref-type node con in)
405 (when (continuation-type-check cont)
407 (find-constraint 'typep var
408 (continuation-asserted-type cont)
412 (let ((var (set-var node)))
413 (when (lambda-var-p var)
414 (let ((cons (lambda-var-constraints var)))
416 (sset-difference in cons))))))))))
418 ;;; Return true if VAR would have to be closed over if environment
419 ;;; analysis ran now (i.e. if there are any uses that have a different
420 ;;; home lambda than VAR's home.)
421 (defun closure-var-p (var)
422 (declare (type lambda-var var))
423 (let ((home (lambda-home (lambda-var-home var))))
426 (unless (eq (node-home-lambda node) home)
428 (or (frob (leaf-refs var))
429 (frob (basic-var-sets var))))))
431 ;;; Give an empty constraints set to any var that doesn't have one and
432 ;;; isn't a set closure var. Since a var that we previously rejected
433 ;;; looks identical to one that is new, so we optimistically keep
434 ;;; hoping that vars stop being closed over or lose their sets.
435 (defun init-var-constraints (component)
436 (declare (type component component))
437 (dolist (fun (component-lambdas component))
439 (dolist (var (lambda-vars x))
440 (unless (lambda-var-constraints var)
441 (when (or (null (lambda-var-sets var))
442 (not (closure-var-p var)))
443 (setf (lambda-var-constraints var) (make-sset)))))))
445 (dolist (let (lambda-lets fun))
448 ;;; BLOCK-IN becomes the intersection of the OUT of the prececessors.
450 ;;; out U (in - kill)
452 ;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must
453 ;;; compute the kill set when there are any vars killed. We bum this a
454 ;;; bit by special-casing when only one var is killed, and just using
455 ;;; that var's constraints as the kill set. This set could possibly be
456 ;;; precomputed, but it would have to be invalidated whenever any
457 ;;; constraint is added, which would be a pain.
458 (defun flow-propagate-constraints (block)
459 (let* ((pred (block-pred block))
461 (let ((res (copy-sset (block-out (first pred)))))
462 (dolist (b (rest pred))
463 (sset-intersection res (block-out b)))
466 (when *check-consistency*
467 (let ((*compiler-error-context* (block-last block)))
469 "*** Unreachable code in constraint ~
470 propagation... Bug?")))
472 (kill (block-kill block))
473 (out (block-out block)))
475 (setf (block-in block) in)
477 (sset-union (block-out block) in))
479 (let ((con (lambda-var-constraints (first kill))))
481 (sset-union-of-difference out in con)
482 (sset-union out in))))
484 (let ((kill-set (make-sset)))
486 (let ((con (lambda-var-constraints var)))
488 (sset-union kill-set con))))
489 (sset-union-of-difference (block-out block) in kill-set))))))
491 (defun constraint-propagate (component)
492 (declare (type component component))
493 (init-var-constraints component)
495 (do-blocks (block component)
496 (when (block-test-modified block)
497 (find-test-constraints block)))
499 (do-blocks (block component)
500 (cond ((block-type-asserted block)
501 (find-block-type-constraints block))
503 (setf (block-in block) nil)
504 (setf (block-out block) (copy-sset (block-gen block))))))
506 (setf (block-out (component-head component)) (make-sset))
508 (let ((did-something nil))
510 (do-blocks (block component)
511 (when (flow-propagate-constraints block)
512 (setq did-something t)))
514 (unless did-something (return))
515 (setq did-something nil)))
517 (do-blocks (block component)
518 (use-result-constraints block))