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 t
) (not simple-array
)) *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 (not (find 1 (conset-vector conset
)
159 :start
(conset-min conset
)
160 ;; the :end argument can be commented out when
161 ;; bootstrapping on a < 1.0.9 SBCL errors out with
162 ;; a full call to DATA-VECTOR-REF-WITH-OFFSET.
163 :end
(conset-max conset
)))))
165 (defun copy-conset (conset)
166 (let ((ret (%copy-conset conset
)))
167 (setf (conset-vector ret
) (copy-seq (conset-vector conset
)))
170 (defun %conset-grow
(conset new-size
)
171 (declare (type index new-size
))
172 (setf (conset-vector conset
)
173 (replace (the simple-bit-vector
175 (ash 1 (integer-length (1- new-size
)))
178 (the simple-bit-vector
179 (conset-vector conset
)))))
181 (declaim (inline conset-grow
))
182 (defun conset-grow (conset new-size
)
183 (declare (type index new-size
))
184 (when (< (length (conset-vector conset
)) new-size
)
185 (%conset-grow conset new-size
))
188 (defun conset-member (constraint conset
)
189 (let ((number (%constraint-number constraint
))
190 (vector (conset-vector conset
)))
191 (when (< number
(length vector
))
192 (plusp (sbit vector number
)))))
194 (defun conset-adjoin (constraint conset
)
195 (let ((number (%constraint-number constraint
)))
196 (conset-grow conset
(1+ number
))
197 (setf (sbit (conset-vector conset
) number
) 1)
198 (setf (conset-min conset
) (min number
(conset-min conset
)))
199 (when (>= number
(conset-max conset
))
200 (setf (conset-max conset
) (1+ number
))))
203 (defun conset= (conset1 conset2
)
204 (let* ((vector1 (conset-vector conset1
))
205 (vector2 (conset-vector conset2
))
206 (length1 (length vector1
))
207 (length2 (length vector2
)))
208 (if (= length1 length2
)
209 ;; When the lengths are the same, we can rely on EQUAL being
210 ;; nicely optimized on bit-vectors.
211 (equal vector1 vector2
)
212 (multiple-value-bind (shorter longer
)
213 (if (< length1 length2
)
214 (values vector1 vector2
)
215 (values vector2 vector1
))
216 ;; FIXME: make MISMATCH fast on bit-vectors.
217 (dotimes (index (length shorter
))
218 (when (/= (sbit vector1 index
) (sbit vector2 index
))
219 (return-from conset
= nil
)))
220 (if (find 1 longer
:start
(length shorter
))
225 ((defconsetop (name bit-op
)
226 `(defun ,name
(conset-1 conset-2
)
227 (declare (optimize (speed 3) (safety 0)))
228 (let* ((size-1 (length (conset-vector conset-1
)))
229 (size-2 (length (conset-vector conset-2
)))
230 (new-size (max size-1 size-2
)))
231 (conset-grow conset-1 new-size
)
232 (conset-grow conset-2 new-size
))
233 (let ((vector1 (conset-vector conset-1
))
234 (vector2 (conset-vector conset-2
)))
235 (declare (simple-bit-vector vector1 vector2
))
236 (setf (conset-vector conset-1
) (,bit-op vector1 vector2 t
))
237 ;; Update the extrema.
240 `(setf (conset-min conset-1
)
241 (min (conset-min conset-1
)
242 (conset-min conset-2
))
243 (conset-max conset-1
)
244 (max (conset-max conset-1
)
245 (conset-max conset-2
))))
246 ((conset-intersection)
247 `(let ((start (max (conset-min conset-1
)
248 (conset-min conset-2
)))
249 (end (min (conset-max conset-1
)
250 (conset-max conset-2
))))
251 (setf (conset-min conset-1
)
254 (or (position 1 (conset-vector conset-1
)
255 :start start
:end end
)
257 (conset-max conset-1
)
262 1 (conset-vector conset-1
)
263 :start start
:end end
:from-end t
)))
268 `(setf (conset-min conset-1
)
269 (or (position 1 (conset-vector conset-1
)
270 :start
(conset-min conset-1
)
271 :end
(conset-max conset-1
))
273 (conset-max conset-1
)
276 1 (conset-vector conset-1
)
277 :start
(conset-min conset-1
)
278 :end
(conset-max conset-1
)
284 (defconsetop conset-union bit-ior
)
285 (defconsetop conset-intersection bit-and
)
286 (defconsetop conset-difference bit-andc2
)))
288 ;;; Constraints are hash-consed. Unfortunately, types aren't, so we have
289 ;;; to over-approximate and then linear search through the potential hits.
290 ;;; LVARs can only be found in EQL (not-p = NIL) constraints, while constant
291 ;;; and lambda-vars can only be found in EQL constraints.
292 (defun find-constraint (kind x y not-p
)
293 (declare (type lambda-var x
) (type constraint-y y
) (type boolean not-p
))
296 (awhen (lambda-var-ctype-constraints x
)
297 (dolist (con (gethash (sb!kernel
::type-class-info y
) it
) nil
)
298 (when (and (eq (constraint-kind con
) kind
)
299 (eq (constraint-not-p con
) not-p
)
300 (type= (constraint-y con
) y
))
301 (return-from find-constraint con
)))
304 (awhen (lambda-var-eq-constraints x
)
306 ((or constant lambda-var
)
307 (awhen (lambda-var-eq-constraints x
)
308 (let ((cache (gethash y it
)))
309 (declare (type list cache
))
310 (if not-p
(cdr cache
) (car cache
)))))))
312 ;;; The most common operations on consets are iterating through the constraints
313 ;;; that are related to a certain variable in a given conset. Storing the
314 ;;; constraints related to each variable in vectors allows us to easily iterate
315 ;;; through the intersection of such constraints and the constraints in a conset.
317 ;;; EQL-var constraints assert that two lambda-vars are EQL.
318 ;;; Private constraints assert that a lambda-var is EQL or not EQL to a constant.
319 ;;; Inheritable constraints are constraints that may be propagated to EQL
320 ;;; lambda-vars (along with EQL-var constraints).
322 ;;; Lambda-var -- lvar EQL constraints only serve one purpose: remember whether
323 ;;; an lvar is (only) written to by a ref to that lambda-var, and aren't ever
326 ;;; Finally, the lambda-var conset is only used to track the whole set of
327 ;;; constraints associated with a given lambda-var, and thus easily delete
328 ;;; such constraints from a conset.
329 (defun register-constraint (x con y
)
330 (declare (type lambda-var x
) (type constraint con
) (type constraint-y y
))
331 (conset-adjoin con
(lambda-var-constraints x
))
332 (macrolet ((ensuref (place default
)
333 `(or ,place
(setf ,place
,default
)))
335 `(ensuref ,place
(make-hash-table)))
337 `(ensuref ,place
(make-array 8 :adjustable t
:fill-pointer
0))))
340 (let ((index (ensure-hash (lambda-var-ctype-constraints x
)))
341 (vec (ensure-vec (lambda-var-inheritable-constraints x
))))
342 (push con
(gethash (sb!kernel
::type-class-info y
) index
))
343 (vector-push-extend con vec
)))
345 (let ((index (ensure-hash (lambda-var-eq-constraints x
))))
346 (setf (gethash y index
) con
)))
347 ((or constant lambda-var
)
348 (let* ((index (ensure-hash (lambda-var-eq-constraints x
)))
349 (cons (ensuref (gethash y index
) (list nil
))))
350 (if (constraint-not-p con
)
351 (setf (cdr cons
) con
)
352 (setf (car cons
) con
)))
355 (let ((vec (ensure-vec (lambda-var-private-constraints x
))))
356 (vector-push-extend con vec
)))
358 (let ((vec (if (constraint-not-p con
)
359 (ensure-vec (lambda-var-inheritable-constraints x
))
360 (ensure-vec (lambda-var-eql-var-constraints x
)))))
361 (vector-push-extend con vec
)))))))
364 ;;; Return a constraint for the specified arguments. We only create a
365 ;;; new constraint if there isn't already an equivalent old one,
366 ;;; guaranteeing that all equivalent constraints are EQ. This
367 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
368 (defun find-or-create-constraint (kind x y not-p
)
369 (declare (type lambda-var x
) (type constraint-y y
) (type boolean not-p
))
370 (or (find-constraint kind x y not-p
)
371 (let ((new (make-constraint (length *constraint-universe
*)
373 (vector-push-extend new
*constraint-universe
*
374 (1+ (length *constraint-universe
*)))
375 (register-constraint x new y
)
376 (when (lambda-var-p y
)
377 (register-constraint y new x
))
380 ;;; Actual conset interface
382 ;;; Constraint propagation needs to iterate over the set of lambda-vars known to
383 ;;; be EQL to a given variable (including itself), via DO-EQL-VARS.
385 ;;; It also has to iterate through constraints that are inherited by EQL variables
386 ;;; (DO-INHERITABLE-CONSTRAINTS), and through constraints used by
387 ;;; CONSTRAIN-REF-TYPE (to derive the type of a REF to a lambda-var).
389 ;;; Consets must keep track of which lvars are EQL to a given lambda-var (result
390 ;;; from a REF to the lambda-var): CONSET-LVAR-LAMBDA-VAR-EQL-P and
391 ;;; CONSET-ADD-LVAR-LAMBDA-VAR-EQL. This, as all other constraints, must of
392 ;;; course be cleared when a lambda-var's constraints are dropped because of
395 ;;; Consets must be able to add constraints to a given lambda-var
396 ;;; (CONSET-ADD-CONSTRAINT), and to the set of variables EQL to a given
397 ;;; lambda-var (CONSET-ADD-CONSTRAINT-TO-EQL).
399 ;;; When a lambda-var is assigned to, all the constraints involving that variable
400 ;;; must be dropped: constraint propagation is flow-sensitive, so the constraints
401 ;;; relate to the variable at a given range of program point. In such cases,
402 ;;; constraint propagation calls CONSET-CLEAR-LAMBDA-VAR.
404 ;;; Finally, one of the main strengths of constraint propagation in SBCL is the
405 ;;; tracking of EQL variables to help constraint propagation. When two variables
406 ;;; are known to be EQL (e.g. after a branch), ADD-EQL-VAR-VAR-CONSTRAINT is
407 ;;; called to add the EQL constraint, but also have each equality class inherit
408 ;;; the other's (inheritable) constraints.
410 ;;; On top of that, we have the usual bulk set operations: intersection, copy,
411 ;;; equality or emptiness testing. There's also union, but that's only an
412 ;;; optimisation to avoid useless copies in ADD-TEST-CONSTRAINTS and
413 ;;; FIND-BLOCK-TYPE-CONSTRAINTS.
414 (defmacro do-conset-constraints-intersection
((symbol (conset constraints
) &optional result
)
416 (let ((min (gensym "MIN"))
417 (max (gensym "MAX")))
418 (once-only ((conset conset
)
419 (constraints constraints
))
420 `(flet ((body (,symbol
)
421 (declare (type constraint
,symbol
))
424 (let ((,min
(conset-min ,conset
))
425 (,max
(conset-max ,conset
)))
426 (declare (optimize speed
))
427 (map nil
(lambda (constraint)
428 (declare (type constraint constraint
))
429 (let ((number (constraint-number constraint
)))
430 (when (and (<= ,min number
)
432 (conset-member constraint
,conset
))
437 (defmacro do-eql-vars
((symbol (var constraints
) &optional result
) &body body
)
438 (once-only ((var var
)
439 (constraints constraints
))
440 `(flet ((body-fun (,symbol
)
443 (do-conset-constraints-intersection
444 (con (,constraints
(lambda-var-eql-var-constraints ,var
)) ,result
)
445 (let ((x (constraint-x con
))
446 (y (constraint-y con
)))
447 (body-fun (if (eq ,var x
) y x
)))))))
449 (defmacro do-inheritable-constraints
((symbol (conset variable
) &optional result
)
451 (once-only ((conset conset
)
454 (flet ((body-fun (,symbol
)
456 (do-conset-constraints-intersection
457 (con (,conset
(lambda-var-inheritable-constraints ,variable
)))
459 (do-conset-constraints-intersection
460 (con (,conset
(lambda-var-eql-var-constraints ,variable
)) ,result
)
463 (defmacro do-propagatable-constraints
((symbol (conset variable
) &optional result
)
465 (once-only ((conset conset
)
468 (flet ((body-fun (,symbol
)
470 (do-conset-constraints-intersection
471 (con (,conset
(lambda-var-private-constraints ,variable
)))
473 (do-conset-constraints-intersection
474 (con (,conset
(lambda-var-eql-var-constraints ,variable
)))
476 (do-conset-constraints-intersection
477 (con (,conset
(lambda-var-inheritable-constraints ,variable
)) ,result
)
480 (declaim (inline conset-lvar-lambda-var-eql-p conset-add-lvar-lambda-var-eql
))
481 (defun conset-lvar-lambda-var-eql-p (conset lvar lambda-var
)
482 (let ((constraint (find-constraint 'eql lambda-var lvar nil
)))
484 (conset-member constraint conset
))))
486 (defun conset-add-lvar-lambda-var-eql (conset lvar lambda-var
)
487 (let ((constraint (find-or-create-constraint 'eql lambda-var lvar nil
)))
488 (conset-adjoin constraint conset
)))
490 (declaim (inline conset-add-constraint conset-add-constraint-to-eql
))
491 (defun conset-add-constraint (conset kind x y not-p
)
492 (declare (type conset conset
)
494 (conset-adjoin (find-or-create-constraint kind x y not-p
)
497 (defun conset-add-constraint-to-eql (conset kind x y not-p
&optional
(target conset
))
498 (declare (type conset target conset
)
500 (do-eql-vars (x (x conset
))
501 (conset-add-constraint target kind x y not-p
)))
503 (declaim (inline conset-clear-lambda-var
))
504 (defun conset-clear-lambda-var (conset var
)
505 (conset-difference conset
(lambda-var-constraints var
)))
507 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
508 ;;; LVAR) ones - to all of the variables in the VARS list.
509 (defun inherit-constraints (vars from-var constraints target
)
510 (do-inheritable-constraints (con (constraints from-var
))
511 (let ((eq-x (eq from-var
(constraint-x con
)))
512 (eq-y (eq from-var
(constraint-y con
))))
514 (conset-add-constraint target
515 (constraint-kind con
)
516 (if eq-x var
(constraint-x con
))
517 (if eq-y var
(constraint-y con
))
518 (constraint-not-p con
))))))
520 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
521 ;; inherit each other's constraints.
522 (defun add-eql-var-var-constraint (var1 var2 constraints
523 &optional
(target constraints
))
524 (let ((constraint (find-or-create-constraint 'eql var1 var2 nil
)))
525 (unless (conset-member constraint target
)
526 (conset-adjoin constraint target
)
527 (collect ((eql1) (eql2))
528 (do-eql-vars (var1 (var1 constraints
))
530 (do-eql-vars (var2 (var2 constraints
))
532 (inherit-constraints (eql1) var2 constraints target
)
533 (inherit-constraints (eql2) var1 constraints target
))
536 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
537 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
538 #!-sb-fluid
(declaim (inline ok-ref-lambda-var
))
539 (defun ok-ref-lambda-var (ref)
540 (declare (type ref ref
))
541 (let ((leaf (ref-leaf ref
)))
542 (when (and (lambda-var-p leaf
)
543 (lambda-var-constraints leaf
))
546 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
547 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
548 (defun ok-lvar-lambda-var (lvar constraints
)
549 (declare (type lvar lvar
))
550 (let ((use (lvar-uses lvar
)))
552 (let ((lambda-var (ok-ref-lambda-var use
)))
554 (conset-lvar-lambda-var-eql-p constraints lvar lambda-var
)
557 (ok-lvar-lambda-var (cast-value use
) constraints
)))))
558 ;;;; Searching constraints
560 ;;; Add the indicated test constraint to TARGET.
561 (declaim (inline precise-add-test-constraint
))
562 (defun precise-add-test-constraint (fun x y not-p constraints target
)
563 (if (and (eq 'eql fun
) (lambda-var-p y
) (not not-p
))
564 (add-eql-var-var-constraint x y constraints target
)
565 (conset-add-constraint-to-eql constraints fun x y not-p target
))
568 (defun add-test-constraint (quick-p fun x y not-p constraints target
)
570 (conset-add-constraint target fun x y not-p
))
572 (precise-add-test-constraint fun x y not-p constraints target
))))
573 ;;; Add complementary constraints to the consequent and alternative
574 ;;; blocks of IF. We do nothing if X is NIL.
575 (declaim (inline quick-add-complement-constraints
))
576 (defun precise-add-complement-constraints (fun x y not-p constraints
577 consequent-constraints
578 alternative-constraints
)
580 (precise-add-test-constraint fun x y not-p constraints
581 consequent-constraints
)
582 (precise-add-test-constraint fun x y
(not not-p
) constraints
583 alternative-constraints
))
586 (defun quick-add-complement-constraints (fun x y not-p
587 consequent-constraints
588 alternative-constraints
)
590 (conset-add-constraint consequent-constraints fun x y not-p
)
591 (conset-add-constraint alternative-constraints fun x y
(not not-p
)))
594 (defun add-complement-constraints (quick-p fun x y not-p constraints
595 consequent-constraints
596 alternative-constraints
)
598 (quick-add-complement-constraints fun x y not-p
599 consequent-constraints
600 alternative-constraints
)
601 (precise-add-complement-constraints fun x y not-p constraints
602 consequent-constraints
603 alternative-constraints
)))
605 (defun add-combination-test-constraints (use constraints
606 consequent-constraints
607 alternative-constraints
609 (flet ((add (fun x y not-p
)
610 (add-complement-constraints quick-p
613 consequent-constraints
614 alternative-constraints
))
615 (prop (triples target
)
616 (map nil
(lambda (constraint)
617 (destructuring-bind (kind x y
&optional not-p
)
620 (add-test-constraint quick-p
625 (when (eq (combination-kind use
) :known
)
626 (binding* ((info (combination-fun-info use
) :exit-if-null
)
627 (propagate (fun-info-constraint-propagate-if
630 (multiple-value-bind (lvar type if else
)
631 (funcall propagate use constraints
)
632 (prop if consequent-constraints
)
633 (prop else alternative-constraints
)
634 (when (and lvar type
)
635 (add 'typep
(ok-lvar-lambda-var lvar constraints
)
637 (return-from add-combination-test-constraints
)))))
638 (let* ((name (lvar-fun-name
639 (basic-combination-fun use
)))
640 (args (basic-combination-args use
))
641 (ptype (gethash name
*backend-predicate-types
*)))
643 (add 'typep
(ok-lvar-lambda-var (first args
)
647 ;;; Add test constraints to the consequent and alternative blocks of
648 ;;; the test represented by USE.
649 (defun add-test-constraints (use if constraints
)
650 (declare (type node use
) (type cif if
))
651 ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
652 ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
653 ;; can't guarantee that the optimization will be done, so we still
654 ;; need to avoid barfing on this case.
655 (unless (eq (if-consequent if
) (if-alternative if
))
656 (let ((consequent-constraints (make-conset))
657 (alternative-constraints (make-conset))
658 (quick-p (policy if
(> compilation-speed speed
))))
659 (macrolet ((add (fun x y not-p
)
660 `(add-complement-constraints quick-p
663 consequent-constraints
664 alternative-constraints
)))
667 (add 'typep
(ok-lvar-lambda-var (ref-lvar use
) constraints
)
668 (specifier-type 'null
) t
))
670 (unless (eq (combination-kind use
)
672 (let ((name (lvar-fun-name
673 (basic-combination-fun use
)))
674 (args (basic-combination-args use
)))
676 ((%typep %instance-typep
)
677 (let ((type (second args
)))
678 (when (constant-lvar-p type
)
679 (let ((val (lvar-value type
)))
681 (ok-lvar-lambda-var (first args
) constraints
)
684 (let ((*compiler-error-context
* use
))
685 (specifier-type val
)))
688 (let* ((arg1 (first args
))
689 (var1 (ok-lvar-lambda-var arg1 constraints
))
691 (var2 (ok-lvar-lambda-var arg2 constraints
)))
692 ;; The code below assumes that the constant is the
693 ;; second argument in case of variable to constant
694 ;; comparison which is sometimes true (see source
695 ;; transformations for EQ, EQL and CHAR=). Fixing
696 ;; that would result in more constant substitutions
697 ;; which is not a universally good thing, thus the
698 ;; unnatural asymmetry of the tests.
701 (add-test-constraint quick-p
702 'typep var2
(lvar-type arg1
)
704 consequent-constraints
)))
706 (add 'eql var1 var2 nil
))
707 ((constant-lvar-p arg2
)
709 (find-constant (lvar-value arg2
))
712 (add-test-constraint quick-p
713 'typep var1
(lvar-type arg2
)
715 consequent-constraints
)))))
717 (let* ((arg1 (first args
))
718 (var1 (ok-lvar-lambda-var arg1 constraints
))
720 (var2 (ok-lvar-lambda-var arg2 constraints
)))
722 (add name var1
(lvar-type arg2
) nil
))
724 (add (if (eq name
'<) '> '<) var2
(lvar-type arg1
) nil
))))
726 (add-combination-test-constraints use constraints
727 consequent-constraints
728 alternative-constraints
730 (values consequent-constraints alternative-constraints
))))
732 ;;;; Applying constraints
734 ;;; Return true if X is an integer NUMERIC-TYPE.
735 (defun integer-type-p (x)
736 (declare (type ctype x
))
737 (and (numeric-type-p x
)
738 (eq (numeric-type-class x
) 'integer
)
739 (eq (numeric-type-complexp x
) :real
)))
741 ;;; Given that an inequality holds on values of type X and Y, return a
742 ;;; new type for X. If GREATER is true, then X was greater than Y,
743 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
744 ;;; inclusive, i.e. >=.
746 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
747 ;;; bound into X and return that result. If not OR-EQUAL, we can go
748 ;;; one greater (less) than Y's bound.
749 (defun constrain-integer-type (x y greater or-equal
)
750 (declare (type numeric-type x y
))
757 (if greater
(numeric-type-low x
) (numeric-type-high x
))))
758 (let* ((x-bound (bound x
))
759 (y-bound (exclude (bound y
)))
760 (new-bound (cond ((not x-bound
) y-bound
)
761 ((not y-bound
) x-bound
)
762 (greater (max x-bound y-bound
))
763 (t (min x-bound y-bound
)))))
765 (modified-numeric-type x
:low new-bound
)
766 (modified-numeric-type x
:high new-bound
)))))
768 ;;; Return true if X is a float NUMERIC-TYPE.
769 (defun float-type-p (x)
770 (declare (type ctype x
))
771 (and (numeric-type-p x
)
772 (eq (numeric-type-class x
) 'float
)
773 (eq (numeric-type-complexp x
) :real
)))
775 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
777 ;;; In contrast to the integer version, here the input types can have
778 ;;; open bounds in addition to closed ones and we don't increment or
779 ;;; decrement a bound to honor OR-EQUAL being NIL but put an open bound
780 ;;; into the result instead, if appropriate.
781 (defun constrain-float-type (x y greater or-equal
)
782 (declare (type numeric-type x y
))
783 (declare (ignorable x y greater or-equal
)) ; for CROSS-FLOAT-INFINITY-KLUDGE
785 (aver (eql (numeric-type-class x
) 'float
))
786 (aver (eql (numeric-type-class y
) 'float
))
787 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
789 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
790 (labels ((exclude (x)
798 (if greater
(numeric-type-low x
) (numeric-type-high x
)))
802 ((= (type-bound-number x
) (type-bound-number ref
))
803 ;; X is tighter if X is an open bound and REF is not
804 (and (consp x
) (not (consp ref
))))
806 (< (type-bound-number ref
) (type-bound-number x
)))
808 (> (type-bound-number ref
) (type-bound-number x
))))))
809 (let* ((x-bound (bound x
))
810 (y-bound (exclude (bound y
)))
811 (new-bound (cond ((not x-bound
)
815 ((tighter-p y-bound x-bound
)
820 (modified-numeric-type x
:low new-bound
)
821 (modified-numeric-type x
:high new-bound
)))))
823 ;;; Return true if LEAF is "visible" from NODE.
824 (defun leaf-visible-from-node-p (leaf node
)
827 ;; A LAMBDA-VAR is visible iif it is homed in a CLAMBDA that is an
828 ;; ancestor for NODE.
829 (let ((leaf-lambda (lambda-var-home leaf
)))
830 (loop for lambda
= (node-home-lambda node
)
831 then
(lambda-parent lambda
)
833 when
(eq lambda leaf-lambda
)
835 ;; FIXME: Check on FUNCTIONALs (CLAMBDAs and OPTIONAL-DISPATCHes),
836 ;; not just LAMBDA-VARs.
838 ;; Assume everything else is globally visible.
841 ;;; Given the set of CONSTRAINTS for a variable and the current set of
842 ;;; restrictions from flow analysis IN, set the type for REF
844 (defun constrain-ref-type (ref in
)
845 (declare (type ref ref
) (type conset in
))
846 ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
847 ;; cons up endless union types when propagating large number of EQL
848 ;; constraints -- eg. from large CASE forms -- instead we just
849 ;; directly accumulate one XSET, and a set of fp zeroes, which we at
850 ;; the end turn into a MEMBER-TYPE.
852 ;; Since massive symbol cases are an especially atrocious pattern
853 ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
854 ;; a more useful type, don't propagate their negation except for NIL
855 ;; unless SPEED > COMPILATION-SPEED.
856 (let ((res (single-value-type (node-derived-type ref
)))
857 (constrain-symbols (policy ref
(> speed compilation-speed
)))
858 (not-set (alloc-xset))
860 (not-res *empty-type
*)
861 (leaf (ref-leaf ref
)))
862 (declare (type lambda-var leaf
))
866 (when (or constrain-symbols
(null x
) (not (symbolp x
)))
867 (add-to-xset x not-set
)))))
868 (do-propagatable-constraints (con (in leaf
))
869 (let* ((x (constraint-x con
))
870 (y (constraint-y con
))
871 (not-p (constraint-not-p con
))
872 (other (if (eq x leaf
) y x
))
873 (kind (constraint-kind con
)))
877 (if (member-type-p other
)
878 (mapc-member-type-members #'note-not other
)
879 (setq not-res
(type-union not-res other
)))
880 (setq res
(type-approx-intersection2 res other
))))
882 (let ((other-type (leaf-type other
)))
884 (when (and (constant-p other
)
885 (member-type-p other-type
))
886 (note-not (constant-value other
)))
887 (let ((leaf-type (leaf-type leaf
)))
889 ((or (constant-p other
)
890 (and (leaf-refs other
) ; protect from
892 (csubtypep other-type leaf-type
)
893 (not (type= other-type leaf-type
))
894 ;; Don't change to a LEAF not visible here.
895 (leaf-visible-from-node-p other ref
)))
896 (change-ref-leaf ref other
)
897 (when (constant-p other
) (return)))
899 (setq res
(type-approx-intersection2
900 res other-type
))))))))
903 ((and (integer-type-p res
) (integer-type-p y
))
904 (let ((greater (eq kind
'>)))
905 (let ((greater (if not-p
(not greater
) greater
)))
907 (constrain-integer-type res y greater not-p
)))))
908 ((and (float-type-p res
) (float-type-p y
))
909 (let ((greater (eq kind
'>)))
910 (let ((greater (if not-p
(not greater
) greater
)))
912 (constrain-float-type res y greater not-p
)))))))))))
913 (cond ((and (if-p (node-dest ref
))
914 (or (xset-member-p nil not-set
)
915 (csubtypep (specifier-type 'null
) not-res
)))
916 (setf (node-derived-type ref
) *wild-type
*)
917 (change-ref-leaf ref
(find-constant t
)))
920 (type-union not-res
(make-member-type not-set not-fpz
)))
921 (derive-node-type ref
922 (make-single-value-type
923 (or (type-difference res not-res
)
925 (maybe-terminate-block ref nil
))))
930 (defun maybe-add-eql-var-lvar-constraint (ref gen
)
931 (let ((lvar (ref-lvar ref
))
932 (leaf (ref-leaf ref
)))
933 (when (and (lambda-var-p leaf
) lvar
)
934 (conset-add-lvar-lambda-var-eql gen lvar leaf
))))
936 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
937 ;; LAMBDA-VAR if possible.
938 (defun maybe-add-eql-var-var-constraint (var lvar constraints
939 &optional
(target constraints
))
940 (declare (type lambda-var var
) (type lvar lvar
))
941 (let ((lambda-var (ok-lvar-lambda-var lvar constraints
)))
943 (add-eql-var-var-constraint var lambda-var constraints target
))))
945 ;;; Local propagation
946 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
948 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
949 ;;; a type constraint based on the new value type.
950 (declaim (ftype (function (cblock conset boolean
)
952 constraint-propagate-in-block
))
953 (defun constraint-propagate-in-block (block gen preprocess-refs-p
)
954 (do-nodes (node lvar block
)
957 (let ((fun (bind-lambda node
)))
958 (when (eq (functional-kind fun
) :let
)
959 (loop with call
= (lvar-dest (node-lvar (first (lambda-refs fun
))))
960 for var in
(lambda-vars fun
)
961 and val in
(combination-args call
)
962 when
(and val
(lambda-var-constraints var
))
963 do
(let ((type (lvar-type val
)))
964 (unless (eq type
*universal-type
*)
965 (conset-add-constraint gen
'typep var type nil
)))
966 (maybe-add-eql-var-var-constraint var val gen
)))))
968 (when (ok-ref-lambda-var node
)
969 (maybe-add-eql-var-lvar-constraint node gen
)
970 (when preprocess-refs-p
971 (constrain-ref-type node gen
))))
973 (let ((lvar (cast-value node
)))
974 (let ((var (ok-lvar-lambda-var lvar gen
)))
976 (let ((atype (single-value-type (cast-derived-type node
)))) ;FIXME
977 (unless (eq atype
*universal-type
*)
978 (conset-add-constraint-to-eql gen
'typep var atype nil
)))))))
980 (binding* ((var (set-var node
))
981 (nil (lambda-var-p var
) :exit-if-null
)
982 (nil (lambda-var-constraints var
) :exit-if-null
))
983 (when (policy node
(and (= speed
3) (> speed compilation-speed
)))
984 (let ((type (lambda-var-type var
)))
985 (unless (eq *universal-type
* type
)
986 (do-eql-vars (other (var gen
))
987 (unless (eql other var
)
988 (conset-add-constraint gen
'typep other type nil
))))))
989 (conset-clear-lambda-var gen var
)
990 (let ((type (single-value-type (node-derived-type node
))))
991 (unless (eq type
*universal-type
*)
992 (conset-add-constraint gen
'typep var type nil
)))
993 (unless (policy node
(> compilation-speed speed
))
994 (maybe-add-eql-var-var-constraint var
(set-value node
) gen
))))
996 (when (eq (combination-kind node
) :known
)
997 (binding* ((info (combination-fun-info node
) :exit-if-null
)
998 (propagate (fun-info-constraint-propagate info
)
1000 (constraints (funcall propagate node gen
))
1001 (register (if (policy node
1002 (> compilation-speed speed
))
1003 #'conset-add-constraint
1004 #'conset-add-constraint-to-eql
)))
1005 (map nil
(lambda (constraint)
1006 (destructuring-bind (kind x y
&optional not-p
)
1008 (when (and kind x y
)
1009 (funcall register gen
1015 (defun constraint-propagate-if (block gen
)
1016 (let ((node (block-last block
)))
1018 (let ((use (lvar-uses (if-test node
))))
1020 (add-test-constraints use node gen
))))))
1022 ;;; Starting from IN compute OUT and (consequent/alternative
1023 ;;; constraints if the block ends with an IF). Return the list of
1024 ;;; successors that may need to be recomputed.
1025 (defun find-block-type-constraints (block final-pass-p
)
1026 (declare (type cblock block
))
1027 (let ((gen (constraint-propagate-in-block
1031 (copy-conset (block-in block
)))
1033 (setf (block-gen block
) gen
)
1034 (multiple-value-bind (consequent-constraints alternative-constraints
)
1035 (constraint-propagate-if block gen
)
1036 (if consequent-constraints
1037 (let* ((node (block-last block
))
1038 (old-consequent-constraints (if-consequent-constraints node
))
1039 (old-alternative-constraints (if-alternative-constraints node
))
1040 (no-consequent (conset-empty consequent-constraints
))
1041 (no-alternative (conset-empty alternative-constraints
))
1043 ;; Add the consequent and alternative constraints to GEN.
1044 (cond ((and no-consequent no-alternative
)
1045 (setf (if-consequent-constraints node
) gen
)
1046 (setf (if-alternative-constraints node
) gen
))
1048 (setf (if-consequent-constraints node
) (copy-conset gen
))
1049 (unless no-consequent
1050 (conset-union (if-consequent-constraints node
)
1051 consequent-constraints
))
1052 (setf (if-alternative-constraints node
) gen
)
1053 (unless no-alternative
1054 (conset-union (if-alternative-constraints node
)
1055 alternative-constraints
))))
1056 ;; Has the consequent been changed?
1057 (unless (and old-consequent-constraints
1058 (conset= (if-consequent-constraints node
)
1059 old-consequent-constraints
))
1060 (push (if-consequent node
) succ
))
1061 ;; Has the alternative been changed?
1062 (unless (and old-alternative-constraints
1063 (conset= (if-alternative-constraints node
)
1064 old-alternative-constraints
))
1065 (push (if-alternative node
) succ
))
1068 (unless (and (block-out block
)
1069 (conset= gen
(block-out block
)))
1070 (setf (block-out block
) gen
)
1071 (block-succ block
))))))
1073 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
1074 ;;; During this pass, we also do local constraint propagation by
1075 ;;; adding in constraints as we see them during the pass through the
1077 (defun use-result-constraints (block)
1078 (declare (type cblock block
))
1079 (constraint-propagate-in-block block
(block-in block
) t
))
1081 ;;; Give an empty constraints set to any var that doesn't have one and
1082 ;;; isn't a set closure var. Since a var that we previously rejected
1083 ;;; looks identical to one that is new, so we optimistically keep
1084 ;;; hoping that vars stop being closed over or lose their sets.
1085 (defun init-var-constraints (component)
1086 (declare (type component component
))
1087 (dolist (fun (component-lambdas component
))
1089 (dolist (var (lambda-vars x
))
1090 (unless (lambda-var-constraints var
)
1091 (when (or (null (lambda-var-sets var
))
1092 (not (closure-var-p var
)))
1093 (setf (lambda-var-constraints var
) (make-conset)))))))
1095 (dolist (let (lambda-lets fun
))
1098 ;;; Return the constraints that flow from PRED to SUCC. This is
1099 ;;; BLOCK-OUT unless PRED ends with an IF and test constraints were
1101 (defun block-out-for-successor (pred succ
)
1102 (declare (type cblock pred succ
))
1103 (let ((last (block-last pred
)))
1104 (or (when (if-p last
)
1105 (cond ((eq succ
(if-consequent last
))
1106 (if-consequent-constraints last
))
1107 ((eq succ
(if-alternative last
))
1108 (if-alternative-constraints last
))))
1111 (defun compute-block-in (block)
1113 (dolist (pred (block-pred block
))
1114 ;; If OUT has not been calculated, assume it to be the universal
1116 (let ((out (block-out-for-successor pred block
)))
1119 (conset-intersection in out
)
1120 (setq in
(copy-conset out
))))))
1121 (or in
(make-conset))))
1123 (defun update-block-in (block)
1124 (let ((in (compute-block-in block
)))
1125 (cond ((and (block-in block
) (conset= in
(block-in block
)))
1128 (setf (block-in block
) in
)))))
1130 ;;; Return two lists: one of blocks that precede all loops and
1131 ;;; therefore require only one constraint propagation pass and the
1132 ;;; rest. This implementation does not find all such blocks.
1134 ;;; A more complete implementation would be:
1136 ;;; (do-blocks (block component)
1137 ;;; (if (every #'(lambda (pred)
1138 ;;; (or (member pred leading-blocks)
1139 ;;; (eq pred head)))
1140 ;;; (block-pred block))
1141 ;;; (push block leading-blocks)
1142 ;;; (push block rest-of-blocks)))
1144 ;;; Trailing blocks that succeed all loops could be found and handled
1145 ;;; similarly. In practice though, these more complex solutions are
1146 ;;; slightly worse performancewise.
1147 (defun leading-component-blocks (component)
1148 (declare (type component component
))
1149 (flet ((loopy-p (block)
1150 (let ((n (block-number block
)))
1151 (dolist (pred (block-pred block
))
1152 (unless (< n
(block-number pred
))
1154 (let ((leading-blocks ())
1157 (do-blocks (block component
)
1158 (when (and (not seen-loop-p
) (loopy-p block
))
1159 (setq seen-loop-p t
))
1161 (push block rest-of-blocks
)
1162 (push block leading-blocks
)))
1163 (values (nreverse leading-blocks
) (nreverse rest-of-blocks
)))))
1165 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
1166 ;;; a member already.
1167 (defun nconc-new (obj list
)
1168 (do ((x list
(cdr x
))
1172 (setf (cdr prev
) (list obj
))
1175 (when (eql (car x
) obj
)
1176 (return-from nconc-new list
))))
1178 (defun find-and-propagate-constraints (component)
1179 (let ((blocks-to-process ()))
1180 (flet ((enqueue (blocks)
1181 (dolist (block blocks
)
1182 (setq blocks-to-process
(nconc-new block blocks-to-process
)))))
1183 (multiple-value-bind (leading-blocks rest-of-blocks
)
1184 (leading-component-blocks component
)
1185 ;; Update every block once to account for changes in the
1186 ;; IR1. The constraints of the lead blocks cannot be changed
1187 ;; after the first pass so we might as well use them and skip
1188 ;; USE-RESULT-CONSTRAINTS later.
1189 (dolist (block leading-blocks
)
1190 (setf (block-in block
) (compute-block-in block
))
1191 (find-block-type-constraints block t
))
1192 (setq blocks-to-process
(copy-list rest-of-blocks
))
1193 ;; The rest of the blocks.
1194 (dolist (block rest-of-blocks
)
1195 (aver (eq block
(pop blocks-to-process
)))
1196 (setf (block-in block
) (compute-block-in block
))
1197 (enqueue (find-block-type-constraints block nil
)))
1198 ;; Propagate constraints
1199 (loop for block
= (pop blocks-to-process
)
1201 (unless (eq block
(component-tail component
))
1202 (when (update-block-in block
)
1203 (enqueue (find-block-type-constraints block nil
)))))
1206 (defun constraint-propagate (component)
1207 (declare (type component component
))
1208 (init-var-constraints component
)
1210 (unless (block-out (component-head component
))
1211 (setf (block-out (component-head component
)) (make-conset)))
1213 (dolist (block (find-and-propagate-constraints component
))
1214 (unless (block-delete-p block
)
1215 (use-result-constraints block
)))