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