0.9.10.26
[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): it does not understand that this
41 ;;; constraint follows from (TYPEP I (INTEGER 0 0)).
42
43 (in-package "SB!C")
44
45 (deftype constraint-y () '(or ctype lvar lambda-var constant))
46
47 (defstruct (constraint
48             (:include sset-element)
49             (:constructor make-constraint (number kind x y not-p))
50             (:copier nil))
51   ;; the kind of constraint we have:
52   ;;
53   ;; TYPEP
54   ;;     X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
55   ;;     constrained to be of type Y.
56   ;;
57   ;; > or <
58   ;;     X is a lambda-var and Y is a CTYPE. The relation holds
59   ;;     between X and some object of type Y.
60   ;;
61   ;; EQL
62   ;;     X is a LAMBDA-VAR and Y is a LVAR, a LAMBDA-VAR or a CONSTANT.
63   ;;     The relation is asserted to hold.
64   (kind nil :type (member typep < > eql))
65   ;; The operands to the relation.
66   (x nil :type lambda-var)
67   (y nil :type constraint-y)
68   ;; If true, negates the sense of the constraint, so the relation
69   ;; does *not* hold.
70   (not-p nil :type boolean))
71
72 (defvar *constraint-number*)
73 (declaim (type (integer 0) *constraint-number*))
74
75 (defun find-constraint (kind x y not-p)
76   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
77   (etypecase y
78     (ctype
79      (do-sset-elements (con (lambda-var-constraints x) nil)
80        (when (and (eq (constraint-kind con) kind)
81                   (eq (constraint-not-p con) not-p)
82                   (type= (constraint-y con) y))
83          (return con))))
84     ((or lvar constant)
85      (do-sset-elements (con (lambda-var-constraints x) nil)
86        (when (and (eq (constraint-kind con) kind)
87                   (eq (constraint-not-p con) not-p)
88                   (eq (constraint-y con) y))
89          (return con))))
90     (lambda-var
91      (do-sset-elements (con (lambda-var-constraints x) nil)
92        (when (and (eq (constraint-kind con) kind)
93                   (eq (constraint-not-p con) not-p)
94                   (let ((cx (constraint-x con)))
95                     (eq (if (eq cx x)
96                             (constraint-y con)
97                             cx)
98                         y)))
99          (return con))))))
100
101 ;;; Return a constraint for the specified arguments. We only create a
102 ;;; new constraint if there isn't already an equivalent old one,
103 ;;; guaranteeing that all equivalent constraints are EQ. This
104 ;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
105 (defun find-or-create-constraint (kind x y not-p)
106   (declare (type lambda-var x) (type constraint-y y) (type boolean not-p))
107   (or (find-constraint kind x y not-p)
108       (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
109         (sset-adjoin new (lambda-var-constraints x))
110         (when (lambda-var-p y)
111           (sset-adjoin new (lambda-var-constraints y)))
112         new)))
113
114 ;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
115 ;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
116 #!-sb-fluid (declaim (inline ok-ref-lambda-var))
117 (defun ok-ref-lambda-var (ref)
118   (declare (type ref ref))
119   (let ((leaf (ref-leaf ref)))
120     (when (and (lambda-var-p leaf)
121                (lambda-var-constraints leaf))
122       leaf)))
123
124 ;;; See if LVAR's single USE is a REF to a LAMBDA-VAR and they are EQL
125 ;;; according to CONSTRAINTS. Return LAMBDA-VAR if so.
126 (defun ok-lvar-lambda-var (lvar constraints)
127   (declare (type lvar lvar))
128   (let ((use (lvar-uses lvar)))
129     (cond ((ref-p use)
130            (let ((lambda-var (ok-ref-lambda-var use)))
131              (when lambda-var
132                (let ((constraint (find-constraint 'eql lambda-var lvar nil)))
133                  (when (and constraint (sset-member constraint constraints))
134                    lambda-var)))))
135           ((cast-p use)
136            (ok-lvar-lambda-var (cast-value use) constraints)))))
137
138 (defmacro do-eql-vars ((symbol (var constraints) &optional result) &body body)
139   (once-only ((var var))
140     `(let ((,symbol ,var))
141        (flet ((body-fun ()
142                 ,@body))
143          (body-fun)
144          (do-sset-elements (con ,constraints ,result)
145            (let ((other (and (eq (constraint-kind con) 'eql)
146                              (eq (constraint-not-p con) nil)
147                              (cond ((eq ,var (constraint-x con))
148                                     (constraint-y con))
149                                    ((eq ,var (constraint-y con))
150                                     (constraint-x con))
151                                    (t
152                                     nil)))))
153              (when other
154                (setq ,symbol other)
155                (when (lambda-var-p ,symbol)
156                  (body-fun)))))))))
157
158 ;;;; Searching constraints
159
160 ;;; Add the indicated test constraint to BLOCK. We don't add the
161 ;;; constraint if the block has multiple predecessors, since it only
162 ;;; holds on this particular path.
163 (defun add-test-constraint (fun x y not-p constraints target)
164   (cond ((and (eq 'eql fun) (lambda-var-p y) (not not-p))
165          (add-eql-var-var-constraint x y constraints target))
166         (t
167          (do-eql-vars (x (x constraints))
168            (let ((con (find-or-create-constraint fun x y not-p)))
169              (sset-adjoin con target)))))
170   (values))
171
172 ;;; Add complementary constraints to the consequent and alternative
173 ;;; blocks of IF. We do nothing if X is NIL.
174 (defun add-complement-constraints (if fun x y not-p constraints
175                                       consequent-constraints
176                                       alternative-constraints)
177   (when (and x
178              ;; Note: Even if we do (IF test exp exp) => (PROGN test exp)
179              ;; optimization, the *MAX-OPTIMIZE-ITERATIONS* cutoff means
180              ;; that we can't guarantee that the optimization will be
181              ;; done, so we still need to avoid barfing on this case.
182              (not (eq (if-consequent if)
183                       (if-alternative if))))
184     (add-test-constraint fun x y not-p constraints
185                          consequent-constraints)
186     (add-test-constraint fun x y (not not-p) constraints
187                          alternative-constraints))
188   (values))
189
190 ;;; Add test constraints to the consequent and alternative blocks of
191 ;;; the test represented by USE.
192 (defun add-test-constraints (use if constraints)
193   (declare (type node use) (type cif if))
194   (let ((consequent-constraints (make-sset))
195         (alternative-constraints (make-sset)))
196     (macrolet ((add (fun x y not-p)
197                  `(add-complement-constraints if ,fun ,x ,y ,not-p
198                    constraints
199                    consequent-constraints
200                    alternative-constraints)))
201       (typecase use
202         (ref
203          (add 'typep (ok-lvar-lambda-var (ref-lvar use) constraints)
204               (specifier-type 'null) t))
205         (combination
206          (unless (eq (combination-kind use)
207                      :error)
208            (let ((name (lvar-fun-name
209                         (basic-combination-fun use)))
210                  (args (basic-combination-args use)))
211              (case name
212                ((%typep %instance-typep)
213                 (let ((type (second args)))
214                   (when (constant-lvar-p type)
215                     (let ((val (lvar-value type)))
216                       (add 'typep (ok-lvar-lambda-var (first args) constraints)
217                            (if (ctype-p val)
218                                val
219                                (specifier-type val))
220                            nil)))))
221                ((eq eql)
222                 (let* ((var1 (ok-lvar-lambda-var (first args) constraints))
223                        (arg2 (second args))
224                        (var2 (ok-lvar-lambda-var arg2 constraints)))
225                   (cond ((not var1))
226                         (var2
227                          (add 'eql var1 var2 nil))
228                         ((constant-lvar-p arg2)
229                          (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
230                               nil)))))
231                ((< >)
232                 (let* ((arg1 (first args))
233                        (var1 (ok-lvar-lambda-var arg1 constraints))
234                        (arg2 (second args))
235                        (var2 (ok-lvar-lambda-var arg2 constraints)))
236                   (when var1
237                     (add name var1 (lvar-type arg2) nil))
238                   (when var2
239                     (add (if (eq name '<) '> '<) var2 (lvar-type arg1) nil))))
240                (t
241                 (let ((ptype (gethash name *backend-predicate-types*)))
242                   (when ptype
243                     (add 'typep (ok-lvar-lambda-var (first args) constraints)
244                          ptype nil))))))))))
245     (values consequent-constraints alternative-constraints)))
246
247 ;;;; Applying constraints
248
249 ;;; Return true if X is an integer NUMERIC-TYPE.
250 (defun integer-type-p (x)
251   (declare (type ctype x))
252   (and (numeric-type-p x)
253        (eq (numeric-type-class x) 'integer)
254        (eq (numeric-type-complexp x) :real)))
255
256 ;;; Given that an inequality holds on values of type X and Y, return a
257 ;;; new type for X. If GREATER is true, then X was greater than Y,
258 ;;; otherwise less. If OR-EQUAL is true, then the inequality was
259 ;;; inclusive, i.e. >=.
260 ;;;
261 ;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
262 ;;; bound into X and return that result. If not OR-EQUAL, we can go
263 ;;; one greater (less) than Y's bound.
264 (defun constrain-integer-type (x y greater or-equal)
265   (declare (type numeric-type x y))
266   (flet ((exclude (x)
267            (cond ((not x) nil)
268                  (or-equal x)
269                  (greater (1+ x))
270                  (t (1- x))))
271          (bound (x)
272            (if greater (numeric-type-low x) (numeric-type-high x))))
273     (let* ((x-bound (bound x))
274            (y-bound (exclude (bound y)))
275            (new-bound (cond ((not x-bound) y-bound)
276                             ((not y-bound) x-bound)
277                             (greater (max x-bound y-bound))
278                             (t (min x-bound y-bound)))))
279       (if greater
280           (modified-numeric-type x :low new-bound)
281           (modified-numeric-type x :high new-bound)))))
282
283 ;;; Return true if X is a float NUMERIC-TYPE.
284 (defun float-type-p (x)
285   (declare (type ctype x))
286   (and (numeric-type-p x)
287        (eq (numeric-type-class x) 'float)
288        (eq (numeric-type-complexp x) :real)))
289
290 ;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
291 (defun constrain-float-type (x y greater or-equal)
292   (declare (type numeric-type x y))
293   (declare (ignorable x y greater or-equal)) ; for CROSS-FLOAT-INFINITY-KLUDGE
294
295   (aver (eql (numeric-type-class x) 'float))
296   (aver (eql (numeric-type-class y) 'float))
297   #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
298   x
299   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
300   (labels ((exclude (x)
301              (cond ((not x) nil)
302                    (or-equal x)
303                    (greater
304                     (if (consp x)
305                         (car x)
306                         x))
307                    (t
308                     (if (consp x)
309                         x
310                         (list x)))))
311            (bound (x)
312              (if greater (numeric-type-low x) (numeric-type-high x)))
313            (max-lower-bound (x y)
314              ;; Both X and Y are not null. Find the max.
315              (let ((res (max (type-bound-number x) (type-bound-number y))))
316                ;; An open lower bound is greater than a close
317                ;; lower bound because the open bound doesn't
318                ;; contain the bound, so choose an open lower
319                ;; bound.
320                (set-bound res (or (consp x) (consp y)))))
321            (min-upper-bound (x y)
322              ;; Same as above, but for the min of upper bounds
323              ;; Both X and Y are not null. Find the min.
324              (let ((res (min (type-bound-number x) (type-bound-number y))))
325                ;; An open upper bound is less than a closed
326                ;; upper bound because the open bound doesn't
327                ;; contain the bound, so choose an open lower
328                ;; bound.
329                (set-bound res (or (consp x) (consp y))))))
330     (let* ((x-bound (bound x))
331            (y-bound (exclude (bound y)))
332            (new-bound (cond ((not x-bound)
333                              y-bound)
334                             ((not y-bound)
335                              x-bound)
336                             (greater
337                              (max-lower-bound x-bound y-bound))
338                             (t
339                              (min-upper-bound x-bound y-bound)))))
340       (if greater
341           (modified-numeric-type x :low new-bound)
342           (modified-numeric-type x :high new-bound)))))
343
344 ;;; Given the set of CONSTRAINTS for a variable and the current set of
345 ;;; restrictions from flow analysis IN, set the type for REF
346 ;;; accordingly.
347 (defun constrain-ref-type (ref constraints in)
348   (declare (type ref ref) (type sset constraints in))
349   (let ((var-cons (copy-sset constraints)))
350     (sset-intersection var-cons in)
351     (let ((res (single-value-type (node-derived-type ref)))
352           (not-res *empty-type*)
353           (leaf (ref-leaf ref)))
354       (do-sset-elements (con var-cons)
355         (let* ((x (constraint-x con))
356                (y (constraint-y con))
357                (not-p (constraint-not-p con))
358                (other (if (eq x leaf) y x))
359                (kind (constraint-kind con)))
360           (case kind
361             (typep
362              (if not-p
363                  (setq not-res (type-union not-res other))
364                  (setq res (type-approx-intersection2 res other))))
365             (eql
366              (unless (lvar-p other)
367                (let ((other-type (leaf-type other)))
368                  (if not-p
369                      (when (and (constant-p other)
370                                 (member-type-p other-type))
371                        (setq not-res (type-union not-res other-type)))
372                      (let ((leaf-type (leaf-type leaf)))
373                        (cond
374                          ((or (constant-p other)
375                               (and (leaf-refs other) ; protect from
376                                         ; deleted vars
377                                    (csubtypep other-type leaf-type)
378                                    (not (type= other-type leaf-type))))
379                           (change-ref-leaf ref other)
380                           (when (constant-p other) (return)))
381                          (t
382                           (setq res (type-approx-intersection2
383                                      res other-type)))))))))
384             ((< >)
385              (cond
386                ((and (integer-type-p res) (integer-type-p y))
387                 (let ((greater (eq kind '>)))
388                   (let ((greater (if not-p (not greater) greater)))
389                     (setq res
390                           (constrain-integer-type res y greater not-p)))))
391                ((and (float-type-p res) (float-type-p y))
392                 (let ((greater (eq kind '>)))
393                   (let ((greater (if not-p (not greater) greater)))
394                     (setq res
395                           (constrain-float-type res y greater not-p))))))))))
396       (cond ((and (if-p (node-dest ref))
397                   (csubtypep (specifier-type 'null) not-res))
398              (setf (node-derived-type ref) *wild-type*)
399              (change-ref-leaf ref (find-constant t)))
400             (t
401              (derive-node-type ref
402                                (make-single-value-type
403                                 (or (type-difference res not-res)
404                                     res)))
405              (maybe-terminate-block ref nil)))))
406
407   (values))
408
409 ;;;; Flow analysis
410
411 (defun maybe-add-eql-var-lvar-constraint (ref gen)
412   (let ((lvar (ref-lvar ref))
413         (leaf (ref-leaf ref)))
414     (when (and (lambda-var-p leaf) lvar)
415       (sset-adjoin (find-or-create-constraint 'eql leaf lvar nil)
416                    gen))))
417
418 ;;; Copy all CONSTRAINTS involving FROM-VAR to VAR except the (EQL VAR
419 ;;; LVAR) ones.
420 (defun inherit-constraints (var from-var constraints target)
421   (do-sset-elements (con constraints)
422     (let ((eq-x (eq from-var (constraint-x con)))
423           (eq-y (eq from-var (constraint-y con))))
424       ;; Constant substitution is controversial.
425       (unless (constant-p (constraint-y con))
426         (when (or (and eq-x (not (lvar-p (constraint-y con))))
427                   eq-y)
428           (sset-adjoin (find-or-create-constraint
429                         (constraint-kind con)
430                         (if eq-x var (constraint-x con))
431                         (if eq-y var (constraint-y con))
432                         (constraint-not-p con))
433                        target))))))
434
435 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR1 and VAR2 and
436 ;; inherit each other's constraints.
437 (defun add-eql-var-var-constraint (var1 var2 constraints
438                                    &optional (target constraints))
439   (let ((con (find-or-create-constraint 'eql var1 var2 nil)))
440     (when (sset-adjoin con target)
441       (do-eql-vars (var2 (var2 constraints))
442         (inherit-constraints var1 var2 constraints target))
443       (do-eql-vars (var1 (var1 constraints))
444         (inherit-constraints var1 var2 constraints target))
445       t)))
446
447 ;; Add an (EQL LAMBDA-VAR LAMBDA-VAR) constraint on VAR and LVAR's
448 ;; LAMBDA-VAR if possible.
449 (defun maybe-add-eql-var-var-constraint (var lvar constraints
450                                          &optional (target constraints))
451   (declare (type lambda-var var) (type lvar lvar))
452   (let ((lambda-var (ok-lvar-lambda-var lvar constraints)))
453     (when lambda-var
454       (add-eql-var-var-constraint var lambda-var constraints target))))
455
456 ;;; Local propagation
457 ;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that
458 ;;;    constraint.]
459 ;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add
460 ;;;    a type constraint based on the new value type.
461 (declaim (ftype (function (cblock sset
462                            &key (:ref-preprocessor (or null function))
463                                 (:set-preprocessor (or null function)))
464                           sset)
465                 constraint-propagate-in-block))
466 (defun constraint-propagate-in-block
467     (block gen &key ref-preprocessor set-preprocessor)
468
469   (do-nodes (node lvar block)
470     (typecase node
471       (bind
472        (let ((fun (bind-lambda node)))
473          (when (eq (functional-kind fun) :let)
474            (loop with call = (lvar-dest (node-lvar (first (lambda-refs fun))))
475                  for var in (lambda-vars fun)
476                  and val in (combination-args call)
477                  when (and val (lambda-var-constraints var))
478                  do (let* ((type (lvar-type val))
479                            (con (find-or-create-constraint 'typep var type
480                                                            nil)))
481                       (sset-adjoin con gen))
482                  (maybe-add-eql-var-var-constraint var val gen)))))
483       (ref
484        (when (ok-ref-lambda-var node)
485          (maybe-add-eql-var-lvar-constraint node gen)
486          (when ref-preprocessor
487            (funcall ref-preprocessor node gen))))
488       (cast
489        (let ((lvar (cast-value node)))
490          (let ((var (ok-lvar-lambda-var lvar gen)))
491            (when var
492              (let ((atype (single-value-type (cast-derived-type node)))) ;FIXME
493                (do-eql-vars (var (var gen))
494                  (let ((con (find-or-create-constraint 'typep var atype nil)))
495                    (sset-adjoin con gen))))))))
496       (cset
497        (binding* ((var (set-var node))
498                   (nil (lambda-var-p var) :exit-if-null)
499                   (cons (lambda-var-constraints var) :exit-if-null))
500          (when set-preprocessor
501            (funcall set-preprocessor var))
502          (sset-difference gen cons)
503          (let* ((type (single-value-type (node-derived-type node)))
504                 (con (find-or-create-constraint 'typep var type nil)))
505            (sset-adjoin con gen))
506          (maybe-add-eql-var-var-constraint var (set-value node) gen)))))
507
508   gen)
509
510 (defun constraint-propagate-if (block gen)
511   (let ((node (block-last block)))
512     (when (if-p node)
513       (let ((use (lvar-uses (if-test node))))
514         (when (node-p use)
515           (add-test-constraints use node gen))))))
516
517 (defun constrain-node (node cons)
518   (let* ((var (ref-leaf node))
519          (con (lambda-var-constraints var)))
520     (constrain-ref-type node con cons)))
521
522 ;;; Starting from IN compute OUT and (consequent/alternative
523 ;;; constraints if the block ends with and IF). Return the list of
524 ;;; successors that may need to be recomputed.
525 (defun find-block-type-constraints (block &key final-pass-p)
526   (declare (type cblock block))
527   (let ((gen (constraint-propagate-in-block
528               block
529               (if final-pass-p
530                   (block-in block)
531                   (copy-sset (block-in block)))
532               :ref-preprocessor (if final-pass-p #'constrain-node nil))))
533     (setf (block-gen block) gen)
534     (multiple-value-bind (consequent-constraints alternative-constraints)
535         (constraint-propagate-if block gen)
536       (if consequent-constraints
537           (let* ((node (block-last block))
538                  (old-consequent-constraints (if-consequent-constraints node))
539                  (old-alternative-constraints (if-alternative-constraints node))
540                  (succ ()))
541             ;; Add the consequent and alternative constraints to GEN.
542             (cond ((sset-empty consequent-constraints)
543                    (setf (if-consequent-constraints node) gen)
544                    (setf (if-alternative-constraints node) gen))
545                   (t
546                    (setf (if-consequent-constraints node) (copy-sset gen))
547                    (sset-union (if-consequent-constraints node)
548                                consequent-constraints)
549                    (setf (if-alternative-constraints node) gen)
550                    (sset-union (if-alternative-constraints node)
551                                alternative-constraints)))
552             ;; Has the consequent been changed?
553             (unless (and old-consequent-constraints
554                          (sset= (if-consequent-constraints node)
555                                 old-consequent-constraints))
556               (push (if-consequent node) succ))
557             ;; Has the alternative been changed?
558             (unless (and old-alternative-constraints
559                          (sset= (if-alternative-constraints node)
560                                 old-alternative-constraints))
561               (push (if-alternative node) succ))
562             succ)
563           ;; There is no IF.
564           (unless (and (block-out block)
565                        (sset= gen (block-out block)))
566             (setf (block-out block) gen)
567             (block-succ block))))))
568
569 ;;; Deliver the results of constraint propagation to REFs in BLOCK.
570 ;;; During this pass, we also do local constraint propagation by
571 ;;; adding in constraints as we see them during the pass through the
572 ;;; block.
573 (defun use-result-constraints (block)
574   (declare (type cblock block))
575   (constraint-propagate-in-block block (block-in block)
576                                  :ref-preprocessor #'constrain-node))
577
578 ;;; Give an empty constraints set to any var that doesn't have one and
579 ;;; isn't a set closure var. Since a var that we previously rejected
580 ;;; looks identical to one that is new, so we optimistically keep
581 ;;; hoping that vars stop being closed over or lose their sets.
582 (defun init-var-constraints (component)
583   (declare (type component component))
584   (dolist (fun (component-lambdas component))
585     (flet ((frob (x)
586              (dolist (var (lambda-vars x))
587                (unless (lambda-var-constraints var)
588                  (when (or (null (lambda-var-sets var))
589                            (not (closure-var-p var)))
590                    (setf (lambda-var-constraints var) (make-sset)))))))
591       (frob fun)
592       (dolist (let (lambda-lets fun))
593         (frob let)))))
594
595 ;;; Return the constraints that flow from PRED to SUCC. This is
596 ;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
597 ;;; added.
598 (defun block-out-for-successor (pred succ)
599   (declare (type cblock pred succ))
600   (let ((last (block-last pred)))
601     (or (when (if-p last)
602           (cond ((eq succ (if-consequent last))
603                  (if-consequent-constraints last))
604                 ((eq succ (if-alternative last))
605                  (if-alternative-constraints last))))
606         (block-out pred))))
607
608 (defun compute-block-in (block)
609   (let ((in nil))
610     (dolist (pred (block-pred block))
611       ;; If OUT has not been calculated, assume it to be the universal
612       ;; set.
613       (let ((out (block-out-for-successor pred block)))
614         (when out
615           (if in
616               (sset-intersection in out)
617               (setq in (copy-sset out))))))
618     (or in (make-sset))))
619
620 (defun update-block-in (block)
621   (let ((in (compute-block-in block)))
622     (cond ((and (block-in block) (sset= in (block-in block)))
623            nil)
624           (t
625            (setf (block-in block) in)))))
626
627 ;;; Return two lists: one of blocks that precede all loops and
628 ;;; therefore require only one constraint propagation pass and the
629 ;;; rest. This implementation does not find all such blocks.
630 ;;;
631 ;;; A more complete implementation would be:
632 ;;;
633 ;;;     (do-blocks (block component)
634 ;;;       (if (every #'(lambda (pred)
635 ;;;                      (or (member pred leading-blocks)
636 ;;;                          (eq pred head)))
637 ;;;                  (block-pred block))
638 ;;;           (push block leading-blocks)
639 ;;;           (push block rest-of-blocks)))
640 ;;;
641 ;;; Trailing blocks that succeed all loops could be found and handled
642 ;;; similarly. In practice though, these more complex solutions are
643 ;;; slightly worse performancewise.
644 (defun leading-component-blocks (component)
645   (declare (type component component))
646   (flet ((loopy-p (block)
647            (let ((n (block-number block)))
648              (dolist (pred (block-pred block))
649                (unless (< n (block-number pred))
650                  (return t))))))
651     (let ((leading-blocks ())
652           (rest-of-blocks ())
653           (seen-loop-p ()))
654       (do-blocks (block component)
655         (when (and (not seen-loop-p) (loopy-p block))
656           (setq seen-loop-p t))
657         (if seen-loop-p
658             (push block rest-of-blocks)
659             (push block leading-blocks)))
660       (values (nreverse leading-blocks) (nreverse rest-of-blocks)))))
661
662 ;;; Append OBJ to the end of LIST as if by NCONC but only if it is not
663 ;;; a member already.
664 (defun nconc-new (obj list)
665   (do ((x list (cdr x))
666        (prev nil x))
667       ((endp x) (if prev
668                     (progn
669                       (setf (cdr prev) (list obj))
670                       list)
671                     (list obj)))
672     (when (eql (car x) obj)
673       (return-from nconc-new list))))
674
675 (defun find-and-propagate-constraints (component)
676   (let ((blocks-to-process ()))
677     (flet ((enqueue (blocks)
678              (dolist (block blocks)
679                (setq blocks-to-process (nconc-new block blocks-to-process)))))
680       (multiple-value-bind (leading-blocks rest-of-blocks)
681           (leading-component-blocks component)
682         ;; Update every block once to account for changes in the
683         ;; IR1. The constraints of the lead blocks cannot be changed
684         ;; after the first pass so we might as well use them and skip
685         ;; USE-RESULT-CONSTRAINTS later.
686         (dolist (block leading-blocks)
687           (setf (block-in block) (compute-block-in block))
688           (find-block-type-constraints block :final-pass-p t))
689         (setq blocks-to-process (copy-list rest-of-blocks))
690         ;; The rest of the blocks.
691         (dolist (block rest-of-blocks)
692           (aver (eq block (pop blocks-to-process)))
693           (setf (block-in block) (compute-block-in block))
694           (enqueue (find-block-type-constraints block)))
695         ;; Propagate constraints
696         (loop for block = (pop blocks-to-process)
697               while block do
698               (unless (eq block (component-tail component))
699                 (when (update-block-in block)
700                   (enqueue (find-block-type-constraints block)))))
701         rest-of-blocks))))
702
703 (defun constraint-propagate (component)
704   (declare (type component component))
705   (init-var-constraints component)
706
707   (unless (block-out (component-head component))
708     (setf (block-out (component-head component)) (make-sset)))
709
710   (dolist (block (find-and-propagate-constraints component))
711     (unless (block-delete-p block)
712       (use-result-constraints block)))
713
714   (values))