1.0.21.14: fix CHECK-FASL-HEADER buglet
[sbcl.git] / src / compiler / constraint.lisp
1 ;;;; This file implements the constraint propagation phase of the
2 ;;;; compiler, which uses global flow analysis to obtain dynamic type
3 ;;;; information.
4
5 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; more information.
7 ;;;;
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.
13
14 ;;; TODO:
15 ;;;
16 ;;; -- documentation
17 ;;;
18 ;;; -- MV-BIND, :ASSIGNMENT
19 ;;;
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.
25
26 ;;; Problems:
27 ;;;
28 ;;; -- Constraint propagation badly interacts with bottom-up type
29 ;;; inference. Consider
30 ;;;
31 ;;; (defun foo (n &aux (i 42))
32 ;;;   (declare (optimize speed))
33 ;;;   (declare (fixnum n)
34 ;;;            #+nil (type (integer 0) i))
35 ;;;   (tagbody
36 ;;;      (setq i 0)
37 ;;;    :loop
38 ;;;      (when (>= i n) (go :exit))
39 ;;;      (setq i (1+ i))
40 ;;;      (go :loop)
41 ;;;    :exit))
42 ;;;
43 ;;; In this case CP cannot even infer that I is of class INTEGER.
44 ;;;
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)).
48
49 (in-package "SB!C")
50
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*)
55
56 (deftype constraint-y () '(or ctype lvar lambda-var constant))
57
58 (defstruct (constraint
59             (:include sset-element)
60             (:constructor make-constraint (number kind x y not-p))
61             (:copier nil))
62   ;; the kind of constraint we have:
63   ;;
64   ;; TYPEP
65   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
66   ;;     constrained to be of type Y.
67   ;;
68   ;; > or <
69   ;;     X is a lambda-var and Y is a CTYPE. The relation holds
70   ;;     between X and some object of type Y.
71   ;;
72   ;; EQL
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
80   ;; does *not* hold.
81   (not-p nil :type boolean))
82 \f
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.
93
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
98 ;;; around SSETs:
99 #+nil
100 (progn
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)
117          ,@body)))
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)))
133
134 (locally
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))
142   (defstruct (conset
143               (:constructor make-conset ())
144               (:copier %copy-conset))
145     (vector (make-array
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.  Note
153     ;; that the CONSET-MIN is NIL when the set is known to be empty.
154     ;; CONSET-MAX is a normal end bounding index.
155     (min nil :type (or fixnum null))
156     (max 0 :type fixnum))
157
158   (defmacro do-conset-elements ((constraint conset &optional result) &body body)
159     (with-unique-names (vector index start end
160                                ignore constraint-universe-end)
161       (let* ((constraint-universe #+sb-xc-host '*constraint-universe*
162                                   #-sb-xc-host (gensym))
163              (with-array-data
164                 #+sb-xc-host '(progn)
165                 #-sb-xc-host `(with-array-data
166                                   ((,constraint-universe *constraint-universe*)
167                                    (,ignore 0) (,constraint-universe-end nil)
168                                    :check-fill-pointer t)
169                                 (declare (ignore ,ignore))
170                                 (aver (<= ,end ,constraint-universe-end)))))
171         `(let* ((,vector (conset-vector ,conset))
172                (,start (or (conset-min ,conset) 0))
173                (,end (min (conset-max ,conset) (length ,vector))))
174           (,@with-array-data
175             (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
176               (when (plusp (sbit ,vector ,index))
177                 (let ((,constraint (elt ,constraint-universe ,index)))
178                   ,@body))))))))
179
180   ;; Oddly, iterating just between the maximum of the two sets' minima
181   ;; and the minimum of the sets' maxima slowed down CP.
182   (defmacro do-conset-intersection
183       ((constraint conset1 conset2 &optional result) &body body)
184     `(do-conset-elements (,constraint ,conset1 ,result)
185        (when (conset-member ,constraint ,conset2)
186          ,@body)))
187
188   (defun conset-empty (conset)
189     (or (null (conset-min conset))
190         ;; TODO: I bet FIND on bit-vectors can be optimized, if it
191         ;; isn't.
192         (not (find 1 (conset-vector conset)
193                    :start (conset-min conset)
194                    ;; By inspection, supplying :END here breaks the
195                    ;; build with a "full call to
196                    ;; DATA-VECTOR-REF-WITH-OFFSET" in the
197                    ;; cross-compiler.  If that should change, add
198                    ;; :end (conset-max conset)
199                    ))))
200
201   (defun copy-conset (conset)
202     (let ((ret (%copy-conset conset)))
203       (setf (conset-vector ret) (copy-seq (conset-vector conset)))
204       ret))
205
206   (defun %conset-grow (conset new-size)
207     (declare (index new-size))
208     (setf (conset-vector conset)
209           (replace (the simple-bit-vector
210                      (make-array
211                       (ash 1 (integer-length (1- new-size)))
212                       :element-type 'bit
213                       :initial-element 0))
214                    (the simple-bit-vector
215                      (conset-vector conset)))))
216
217   (declaim (inline conset-grow))
218   (defun conset-grow (conset new-size)
219     (declare (index new-size))
220     (when (< (length (conset-vector conset)) new-size)
221       (%conset-grow conset new-size))
222     (values))
223
224   (defun conset-member (constraint conset)
225     (let ((number (constraint-number constraint))
226           (vector (conset-vector conset)))
227       (when (< number (length vector))
228         (plusp (sbit vector number)))))
229
230   (defun conset-adjoin (constraint conset)
231     (prog1
232       (not (conset-member constraint conset))
233       (let ((number (constraint-number constraint)))
234         (conset-grow conset (1+ number))
235         (setf (sbit (conset-vector conset) number) 1)
236         (setf (conset-min conset) (min number (or (conset-min conset)
237                                                   most-positive-fixnum)))
238         (when (>= number (conset-max conset))
239           (setf (conset-max conset) (1+ number))))))
240
241   (defun conset= (conset1 conset2)
242     (let* ((vector1 (conset-vector conset1))
243            (vector2 (conset-vector conset2))
244            (length1 (length vector1))
245            (length2 (length vector2)))
246       (if (= length1 length2)
247           ;; When the lengths are the same, we can rely on EQUAL being
248           ;; nicely optimized on bit-vectors.
249           (equal vector1 vector2)
250           (multiple-value-bind (shorter longer)
251               (if (< length1 length2)
252                   (values vector1 vector2)
253                   (values vector2 vector1))
254             ;; FIXME: make MISMATCH fast on bit-vectors.
255             (dotimes (index (length shorter))
256               (when (/= (sbit vector1 index) (sbit vector2 index))
257                 (return-from conset= nil)))
258             (if (find 1 longer :start (length shorter))
259                 nil
260                 t)))))
261
262   (macrolet
263       ((defconsetop (name bit-op)
264            `(defun ,name (conset-1 conset-2)
265               (declare (optimize (speed 3) (safety 0)))
266               (let* ((size-1 (length (conset-vector conset-1)))
267                      (size-2 (length (conset-vector conset-2)))
268                      (new-size (max size-1 size-2)))
269                 (conset-grow conset-1 new-size)
270                 (conset-grow conset-2 new-size))
271               (let ((vector1 (conset-vector conset-1))
272                     (vector2 (conset-vector conset-2)))
273                 (declare (simple-bit-vector vector1 vector2))
274                 (setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
275                 ;; Update the extrema.
276                 (setf (conset-min conset-1)
277                       ,(ecase name
278                          ((conset-union)
279                           `(min (or (conset-min conset-1)
280                                     most-positive-fixnum)
281                                 (or (conset-min conset-2)
282                                     most-positive-fixnum)))
283                          ((conset-intersection)
284                           `(let ((start (max (or (conset-min conset-1) 0)
285                                              (or (conset-min conset-2) 0)))
286                                  (end (min (conset-max conset-1)
287                                            (conset-max conset-1))))
288                              (if (> start end)
289                                  nil
290                                  (position 1 (conset-vector conset-1)
291                                            :start start :end end))))
292                          ((conset-difference)
293                           `(position 1 (conset-vector conset-1)
294                                      :start (or (conset-min conset-1) 0)
295                                      :end (conset-max conset-1)
296                                      )))
297                       (conset-max conset-1)
298                       ,(ecase name
299                          ((conset-union)
300                           `(max (conset-max conset-1)
301                                 (conset-max conset-2)))
302                          ((conset-intersection)
303                           `(let ((start (max (or (conset-min conset-1) 0)
304                                              (or (conset-min conset-2) 0)))
305                                  (end (let ((minimum-maximum
306                                              (min (conset-max conset-1)
307                                                   (conset-max conset-2))))
308                                         (if (plusp minimum-maximum)
309                                             (1- minimum-maximum)
310                                             0))))
311                              (if (> start end)
312                                  0
313                                  (let ((position
314                                         (position
315                                          1 (conset-vector conset-1)
316                                          :start start :end end :from-end t)))
317                                    (if position
318                                        (1+ position)
319                                        0)))))
320                          ((conset-difference)
321                           `(let ((position
322                                   (position
323                                    1 (conset-vector conset-1)
324                                    :start (or (conset-min conset-1) 0)
325                                    :end (conset-max conset-1)
326                                    :from-end t)))
327                              (if position
328                                  (1+ position)
329                                  0))))))
330               (values))))
331     (defconsetop conset-union bit-ior)
332     (defconsetop conset-intersection bit-and)
333     (defconsetop conset-difference bit-andc2)))
334 \f
335 (defun find-constraint (kind x y not-p)
336   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
337   (etypecase y
338     (ctype
339      (do-conset-elements (con (lambda-var-constraints x) nil)
340        (when (and (eq (constraint-kind con) kind)
341                   (eq (constraint-not-p con) not-p)
342                   (type= (constraint-y con) y))
343          (return con))))
344     ((or lvar constant)
345      (do-conset-elements (con (lambda-var-constraints x) nil)
346        (when (and (eq (constraint-kind con) kind)
347                   (eq (constraint-not-p con) not-p)
348                   (eq (constraint-y con) y))
349          (return con))))
350     (lambda-var
351      (do-conset-elements (con (lambda-var-constraints x) nil)
352        (when (and (eq (constraint-kind con) kind)
353                   (eq (constraint-not-p con) not-p)
354                   (let ((cx (constraint-x con)))
355                     (eq (if (eq cx x)
356                             (constraint-y con)
357                             cx)
358                         y)))
359          (return con))))))
360
361 ;;; Return a constraint for the specified arguments. We only create a
362 ;;; new constraint if there isn't already an equivalent old one,
363 ;;; guaranteeing that all equivalent constraints are EQ. This
364 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
365 (defun find-or-create-constraint (kind x y not-p)
366   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
367   (or (find-constraint kind x y not-p)
368       (let ((new (make-constraint (length *constraint-universe*)
369                                   kind x y not-p)))
370         (vector-push-extend new *constraint-universe*
371                             (* 2 (length *constraint-universe*)))
372         (conset-adjoin new (lambda-var-constraints x))
373         (when (lambda-var-p y)
374           (conset-adjoin new (lambda-var-constraints y)))
375         new)))
376
377 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
378 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
379 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
380 (defun ok-ref-lambda-var (ref)
381   (declare (type ref ref))
382   (let ((leaf (ref-leaf ref)))
383     (when (and (lambda-var-p leaf)
384                (lambda-var-constraints leaf))
385       leaf)))
386
387 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
388 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
389 (defun ok-lvar-lambda-var (lvar constraints)
390   (declare (type lvar lvar))
391   (let ((use (lvar-uses lvar)))
392     (cond ((ref-p use)
393            (let ((lambda-var (ok-ref-lambda-var use)))
394              (when lambda-var
395                (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
396                  (when (and constraint (conset-member constraint constraints))
397                    lambda-var)))))
398           ((cast-p use)
399            (ok-lvar-lambda-var (cast-value use) constraints)))))
400
401 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
402   (once-only ((var var))
403     `(let ((,symbol ,var))
404        (flet ((body-fun ()
405                 ,@body))
406          (body-fun)
407          (do-conset-elements (con ,constraints ,result)
408            (let ((other (and (eq (constraint-kind con) 'eql)
409                              (eq (constraint-not-p con) nil)
410                              (cond ((eq ,var (constraint-x con))
411                                     (constraint-y con))
412                                    ((eq ,var (constraint-y con))
413                                     (constraint-x con))
414                                    (t
415                                     nil)))))
416              (when other
417                (setq ,symbol other)
418                (when (lambda-var-p ,symbol)
419                  (body-fun)))))))))
420
421 ;;;; Searching constraints
422
423 ;;; Add the indicated test constraint to BLOCK. We don't add the
424 ;;; constraint if the block has multiple predecessors, since it only
425 ;;; holds on this particular path.
426 (defun add-test-constraint (fun x y not-p constraints target)
427   (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
428          (add-eql-var-var-constraint x y constraints target))
429         (t
430          (do-eql-vars (x (x constraints))
431            (let ((con (find-or-create-constraint fun x y not-p)))
432              (conset-adjoin con target)))))
433   (values))
434
435 ;;; Add complementary constraints to the consequent and alternative
436 ;;; blocks of IF. We do nothing if X is NIL.
437 (defun add-complement-constraints (fun x y not-p constraints
438                                    consequent-constraints
439                                    alternative-constraints)
440   (when x
441     (add-test-constraint fun x y not-p constraints
442                          consequent-constraints)
443     (add-test-constraint fun x y (not not-p) constraints
444                          alternative-constraints))
445   (values))
446
447 ;;; Add test constraints to the consequent and alternative blocks of
448 ;;; the test represented by USE.
449 (defun add-test-constraints (use if constraints)
450   (declare (type node use) (type cif if))
451   ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
452   ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means that we
453   ;; can't guarantee that the optimization will be done, so we still
454   ;; need to avoid barfing on this case.
455   (unless (eq (if-consequent if) (if-alternative if))
456     (let ((consequent-constraints (make-conset))
457           (alternative-constraints (make-conset)))
458       (macrolet ((add (fun x y not-p)
459                    `(add-complement-constraints ,fun ,x ,y ,not-p
460                                                 constraints
461                                                 consequent-constraints
462                                                 alternative-constraints)))
463         (typecase use
464           (ref
465            (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
466                 (specifier-type 'null) t))
467           (combination
468            (unless (eq (combination-kind use)
469                        :error)
470              (let ((name (lvar-fun-name
471                           (basic-combination-fun use)))
472                    (args (basic-combination-args use)))
473                (case name
474                  ((%typep %instance-typep)
475                   (let ((type (second args)))
476                     (when (constant-lvar-p type)
477                       (let ((val (lvar-value type)))
478                         (add 'typep
479                              (ok-lvar-lambda-var (first args) constraints)
480                              (if (ctype-p val)
481                                  val
482                                  (specifier-type val))
483                              nil)))))
484                  ((eq eql)
485                   (let* ((arg1 (first args))
486                          (var1 (ok-lvar-lambda-var arg1 constraints))
487                          (arg2 (second args))
488                          (var2 (ok-lvar-lambda-var arg2 constraints)))
489                     ;; The code below assumes that the constant is the
490                     ;; second argument in case of variable to constant
491                     ;; comparision which is sometimes true (see source
492                     ;; transformations for EQ, EQL and CHAR=). Fixing
493                     ;; that would result in more constant substitutions
494                     ;; which is not a universally good thing, thus the
495                     ;; unnatural asymmetry of the tests.
496                     (cond ((not var1)
497                            (when var2
498                              (add-test-constraint 'typep var2 (lvar-type arg1)
499                                                   nil constraints
500                                                   consequent-constraints)))
501                           (var2
502                            (add 'eql var1 var2 nil))
503                           ((constant-lvar-p arg2)
504                            (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
505                                 nil))
506                           (t
507                            (add-test-constraint 'typep var1 (lvar-type arg2)
508                                                 nil constraints
509                                                 consequent-constraints)))))
510                  ((< >)
511                   (let* ((arg1 (first args))
512                          (var1 (ok-lvar-lambda-var arg1 constraints))
513                          (arg2 (second args))
514                          (var2 (ok-lvar-lambda-var arg2 constraints)))
515                     (when var1
516                       (add name var1 (lvar-type arg2) nil))
517                     (when var2
518                       (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
519                  (t
520                   (let ((ptype (gethash name *backend-predicate-types*)))
521                     (when ptype
522                       (add 'typep (ok-lvar-lambda-var (first args) constraints)
523                            ptype nil))))))))))
524       (values consequent-constraints alternative-constraints))))
525
526 ;;;; Applying constraints
527
528 ;;; Return true if X is an integer NUMERIC-TYPE.
529 (defun integer-type-p (x)
530   (declare (type ctype x))
531   (and (numeric-type-p x)
532        (eq (numeric-type-class x) 'integer)
533        (eq (numeric-type-complexp x) :real)))
534
535 ;;; Given that an inequality holds on values of type X and Y, return a
536 ;;; new type for X. If GREATER is true, then X was greater than Y,
537 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
538 ;;; inclusive, i.e. >=.
539 ;;;
540 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
541 ;;; bound into X and return that result. If not OR-EQUAL, we can go
542 ;;; one greater (less) than Y's bound.
543 (defun constrain-integer-type (x y greater or-equal)
544   (declare (type numeric-type x y))
545   (flet ((exclude (x)
546            (cond ((not x) nil)
547                  (or-equal x)
548                  (greater (1+ x))
549                  (t (1- x))))
550          (bound (x)
551            (if greater (numeric-type-low x) (numeric-type-high x))))
552     (let* ((x-bound (bound x))
553            (y-bound (exclude (bound y)))
554            (new-bound (cond ((not x-bound) y-bound)
555                             ((not y-bound) x-bound)
556                             (greater (max x-bound y-bound))
557                             (t (min x-bound y-bound)))))
558       (if greater
559           (modified-numeric-type x :low new-bound)
560           (modified-numeric-type x :high new-bound)))))
561
562 ;;; Return true if X is a float NUMERIC-TYPE.
563 (defun float-type-p (x)
564   (declare (type ctype x))
565   (and (numeric-type-p x)
566        (eq (numeric-type-class x) 'float)
567        (eq (numeric-type-complexp x) :real)))
568
569 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
570 (defun constrain-float-type (x y greater or-equal)
571   (declare (type numeric-type x y))
572   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
573
574   (aver (eql (numeric-type-class x) 'float))
575   (aver (eql (numeric-type-class y) 'float))
576   #+sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
577   x
578   #-sb-xc-host                    ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
579   (labels ((exclude (x)
580              (cond ((not x) nil)
581                    (or-equal x)
582                    (t
583                     (if (consp x)
584                         x
585                         (list x)))))
586            (bound (x)
587              (if greater (numeric-type-low x) (numeric-type-high x)))
588            (tighter-p (x ref)
589              (cond ((null x) nil)
590                    ((null ref) t)
591                    ((and or-equal
592                          (= (type-bound-number x) (type-bound-number ref)))
593                     ;; X is tighter if REF is not an open bound and X is
594                     (and (not (consp ref)) (consp x)))
595                    (greater
596                     (< (type-bound-number ref) (type-bound-number x)))
597                    (t
598                     (> (type-bound-number ref) (type-bound-number x))))))
599     (let* ((x-bound (bound x))
600            (y-bound (exclude (bound y)))
601            (new-bound (cond ((not x-bound)
602                              y-bound)
603                             ((not y-bound)
604                              x-bound)
605                             ((tighter-p y-bound x-bound)
606                              y-bound)
607                             (t
608                              x-bound))))
609       (if greater
610           (modified-numeric-type x :low new-bound)
611           (modified-numeric-type x :high new-bound)))))
612
613 ;;; Given the set of CONSTRAINTS for a variable and the current set of
614 ;;; restrictions from flow analysis IN, set the type for REF
615 ;;; accordingly.
616 (defun constrain-ref-type (ref constraints in)
617   (declare (type ref ref) (type conset constraints in))
618   ;; KLUDGE: The NOT-SET and NOT-FPZ here are so that we don't need to
619   ;; cons up endless union types when propagating large number of EQL
620   ;; constraints -- eg. from large CASE forms -- instead we just
621   ;; directly accumulate one XSET, and a set of fp zeroes, which we at
622   ;; the end turn into a MEMBER-TYPE.
623   ;;
624   ;; Since massive symbol cases are an especially atrocious pattern
625   ;; and the (NOT (MEMBER ...ton of symbols...)) will never turn into
626   ;; a more useful type, don't propagate their negation except for NIL
627   ;; unless SPEED > COMPILATION-SPEED.
628   (let ((res (single-value-type (node-derived-type ref)))
629         (constrain-symbols (policy ref (> speed compilation-speed)))
630         (not-set (alloc-xset))
631         (not-fpz nil)
632         (not-res *empty-type*)
633         (leaf (ref-leaf ref)))
634     (flet ((note-not (x)
635              (if (fp-zero-p x)
636                  (push x not-fpz)
637                  (when (or constrain-symbols (null x) (not (symbolp x)))
638                    (add-to-xset x not-set)))))
639       ;; KLUDGE: the implementations of DO-CONSET-INTERSECTION will
640       ;; probably run faster when the smaller set comes first, so
641       ;; don't change the order here.
642       (do-conset-intersection (con constraints in)
643         (let* ((x (constraint-x con))
644                (y (constraint-y con))
645                (not-p (constraint-not-p con))
646                (other (if (eq x leaf) y x))
647                (kind (constraint-kind con)))
648           (case kind
649             (typep
650              (if not-p
651                  (if (member-type-p other)
652                      (mapc-member-type-members #'note-not other)
653                      (setq not-res (type-union not-res other)))
654                  (setq res (type-approx-intersection2 res other))))
655             (eql
656              (unless (lvar-p other)
657                (let ((other-type (leaf-type other)))
658                  (if not-p
659                      (when (and (constant-p other)
660                                 (member-type-p other-type))
661                        (note-not (constant-value other)))
662                      (let ((leaf-type (leaf-type leaf)))
663                        (cond
664                          ((or (constant-p other)
665                               (and (leaf-refs other) ; protect from
666                                         ; deleted vars
667                                    (csubtypep other-type leaf-type)
668                                    (not (type= other-type leaf-type))))
669                           (change-ref-leaf ref other)
670                           (when (constant-p other) (return)))
671                          (t
672                           (setq res (type-approx-intersection2
673                                      res other-type)))))))))
674             ((< >)
675              (cond
676                ((and (integer-type-p res) (integer-type-p y))
677                 (let ((greater (eq kind '>)))
678                   (let ((greater (if not-p (not greater) greater)))
679                     (setq res
680                           (constrain-integer-type res y greater not-p)))))
681                ((and (float-type-p res) (float-type-p y))
682                 (let ((greater (eq kind '>)))
683                   (let ((greater (if not-p (not greater) greater)))
684                     (setq res
685                           (constrain-float-type res y greater not-p)))))))))))
686     (cond ((and (if-p (node-dest ref))
687                 (or (xset-member-p nil not-set)
688                     (csubtypep (specifier-type 'null) not-res)))
689            (setf (node-derived-type ref) *wild-type*)
690            (change-ref-leaf ref (find-constant t)))
691           (t
692            (setf not-res
693                  (type-union not-res (make-member-type :xset not-set :fp-zeroes not-fpz)))
694            (derive-node-type ref
695                              (make-single-value-type
696                               (or (type-difference res not-res)
697                                   res)))
698            (maybe-terminate-block ref nil))))
699   (values))
700
701 ;;;; Flow analysis
702
703 (defun maybe-add-eql-var-lvar-constraint (ref gen)
704   (let ((lvar (ref-lvar ref))
705         (leaf (ref-leaf ref)))
706     (when (and (lambda-var-p leaf) lvar)
707       (conset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
708                      gen))))
709
710 ;;; Copy all CONSTRAINTS involving FROM-VAR - except the (EQL VAR
711 ;;; LVAR) ones - to all of the variables in the VARS list.
712 (defun inherit-constraints (vars from-var constraints target)
713   (do-conset-elements (con constraints)
714     ;; Constant substitution is controversial.
715     (unless (constant-p (constraint-y con))
716       (dolist (var vars)
717         (let ((eq-x (eq from-var (constraint-x con)))
718               (eq-y (eq from-var (constraint-y con))))
719           (when (or (and eq-x (not (lvar-p (constraint-y con))))
720                     eq-y)
721             (conset-adjoin (find-or-create-constraint
722                             (constraint-kind con)
723                             (if eq-x var (constraint-x con))
724                             (if eq-y var (constraint-y con))
725                             (constraint-not-p con))
726                            target)))))))
727
728 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
729 ;; inherit each other's constraints.
730 (defun add-eql-var-var-constraint (var1 var2 constraints
731                                    &optional (target constraints))
732   (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
733     (when (conset-adjoin con target)
734       (collect ((eql1) (eql2))
735         (do-eql-vars (var1 (var1 constraints))
736           (eql1 var1))
737         (do-eql-vars (var2 (var2 constraints))
738           (eql2 var2))
739         (inherit-constraints (eql1) var2 constraints target)
740         (inherit-constraints (eql2) var1 constraints target))
741       t)))
742
743 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
744 ;; LAMBDA-VAR if possible.
745 (defun maybe-add-eql-var-var-constraint (var lvar constraints
746                                          &optional (target constraints))
747   (declare (type lambda-var var) (type lvar lvar))
748   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
749     (when lambda-var
750       (add-eql-var-var-constraint var lambda-var constraints target))))
751
752 ;;; Local propagation
753 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
754 ;;;    constraint.]
755 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
756 ;;;    a type constraint based on the new value type.
757 (declaim (ftype (function (cblock conset boolean)
758                           conset)
759                 constraint-propagate-in-block))
760 (defun constraint-propagate-in-block (block gen preprocess-refs-p)
761   (do-nodes (node lvar block)
762     (typecase node
763       (bind
764        (let ((fun (bind-lambda node)))
765          (when (eq (functional-kind fun) :let)
766            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
767                  for var in (lambda-vars fun)
768                  and val in (combination-args call)
769                  when (and val (lambda-var-constraints var))
770                  do (let* ((type (lvar-type val))
771                            (con (find-or-create-constraint 'typep var type
772                                                            nil)))
773                       (conset-adjoin con gen))
774                  (maybe-add-eql-var-var-constraint var val gen)))))
775       (ref
776        (when (ok-ref-lambda-var node)
777          (maybe-add-eql-var-lvar-constraint node gen)
778          (when preprocess-refs-p
779            (let* ((var (ref-leaf node))
780                   (con (lambda-var-constraints var)))
781              (constrain-ref-type node con gen)))))
782       (cast
783        (let ((lvar (cast-value node)))
784          (let ((var (ok-lvar-lambda-var lvar gen)))
785            (when var
786              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
787                (do-eql-vars (var (var gen))
788                  (let ((con (find-or-create-constraint 'typep var atype nil)))
789                    (conset-adjoin con gen))))))))
790       (cset
791        (binding* ((var (set-var node))
792                   (nil (lambda-var-p var) :exit-if-null)
793                   (cons (lambda-var-constraints var) :exit-if-null))
794          (conset-difference gen cons)
795          (let* ((type (single-value-type (node-derived-type node)))
796                 (con (find-or-create-constraint 'typep var type nil)))
797            (conset-adjoin con gen))
798          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
799   gen)
800
801 (defun constraint-propagate-if (block gen)
802   (let ((node (block-last block)))
803     (when (if-p node)
804       (let ((use (lvar-uses (if-test node))))
805         (when (node-p use)
806           (add-test-constraints use node gen))))))
807
808 ;;; Starting from IN compute OUT and (consequent/alternative
809 ;;; constraints if the block ends with and IF). Return the list of
810 ;;; successors that may need to be recomputed.
811 (defun find-block-type-constraints (block final-pass-p)
812   (declare (type cblock block))
813   (let ((gen (constraint-propagate-in-block
814               block
815               (if final-pass-p
816                   (block-in block)
817                   (copy-conset (block-in block)))
818               final-pass-p)))
819     (setf (block-gen block) gen)
820     (multiple-value-bind (consequent-constraints alternative-constraints)
821         (constraint-propagate-if block gen)
822       (if consequent-constraints
823           (let* ((node (block-last block))
824                  (old-consequent-constraints (if-consequent-constraints node))
825                  (old-alternative-constraints (if-alternative-constraints node))
826                  (succ ()))
827             ;; Add the consequent and alternative constraints to GEN.
828             (cond ((conset-empty consequent-constraints)
829                    (setf (if-consequent-constraints node) gen)
830                    (setf (if-alternative-constraints node) gen))
831                   (t
832                    (setf (if-consequent-constraints node) (copy-conset gen))
833                    (conset-union (if-consequent-constraints node)
834                                  consequent-constraints)
835                    (setf (if-alternative-constraints node) gen)
836                    (conset-union (if-alternative-constraints node)
837                                  alternative-constraints)))
838             ;; Has the consequent been changed?
839             (unless (and old-consequent-constraints
840                          (conset= (if-consequent-constraints node)
841                                   old-consequent-constraints))
842               (push (if-consequent node) succ))
843             ;; Has the alternative been changed?
844             (unless (and old-alternative-constraints
845                          (conset= (if-alternative-constraints node)
846                                   old-alternative-constraints))
847               (push (if-alternative node) succ))
848             succ)
849           ;; There is no IF.
850           (unless (and (block-out block)
851                        (conset= gen (block-out block)))
852             (setf (block-out block) gen)
853             (block-succ block))))))
854
855 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
856 ;;; During this pass, we also do local constraint propagation by
857 ;;; adding in constraints as we see them during the pass through the
858 ;;; block.
859 (defun use-result-constraints (block)
860   (declare (type cblock block))
861   (constraint-propagate-in-block block (block-in block) t))
862
863 ;;; Give an empty constraints set to any var that doesn't have one and
864 ;;; isn't a set closure var. Since a var that we previously rejected
865 ;;; looks identical to one that is new, so we optimistically keep
866 ;;; hoping that vars stop being closed over or lose their sets.
867 (defun init-var-constraints (component)
868   (declare (type component component))
869   (dolist (fun (component-lambdas component))
870     (flet ((frob (x)
871              (dolist (var (lambda-vars x))
872                (unless (lambda-var-constraints var)
873                  (when (or (null (lambda-var-sets var))
874                            (not (closure-var-p var)))
875                    (setf (lambda-var-constraints var) (make-conset)))))))
876       (frob fun)
877       (dolist (let (lambda-lets fun))
878         (frob let)))))
879
880 ;;; Return the constraints that flow from PRED to SUCC. This is
881 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
882 ;;; added.
883 (defun block-out-for-successor (pred succ)
884   (declare (type cblock pred succ))
885   (let ((last (block-last pred)))
886     (or (when (if-p last)
887           (cond ((eq succ (if-consequent last))
888                  (if-consequent-constraints last))
889                 ((eq succ (if-alternative last))
890                  (if-alternative-constraints last))))
891         (block-out pred))))
892
893 (defun compute-block-in (block)
894   (let ((in nil))
895     (dolist (pred (block-pred block))
896       ;; If OUT has not been calculated, assume it to be the universal
897       ;; set.
898       (let ((out (block-out-for-successor pred block)))
899         (when out
900           (if in
901               (conset-intersection in out)
902               (setq in (copy-conset out))))))
903     (or in (make-conset))))
904
905 (defun update-block-in (block)
906   (let ((in (compute-block-in block)))
907     (cond ((and (block-in block) (conset= in (block-in block)))
908            nil)
909           (t
910            (setf (block-in block) in)))))
911
912 ;;; Return two lists: one of blocks that precede all loops and
913 ;;; therefore require only one constraint propagation pass and the
914 ;;; rest. This implementation does not find all such blocks.
915 ;;;
916 ;;; A more complete implementation would be:
917 ;;;
918 ;;;     (do-blocks (block component)
919 ;;;       (if (every #'(lambda (pred)
920 ;;;                      (or (member pred leading-blocks)
921 ;;;                          (eq pred head)))
922 ;;;                  (block-pred block))
923 ;;;           (push block leading-blocks)
924 ;;;           (push block rest-of-blocks)))
925 ;;;
926 ;;; Trailing blocks that succeed all loops could be found and handled
927 ;;; similarly. In practice though, these more complex solutions are
928 ;;; slightly worse performancewise.
929 (defun leading-component-blocks (component)
930   (declare (type component component))
931   (flet ((loopy-p (block)
932            (let ((n (block-number block)))
933              (dolist (pred (block-pred block))
934                (unless (< n (block-number pred))
935                  (return t))))))
936     (let ((leading-blocks ())
937           (rest-of-blocks ())
938           (seen-loop-p ()))
939       (do-blocks (block component)
940         (when (and (not seen-loop-p) (loopy-p block))
941           (setq seen-loop-p t))
942         (if seen-loop-p
943             (push block rest-of-blocks)
944             (push block leading-blocks)))
945       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
946
947 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
948 ;;; a member already.
949 (defun nconc-new (obj list)
950   (do ((x list (cdr x))
951        (prev nil x))
952       ((endp x) (if prev
953                     (progn
954                       (setf (cdr prev) (list obj))
955                       list)
956                     (list obj)))
957     (when (eql (car x) obj)
958       (return-from nconc-new list))))
959
960 (defun find-and-propagate-constraints (component)
961   (let ((blocks-to-process ()))
962     (flet ((enqueue (blocks)
963              (dolist (block blocks)
964                (setq blocks-to-process (nconc-new block blocks-to-process)))))
965       (multiple-value-bind (leading-blocks rest-of-blocks)
966           (leading-component-blocks component)
967         ;; Update every block once to account for changes in the
968         ;; IR1. The constraints of the lead blocks cannot be changed
969         ;; after the first pass so we might as well use them and skip
970         ;; USE-RESULT-CONSTRAINTS later.
971         (dolist (block leading-blocks)
972           (setf (block-in block) (compute-block-in block))
973           (find-block-type-constraints block t))
974         (setq blocks-to-process (copy-list rest-of-blocks))
975         ;; The rest of the blocks.
976         (dolist (block rest-of-blocks)
977           (aver (eq block (pop blocks-to-process)))
978           (setf (block-in block) (compute-block-in block))
979           (enqueue (find-block-type-constraints block nil)))
980         ;; Propagate constraints
981         (loop for block = (pop blocks-to-process)
982               while block do
983               (unless (eq block (component-tail component))
984                 (when (update-block-in block)
985                   (enqueue (find-block-type-constraints block nil)))))
986         rest-of-blocks))))
987
988 (defun constraint-propagate (component)
989   (declare (type component component))
990   (init-var-constraints component)
991
992   (unless (block-out (component-head component))
993     (setf (block-out (component-head component)) (make-conset)))
994
995   (dolist (block (find-and-propagate-constraints component))
996     (unless (block-delete-p block)
997       (use-result-constraints block)))
998
999   (values))