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
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.
28 ;;; -- Constraint propagation badly interacts with bottom-up type
29 ;;; inference. Consider
31 ;;; (defun foo (n &aux (i 42))
32 ;;; (declare (optimize speed))
33 ;;; (declare (fixnum n)
34 ;;; #+nil (type (integer 0) i))
38 ;;; (when (>= i n) (go :exit))
43 ;;; In this case CP cannot even infer that I is of class INTEGER.
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)).
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*)
56 (deftype constraint-y () '(or ctype lvar lambda-var constant))
58 (defstruct (constraint
59 (:include sset-element)
60 (:constructor make-constraint (number kind x y not-p))
62 ;; the kind of constraint we have:
65 ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
66 ;; constrained to be of type Y.
69 ;; X is a lambda-var and Y is a CTYPE. The relation holds
70 ;; between X and some object of type Y.
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
81 (not-p nil :type boolean))
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.
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
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)
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)))
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))
143 (:constructor make-conset ())
144 (:copier %copy-conset))
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. Under some measurements in 2008, it
153 ;; turned out that constraint sets elements were normally clumped
154 ;; together: for compiling SBCL, the average difference between
155 ;; the maximum and minimum constraint-number was 90 (with the
156 ;; average constraint set having around 25 elements). So using
157 ;; the minimum and maximum constraint-number for iteration bounds
158 ;; makes iteration over a subrange of the bit-vector comparable to
159 ;; iteration across the hash storage. Note that the CONSET-MIN is
160 ;; NIL when the set is known to be empty. CONSET-MAX is a normal
161 ;; end bounding index.
162 (min nil :type (or fixnum null))
163 (max 0 :type fixnum))
165 (defmacro do-conset-elements ((constraint conset &optional result) &body body)
166 (with-unique-names (vector index start end
167 ignore constraint-universe-end)
168 (let* ((constraint-universe #+sb-xc-host '*constraint-universe*
169 #-sb-xc-host (gensym))
171 #+sb-xc-host '(progn)
172 #-sb-xc-host `(with-array-data
173 ((,constraint-universe *constraint-universe*)
174 (,ignore 0) (,constraint-universe-end nil)
175 :check-fill-pointer t)
176 (declare (ignore ,ignore))
177 (aver (<= ,end ,constraint-universe-end)))))
178 `(let* ((,vector (conset-vector ,conset))
179 (,start (or (conset-min ,conset) 0))
180 (,end (min (conset-max ,conset) (length ,vector))))
182 (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
183 (when (plusp (sbit ,vector ,index))
184 (let ((,constraint (elt ,constraint-universe ,index)))
187 ;; Oddly, iterating just between the maximum of the two sets' minima
188 ;; and the minimum of the sets' maxima slowed down CP.
189 (defmacro do-conset-intersection
190 ((constraint conset1 conset2 &optional result) &body body)
191 `(do-conset-elements (,constraint ,conset1 ,result)
192 (when (conset-member ,constraint ,conset2)
195 (defun conset-empty (conset)
196 (or (null (conset-min conset))
197 ;; TODO: I bet FIND on bit-vectors can be optimized, if it
199 (not (find 1 (conset-vector conset)
200 :start (conset-min conset)
201 ;; By inspection, supplying :END here breaks the
202 ;; build with a "full call to
203 ;; DATA-VECTOR-REF-WITH-OFFSET" in the
204 ;; cross-compiler. If that should change, add
205 ;; :end (conset-max conset)
208 (defun copy-conset (conset)
209 (let ((ret (%copy-conset conset)))
210 (setf (conset-vector ret) (copy-seq (conset-vector conset)))
213 (defun %conset-grow (conset new-size)
214 (declare (index new-size))
215 (setf (conset-vector conset)
216 (replace (the simple-bit-vector
218 (ash 1 (integer-length (1- new-size)))
221 (the simple-bit-vector
222 (conset-vector conset)))))
224 (declaim (inline conset-grow))
225 (defun conset-grow (conset new-size)
226 (declare (index new-size))
227 (when (< (length (conset-vector conset)) new-size)
228 (%conset-grow conset new-size))
231 (defun conset-member (constraint conset)
232 (let ((number (constraint-number constraint))
233 (vector (conset-vector conset)))
234 (when (< number (length vector))
235 (plusp (sbit vector number)))))
237 (defun conset-adjoin (constraint conset)
239 (not (conset-member constraint conset))
240 (let ((number (constraint-number constraint)))
241 (conset-grow conset (1+ number))
242 (setf (sbit (conset-vector conset) number) 1)
243 (setf (conset-min conset) (min number (or (conset-min conset)
244 most-positive-fixnum)))
245 (when (>= number (conset-max conset))
246 (setf (conset-max conset) (1+ number))))))
248 (defun conset= (conset1 conset2)
249 (let* ((vector1 (conset-vector conset1))
250 (vector2 (conset-vector conset2))
251 (length1 (length vector1))
252 (length2 (length vector2)))
253 (if (= length1 length2)
254 ;; When the lengths are the same, we can rely on EQUAL being
255 ;; nicely optimized on bit-vectors.
256 (equal vector1 vector2)
257 (multiple-value-bind (shorter longer)
258 (if (< length1 length2)
259 (values vector1 vector2)
260 (values vector2 vector1))
261 ;; FIXME: make MISMATCH fast on bit-vectors.
262 (dotimes (index (length shorter))
263 (when (/= (sbit vector1 index) (sbit vector2 index))
264 (return-from conset= nil)))
265 (if (find 1 longer :start (length shorter))
270 ((defconsetop (name bit-op)
271 `(defun ,name (conset-1 conset-2)
272 (declare (optimize (speed 3) (safety 0)))
273 (let* ((size-1 (length (conset-vector conset-1)))
274 (size-2 (length (conset-vector conset-2)))
275 (new-size (max size-1 size-2)))
276 (conset-grow conset-1 new-size)
277 (conset-grow conset-2 new-size))
278 (let ((vector1 (conset-vector conset-1))
279 (vector2 (conset-vector conset-2)))
280 (declare (simple-bit-vector vector1 vector2))
281 (setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
282 ;; Update the extrema.
283 (setf (conset-min conset-1)
286 `(min (or (conset-min conset-1)
287 most-positive-fixnum)
288 (or (conset-min conset-2)
289 most-positive-fixnum)))
290 ((conset-intersection)
291 `(position 1 (conset-vector conset-1)
293 (max (or (conset-min conset-1) 0)
294 (or (conset-min conset-2) 0))
295 :end (min (conset-max conset-1)
296 (conset-max conset-1))))
298 `(position 1 (conset-vector conset-1)
299 :start (or (conset-min conset-1) 0)
300 :end (conset-max conset-1)
302 (conset-max conset-1)
305 `(max (conset-max conset-1)
306 (conset-max conset-2)))
307 ((conset-intersection)
310 1 (conset-vector conset-1)
312 (min (conset-max conset-1)
313 (conset-max conset-2))))
317 :end (conset-min conset-1)
325 1 (conset-vector conset-1)
326 :start (let ((max (conset-max conset-1)))
330 :end (or (conset-min conset-1) 0)
336 (defconsetop conset-union bit-ior)
337 (defconsetop conset-intersection bit-and)
338 (defconsetop conset-difference bit-andc2)))
340 (defun find-constraint (kind x y not-p)
341 (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
344 (do-conset-elements (con (lambda-var-constraints x) nil)
345 (when (and (eq (constraint-kind con) kind)
346 (eq (constraint-not-p con) not-p)
347 (type= (constraint-y con) y))
350 (do-conset-elements (con (lambda-var-constraints x) nil)
351 (when (and (eq (constraint-kind con) kind)
352 (eq (constraint-not-p con) not-p)
353 (eq (constraint-y con) y))
356 (do-conset-elements (con (lambda-var-constraints x) nil)
357 (when (and (eq (constraint-kind con) kind)
358 (eq (constraint-not-p con) not-p)
359 (let ((cx (constraint-x con)))
366 ;;; Return a constraint for the specified arguments. We only create a
367 ;;; new constraint if there isn't already an equivalent old one,
368 ;;; guaranteeing that all equivalent constraints are EQ. This
369 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
370 (defun find-or-create-constraint (kind x y not-p)
371 (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
372 (or (find-constraint kind x y not-p)
373 (let ((new (make-constraint (length *constraint-universe*)
375 (vector-push-extend new *constraint-universe*
376 (* 2 (length *constraint-universe*)))
377 (conset-adjoin new (lambda-var-constraints x))
378 (when (lambda-var-p y)
379 (conset-adjoin new (lambda-var-constraints y)))
382 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
383 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
384 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
385 (defun ok-ref-lambda-var (ref)
386 (declare (type ref ref))
387 (let ((leaf (ref-leaf ref)))
388 (when (and (lambda-var-p leaf)
389 (lambda-var-constraints leaf))
392 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
393 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
394 (defun ok-lvar-lambda-var (lvar constraints)
395 (declare (type lvar lvar))
396 (let ((use (lvar-uses lvar)))
398 (let ((lambda-var (ok-ref-lambda-var use)))
400 (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
401 (when (and constraint (conset-member constraint constraints))
404 (ok-lvar-lambda-var (cast-value use) constraints)))))
406 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
407 (once-only ((var var))
408 `(let ((,symbol ,var))
412 (do-conset-elements (con ,constraints ,result)
413 (let ((other (and (eq (constraint-kind con) 'eql)
414 (eq (constraint-not-p con) nil)
415 (cond ((eq ,var (constraint-x con))
417 ((eq ,var (constraint-y con))
423 (when (lambda-var-p ,symbol)
426 ;;;; Searching constraints
428 ;;; Add the indicated test constraint to BLOCK. We don't add the
429 ;;; constraint if the block has multiple predecessors, since it only
430 ;;; holds on this particular path.
431 (defun add-test-constraint (fun x y not-p constraints target)
432 (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
433 (add-eql-var-var-constraint x y constraints target))
435 (do-eql-vars (x (x constraints))
436 (let ((con (find-or-create-constraint fun x y not-p)))
437 (conset-adjoin con target)))))
440 ;;; Add complementary constraints to the consequent and alternative
441 ;;; blocks of IF. We do nothing if X is NIL.
442 (defun add-complement-constraints (fun x y not-p constraints
443 consequent-constraints
444 alternative-constraints)
446 (add-test-constraint fun x y not-p constraints
447 consequent-constraints)
448 (add-test-constraint fun x y (not not-p) constraints
449 alternative-constraints))
452 ;;; Add test constraints to the consequent and alternative blocks of
453 ;;; the test represented by USE.
454 (defun add-test-constraints (use if constraints)
455 (declare (type node use) (type cif if))
456 ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
457 ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
458 ;; can't guarantee that the optimization will be done, so we still
459 ;; need to avoid barfing on this case.
460 (unless (eq (if-consequent if) (if-alternative if))
461 (let ((consequent-constraints (make-conset))
462 (alternative-constraints (make-conset)))
463 (macrolet ((add (fun x y not-p)
464 `(add-complement-constraints ,fun ,x ,y ,not-p
466 consequent-constraints
467 alternative-constraints)))
470 (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
471 (specifier-type 'null) t))
473 (unless (eq (combination-kind use)
475 (let ((name (lvar-fun-name
476 (basic-combination-fun use)))
477 (args (basic-combination-args use)))
479 ((%typep %instance-typep)
480 (let ((type (second args)))
481 (when (constant-lvar-p type)
482 (let ((val (lvar-value type)))
484 (ok-lvar-lambda-var (first args) constraints)
487 (specifier-type val))
490 (let* ((arg1 (first args))
491 (var1 (ok-lvar-lambda-var arg1 constraints))
493 (var2 (ok-lvar-lambda-var arg2 constraints)))
494 ;; The code below assumes that the constant is the
495 ;; second argument in case of variable to constant
496 ;; comparision which is sometimes true (see source
497 ;; transformations for EQ, EQL and CHAR=). Fixing
498 ;; that would result in more constant substitutions
499 ;; which is not a universally good thing, thus the
500 ;; unnatural asymmetry of the tests.
503 (add-test-constraint 'typep var2 (lvar-type arg1)
505 consequent-constraints)))
507 (add 'eql var1 var2 nil))
508 ((constant-lvar-p arg2)
509 (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
512 (add-test-constraint 'typep var1 (lvar-type arg2)
514 consequent-constraints)))))
516 (let* ((arg1 (first args))
517 (var1 (ok-lvar-lambda-var arg1 constraints))
519 (var2 (ok-lvar-lambda-var arg2 constraints)))
521 (add name var1 (lvar-type arg2) nil))
523 (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
525 (let ((ptype (gethash name *backend-predicate-types*)))
527 (add 'typep (ok-lvar-lambda-var (first args) constraints)
529 (values consequent-constraints alternative-constraints))))
531 ;;;; Applying constraints
533 ;;; Return true if X is an integer NUMERIC-TYPE.
534 (defun integer-type-p (x)
535 (declare (type ctype x))
536 (and (numeric-type-p x)
537 (eq (numeric-type-class x) 'integer)
538 (eq (numeric-type-complexp x) :real)))
540 ;;; Given that an inequality holds on values of type X and Y, return a
541 ;;; new type for X. If GREATER is true, then X was greater than Y,
542 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
543 ;;; inclusive, i.e. >=.
545 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
546 ;;; bound into X and return that result. If not OR-EQUAL, we can go
547 ;;; one greater (less) than Y's bound.
548 (defun constrain-integer-type (x y greater or-equal)
549 (declare (type numeric-type x y))
556 (if greater (numeric-type-low x) (numeric-type-high x))))
557 (let* ((x-bound (bound x))
558 (y-bound (exclude (bound y)))
559 (new-bound (cond ((not x-bound) y-bound)
560 ((not y-bound) x-bound)
561 (greater (max x-bound y-bound))
562 (t (min x-bound y-bound)))))
564 (modified-numeric-type x :low new-bound)
565 (modified-numeric-type x :high new-bound)))))
567 ;;; Return true if X is a float NUMERIC-TYPE.
568 (defun float-type-p (x)
569 (declare (type ctype x))
570 (and (numeric-type-p x)
571 (eq (numeric-type-class x) 'float)
572 (eq (numeric-type-complexp x) :real)))
574 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
575 (defun constrain-float-type (x y greater or-equal)
576 (declare (type numeric-type x y))
577 (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
579 (aver (eql (numeric-type-class x) 'float))
580 (aver (eql (numeric-type-class y) 'float))
581 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
583 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
584 (labels ((exclude (x)
592 (if greater (numeric-type-low x) (numeric-type-high x)))
597 (= (type-bound-number x) (type-bound-number ref)))
598 ;; X is tighter if REF is not an open bound and X is
599 (and (not (consp ref)) (consp x)))
601 (< (type-bound-number ref) (type-bound-number x)))
603 (> (type-bound-number ref) (type-bound-number x))))))
604 (let* ((x-bound (bound x))
605 (y-bound (exclude (bound y)))
606 (new-bound (cond ((not x-bound)
610 ((tighter-p y-bound x-bound)
615 (modified-numeric-type x :low new-bound)
616 (modified-numeric-type x :high new-bound)))))
618 ;;; Given the set of CONSTRAINTS for a variable and the current set of
619 ;;; restrictions from flow analysis IN, set the type for REF
621 (defun constrain-ref-type (ref constraints in)
622 (declare (type ref ref) (type conset constraints in))
623 ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
624 ;; cons up endless union types when propagating large number of EQL
625 ;; constraints -- eg. from large CASE forms -- instead we just
626 ;; directly accumulate one XSET, and a set of fp zeroes, which we at
627 ;; the end turn into a MEMBER-TYPE.
629 ;; Since massive symbol cases are an especially atrocious pattern
630 ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
631 ;; a more useful type, don't propagate their negation except for NIL
632 ;; unless SPEED > COMPILATION-SPEED.
633 (let ((res (single-value-type (node-derived-type ref)))
634 (constrain-symbols (policy ref (> speed compilation-speed)))
635 (not-set (alloc-xset))
637 (not-res *empty-type*)
638 (leaf (ref-leaf ref)))
642 (when (or constrain-symbols (null x) (not (symbolp x)))
643 (add-to-xset x not-set)))))
644 ;; KLUDGE: the implementations of DO-CONSET-INTERSECTION will
645 ;; probably run faster when the smaller set comes first, so
646 ;; don't change the order here.
647 (do-conset-intersection (con constraints in)
648 (let* ((x (constraint-x con))
649 (y (constraint-y con))
650 (not-p (constraint-not-p con))
651 (other (if (eq x leaf) y x))
652 (kind (constraint-kind con)))
656 (if (member-type-p other)
657 (mapc-member-type-members #'note-not other)
658 (setq not-res (type-union not-res other)))
659 (setq res (type-approx-intersection2 res other))))
661 (unless (lvar-p other)
662 (let ((other-type (leaf-type other)))
664 (when (and (constant-p other)
665 (member-type-p other-type))
666 (note-not (constant-value other)))
667 (let ((leaf-type (leaf-type leaf)))
669 ((or (constant-p other)
670 (and (leaf-refs other) ; protect from
672 (csubtypep other-type leaf-type)
673 (not (type= other-type leaf-type))))
674 (change-ref-leaf ref other)
675 (when (constant-p other) (return)))
677 (setq res (type-approx-intersection2
678 res other-type)))))))))
681 ((and (integer-type-p res) (integer-type-p y))
682 (let ((greater (eq kind '>)))
683 (let ((greater (if not-p (not greater) greater)))
685 (constrain-integer-type res y greater not-p)))))
686 ((and (float-type-p res) (float-type-p y))
687 (let ((greater (eq kind '>)))
688 (let ((greater (if not-p (not greater) greater)))
690 (constrain-float-type res y greater not-p)))))))))))
691 (cond ((and (if-p (node-dest ref))
692 (or (xset-member-p nil not-set)
693 (csubtypep (specifier-type 'null) not-res)))
694 (setf (node-derived-type ref) *wild-type*)
695 (change-ref-leaf ref (find-constant t)))
698 (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
699 (derive-node-type ref
700 (make-single-value-type
701 (or (type-difference res not-res)
703 (maybe-terminate-block ref nil))))
708 (defun maybe-add-eql-var-lvar-constraint (ref gen)
709 (let ((lvar (ref-lvar ref))
710 (leaf (ref-leaf ref)))
711 (when (and (lambda-var-p leaf) lvar)
712 (conset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
715 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
716 ;;; LVAR) ones - to all of the variables in the VARS list.
717 (defun inherit-constraints (vars from-var constraints target)
718 (do-conset-elements (con constraints)
719 ;; Constant substitution is controversial.
720 (unless (constant-p (constraint-y con))
722 (let ((eq-x (eq from-var (constraint-x con)))
723 (eq-y (eq from-var (constraint-y con))))
724 (when (or (and eq-x (not (lvar-p (constraint-y con))))
726 (conset-adjoin (find-or-create-constraint
727 (constraint-kind con)
728 (if eq-x var (constraint-x con))
729 (if eq-y var (constraint-y con))
730 (constraint-not-p con))
733 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
734 ;; inherit each other's constraints.
735 (defun add-eql-var-var-constraint (var1 var2 constraints
736 &optional (target constraints))
737 (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
738 (when (conset-adjoin con target)
739 (collect ((eql1) (eql2))
740 (do-eql-vars (var1 (var1 constraints))
742 (do-eql-vars (var2 (var2 constraints))
744 (inherit-constraints (eql1) var2 constraints target)
745 (inherit-constraints (eql2) var1 constraints target))
748 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
749 ;; LAMBDA-VAR if possible.
750 (defun maybe-add-eql-var-var-constraint (var lvar constraints
751 &optional (target constraints))
752 (declare (type lambda-var var) (type lvar lvar))
753 (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
755 (add-eql-var-var-constraint var lambda-var constraints target))))
757 ;;; Local propagation
758 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
760 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
761 ;;; a type constraint based on the new value type.
762 (declaim (ftype (function (cblock conset boolean)
764 constraint-propagate-in-block))
765 (defun constraint-propagate-in-block (block gen preprocess-refs-p)
766 (do-nodes (node lvar block)
769 (let ((fun (bind-lambda node)))
770 (when (eq (functional-kind fun) :let)
771 (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
772 for var in (lambda-vars fun)
773 and val in (combination-args call)
774 when (and val (lambda-var-constraints var))
775 do (let* ((type (lvar-type val))
776 (con (find-or-create-constraint 'typep var type
778 (conset-adjoin con gen))
779 (maybe-add-eql-var-var-constraint var val gen)))))
781 (when (ok-ref-lambda-var node)
782 (maybe-add-eql-var-lvar-constraint node gen)
783 (when preprocess-refs-p
784 (let* ((var (ref-leaf node))
785 (con (lambda-var-constraints var)))
786 (constrain-ref-type node con gen)))))
788 (let ((lvar (cast-value node)))
789 (let ((var (ok-lvar-lambda-var lvar gen)))
791 (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
792 (do-eql-vars (var (var gen))
793 (let ((con (find-or-create-constraint 'typep var atype nil)))
794 (conset-adjoin con gen))))))))
796 (binding* ((var (set-var node))
797 (nil (lambda-var-p var) :exit-if-null)
798 (cons (lambda-var-constraints var) :exit-if-null))
799 (conset-difference gen cons)
800 (let* ((type (single-value-type (node-derived-type node)))
801 (con (find-or-create-constraint 'typep var type nil)))
802 (conset-adjoin con gen))
803 (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
806 (defun constraint-propagate-if (block gen)
807 (let ((node (block-last block)))
809 (let ((use (lvar-uses (if-test node))))
811 (add-test-constraints use node gen))))))
813 ;;; Starting from IN compute OUT and (consequent/alternative
814 ;;; constraints if the block ends with and IF). Return the list of
815 ;;; successors that may need to be recomputed.
816 (defun find-block-type-constraints (block final-pass-p)
817 (declare (type cblock block))
818 (let ((gen (constraint-propagate-in-block
822 (copy-conset (block-in block)))
824 (setf (block-gen block) gen)
825 (multiple-value-bind (consequent-constraints alternative-constraints)
826 (constraint-propagate-if block gen)
827 (if consequent-constraints
828 (let* ((node (block-last block))
829 (old-consequent-constraints (if-consequent-constraints node))
830 (old-alternative-constraints (if-alternative-constraints node))
832 ;; Add the consequent and alternative constraints to GEN.
833 (cond ((conset-empty consequent-constraints)
834 (setf (if-consequent-constraints node) gen)
835 (setf (if-alternative-constraints node) gen))
837 (setf (if-consequent-constraints node) (copy-conset gen))
838 (conset-union (if-consequent-constraints node)
839 consequent-constraints)
840 (setf (if-alternative-constraints node) gen)
841 (conset-union (if-alternative-constraints node)
842 alternative-constraints)))
843 ;; Has the consequent been changed?
844 (unless (and old-consequent-constraints
845 (conset= (if-consequent-constraints node)
846 old-consequent-constraints))
847 (push (if-consequent node) succ))
848 ;; Has the alternative been changed?
849 (unless (and old-alternative-constraints
850 (conset= (if-alternative-constraints node)
851 old-alternative-constraints))
852 (push (if-alternative node) succ))
855 (unless (and (block-out block)
856 (conset= gen (block-out block)))
857 (setf (block-out block) gen)
858 (block-succ block))))))
860 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
861 ;;; During this pass, we also do local constraint propagation by
862 ;;; adding in constraints as we see them during the pass through the
864 (defun use-result-constraints (block)
865 (declare (type cblock block))
866 (constraint-propagate-in-block block (block-in block) t))
868 ;;; Give an empty constraints set to any var that doesn't have one and
869 ;;; isn't a set closure var. Since a var that we previously rejected
870 ;;; looks identical to one that is new, so we optimistically keep
871 ;;; hoping that vars stop being closed over or lose their sets.
872 (defun init-var-constraints (component)
873 (declare (type component component))
874 (dolist (fun (component-lambdas component))
876 (dolist (var (lambda-vars x))
877 (unless (lambda-var-constraints var)
878 (when (or (null (lambda-var-sets var))
879 (not (closure-var-p var)))
880 (setf (lambda-var-constraints var) (make-conset)))))))
882 (dolist (let (lambda-lets fun))
885 ;;; Return the constraints that flow from PRED to SUCC. This is
886 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
888 (defun block-out-for-successor (pred succ)
889 (declare (type cblock pred succ))
890 (let ((last (block-last pred)))
891 (or (when (if-p last)
892 (cond ((eq succ (if-consequent last))
893 (if-consequent-constraints last))
894 ((eq succ (if-alternative last))
895 (if-alternative-constraints last))))
898 (defun compute-block-in (block)
900 (dolist (pred (block-pred block))
901 ;; If OUT has not been calculated, assume it to be the universal
903 (let ((out (block-out-for-successor pred block)))
906 (conset-intersection in out)
907 (setq in (copy-conset out))))))
908 (or in (make-conset))))
910 (defun update-block-in (block)
911 (let ((in (compute-block-in block)))
912 (cond ((and (block-in block) (conset= in (block-in block)))
915 (setf (block-in block) in)))))
917 ;;; Return two lists: one of blocks that precede all loops and
918 ;;; therefore require only one constraint propagation pass and the
919 ;;; rest. This implementation does not find all such blocks.
921 ;;; A more complete implementation would be:
923 ;;; (do-blocks (block component)
924 ;;; (if (every #'(lambda (pred)
925 ;;; (or (member pred leading-blocks)
927 ;;; (block-pred block))
928 ;;; (push block leading-blocks)
929 ;;; (push block rest-of-blocks)))
931 ;;; Trailing blocks that succeed all loops could be found and handled
932 ;;; similarly. In practice though, these more complex solutions are
933 ;;; slightly worse performancewise.
934 (defun leading-component-blocks (component)
935 (declare (type component component))
936 (flet ((loopy-p (block)
937 (let ((n (block-number block)))
938 (dolist (pred (block-pred block))
939 (unless (< n (block-number pred))
941 (let ((leading-blocks ())
944 (do-blocks (block component)
945 (when (and (not seen-loop-p) (loopy-p block))
946 (setq seen-loop-p t))
948 (push block rest-of-blocks)
949 (push block leading-blocks)))
950 (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
952 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
953 ;;; a member already.
954 (defun nconc-new (obj list)
955 (do ((x list (cdr x))
959 (setf (cdr prev) (list obj))
962 (when (eql (car x) obj)
963 (return-from nconc-new list))))
965 (defun find-and-propagate-constraints (component)
966 (let ((blocks-to-process ()))
967 (flet ((enqueue (blocks)
968 (dolist (block blocks)
969 (setq blocks-to-process (nconc-new block blocks-to-process)))))
970 (multiple-value-bind (leading-blocks rest-of-blocks)
971 (leading-component-blocks component)
972 ;; Update every block once to account for changes in the
973 ;; IR1. The constraints of the lead blocks cannot be changed
974 ;; after the first pass so we might as well use them and skip
975 ;; USE-RESULT-CONSTRAINTS later.
976 (dolist (block leading-blocks)
977 (setf (block-in block) (compute-block-in block))
978 (find-block-type-constraints block t))
979 (setq blocks-to-process (copy-list rest-of-blocks))
980 ;; The rest of the blocks.
981 (dolist (block rest-of-blocks)
982 (aver (eq block (pop blocks-to-process)))
983 (setf (block-in block) (compute-block-in block))
984 (enqueue (find-block-type-constraints block nil)))
985 ;; Propagate constraints
986 (loop for block = (pop blocks-to-process)
988 (unless (eq block (component-tail component))
989 (when (update-block-in block)
990 (enqueue (find-block-type-constraints block nil)))))
993 (defun constraint-propagate (component)
994 (declare (type component component))
995 (init-var-constraints component)
997 (unless (block-out (component-head component))
998 (setf (block-out (component-head component)) (make-conset)))
1000 (dolist (block (find-and-propagate-constraints component))
1001 (unless (block-delete-p block)
1002 (use-result-constraints block)))