0.7.9.60:
[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 (in-package "SB!C")
15
16 (defstruct (constraint
17             (:include sset-element)
18             (:constructor make-constraint (number kind x y not-p))
19             (:copier nil))
20   ;; the kind of constraint we have:
21   ;;
22   ;; TYPEP
23   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is 
24   ;;     constrained to be of type Y.
25   ;;
26   ;; > or <
27   ;;     X is a lambda-var and Y is a CTYPE. The relation holds 
28   ;;     between X and some object of type Y.
29   ;;
30   ;; EQL
31   ;;     X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT. The
32   ;;     relation is asserted to hold.
33   (kind nil :type (member typep < > eql))
34   ;; The operands to the relation.
35   (x nil :type lambda-var)
36   (y nil :type (or ctype lambda-var constant))
37   ;; If true, negates the sense of the constraint, so the relation 
38   ;; does *not* hold.
39   (not-p nil :type boolean))
40
41 (defvar *constraint-number*)
42
43 ;;; Return a constraint for the specified arguments. We only create a
44 ;;; new constraint if there isn't already an equivalent old one,
45 ;;; guaranteeing that all equivalent constraints are EQ. This
46 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
47 (defun find-constraint (kind x y not-p)
48   (declare (type lambda-var x) (type (or constant lambda-var ctype) y)
49            (type boolean not-p))
50   (or (etypecase y
51         (ctype
52          (do-sset-elements (con (lambda-var-constraints x) nil)
53            (when (and (eq (constraint-kind con) kind)
54                       (eq (constraint-not-p con) not-p)
55                       (type= (constraint-y con) y))
56              (return con))))
57         (constant
58          (do-sset-elements (con (lambda-var-constraints x) nil)
59            (when (and (eq (constraint-kind con) kind)
60                       (eq (constraint-not-p con) not-p)
61                       (eq (constraint-y con) y))
62              (return con))))
63         (lambda-var
64          (do-sset-elements (con (lambda-var-constraints x) nil)
65            (when (and (eq (constraint-kind con) kind)
66                       (eq (constraint-not-p con) not-p)
67                       (let ((cx (constraint-x con)))
68                         (eq (if (eq cx x)
69                                 (constraint-y con)
70                                 cx)
71                             y)))
72              (return con)))))
73       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
74         (sset-adjoin new (lambda-var-constraints x))
75         (when (lambda-var-p y)
76           (sset-adjoin new (lambda-var-constraints y)))
77         new)))
78
79 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
80 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
81 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
82 (defun ok-ref-lambda-var (ref)
83   (declare (type ref ref))
84   (let ((leaf (ref-leaf ref)))
85     (when (and (lambda-var-p leaf)
86                (lambda-var-constraints leaf))
87       leaf)))
88
89 ;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
90 ;;; otherwise NIL.
91 #!-sb-fluid (declaim (inline ok-cont-lambda-var))
92 (defun ok-cont-lambda-var (cont)
93   (declare (type continuation cont))
94   (let ((use (continuation-use cont)))
95     (when (ref-p use)
96       (ok-ref-lambda-var use))))
97
98 ;;; Add the indicated test constraint to BLOCK, marking the block as
99 ;;; having a new assertion when the constriant was not already
100 ;;; present. We don't add the constraint if the block has multiple
101 ;;; predecessors, since it only holds on this particular path.
102 (defun add-test-constraint (block fun x y not-p)
103   (unless (rest (block-pred block))
104     (let ((con (find-constraint fun x y not-p))
105           (old (or (block-test-constraint block)
106                    (setf (block-test-constraint block) (make-sset)))))
107       (when (sset-adjoin con old)
108         (setf (block-type-asserted block) t))))
109   (values))
110
111 ;;; Add complementary constraints to the consequent and alternative
112 ;;; blocks of IF. We do nothing if X is NIL.
113 (defun add-complement-constraints (if fun x y not-p)
114   (when (and x
115              ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
116              ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
117              ;; that we can't guarantee that the optimization will be
118              ;; done, so we still need to avoid barfing on this case.
119              (not (eq (if-consequent if)
120                       (if-alternative if))))
121     (add-test-constraint (if-consequent if) fun x y not-p)
122     (add-test-constraint (if-alternative if) fun x y (not not-p)))
123   (values))
124
125 ;;; Add test constraints to the consequent and alternative blocks of
126 ;;; the test represented by USE.
127 (defun add-test-constraints (use if)
128   (declare (type node use) (type cif if))
129   (typecase use
130     (ref
131      (add-complement-constraints if 'typep (ok-ref-lambda-var use)
132                                  (specifier-type 'null) t))
133     (combination
134      (unless (eq (combination-kind use)
135                  :error)
136        (let ((name (continuation-fun-name
137                     (basic-combination-fun use)))
138              (args (basic-combination-args use)))
139          (case name
140            ((%typep %instance-typep)
141             (let ((type (second args)))
142               (when (constant-continuation-p type)
143                 (let ((val (continuation-value type)))
144                   (add-complement-constraints if 'typep
145                                               (ok-cont-lambda-var (first args))
146                                               (if (ctype-p val)
147                                                   val
148                                                   (specifier-type val))
149                                               nil)))))
150            ((eq eql)
151             (let* ((var1 (ok-cont-lambda-var (first args)))
152                    (arg2 (second args))
153                    (var2 (ok-cont-lambda-var arg2)))
154               (cond ((not var1))
155                     (var2
156                      (add-complement-constraints if 'eql var1 var2 nil))
157                     ((constant-continuation-p arg2)
158                      (add-complement-constraints if 'eql var1
159                                                  (ref-leaf
160                                                   (continuation-use arg2))
161                                                  nil)))))
162            ((< >)
163             (let* ((arg1 (first args))
164                    (var1 (ok-cont-lambda-var arg1))
165                    (arg2 (second args))
166                    (var2 (ok-cont-lambda-var arg2)))
167               (when var1
168                 (add-complement-constraints if name var1 (continuation-type arg2)
169                                             nil))
170               (when var2
171                 (add-complement-constraints if (if (eq name '<) '> '<)
172                                             var2 (continuation-type arg1)
173                                             nil))))
174            (t
175             (let ((ptype (gethash name *backend-predicate-types*)))
176               (when ptype
177                 (add-complement-constraints if 'typep
178                                             (ok-cont-lambda-var (first args))
179                                             ptype nil)))))))))
180   (values))
181
182 ;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
183 ;;; the condition it tests.
184 (defun find-test-constraints (block)
185   (declare (type cblock block))
186   (let ((last (block-last block)))
187     (when (if-p last)
188       (let ((use (continuation-use (if-test last))))
189         (when use
190           (add-test-constraints use last)))))
191
192   (setf (block-test-modified block) nil)
193   (values))
194
195 ;;; Compute the initial flow analysis sets for BLOCK:
196 ;;; -- For any lambda-var ref with a type check, add that constraint.
197 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var, and add
198 ;;;    those constraints to the set nuked by this block.
199 (defun find-block-type-constraints (block)
200   (declare (type cblock block))
201   (let ((gen (make-sset)))
202     (collect ((kill nil adjoin))
203
204       (let ((test (block-test-constraint block)))
205         (when test
206           (sset-union gen test)))
207
208       (do-nodes (node cont block)
209         (typecase node
210           (ref
211            (when (continuation-type-check cont)
212              (let ((var (ok-ref-lambda-var node)))
213                (when var
214                  (let* ((atype (continuation-derived-type cont))
215                         (con (find-constraint 'typep var atype nil)))
216                    (sset-adjoin con gen))))))
217           (cset
218            (let ((var (set-var node)))
219              (when (lambda-var-p var)
220                (kill var)
221                (let ((cons (lambda-var-constraints var)))
222                  (when cons
223                    (sset-difference gen cons))))))))
224
225       (setf (block-in block) nil)
226       (setf (block-gen block) gen)
227       (setf (block-kill-list block) (kill))
228       (setf (block-out block) (copy-sset gen))
229       (setf (block-type-asserted block) nil)
230       (values))))
231
232 ;;; Return true if X is an integer NUMERIC-TYPE.
233 (defun integer-type-p (x)
234   (declare (type ctype x))
235   (and (numeric-type-p x)
236        (eq (numeric-type-class x) 'integer)
237        (eq (numeric-type-complexp x) :real)))
238
239 ;;; Given that an inequality holds on values of type X and Y, return a
240 ;;; new type for X. If GREATER is true, then X was greater than Y,
241 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
242 ;;; inclusive, i.e. >=.
243 ;;;
244 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
245 ;;; bound into X and return that result. If not OR-EQUAL, we can go
246 ;;; one greater (less) than Y's bound.
247 (defun constrain-integer-type (x y greater or-equal)
248   (declare (type numeric-type x y))
249   (flet ((exclude (x)
250            (cond ((not x) nil)
251                  (or-equal x)
252                  (greater (1+ x))
253                  (t (1- x))))
254          (bound (x)
255            (if greater (numeric-type-low x) (numeric-type-high x))))
256     (let* ((x-bound (bound x))
257            (y-bound (exclude (bound y)))
258            (new-bound (cond ((not x-bound) y-bound)
259                             ((not y-bound) x-bound)
260                             (greater (max x-bound y-bound))
261                             (t (min x-bound y-bound)))))
262       (if greater
263           (modified-numeric-type x :low new-bound)
264           (modified-numeric-type x :high new-bound)))))
265
266 ;;; Return true if X is a float NUMERIC-TYPE.
267 (defun float-type-p (x)
268   (declare (type ctype x))
269   (and (numeric-type-p x)
270        (eq (numeric-type-class x) 'float)
271        (eq (numeric-type-complexp x) :real)))
272
273 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
274 (defun constrain-float-type (x y greater or-equal)
275   (declare (type numeric-type x y))
276   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
277   
278   (aver (eql (numeric-type-class x) 'float))
279   (aver (eql (numeric-type-class y) 'float))
280   #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
281   x
282   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
283   (labels ((exclude (x)
284              (cond ((not x) nil)
285                    (or-equal x)
286                    (greater
287                     (if (consp x)
288                         (car x)
289                         x))
290                    (t
291                     (if (consp x)
292                         x
293                         (list x)))))
294            (bound (x)
295              (if greater (numeric-type-low x) (numeric-type-high x)))
296            (max-lower-bound (x y)
297              ;; Both X and Y are not null. Find the max.
298              (let ((res (max (type-bound-number x) (type-bound-number y))))
299                ;; An open lower bound is greater than a close
300                ;; lower bound because the open bound doesn't
301                ;; contain the bound, so choose an open lower
302                ;; bound.
303                (set-bound res (or (consp x) (consp y)))))
304            (min-upper-bound (x y)
305              ;; Same as above, but for the min of upper bounds
306              ;; Both X and Y are not null. Find the min.
307              (let ((res (min (type-bound-number x) (type-bound-number y))))
308                ;; An open upper bound is less than a closed
309                ;; upper bound because the open bound doesn't
310                ;; contain the bound, so choose an open lower
311                ;; bound.
312                (set-bound res (or (consp x) (consp y))))))
313     (let* ((x-bound (bound x))
314            (y-bound (exclude (bound y)))
315            (new-bound (cond ((not x-bound)
316                              y-bound)
317                             ((not y-bound)
318                              x-bound)
319                             (greater
320                              (max-lower-bound x-bound y-bound))
321                             (t
322                              (min-upper-bound x-bound y-bound)))))
323       (if greater
324           (modified-numeric-type x :low new-bound)
325           (modified-numeric-type x :high new-bound)))))
326
327 ;;; Given the set of CONSTRAINTS for a variable and the current set of
328 ;;; restrictions from flow analysis IN, set the type for REF
329 ;;; accordingly.
330 (defun constrain-ref-type (ref constraints in)
331   (declare (type ref ref) (type sset constraints in))
332   (let ((var-cons (copy-sset constraints)))
333     (sset-intersection var-cons in)
334     (let ((res (single-value-type (node-derived-type ref)))
335           (not-res *empty-type*)
336           (leaf (ref-leaf ref)))
337       (do-sset-elements (con var-cons)
338         (let* ((x (constraint-x con))
339                (y (constraint-y con))
340                (not-p (constraint-not-p con))
341                (other (if (eq x leaf) y x))
342                (kind (constraint-kind con)))
343           (case kind
344             (typep
345              (if not-p
346                  (setq not-res (type-union not-res other))
347                  (setq res (type-approx-intersection2 res other))))
348             (eql
349              (let ((other-type (leaf-type other)))
350                (if not-p
351                    (when (and (constant-p other)
352                               (member-type-p other-type))
353                      (setq not-res (type-union not-res other-type)))
354                    (let ((leaf-type (leaf-type leaf)))
355                      (when (or (constant-p other)
356                                (and (csubtypep other-type leaf-type)
357                                     (not (type= other-type leaf-type))))
358                        (change-ref-leaf ref other)
359                        (when (constant-p other) (return)))))))
360             ((< >)
361              (cond ((and (integer-type-p res) (integer-type-p y))
362                     (let ((greater (eq kind '>)))
363                       (let ((greater (if not-p (not greater) greater)))
364                         (setq res
365                               (constrain-integer-type res y greater not-p)))))
366                    ((and (float-type-p res) (float-type-p y))
367                     (let ((greater (eq kind '>)))
368                       (let ((greater (if not-p (not greater) greater)))
369                         (setq res
370                               (constrain-float-type res y greater not-p)))))
371                    )))))
372
373       (let* ((cont (node-cont ref))
374              (dest (continuation-dest cont)))
375         (cond ((and (if-p dest)
376                     (csubtypep (specifier-type 'null) not-res)
377                     (eq (continuation-asserted-type cont) *wild-type*))
378                (setf (node-derived-type ref) *wild-type*)
379                (change-ref-leaf ref (find-constant t)))
380               (t
381                (derive-node-type ref (or (type-difference res not-res)
382                                          res)))))))
383
384   (values))
385
386 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
387 ;;; During this pass, we also do local constraint propagation by
388 ;;; adding in constraints as we seem them during the pass through the
389 ;;; block.
390 (defun use-result-constraints (block)
391   (declare (type cblock block))
392   (let ((in (block-in block)))
393
394     (let ((test (block-test-constraint block)))
395       (when test
396         (sset-union in test)))
397
398     (do-nodes (node cont block)
399       (typecase node
400         (ref
401          (let ((var (ref-leaf node)))
402            (when (lambda-var-p var)
403              (let ((con (lambda-var-constraints var)))
404                (when con
405                  (constrain-ref-type node con in)
406                  (when (continuation-type-check cont)
407                    (sset-adjoin
408                     (find-constraint 'typep var
409                                      (continuation-asserted-type cont)
410                                      nil)
411                     in)))))))
412         (cset
413          (let ((var (set-var node)))
414            (when (lambda-var-p var)
415              (let ((cons (lambda-var-constraints var)))
416                (when cons
417                  (sset-difference in cons))))))))))
418
419 ;;; Return true if VAR would have to be closed over if environment
420 ;;; analysis ran now (i.e. if there are any uses that have a different
421 ;;; home lambda than VAR's home.)
422 (defun closure-var-p (var)
423   (declare (type lambda-var var))
424   (let ((home (lambda-home (lambda-var-home var))))
425     (flet ((frob (l)
426              (dolist (node l nil)
427                (unless (eq (node-home-lambda node) home)
428                  (return t)))))
429       (or (frob (leaf-refs var))
430           (frob (basic-var-sets var))))))
431
432 ;;; Give an empty constraints set to any var that doesn't have one and
433 ;;; isn't a set closure var. Since a var that we previously rejected
434 ;;; looks identical to one that is new, so we optimistically keep
435 ;;; hoping that vars stop being closed over or lose their sets.
436 (defun init-var-constraints (component)
437   (declare (type component component))
438   (dolist (fun (component-lambdas component))
439     (flet ((frob (x)
440              (dolist (var (lambda-vars x))
441                (unless (lambda-var-constraints var)
442                  (when (or (null (lambda-var-sets var))
443                            (not (closure-var-p var)))
444                    (setf (lambda-var-constraints var) (make-sset)))))))
445       (frob fun)
446       (dolist (let (lambda-lets fun))
447         (frob let)))))
448
449 ;;; BLOCK-IN becomes the intersection of the OUT of the predecessors.
450 ;;; Our OUT is:
451 ;;;     out U (in - kill)
452 ;;;
453 ;;; BLOCK-KILL-LIST is just a list of the LAMBDA-VARs killed, so we must
454 ;;; compute the kill set when there are any vars killed. We bum this a
455 ;;; bit by special-casing when only one var is killed, and just using
456 ;;; that var's constraints as the kill set. This set could possibly be
457 ;;; precomputed, but it would have to be invalidated whenever any
458 ;;; constraint is added, which would be a pain.
459 (defun flow-propagate-constraints (block)
460   (let* ((pred (block-pred block))
461          (in (cond (pred
462                     (let ((res (copy-sset (block-out (first pred)))))
463                       (dolist (b (rest pred))
464                         (sset-intersection res (block-out b)))
465                       res))
466                    (t
467                     (let ((*compiler-error-context* (block-last block)))
468                       (compiler-warn
469                        "unreachable code in constraint ~
470                         propagation -- apparent compiler bug"))
471                     (make-sset))))
472          (kill-list (block-kill-list block))
473          (out (block-out block)))
474
475     (setf (block-in block) in)
476     (cond ((null kill-list)
477            (sset-union (block-out block) in))
478           ((null (rest kill-list))
479            (let ((con (lambda-var-constraints (first kill-list))))
480              (if con
481                  (sset-union-of-difference out in con)
482                  (sset-union out in))))
483           (t
484            (let ((kill-set (make-sset)))
485              (dolist (var kill-list)
486                (let ((con (lambda-var-constraints var)))
487                  (when con
488                    (sset-union kill-set con))))
489              (sset-union-of-difference (block-out block) in kill-set))))))
490
491 ;;; How many blocks does COMPONENT have?
492 (defun component-n-blocks (component)
493   (let ((result 0))
494     (declare (type index result))
495     (do-blocks (block component :both)
496       (incf result))
497     result))
498
499 (defun constraint-propagate (component)
500   (declare (type component component))
501   (init-var-constraints component)
502
503   (do-blocks (block component)
504     (when (block-test-modified block)
505       (find-test-constraints block)))
506
507   (do-blocks (block component)
508     (cond ((block-type-asserted block)
509            (find-block-type-constraints block))
510           (t
511            (setf (block-in block) nil)
512            (setf (block-out block) (copy-sset (block-gen block))))))
513
514   (setf (block-out (component-head component)) (make-sset))
515
516   (let (;; If we have to propagate changes more than this many times,
517         ;; something is wrong.
518         (max-n-changes-remaining (component-n-blocks component)))
519     (declare (type fixnum max-n-changes-remaining))
520     (loop (aver (plusp max-n-changes-remaining))
521           (decf max-n-changes-remaining)
522           (let ((did-something nil))
523             (do-blocks (block component)
524               (when (flow-propagate-constraints block)
525                 (setq did-something t)))
526             (unless did-something
527               (return)))))
528
529   (do-blocks (block component)
530     (use-result-constraints block))
531
532   (values))