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. Tracking extrema helps a bit.
154 (max 0 :type fixnum))
156 (defun conset-empty (conset)
157 (or (= (conset-min conset) (conset-max conset))
158 ;; TODO: I bet FIND on bit-vectors can be optimized, if it
160 (not (find 1 (conset-vector conset)
161 :start (conset-min conset)
162 ;; By inspection, supplying :END here breaks the
163 ;; build with a "full call to
164 ;; DATA-VECTOR-REF-WITH-OFFSET" in the
165 ;; cross-compiler. If that should change, add
166 ;; :end (conset-max conset)
169 (defun copy-conset (conset)
170 (let ((ret (%copy-conset conset)))
171 (setf (conset-vector ret) (copy-seq (conset-vector conset)))
174 (defun %conset-grow (conset new-size)
175 (declare (type index new-size))
176 (setf (conset-vector conset)
177 (replace (the simple-bit-vector
179 (ash 1 (integer-length (1- new-size)))
182 (the simple-bit-vector
183 (conset-vector conset)))))
185 (declaim (inline conset-grow))
186 (defun conset-grow (conset new-size)
187 (declare (type index new-size))
188 (when (< (length (conset-vector conset)) new-size)
189 (%conset-grow conset new-size))
192 (defun conset-member (constraint conset)
193 (let ((number (%constraint-number constraint))
194 (vector (conset-vector conset)))
195 (when (< number (length vector))
196 (plusp (sbit vector number)))))
198 (defun conset-adjoin (constraint conset)
199 (let ((number (%constraint-number constraint)))
200 (conset-grow conset (1+ number))
201 (setf (sbit (conset-vector conset) number) 1)
202 (setf (conset-min conset) (min number (conset-min conset)))
203 (when (>= number (conset-max conset))
204 (setf (conset-max conset) (1+ number))))
207 (defun conset= (conset1 conset2)
208 (let* ((vector1 (conset-vector conset1))
209 (vector2 (conset-vector conset2))
210 (length1 (length vector1))
211 (length2 (length vector2)))
212 (if (= length1 length2)
213 ;; When the lengths are the same, we can rely on EQUAL being
214 ;; nicely optimized on bit-vectors.
215 (equal vector1 vector2)
216 (multiple-value-bind (shorter longer)
217 (if (< length1 length2)
218 (values vector1 vector2)
219 (values vector2 vector1))
220 ;; FIXME: make MISMATCH fast on bit-vectors.
221 (dotimes (index (length shorter))
222 (when (/= (sbit vector1 index) (sbit vector2 index))
223 (return-from conset= nil)))
224 (if (find 1 longer :start (length shorter))
229 ((defconsetop (name bit-op)
230 `(defun ,name (conset-1 conset-2)
231 (declare (optimize (speed 3) (safety 0)))
232 (let* ((size-1 (length (conset-vector conset-1)))
233 (size-2 (length (conset-vector conset-2)))
234 (new-size (max size-1 size-2)))
235 (conset-grow conset-1 new-size)
236 (conset-grow conset-2 new-size))
237 (let ((vector1 (conset-vector conset-1))
238 (vector2 (conset-vector conset-2)))
239 (declare (simple-bit-vector vector1 vector2))
240 (setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
241 ;; Update the extrema.
244 `(setf (conset-min conset-1)
245 (min (conset-min conset-1)
246 (conset-min conset-2))
247 (conset-max conset-1)
248 (max (conset-max conset-1)
249 (conset-max conset-2))))
250 ((conset-intersection)
251 `(let ((start (max (conset-min conset-1)
252 (conset-min conset-2)))
253 (end (min (conset-max conset-1)
254 (conset-max conset-2))))
255 (setf (conset-min conset-1)
258 (or (position 1 (conset-vector conset-1)
259 :start start :end end)
261 (conset-max conset-1)
266 1 (conset-vector conset-1)
267 :start start :end end :from-end t)))
272 `(setf (conset-min conset-1)
273 (or (position 1 (conset-vector conset-1)
274 :start (conset-min conset-1)
275 :end (conset-max conset-1))
277 (conset-max conset-1)
280 1 (conset-vector conset-1)
281 :start (conset-min conset-1)
282 :end (conset-max conset-1)
288 (defconsetop conset-union bit-ior)
289 (defconsetop conset-intersection bit-and)
290 (defconsetop conset-difference bit-andc2)))
292 ;;; Constraints are hash-consed. Unfortunately, types aren't, so we have
293 ;;; to over-approximate and then linear search through the potential hits.
294 ;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant
295 ;;; and lambda-vars can only be found in EQL constraints.
296 (defun find-constraint (kind x y not-p)
297 (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
300 (awhen (lambda-var-ctype-constraints x)
301 (dolist (con (gethash (sb!kernel::type-class-info y) it) nil)
302 (when (and (eq (constraint-kind con) kind)
303 (eq (constraint-not-p con) not-p)
304 (type= (constraint-y con) y))
305 (return-from find-constraint con)))
308 (awhen (lambda-var-eq-constraints x)
310 ((or constant lambda-var)
311 (awhen (lambda-var-eq-constraints x)
312 (let ((cache (gethash y it)))
313 (declare (type list cache))
314 (if not-p (cdr cache) (car cache)))))))
316 ;;; The most common operations on consets are iterating through the constraints
317 ;;; that are related to a certain variable in a given conset. Storing the
318 ;;; constraints related to each variable in vectors allows us to easily iterate
319 ;;; through the intersection of such constraints and the constraints in a conset.
321 ;;; EQL-var constraints assert that two lambda-vars are EQL.
322 ;;; Private constraints assert that a lambda-var is EQL or not EQL to a constant.
323 ;;; Inheritable constraints are constraints that may be propagated to EQL
324 ;;; lambda-vars (along with EQL-var constraints).
326 ;;; Lambda-var -- lvar EQL constraints only serve one purpose: remember whether
327 ;;; an lvar is (only) written to by a ref to that lambda-var, and aren't ever
330 ;;; Finally, the lambda-var conset is only used to track the whole set of
331 ;;; constraints associated with a given lambda-var, and thus easily delete
332 ;;; such constraints from a conset.
333 (defun register-constraint (x con y)
334 (declare (type lambda-var x) (type constraint con) (type constraint-y y))
335 (conset-adjoin con (lambda-var-constraints x))
336 (macrolet ((ensuref (place default)
337 `(or ,place (setf ,place ,default)))
339 `(ensuref ,place (make-hash-table)))
341 `(ensuref ,place (make-array 8 :adjustable t :fill-pointer 0))))
344 (let ((index (ensure-hash (lambda-var-ctype-constraints x)))
345 (vec (ensure-vec (lambda-var-inheritable-constraints x))))
346 (push con (gethash (sb!kernel::type-class-info y) index))
347 (vector-push-extend con vec)))
349 (let ((index (ensure-hash (lambda-var-eq-constraints x))))
350 (setf (gethash y index) con)))
351 ((or constant lambda-var)
352 (let* ((index (ensure-hash (lambda-var-eq-constraints x)))
353 (cons (ensuref (gethash y index) (list nil))))
354 (if (constraint-not-p con)
355 (setf (cdr cons) con)
356 (setf (car cons) con)))
359 (let ((vec (ensure-vec (lambda-var-private-constraints x))))
360 (vector-push-extend con vec)))
362 (let ((vec (if (constraint-not-p con)
363 (ensure-vec (lambda-var-inheritable-constraints x))
364 (ensure-vec (lambda-var-eql-var-constraints x)))))
365 (vector-push-extend con vec)))))))
368 ;;; Return a constraint for the specified arguments. We only create a
369 ;;; new constraint if there isn't already an equivalent old one,
370 ;;; guaranteeing that all equivalent constraints are EQ. This
371 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
372 (defun find-or-create-constraint (kind x y not-p)
373 (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
374 (or (find-constraint kind x y not-p)
375 (let ((new (make-constraint (length *constraint-universe*)
377 (vector-push-extend new *constraint-universe*
378 (1+ (length *constraint-universe*)))
379 (register-constraint x new y)
380 (when (lambda-var-p y)
381 (register-constraint y new x))
384 ;;; Actual conset interface
386 ;;; Constraint propagation needs to iterate over the set of lambda-vars known to
387 ;;; be EQL to a given variable (including itself), via DO-EQL-VARS.
389 ;;; It also has to iterate through constraints that are inherited by EQL variables
390 ;;; (DO-INHERITABLE-CONSTRAINTS), and through constraints used by
391 ;;; CONSTRAIN-REF-TYPE (to derive the type of a REF to a lambda-var).
393 ;;; Consets must keep track of which lvars are EQL to a given lambda-var (result
394 ;;; from a REF to the lambda-var): CONSET-LVAR-LAMBDA-VAR-EQL-P and
395 ;;; CONSET-ADD-LVAR-LAMBDA-VAR-EQL. This, as all other constraints, must of
396 ;;; course be cleared when a lambda-var's constraints are dropped because of
399 ;;; Consets must be able to add constraints to a given lambda-var
400 ;;; (CONSET-ADD-CONSTRAINT), and to the set of variables EQL to a given
401 ;;; lambda-var (CONSET-ADD-CONSTRAINT-TO-EQL).
403 ;;; When a lambda-var is assigned to, all the constraints involving that variable
404 ;;; must be dropped: constraint propagation is flow-sensitive, so the constraints
405 ;;; relate to the variable at a given range of program point. In such cases,
406 ;;; constraint propagation calls CONSET-CLEAR-LAMBDA-VAR.
408 ;;; Finally, one of the main strengths of constraint propagation in SBCL is the
409 ;;; tracking of EQL variables to help constraint propagation. When two variables
410 ;;; are known to be EQL (e.g. after a branch), ADD-EQL-VAR-VAR-CONSTRAINT is
411 ;;; called to add the EQL constraint, but also have each equality class inherit
412 ;;; the other's (inheritable) constraints.
414 ;;; On top of that, we have the usual bulk set operations: intersection, copy,
415 ;;; equality or emptiness testing. There's also union, but that's only an
416 ;;; optimisation to avoid useless copies in ADD-TEST-CONSTRAINTS and
417 ;;; FIND-BLOCK-TYPE-CONSTRAINTS.
418 (defmacro do-conset-constraints-intersection ((symbol (conset constraints) &optional result)
420 (let ((min (gensym "MIN"))
421 (max (gensym "MAX")))
422 (once-only ((conset conset)
423 (constraints constraints))
424 `(flet ((body (,symbol)
425 (declare (type constraint ,symbol))
428 (let ((,min (conset-min ,conset))
429 (,max (conset-max ,conset)))
430 (declare (optimize speed))
431 (map nil (lambda (constraint)
432 (declare (type constraint constraint))
433 (let ((number (constraint-number constraint)))
434 (when (and (<= ,min number)
436 (conset-member constraint ,conset))
441 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
442 (once-only ((var var)
443 (constraints constraints))
444 `(flet ((body-fun (,symbol)
447 (do-conset-constraints-intersection
448 (con (,constraints (lambda-var-eql-var-constraints ,var)) ,result)
449 (let ((x (constraint-x con))
450 (y (constraint-y con)))
451 (body-fun (if (eq ,var x) y x)))))))
453 (defmacro do-inheritable-constraints ((symbol (conset variable) &optional result)
455 (once-only ((conset conset)
458 (flet ((body-fun (,symbol)
460 (do-conset-constraints-intersection
461 (con (,conset (lambda-var-inheritable-constraints ,variable)))
463 (do-conset-constraints-intersection
464 (con (,conset (lambda-var-eql-var-constraints ,variable)) ,result)
467 (defmacro do-propagatable-constraints ((symbol (conset variable) &optional result)
469 (once-only ((conset conset)
472 (flet ((body-fun (,symbol)
474 (do-conset-constraints-intersection
475 (con (,conset (lambda-var-private-constraints ,variable)))
477 (do-conset-constraints-intersection
478 (con (,conset (lambda-var-eql-var-constraints ,variable)))
480 (do-conset-constraints-intersection
481 (con (,conset (lambda-var-inheritable-constraints ,variable)) ,result)
484 (declaim (inline conset-lvar-lambda-var-eql-p conset-add-lvar-lambda-var-eql))
485 (defun conset-lvar-lambda-var-eql-p (conset lvar lambda-var)
486 (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
488 (conset-member constraint conset))))
490 (defun conset-add-lvar-lambda-var-eql (conset lvar lambda-var)
491 (let ((constraint (find-or-create-constraint 'eql lambda-var lvar nil)))
492 (conset-adjoin constraint conset)))
494 (declaim (inline conset-add-constraint conset-add-constraint-to-eql))
495 (defun conset-add-constraint (conset kind x y not-p)
496 (declare (type conset conset)
498 (conset-adjoin (find-or-create-constraint kind x y not-p)
501 (defun conset-add-constraint-to-eql (conset kind x y not-p &optional (target conset))
502 (declare (type conset target conset)
504 (do-eql-vars (x (x conset))
505 (conset-add-constraint target kind x y not-p)))
507 (declaim (inline conset-clear-lambda-var))
508 (defun conset-clear-lambda-var (conset var)
509 (conset-difference conset (lambda-var-constraints var)))
511 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
512 ;;; LVAR) ones - to all of the variables in the VARS list.
513 (defun inherit-constraints (vars from-var constraints target)
514 (do-inheritable-constraints (con (constraints from-var))
515 (let ((eq-x (eq from-var (constraint-x con)))
516 (eq-y (eq from-var (constraint-y con))))
518 (conset-add-constraint target
519 (constraint-kind con)
520 (if eq-x var (constraint-x con))
521 (if eq-y var (constraint-y con))
522 (constraint-not-p con))))))
524 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
525 ;; inherit each other's constraints.
526 (defun add-eql-var-var-constraint (var1 var2 constraints
527 &optional (target constraints))
528 (let ((constraint (find-or-create-constraint 'eql var1 var2 nil)))
529 (unless (conset-member constraint target)
530 (conset-adjoin constraint target)
531 (collect ((eql1) (eql2))
532 (do-eql-vars (var1 (var1 constraints))
534 (do-eql-vars (var2 (var2 constraints))
536 (inherit-constraints (eql1) var2 constraints target)
537 (inherit-constraints (eql2) var1 constraints target))
540 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
541 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
542 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
543 (defun ok-ref-lambda-var (ref)
544 (declare (type ref ref))
545 (let ((leaf (ref-leaf ref)))
546 (when (and (lambda-var-p leaf)
547 (lambda-var-constraints leaf))
550 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
551 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
552 (defun ok-lvar-lambda-var (lvar constraints)
553 (declare (type lvar lvar))
554 (let ((use (lvar-uses lvar)))
556 (let ((lambda-var (ok-ref-lambda-var use)))
558 (conset-lvar-lambda-var-eql-p constraints lvar lambda-var)
561 (ok-lvar-lambda-var (cast-value use) constraints)))))
562 ;;;; Searching constraints
564 ;;; Add the indicated test constraint to TARGET.
565 (defun precise-add-test-constraint (fun x y not-p constraints target)
566 (if (and (eq 'eql fun) (lambda-var-p y) (not not-p))
567 (add-eql-var-var-constraint x y constraints target)
568 (conset-add-constraint-to-eql constraints fun x y not-p target))
571 (defun add-test-constraint (quick-p fun x y not-p constraints target)
573 (conset-add-constraint target fun x y not-p))
575 (precise-add-test-constraint fun x y not-p constraints target))))
576 ;;; Add complementary constraints to the consequent and alternative
577 ;;; blocks of IF. We do nothing if X is NIL.
578 (declaim (inline precise-add-test-constraint quick-add-complement-constraints))
579 (defun precise-add-complement-constraints (fun x y not-p constraints
580 consequent-constraints
581 alternative-constraints)
583 (precise-add-test-constraint fun x y not-p constraints
584 consequent-constraints)
585 (precise-add-test-constraint fun x y (not not-p) constraints
586 alternative-constraints))
589 (defun quick-add-complement-constraints (fun x y not-p
590 consequent-constraints
591 alternative-constraints)
593 (conset-add-constraint consequent-constraints fun x y not-p)
594 (conset-add-constraint alternative-constraints fun x y (not not-p)))
597 (defun add-complement-constraints (quick-p fun x y not-p constraints
598 consequent-constraints
599 alternative-constraints)
601 (quick-add-complement-constraints fun x y not-p
602 consequent-constraints
603 alternative-constraints)
604 (precise-add-complement-constraints fun x y not-p constraints
605 consequent-constraints
606 alternative-constraints)))
608 (defun add-combination-test-constraints (use constraints
609 consequent-constraints
610 alternative-constraints
612 (flet ((add (fun x y not-p)
613 (add-complement-constraints quick-p
616 consequent-constraints
617 alternative-constraints))
618 (prop (triples target)
619 (map nil (lambda (constraint)
620 (destructuring-bind (kind x y &optional not-p)
623 (add-test-constraint quick-p
628 (when (eq (combination-kind use) :known)
629 (binding* ((info (combination-fun-info use) :exit-if-null)
630 (propagate (fun-info-constraint-propagate-if
633 (multiple-value-bind (lvar type if else)
634 (funcall propagate use constraints)
635 (prop if consequent-constraints)
636 (prop else alternative-constraints)
637 (when (and lvar type)
638 (add 'typep (ok-lvar-lambda-var lvar constraints)
640 (return-from add-combination-test-constraints)))))
641 (let* ((name (lvar-fun-name
642 (basic-combination-fun use)))
643 (args (basic-combination-args use))
644 (ptype (gethash name *backend-predicate-types*)))
646 (add 'typep (ok-lvar-lambda-var (first args)
650 ;;; Add test constraints to the consequent and alternative blocks of
651 ;;; the test represented by USE.
652 (defun add-test-constraints (use if constraints)
653 (declare (type node use) (type cif if))
654 ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
655 ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
656 ;; can't guarantee that the optimization will be done, so we still
657 ;; need to avoid barfing on this case.
658 (unless (eq (if-consequent if) (if-alternative if))
659 (let ((consequent-constraints (make-conset))
660 (alternative-constraints (make-conset))
661 (quick-p (policy if (> compilation-speed speed))))
662 (macrolet ((add (fun x y not-p)
663 `(add-complement-constraints quick-p
666 consequent-constraints
667 alternative-constraints)))
670 (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
671 (specifier-type 'null) t))
673 (unless (eq (combination-kind use)
675 (let ((name (lvar-fun-name
676 (basic-combination-fun use)))
677 (args (basic-combination-args use)))
679 ((%typep %instance-typep)
680 (let ((type (second args)))
681 (when (constant-lvar-p type)
682 (let ((val (lvar-value type)))
684 (ok-lvar-lambda-var (first args) constraints)
687 (let ((*compiler-error-context* use))
688 (specifier-type val)))
691 (let* ((arg1 (first args))
692 (var1 (ok-lvar-lambda-var arg1 constraints))
694 (var2 (ok-lvar-lambda-var arg2 constraints)))
695 ;; The code below assumes that the constant is the
696 ;; second argument in case of variable to constant
697 ;; comparison which is sometimes true (see source
698 ;; transformations for EQ, EQL and CHAR=). Fixing
699 ;; that would result in more constant substitutions
700 ;; which is not a universally good thing, thus the
701 ;; unnatural asymmetry of the tests.
704 (add-test-constraint quick-p
705 'typep var2 (lvar-type arg1)
707 consequent-constraints)))
709 (add 'eql var1 var2 nil))
710 ((constant-lvar-p arg2)
712 (find-constant (lvar-value arg2))
715 (add-test-constraint quick-p
716 'typep var1 (lvar-type arg2)
718 consequent-constraints)))))
720 (let* ((arg1 (first args))
721 (var1 (ok-lvar-lambda-var arg1 constraints))
723 (var2 (ok-lvar-lambda-var arg2 constraints)))
725 (add name var1 (lvar-type arg2) nil))
727 (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
729 (add-combination-test-constraints use constraints
730 consequent-constraints
731 alternative-constraints
733 (values consequent-constraints alternative-constraints))))
735 ;;;; Applying constraints
737 ;;; Return true if X is an integer NUMERIC-TYPE.
738 (defun integer-type-p (x)
739 (declare (type ctype x))
740 (and (numeric-type-p x)
741 (eq (numeric-type-class x) 'integer)
742 (eq (numeric-type-complexp x) :real)))
744 ;;; Given that an inequality holds on values of type X and Y, return a
745 ;;; new type for X. If GREATER is true, then X was greater than Y,
746 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
747 ;;; inclusive, i.e. >=.
749 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
750 ;;; bound into X and return that result. If not OR-EQUAL, we can go
751 ;;; one greater (less) than Y's bound.
752 (defun constrain-integer-type (x y greater or-equal)
753 (declare (type numeric-type x y))
760 (if greater (numeric-type-low x) (numeric-type-high x))))
761 (let* ((x-bound (bound x))
762 (y-bound (exclude (bound y)))
763 (new-bound (cond ((not x-bound) y-bound)
764 ((not y-bound) x-bound)
765 (greater (max x-bound y-bound))
766 (t (min x-bound y-bound)))))
768 (modified-numeric-type x :low new-bound)
769 (modified-numeric-type x :high new-bound)))))
771 ;;; Return true if X is a float NUMERIC-TYPE.
772 (defun float-type-p (x)
773 (declare (type ctype x))
774 (and (numeric-type-p x)
775 (eq (numeric-type-class x) 'float)
776 (eq (numeric-type-complexp x) :real)))
778 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
780 ;;; In contrast to the integer version, here the input types can have
781 ;;; open bounds in addition to closed ones and we don't increment or
782 ;;; decrement a bound to honor OR-EQUAL being NIL but put an open bound
783 ;;; into the result instead, if appropriate.
784 (defun constrain-float-type (x y greater or-equal)
785 (declare (type numeric-type x y))
786 (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
788 (aver (eql (numeric-type-class x) 'float))
789 (aver (eql (numeric-type-class y) 'float))
790 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
792 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
793 (labels ((exclude (x)
801 (if greater (numeric-type-low x) (numeric-type-high x)))
805 ((= (type-bound-number x) (type-bound-number ref))
806 ;; X is tighter if X is an open bound and REF is not
807 (and (consp x) (not (consp ref))))
809 (< (type-bound-number ref) (type-bound-number x)))
811 (> (type-bound-number ref) (type-bound-number x))))))
812 (let* ((x-bound (bound x))
813 (y-bound (exclude (bound y)))
814 (new-bound (cond ((not x-bound)
818 ((tighter-p y-bound x-bound)
823 (modified-numeric-type x :low new-bound)
824 (modified-numeric-type x :high new-bound)))))
826 ;;; Return true if LEAF is "visible" from NODE.
827 (defun leaf-visible-from-node-p (leaf node)
830 ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an
831 ;; ancestor for NODE.
832 (let ((leaf-lambda (lambda-var-home leaf)))
833 (loop for lambda = (node-home-lambda node)
834 then (lambda-parent lambda)
836 when (eq lambda leaf-lambda)
838 ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes),
839 ;; not just LAMBDA-VARs.
841 ;; Assume everything else is globally visible.
844 ;;; Given the set of CONSTRAINTS for a variable and the current set of
845 ;;; restrictions from flow analysis IN, set the type for REF
847 (defun constrain-ref-type (ref in)
848 (declare (type ref ref) (type conset in))
849 ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
850 ;; cons up endless union types when propagating large number of EQL
851 ;; constraints -- eg. from large CASE forms -- instead we just
852 ;; directly accumulate one XSET, and a set of fp zeroes, which we at
853 ;; the end turn into a MEMBER-TYPE.
855 ;; Since massive symbol cases are an especially atrocious pattern
856 ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
857 ;; a more useful type, don't propagate their negation except for NIL
858 ;; unless SPEED > COMPILATION-SPEED.
859 (let ((res (single-value-type (node-derived-type ref)))
860 (constrain-symbols (policy ref (> speed compilation-speed)))
861 (not-set (alloc-xset))
863 (not-res *empty-type*)
864 (leaf (ref-leaf ref)))
865 (declare (type lambda-var leaf))
869 (when (or constrain-symbols (null x) (not (symbolp x)))
870 (add-to-xset x not-set)))))
871 (do-propagatable-constraints (con (in leaf))
872 (let* ((x (constraint-x con))
873 (y (constraint-y con))
874 (not-p (constraint-not-p con))
875 (other (if (eq x leaf) y x))
876 (kind (constraint-kind con)))
880 (if (member-type-p other)
881 (mapc-member-type-members #'note-not other)
882 (setq not-res (type-union not-res other)))
883 (setq res (type-approx-intersection2 res other))))
885 (let ((other-type (leaf-type other)))
887 (when (and (constant-p other)
888 (member-type-p other-type))
889 (note-not (constant-value other)))
890 (let ((leaf-type (leaf-type leaf)))
892 ((or (constant-p other)
893 (and (leaf-refs other) ; protect from
895 (csubtypep other-type leaf-type)
896 (not (type= other-type leaf-type))
897 ;; Don't change to a LEAF not visible here.
898 (leaf-visible-from-node-p other ref)))
899 (change-ref-leaf ref other)
900 (when (constant-p other) (return)))
902 (setq res (type-approx-intersection2
903 res other-type))))))))
906 ((and (integer-type-p res) (integer-type-p y))
907 (let ((greater (eq kind '>)))
908 (let ((greater (if not-p (not greater) greater)))
910 (constrain-integer-type res y greater not-p)))))
911 ((and (float-type-p res) (float-type-p y))
912 (let ((greater (eq kind '>)))
913 (let ((greater (if not-p (not greater) greater)))
915 (constrain-float-type res y greater not-p)))))))))))
916 (cond ((and (if-p (node-dest ref))
917 (or (xset-member-p nil not-set)
918 (csubtypep (specifier-type 'null) not-res)))
919 (setf (node-derived-type ref) *wild-type*)
920 (change-ref-leaf ref (find-constant t)))
923 (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
924 (derive-node-type ref
925 (make-single-value-type
926 (or (type-difference res not-res)
928 (maybe-terminate-block ref nil))))
933 (defun maybe-add-eql-var-lvar-constraint (ref gen)
934 (let ((lvar (ref-lvar ref))
935 (leaf (ref-leaf ref)))
936 (when (and (lambda-var-p leaf) lvar)
937 (conset-add-lvar-lambda-var-eql gen lvar leaf))))
939 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
940 ;; LAMBDA-VAR if possible.
941 (defun maybe-add-eql-var-var-constraint (var lvar constraints
942 &optional (target constraints))
943 (declare (type lambda-var var) (type lvar lvar))
944 (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
946 (add-eql-var-var-constraint var lambda-var constraints target))))
948 ;;; Local propagation
949 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
951 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
952 ;;; a type constraint based on the new value type.
953 (declaim (ftype (function (cblock conset boolean)
955 constraint-propagate-in-block))
956 (defun constraint-propagate-in-block (block gen preprocess-refs-p)
957 (do-nodes (node lvar block)
960 (let ((fun (bind-lambda node)))
961 (when (eq (functional-kind fun) :let)
962 (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
963 for var in (lambda-vars fun)
964 and val in (combination-args call)
965 when (and val (lambda-var-constraints var))
966 do (let ((type (lvar-type val)))
967 (unless (eq type *universal-type*)
968 (conset-add-constraint gen 'typep var type nil)))
969 (maybe-add-eql-var-var-constraint var val gen)))))
971 (when (ok-ref-lambda-var node)
972 (maybe-add-eql-var-lvar-constraint node gen)
973 (when preprocess-refs-p
974 (constrain-ref-type node gen))))
976 (let ((lvar (cast-value node)))
977 (let ((var (ok-lvar-lambda-var lvar gen)))
979 (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
980 (unless (eq atype *universal-type*)
981 (conset-add-constraint-to-eql gen 'typep var atype nil)))))))
983 (binding* ((var (set-var node))
984 (nil (lambda-var-p var) :exit-if-null)
985 (nil (lambda-var-constraints var) :exit-if-null))
986 (when (policy node (and (= speed 3) (> speed compilation-speed)))
987 (let ((type (lambda-var-type var)))
988 (unless (eql *universal-type* type)
989 (do-eql-vars (other (var gen))
990 (unless (eql other var)
991 (conset-add-constraint gen 'typep other type nil))))))
992 (conset-clear-lambda-var gen var)
993 (let ((type (single-value-type (node-derived-type node))))
994 (unless (eq type *universal-type*)
995 (conset-add-constraint gen 'typep var type nil)))
996 (unless (policy node (> compilation-speed speed))
997 (maybe-add-eql-var-var-constraint var (set-value node) gen))))
999 (when (eq (combination-kind node) :known)
1000 (binding* ((info (combination-fun-info node) :exit-if-null)
1001 (propagate (fun-info-constraint-propagate info)
1003 (constraints (funcall propagate node gen))
1004 (register (if (policy node
1005 (> compilation-speed speed))
1006 #'conset-add-constraint
1007 #'conset-add-constraint-to-eql)))
1008 (map nil (lambda (constraint)
1009 (destructuring-bind (kind x y &optional not-p)
1011 (when (and kind x y)
1012 (funcall register gen
1018 (defun constraint-propagate-if (block gen)
1019 (let ((node (block-last block)))
1021 (let ((use (lvar-uses (if-test node))))
1023 (add-test-constraints use node gen))))))
1025 ;;; Starting from IN compute OUT and (consequent/alternative
1026 ;;; constraints if the block ends with an IF). Return the list of
1027 ;;; successors that may need to be recomputed.
1028 (defun find-block-type-constraints (block final-pass-p)
1029 (declare (type cblock block))
1030 (let ((gen (constraint-propagate-in-block
1034 (copy-conset (block-in block)))
1036 (setf (block-gen block) gen)
1037 (multiple-value-bind (consequent-constraints alternative-constraints)
1038 (constraint-propagate-if block gen)
1039 (if consequent-constraints
1040 (let* ((node (block-last block))
1041 (old-consequent-constraints (if-consequent-constraints node))
1042 (old-alternative-constraints (if-alternative-constraints node))
1044 ;; Add the consequent and alternative constraints to GEN.
1045 (cond ((conset-empty consequent-constraints)
1046 (setf (if-consequent-constraints node) gen)
1047 (setf (if-alternative-constraints node) gen))
1049 (setf (if-consequent-constraints node) (copy-conset gen))
1050 (conset-union (if-consequent-constraints node)
1051 consequent-constraints)
1052 (setf (if-alternative-constraints node) gen)
1053 (conset-union (if-alternative-constraints node)
1054 alternative-constraints)))
1055 ;; Has the consequent been changed?
1056 (unless (and old-consequent-constraints
1057 (conset= (if-consequent-constraints node)
1058 old-consequent-constraints))
1059 (push (if-consequent node) succ))
1060 ;; Has the alternative been changed?
1061 (unless (and old-alternative-constraints
1062 (conset= (if-alternative-constraints node)
1063 old-alternative-constraints))
1064 (push (if-alternative node) succ))
1067 (unless (and (block-out block)
1068 (conset= gen (block-out block)))
1069 (setf (block-out block) gen)
1070 (block-succ block))))))
1072 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
1073 ;;; During this pass, we also do local constraint propagation by
1074 ;;; adding in constraints as we see them during the pass through the
1076 (defun use-result-constraints (block)
1077 (declare (type cblock block))
1078 (constraint-propagate-in-block block (block-in block) t))
1080 ;;; Give an empty constraints set to any var that doesn't have one and
1081 ;;; isn't a set closure var. Since a var that we previously rejected
1082 ;;; looks identical to one that is new, so we optimistically keep
1083 ;;; hoping that vars stop being closed over or lose their sets.
1084 (defun init-var-constraints (component)
1085 (declare (type component component))
1086 (dolist (fun (component-lambdas component))
1088 (dolist (var (lambda-vars x))
1089 (unless (lambda-var-constraints var)
1090 (when (or (null (lambda-var-sets var))
1091 (not (closure-var-p var)))
1092 (setf (lambda-var-constraints var) (make-conset)))))))
1094 (dolist (let (lambda-lets fun))
1097 ;;; Return the constraints that flow from PRED to SUCC. This is
1098 ;;; BLOCK-OUT unless PRED ends with an IF and test constraints were
1100 (defun block-out-for-successor (pred succ)
1101 (declare (type cblock pred succ))
1102 (let ((last (block-last pred)))
1103 (or (when (if-p last)
1104 (cond ((eq succ (if-consequent last))
1105 (if-consequent-constraints last))
1106 ((eq succ (if-alternative last))
1107 (if-alternative-constraints last))))
1110 (defun compute-block-in (block)
1112 (dolist (pred (block-pred block))
1113 ;; If OUT has not been calculated, assume it to be the universal
1115 (let ((out (block-out-for-successor pred block)))
1118 (conset-intersection in out)
1119 (setq in (copy-conset out))))))
1120 (or in (make-conset))))
1122 (defun update-block-in (block)
1123 (let ((in (compute-block-in block)))
1124 (cond ((and (block-in block) (conset= in (block-in block)))
1127 (setf (block-in block) in)))))
1129 ;;; Return two lists: one of blocks that precede all loops and
1130 ;;; therefore require only one constraint propagation pass and the
1131 ;;; rest. This implementation does not find all such blocks.
1133 ;;; A more complete implementation would be:
1135 ;;; (do-blocks (block component)
1136 ;;; (if (every #'(lambda (pred)
1137 ;;; (or (member pred leading-blocks)
1138 ;;; (eq pred head)))
1139 ;;; (block-pred block))
1140 ;;; (push block leading-blocks)
1141 ;;; (push block rest-of-blocks)))
1143 ;;; Trailing blocks that succeed all loops could be found and handled
1144 ;;; similarly. In practice though, these more complex solutions are
1145 ;;; slightly worse performancewise.
1146 (defun leading-component-blocks (component)
1147 (declare (type component component))
1148 (flet ((loopy-p (block)
1149 (let ((n (block-number block)))
1150 (dolist (pred (block-pred block))
1151 (unless (< n (block-number pred))
1153 (let ((leading-blocks ())
1156 (do-blocks (block component)
1157 (when (and (not seen-loop-p) (loopy-p block))
1158 (setq seen-loop-p t))
1160 (push block rest-of-blocks)
1161 (push block leading-blocks)))
1162 (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
1164 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
1165 ;;; a member already.
1166 (defun nconc-new (obj list)
1167 (do ((x list (cdr x))
1171 (setf (cdr prev) (list obj))
1174 (when (eql (car x) obj)
1175 (return-from nconc-new list))))
1177 (defun find-and-propagate-constraints (component)
1178 (let ((blocks-to-process ()))
1179 (flet ((enqueue (blocks)
1180 (dolist (block blocks)
1181 (setq blocks-to-process (nconc-new block blocks-to-process)))))
1182 (multiple-value-bind (leading-blocks rest-of-blocks)
1183 (leading-component-blocks component)
1184 ;; Update every block once to account for changes in the
1185 ;; IR1. The constraints of the lead blocks cannot be changed
1186 ;; after the first pass so we might as well use them and skip
1187 ;; USE-RESULT-CONSTRAINTS later.
1188 (dolist (block leading-blocks)
1189 (setf (block-in block) (compute-block-in block))
1190 (find-block-type-constraints block t))
1191 (setq blocks-to-process (copy-list rest-of-blocks))
1192 ;; The rest of the blocks.
1193 (dolist (block rest-of-blocks)
1194 (aver (eq block (pop blocks-to-process)))
1195 (setf (block-in block) (compute-block-in block))
1196 (enqueue (find-block-type-constraints block nil)))
1197 ;; Propagate constraints
1198 (loop for block = (pop blocks-to-process)
1200 (unless (eq block (component-tail component))
1201 (when (update-block-in block)
1202 (enqueue (find-block-type-constraints block nil)))))
1205 (defun constraint-propagate (component)
1206 (declare (type component component))
1207 (init-var-constraints component)
1209 (unless (block-out (component-head component))
1210 (setf (block-out (component-head component)) (make-conset)))
1212 (dolist (block (find-and-propagate-constraints component))
1213 (unless (block-delete-p block)
1214 (use-result-constraints block)))