0.7.4.20:
[sbcl.git] / src / compiler / srctran.lisp
1 ;;;; This file contains macro-like source transformations which
2 ;;;; convert uses of certain functions into the canonical form desired
3 ;;;; within the compiler. ### and other IR1 transforms and stuff.
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 ;;; Convert into an IF so that IF optimizations will eliminate redundant
17 ;;; negations.
18 (define-source-transform not (x) `(if ,x nil t))
19 (define-source-transform null (x) `(if ,x nil t))
20
21 ;;; ENDP is just NULL with a LIST assertion. The assertion will be
22 ;;; optimized away when SAFETY optimization is low; hopefully that
23 ;;; is consistent with ANSI's "should return an error".
24 (define-source-transform endp (x) `(null (the list ,x)))
25
26 ;;; We turn IDENTITY into PROG1 so that it is obvious that it just
27 ;;; returns the first value of its argument. Ditto for VALUES with one
28 ;;; arg.
29 (define-source-transform identity (x) `(prog1 ,x))
30 (define-source-transform values (x) `(prog1 ,x))
31
32 ;;; Bind the values and make a closure that returns them.
33 (define-source-transform constantly (value)
34   (let ((rest (gensym "CONSTANTLY-REST-")))
35     `(lambda (&rest ,rest)
36        (declare (ignore ,rest))
37        ,value)))
38
39 ;;; If the function has a known number of arguments, then return a
40 ;;; lambda with the appropriate fixed number of args. If the
41 ;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
42 ;;; MV optimization figure things out.
43 (deftransform complement ((fun) * * :node node)
44   "open code"
45   (multiple-value-bind (min max)
46       (fun-type-nargs (continuation-type fun))
47     (cond
48      ((and min (eql min max))
49       (let ((dums (make-gensym-list min)))
50         `#'(lambda ,dums (not (funcall fun ,@dums)))))
51      ((let* ((cont (node-cont node))
52              (dest (continuation-dest cont)))
53         (and (combination-p dest)
54              (eq (combination-fun dest) cont)))
55       '#'(lambda (&rest args)
56            (not (apply fun args))))
57      (t
58       (give-up-ir1-transform
59        "The function doesn't have a fixed argument count.")))))
60 \f
61 ;;;; list hackery
62
63 ;;; Translate CxR into CAR/CDR combos.
64 (defun source-transform-cxr (form)
65   (if (/= (length form) 2)
66       (values nil t)
67       (let ((name (symbol-name (car form))))
68         (do ((i (- (length name) 2) (1- i))
69              (res (cadr form)
70                   `(,(ecase (char name i)
71                        (#\A 'car)
72                        (#\D 'cdr))
73                     ,res)))
74             ((zerop i) res)))))
75
76 ;;; Make source transforms to turn CxR forms into combinations of CAR
77 ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
78 ;;; defined.
79 (/show0 "about to set CxR source transforms")
80 (loop for i of-type index from 2 upto 4 do
81       ;; Iterate over BUF = all names CxR where x = an I-element
82       ;; string of #\A or #\D characters.
83       (let ((buf (make-string (+ 2 i))))
84         (setf (aref buf 0) #\C
85               (aref buf (1+ i)) #\R)
86         (dotimes (j (ash 2 i))
87           (declare (type index j))
88           (dotimes (k i)
89             (declare (type index k))
90             (setf (aref buf (1+ k))
91                   (if (logbitp k j) #\A #\D)))
92           (setf (info :function :source-transform (intern buf))
93                 #'source-transform-cxr))))
94 (/show0 "done setting CxR source transforms")
95
96 ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
97 ;;; whatever is right for them is right for us. FIFTH..TENTH turn into
98 ;;; Nth, which can be expanded into a CAR/CDR later on if policy
99 ;;; favors it.
100 (define-source-transform first (x) `(car ,x))
101 (define-source-transform rest (x) `(cdr ,x))
102 (define-source-transform second (x) `(cadr ,x))
103 (define-source-transform third (x) `(caddr ,x))
104 (define-source-transform fourth (x) `(cadddr ,x))
105 (define-source-transform fifth (x) `(nth 4 ,x))
106 (define-source-transform sixth (x) `(nth 5 ,x))
107 (define-source-transform seventh (x) `(nth 6 ,x))
108 (define-source-transform eighth (x) `(nth 7 ,x))
109 (define-source-transform ninth (x) `(nth 8 ,x))
110 (define-source-transform tenth (x) `(nth 9 ,x))
111
112 ;;; Translate RPLACx to LET and SETF.
113 (define-source-transform rplaca (x y)
114   (once-only ((n-x x))
115     `(progn
116        (setf (car ,n-x) ,y)
117        ,n-x)))
118 (define-source-transform rplacd (x y)
119   (once-only ((n-x x))
120     `(progn
121        (setf (cdr ,n-x) ,y)
122        ,n-x)))
123
124 (define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
125
126 (defvar *default-nthcdr-open-code-limit* 6)
127 (defvar *extreme-nthcdr-open-code-limit* 20)
128
129 (deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
130   "convert NTHCDR to CAxxR"
131   (unless (constant-continuation-p n)
132     (give-up-ir1-transform))
133   (let ((n (continuation-value n)))
134     (when (> n
135              (if (policy node (and (= speed 3) (= space 0)))
136                  *extreme-nthcdr-open-code-limit*
137                  *default-nthcdr-open-code-limit*))
138       (give-up-ir1-transform))
139
140     (labels ((frob (n)
141                (if (zerop n)
142                    'l
143                    `(cdr ,(frob (1- n))))))
144       (frob n))))
145 \f
146 ;;;; arithmetic and numerology
147
148 (define-source-transform plusp (x) `(> ,x 0))
149 (define-source-transform minusp (x) `(< ,x 0))
150 (define-source-transform zerop (x) `(= ,x 0))
151
152 (define-source-transform 1+ (x) `(+ ,x 1))
153 (define-source-transform 1- (x) `(- ,x 1))
154
155 (define-source-transform oddp (x) `(not (zerop (logand ,x 1))))
156 (define-source-transform evenp (x) `(zerop (logand ,x 1)))
157
158 ;;; Note that all the integer division functions are available for
159 ;;; inline expansion.
160
161 (macrolet ((deffrob (fun)
162              `(define-source-transform ,fun (x &optional (y nil y-p))
163                 (declare (ignore y))
164                 (if y-p
165                     (values nil t)
166                     `(,',fun ,x 1)))))
167   (deffrob truncate)
168   (deffrob round)
169   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
170   (deffrob floor)
171   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
172   (deffrob ceiling))
173
174 (define-source-transform lognand (x y) `(lognot (logand ,x ,y)))
175 (define-source-transform lognor (x y) `(lognot (logior ,x ,y)))
176 (define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
177 (define-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
178 (define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
179 (define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
180 (define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
181 (define-source-transform logbitp (index integer)
182   `(not (zerop (logand (ash 1 ,index) ,integer))))
183 (define-source-transform byte (size position) `(cons ,size ,position))
184 (define-source-transform byte-size (spec) `(car ,spec))
185 (define-source-transform byte-position (spec) `(cdr ,spec))
186 (define-source-transform ldb-test (bytespec integer)
187   `(not (zerop (mask-field ,bytespec ,integer))))
188
189 ;;; With the ratio and complex accessors, we pick off the "identity"
190 ;;; case, and use a primitive to handle the cell access case.
191 (define-source-transform numerator (num)
192   (once-only ((n-num `(the rational ,num)))
193     `(if (ratiop ,n-num)
194          (%numerator ,n-num)
195          ,n-num)))
196 (define-source-transform denominator (num)
197   (once-only ((n-num `(the rational ,num)))
198     `(if (ratiop ,n-num)
199          (%denominator ,n-num)
200          1)))
201 \f
202 ;;;; interval arithmetic for computing bounds
203 ;;;;
204 ;;;; This is a set of routines for operating on intervals. It
205 ;;;; implements a simple interval arithmetic package. Although SBCL
206 ;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
207 ;;;; for two reasons:
208 ;;;;
209 ;;;;   1. This package is simpler than NUMERIC-TYPE.
210 ;;;;
211 ;;;;   2. It makes debugging much easier because you can just strip
212 ;;;;   out these routines and test them independently of SBCL. (This is a
213 ;;;;   big win!)
214 ;;;;
215 ;;;; One disadvantage is a probable increase in consing because we
216 ;;;; have to create these new interval structures even though
217 ;;;; numeric-type has everything we want to know. Reason 2 wins for
218 ;;;; now.
219
220 ;;; The basic interval type. It can handle open and closed intervals.
221 ;;; A bound is open if it is a list containing a number, just like
222 ;;; Lisp says. NIL means unbounded.
223 (defstruct (interval (:constructor %make-interval)
224                      (:copier nil))
225   low high)
226
227 (defun make-interval (&key low high)
228   (labels ((normalize-bound (val)
229              (cond ((and (floatp val)
230                          (float-infinity-p val))
231                     ;; Handle infinities.
232                     nil)
233                    ((or (numberp val)
234                         (eq val nil))
235                     ;; Handle any closed bounds.
236                     val)
237                    ((listp val)
238                     ;; We have an open bound. Normalize the numeric
239                     ;; bound. If the normalized bound is still a number
240                     ;; (not nil), keep the bound open. Otherwise, the
241                     ;; bound is really unbounded, so drop the openness.
242                     (let ((new-val (normalize-bound (first val))))
243                       (when new-val
244                         ;; The bound exists, so keep it open still.
245                         (list new-val))))
246                    (t
247                     (error "unknown bound type in MAKE-INTERVAL")))))
248     (%make-interval :low (normalize-bound low)
249                     :high (normalize-bound high))))
250
251 ;;; Given a number X, create a form suitable as a bound for an
252 ;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
253 #!-sb-fluid (declaim (inline set-bound))
254 (defun set-bound (x open-p)
255   (if (and x open-p) (list x) x))
256
257 ;;; Apply the function F to a bound X. If X is an open bound, then
258 ;;; the result will be open. IF X is NIL, the result is NIL.
259 (defun bound-func (f x)
260   (and x
261        (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
262          ;; With these traps masked, we might get things like infinity
263          ;; or negative infinity returned. Check for this and return
264          ;; NIL to indicate unbounded.
265          (let ((y (funcall f (type-bound-number x))))
266            (if (and (floatp y)
267                     (float-infinity-p y))
268                nil
269                (set-bound (funcall f (type-bound-number x)) (consp x)))))))
270
271 ;;; Apply a binary operator OP to two bounds X and Y. The result is
272 ;;; NIL if either is NIL. Otherwise bound is computed and the result
273 ;;; is open if either X or Y is open.
274 ;;;
275 ;;; FIXME: only used in this file, not needed in target runtime
276 (defmacro bound-binop (op x y)
277   `(and ,x ,y
278        (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
279          (set-bound (,op (type-bound-number ,x)
280                          (type-bound-number ,y))
281                     (or (consp ,x) (consp ,y))))))
282
283 ;;; Convert a numeric-type object to an interval object.
284 (defun numeric-type->interval (x)
285   (declare (type numeric-type x))
286   (make-interval :low (numeric-type-low x)
287                  :high (numeric-type-high x)))
288
289 (defun copy-interval-limit (limit)
290   (if (numberp limit)
291       limit
292       (copy-list limit)))
293
294 (defun copy-interval (x)
295   (declare (type interval x))
296   (make-interval :low (copy-interval-limit (interval-low x))
297                  :high (copy-interval-limit (interval-high x))))
298
299 ;;; Given a point P contained in the interval X, split X into two
300 ;;; interval at the point P. If CLOSE-LOWER is T, then the left
301 ;;; interval contains P. If CLOSE-UPPER is T, the right interval
302 ;;; contains P. You can specify both to be T or NIL.
303 (defun interval-split (p x &optional close-lower close-upper)
304   (declare (type number p)
305            (type interval x))
306   (list (make-interval :low (copy-interval-limit (interval-low x))
307                        :high (if close-lower p (list p)))
308         (make-interval :low (if close-upper (list p) p)
309                        :high (copy-interval-limit (interval-high x)))))
310
311 ;;; Return the closure of the interval. That is, convert open bounds
312 ;;; to closed bounds.
313 (defun interval-closure (x)
314   (declare (type interval x))
315   (make-interval :low (type-bound-number (interval-low x))
316                  :high (type-bound-number (interval-high x))))
317
318 (defun signed-zero->= (x y)
319   (declare (real x y))
320   (or (> x y)
321       (and (= x y)
322            (>= (float-sign (float x))
323                (float-sign (float y))))))
324
325 ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
326 ;;; '-. Otherwise return NIL.
327 #+nil
328 (defun interval-range-info (x &optional (point 0))
329   (declare (type interval x))
330   (let ((lo (interval-low x))
331         (hi (interval-high x)))
332     (cond ((and lo (signed-zero->= (type-bound-number lo) point))
333            '+)
334           ((and hi (signed-zero->= point (type-bound-number hi)))
335            '-)
336           (t
337            nil))))
338 (defun interval-range-info (x &optional (point 0))
339   (declare (type interval x))
340   (labels ((signed->= (x y)
341              (if (and (zerop x) (zerop y) (floatp x) (floatp y))
342                  (>= (float-sign x) (float-sign y))
343                  (>= x y))))
344     (let ((lo (interval-low x))
345           (hi (interval-high x)))
346       (cond ((and lo (signed->= (type-bound-number lo) point))
347              '+)
348             ((and hi (signed->= point (type-bound-number hi)))
349              '-)
350             (t
351              nil)))))
352
353 ;;; Test to see whether the interval X is bounded. HOW determines the
354 ;;; test, and should be either ABOVE, BELOW, or BOTH.
355 (defun interval-bounded-p (x how)
356   (declare (type interval x))
357   (ecase how
358     (above
359      (interval-high x))
360     (below
361      (interval-low x))
362     (both
363      (and (interval-low x) (interval-high x)))))
364
365 ;;; signed zero comparison functions. Use these functions if we need
366 ;;; to distinguish between signed zeroes.
367 (defun signed-zero-< (x y)
368   (declare (real x y))
369   (or (< x y)
370       (and (= x y)
371            (< (float-sign (float x))
372               (float-sign (float y))))))
373 (defun signed-zero-> (x y)
374   (declare (real x y))
375   (or (> x y)
376       (and (= x y)
377            (> (float-sign (float x))
378               (float-sign (float y))))))
379 (defun signed-zero-= (x y)
380   (declare (real x y))
381   (and (= x y)
382        (= (float-sign (float x))
383           (float-sign (float y)))))
384 (defun signed-zero-<= (x y)
385   (declare (real x y))
386   (or (< x y)
387       (and (= x y)
388            (<= (float-sign (float x))
389                (float-sign (float y))))))
390
391 ;;; See whether the interval X contains the number P, taking into
392 ;;; account that the interval might not be closed.
393 (defun interval-contains-p (p x)
394   (declare (type number p)
395            (type interval x))
396   ;; Does the interval X contain the number P?  This would be a lot
397   ;; easier if all intervals were closed!
398   (let ((lo (interval-low x))
399         (hi (interval-high x)))
400     (cond ((and lo hi)
401            ;; The interval is bounded
402            (if (and (signed-zero-<= (type-bound-number lo) p)
403                     (signed-zero-<= p (type-bound-number hi)))
404                ;; P is definitely in the closure of the interval.
405                ;; We just need to check the end points now.
406                (cond ((signed-zero-= p (type-bound-number lo))
407                       (numberp lo))
408                      ((signed-zero-= p (type-bound-number hi))
409                       (numberp hi))
410                      (t t))
411                nil))
412           (hi
413            ;; Interval with upper bound
414            (if (signed-zero-< p (type-bound-number hi))
415                t
416                (and (numberp hi) (signed-zero-= p hi))))
417           (lo
418            ;; Interval with lower bound
419            (if (signed-zero-> p (type-bound-number lo))
420                t
421                (and (numberp lo) (signed-zero-= p lo))))
422           (t
423            ;; Interval with no bounds
424            t))))
425
426 ;;; Determine whether two intervals X and Y intersect. Return T if so.
427 ;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
428 ;;; were closed. Otherwise the intervals are treated as they are.
429 ;;;
430 ;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
431 ;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
432 ;;; is T, then they do intersect because we use the closure of X = [0,
433 ;;; 1] and Y = [1, 2] to determine intersection.
434 (defun interval-intersect-p (x y &optional closed-intervals-p)
435   (declare (type interval x y))
436   (multiple-value-bind (intersect diff)
437       (interval-intersection/difference (if closed-intervals-p
438                                             (interval-closure x)
439                                             x)
440                                         (if closed-intervals-p
441                                             (interval-closure y)
442                                             y))
443     (declare (ignore diff))
444     intersect))
445
446 ;;; Are the two intervals adjacent?  That is, is there a number
447 ;;; between the two intervals that is not an element of either
448 ;;; interval?  If so, they are not adjacent. For example [0, 1) and
449 ;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
450 ;;; between both intervals.
451 (defun interval-adjacent-p (x y)
452   (declare (type interval x y))
453   (flet ((adjacent (lo hi)
454            ;; Check to see whether lo and hi are adjacent. If either is
455            ;; nil, they can't be adjacent.
456            (when (and lo hi (= (type-bound-number lo) (type-bound-number hi)))
457              ;; The bounds are equal. They are adjacent if one of
458              ;; them is closed (a number). If both are open (consp),
459              ;; then there is a number that lies between them.
460              (or (numberp lo) (numberp hi)))))
461     (or (adjacent (interval-low y) (interval-high x))
462         (adjacent (interval-low x) (interval-high y)))))
463
464 ;;; Compute the intersection and difference between two intervals.
465 ;;; Two values are returned: the intersection and the difference.
466 ;;;
467 ;;; Let the two intervals be X and Y, and let I and D be the two
468 ;;; values returned by this function. Then I = X intersect Y. If I
469 ;;; is NIL (the empty set), then D is X union Y, represented as the
470 ;;; list of X and Y. If I is not the empty set, then D is (X union Y)
471 ;;; - I, which is a list of two intervals.
472 ;;;
473 ;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
474 ;;; [-1,1) union [3,5], which is returned as a list of two intervals.
475 (defun interval-intersection/difference (x y)
476   (declare (type interval x y))
477   (let ((x-lo (interval-low x))
478         (x-hi (interval-high x))
479         (y-lo (interval-low y))
480         (y-hi (interval-high y)))
481     (labels
482         ((opposite-bound (p)
483            ;; If p is an open bound, make it closed. If p is a closed
484            ;; bound, make it open.
485            (if (listp p)
486                (first p)
487                (list p)))
488          (test-number (p int)
489            ;; Test whether P is in the interval.
490            (when (interval-contains-p (type-bound-number p)
491                                       (interval-closure int))
492              (let ((lo (interval-low int))
493                    (hi (interval-high int)))
494                ;; Check for endpoints.
495                (cond ((and lo (= (type-bound-number p) (type-bound-number lo)))
496                       (not (and (consp p) (numberp lo))))
497                      ((and hi (= (type-bound-number p) (type-bound-number hi)))
498                       (not (and (numberp p) (consp hi))))
499                      (t t)))))
500          (test-lower-bound (p int)
501            ;; P is a lower bound of an interval.
502            (if p
503                (test-number p int)
504                (not (interval-bounded-p int 'below))))
505          (test-upper-bound (p int)
506            ;; P is an upper bound of an interval.
507            (if p
508                (test-number p int)
509                (not (interval-bounded-p int 'above)))))
510       (let ((x-lo-in-y (test-lower-bound x-lo y))
511             (x-hi-in-y (test-upper-bound x-hi y))
512             (y-lo-in-x (test-lower-bound y-lo x))
513             (y-hi-in-x (test-upper-bound y-hi x)))
514         (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x)
515                ;; Intervals intersect. Let's compute the intersection
516                ;; and the difference.
517                (multiple-value-bind (lo left-lo left-hi)
518                    (cond (x-lo-in-y (values x-lo y-lo (opposite-bound x-lo)))
519                          (y-lo-in-x (values y-lo x-lo (opposite-bound y-lo))))
520                  (multiple-value-bind (hi right-lo right-hi)
521                      (cond (x-hi-in-y
522                             (values x-hi (opposite-bound x-hi) y-hi))
523                            (y-hi-in-x
524                             (values y-hi (opposite-bound y-hi) x-hi)))
525                    (values (make-interval :low lo :high hi)
526                            (list (make-interval :low left-lo
527                                                 :high left-hi)
528                                  (make-interval :low right-lo
529                                                 :high right-hi))))))
530               (t
531                (values nil (list x y))))))))
532
533 ;;; If intervals X and Y intersect, return a new interval that is the
534 ;;; union of the two. If they do not intersect, return NIL.
535 (defun interval-merge-pair (x y)
536   (declare (type interval x y))
537   ;; If x and y intersect or are adjacent, create the union.
538   ;; Otherwise return nil
539   (when (or (interval-intersect-p x y)
540             (interval-adjacent-p x y))
541     (flet ((select-bound (x1 x2 min-op max-op)
542              (let ((x1-val (type-bound-number x1))
543                    (x2-val (type-bound-number x2)))
544                (cond ((and x1 x2)
545                       ;; Both bounds are finite. Select the right one.
546                       (cond ((funcall min-op x1-val x2-val)
547                              ;; x1 is definitely better.
548                              x1)
549                             ((funcall max-op x1-val x2-val)
550                              ;; x2 is definitely better.
551                              x2)
552                             (t
553                              ;; Bounds are equal. Select either
554                              ;; value and make it open only if
555                              ;; both were open.
556                              (set-bound x1-val (and (consp x1) (consp x2))))))
557                      (t
558                       ;; At least one bound is not finite. The
559                       ;; non-finite bound always wins.
560                       nil)))))
561       (let* ((x-lo (copy-interval-limit (interval-low x)))
562              (x-hi (copy-interval-limit (interval-high x)))
563              (y-lo (copy-interval-limit (interval-low y)))
564              (y-hi (copy-interval-limit (interval-high y))))
565         (make-interval :low (select-bound x-lo y-lo #'< #'>)
566                        :high (select-bound x-hi y-hi #'> #'<))))))
567
568 ;;; basic arithmetic operations on intervals. We probably should do
569 ;;; true interval arithmetic here, but it's complicated because we
570 ;;; have float and integer types and bounds can be open or closed.
571
572 ;;; the negative of an interval
573 (defun interval-neg (x)
574   (declare (type interval x))
575   (make-interval :low (bound-func #'- (interval-high x))
576                  :high (bound-func #'- (interval-low x))))
577
578 ;;; Add two intervals.
579 (defun interval-add (x y)
580   (declare (type interval x y))
581   (make-interval :low (bound-binop + (interval-low x) (interval-low y))
582                  :high (bound-binop + (interval-high x) (interval-high y))))
583
584 ;;; Subtract two intervals.
585 (defun interval-sub (x y)
586   (declare (type interval x y))
587   (make-interval :low (bound-binop - (interval-low x) (interval-high y))
588                  :high (bound-binop - (interval-high x) (interval-low y))))
589
590 ;;; Multiply two intervals.
591 (defun interval-mul (x y)
592   (declare (type interval x y))
593   (flet ((bound-mul (x y)
594            (cond ((or (null x) (null y))
595                   ;; Multiply by infinity is infinity
596                   nil)
597                  ((or (and (numberp x) (zerop x))
598                       (and (numberp y) (zerop y)))
599                   ;; Multiply by closed zero is special. The result
600                   ;; is always a closed bound. But don't replace this
601                   ;; with zero; we want the multiplication to produce
602                   ;; the correct signed zero, if needed.
603                   (* (type-bound-number x) (type-bound-number y)))
604                  ((or (and (floatp x) (float-infinity-p x))
605                       (and (floatp y) (float-infinity-p y)))
606                   ;; Infinity times anything is infinity
607                   nil)
608                  (t
609                   ;; General multiply. The result is open if either is open.
610                   (bound-binop * x y)))))
611     (let ((x-range (interval-range-info x))
612           (y-range (interval-range-info y)))
613       (cond ((null x-range)
614              ;; Split x into two and multiply each separately
615              (destructuring-bind (x- x+) (interval-split 0 x t t)
616                (interval-merge-pair (interval-mul x- y)
617                                     (interval-mul x+ y))))
618             ((null y-range)
619              ;; Split y into two and multiply each separately
620              (destructuring-bind (y- y+) (interval-split 0 y t t)
621                (interval-merge-pair (interval-mul x y-)
622                                     (interval-mul x y+))))
623             ((eq x-range '-)
624              (interval-neg (interval-mul (interval-neg x) y)))
625             ((eq y-range '-)
626              (interval-neg (interval-mul x (interval-neg y))))
627             ((and (eq x-range '+) (eq y-range '+))
628              ;; If we are here, X and Y are both positive.
629              (make-interval
630               :low (bound-mul (interval-low x) (interval-low y))
631               :high (bound-mul (interval-high x) (interval-high y))))
632             (t
633              (bug "excluded case in INTERVAL-MUL"))))))
634
635 ;;; Divide two intervals.
636 (defun interval-div (top bot)
637   (declare (type interval top bot))
638   (flet ((bound-div (x y y-low-p)
639            ;; Compute x/y
640            (cond ((null y)
641                   ;; Divide by infinity means result is 0. However,
642                   ;; we need to watch out for the sign of the result,
643                   ;; to correctly handle signed zeros. We also need
644                   ;; to watch out for positive or negative infinity.
645                   (if (floatp (type-bound-number x))
646                       (if y-low-p
647                           (- (float-sign (type-bound-number x) 0.0))
648                           (float-sign (type-bound-number x) 0.0))
649                       0))
650                  ((zerop (type-bound-number y))
651                   ;; Divide by zero means result is infinity
652                   nil)
653                  ((and (numberp x) (zerop x))
654                   ;; Zero divided by anything is zero.
655                   x)
656                  (t
657                   (bound-binop / x y)))))
658     (let ((top-range (interval-range-info top))
659           (bot-range (interval-range-info bot)))
660       (cond ((null bot-range)
661              ;; The denominator contains zero, so anything goes!
662              (make-interval :low nil :high nil))
663             ((eq bot-range '-)
664              ;; Denominator is negative so flip the sign, compute the
665              ;; result, and flip it back.
666              (interval-neg (interval-div top (interval-neg bot))))
667             ((null top-range)
668              ;; Split top into two positive and negative parts, and
669              ;; divide each separately
670              (destructuring-bind (top- top+) (interval-split 0 top t t)
671                (interval-merge-pair (interval-div top- bot)
672                                     (interval-div top+ bot))))
673             ((eq top-range '-)
674              ;; Top is negative so flip the sign, divide, and flip the
675              ;; sign of the result.
676              (interval-neg (interval-div (interval-neg top) bot)))
677             ((and (eq top-range '+) (eq bot-range '+))
678              ;; the easy case
679              (make-interval
680               :low (bound-div (interval-low top) (interval-high bot) t)
681               :high (bound-div (interval-high top) (interval-low bot) nil)))
682             (t
683              (bug "excluded case in INTERVAL-DIV"))))))
684
685 ;;; Apply the function F to the interval X. If X = [a, b], then the
686 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
687 ;;; result makes sense. It will if F is monotonic increasing (or
688 ;;; non-decreasing).
689 (defun interval-func (f x)
690   (declare (type interval x))
691   (let ((lo (bound-func f (interval-low x)))
692         (hi (bound-func f (interval-high x))))
693     (make-interval :low lo :high hi)))
694
695 ;;; Return T if X < Y. That is every number in the interval X is
696 ;;; always less than any number in the interval Y.
697 (defun interval-< (x y)
698   (declare (type interval x y))
699   ;; X < Y only if X is bounded above, Y is bounded below, and they
700   ;; don't overlap.
701   (when (and (interval-bounded-p x 'above)
702              (interval-bounded-p y 'below))
703     ;; Intervals are bounded in the appropriate way. Make sure they
704     ;; don't overlap.
705     (let ((left (interval-high x))
706           (right (interval-low y)))
707       (cond ((> (type-bound-number left)
708                 (type-bound-number right))
709              ;; The intervals definitely overlap, so result is NIL.
710              nil)
711             ((< (type-bound-number left)
712                 (type-bound-number right))
713              ;; The intervals definitely don't touch, so result is T.
714              t)
715             (t
716              ;; Limits are equal. Check for open or closed bounds.
717              ;; Don't overlap if one or the other are open.
718              (or (consp left) (consp right)))))))
719
720 ;;; Return T if X >= Y. That is, every number in the interval X is
721 ;;; always greater than any number in the interval Y.
722 (defun interval->= (x y)
723   (declare (type interval x y))
724   ;; X >= Y if lower bound of X >= upper bound of Y
725   (when (and (interval-bounded-p x 'below)
726              (interval-bounded-p y 'above))
727     (>= (type-bound-number (interval-low x))
728         (type-bound-number (interval-high y)))))
729
730 ;;; Return an interval that is the absolute value of X. Thus, if
731 ;;; X = [-1 10], the result is [0, 10].
732 (defun interval-abs (x)
733   (declare (type interval x))
734   (case (interval-range-info x)
735     (+
736      (copy-interval x))
737     (-
738      (interval-neg x))
739     (t
740      (destructuring-bind (x- x+) (interval-split 0 x t t)
741        (interval-merge-pair (interval-neg x-) x+)))))
742
743 ;;; Compute the square of an interval.
744 (defun interval-sqr (x)
745   (declare (type interval x))
746   (interval-func (lambda (x) (* x x))
747                  (interval-abs x)))
748 \f
749 ;;;; numeric DERIVE-TYPE methods
750
751 ;;; a utility for defining derive-type methods of integer operations. If
752 ;;; the types of both X and Y are integer types, then we compute a new
753 ;;; integer type with bounds determined Fun when applied to X and Y.
754 ;;; Otherwise, we use Numeric-Contagion.
755 (defun derive-integer-type (x y fun)
756   (declare (type continuation x y) (type function fun))
757   (let ((x (continuation-type x))
758         (y (continuation-type y)))
759     (if (and (numeric-type-p x) (numeric-type-p y)
760              (eq (numeric-type-class x) 'integer)
761              (eq (numeric-type-class y) 'integer)
762              (eq (numeric-type-complexp x) :real)
763              (eq (numeric-type-complexp y) :real))
764         (multiple-value-bind (low high) (funcall fun x y)
765           (make-numeric-type :class 'integer
766                              :complexp :real
767                              :low low
768                              :high high))
769         (numeric-contagion x y))))
770
771 ;;; simple utility to flatten a list
772 (defun flatten-list (x)
773   (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
774              (cond ((null x) r)
775                    ((atom x)
776                     (cons x r))
777                    (t (flatten-helper (car x)
778                                       (flatten-helper (cdr x) r))))))
779     (flatten-helper x nil)))
780
781 ;;; Take some type of continuation and massage it so that we get a
782 ;;; list of the constituent types. If ARG is *EMPTY-TYPE*, return NIL
783 ;;; to indicate failure.
784 (defun prepare-arg-for-derive-type (arg)
785   (flet ((listify (arg)
786            (typecase arg
787              (numeric-type
788               (list arg))
789              (union-type
790               (union-type-types arg))
791              (t
792               (list arg)))))
793     (unless (eq arg *empty-type*)
794       ;; Make sure all args are some type of numeric-type. For member
795       ;; types, convert the list of members into a union of equivalent
796       ;; single-element member-type's.
797       (let ((new-args nil))
798         (dolist (arg (listify arg))
799           (if (member-type-p arg)
800               ;; Run down the list of members and convert to a list of
801               ;; member types.
802               (dolist (member (member-type-members arg))
803                 (push (if (numberp member)
804                           (make-member-type :members (list member))
805                           *empty-type*)
806                       new-args))
807               (push arg new-args)))
808         (unless (member *empty-type* new-args)
809           new-args)))))
810
811 ;;; Convert from the standard type convention for which -0.0 and 0.0
812 ;;; are equal to an intermediate convention for which they are
813 ;;; considered different which is more natural for some of the
814 ;;; optimisers.
815 #!-negative-zero-is-not-zero
816 (defun convert-numeric-type (type)
817   (declare (type numeric-type type))
818   ;;; Only convert real float interval delimiters types.
819   (if (eq (numeric-type-complexp type) :real)
820       (let* ((lo (numeric-type-low type))
821              (lo-val (type-bound-number lo))
822              (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0)))
823              (hi (numeric-type-high type))
824              (hi-val (type-bound-number hi))
825              (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0))))
826         (if (or lo-float-zero-p hi-float-zero-p)
827             (make-numeric-type
828              :class (numeric-type-class type)
829              :format (numeric-type-format type)
830              :complexp :real
831              :low (if lo-float-zero-p
832                       (if (consp lo)
833                           (list (float 0.0 lo-val))
834                           (float -0.0 lo-val))
835                       lo)
836              :high (if hi-float-zero-p
837                        (if (consp hi)
838                            (list (float -0.0 hi-val))
839                            (float 0.0 hi-val))
840                        hi))
841             type))
842       ;; Not real float.
843       type))
844
845 ;;; Convert back from the intermediate convention for which -0.0 and
846 ;;; 0.0 are considered different to the standard type convention for
847 ;;; which and equal.
848 #!-negative-zero-is-not-zero
849 (defun convert-back-numeric-type (type)
850   (declare (type numeric-type type))
851   ;;; Only convert real float interval delimiters types.
852   (if (eq (numeric-type-complexp type) :real)
853       (let* ((lo (numeric-type-low type))
854              (lo-val (type-bound-number lo))
855              (lo-float-zero-p
856               (and lo (floatp lo-val) (= lo-val 0.0)
857                    (float-sign lo-val)))
858              (hi (numeric-type-high type))
859              (hi-val (type-bound-number hi))
860              (hi-float-zero-p
861               (and hi (floatp hi-val) (= hi-val 0.0)
862                    (float-sign hi-val))))
863         (cond
864           ;; (float +0.0 +0.0) => (member 0.0)
865           ;; (float -0.0 -0.0) => (member -0.0)
866           ((and lo-float-zero-p hi-float-zero-p)
867            ;; shouldn't have exclusive bounds here..
868            (aver (and (not (consp lo)) (not (consp hi))))
869            (if (= lo-float-zero-p hi-float-zero-p)
870                ;; (float +0.0 +0.0) => (member 0.0)
871                ;; (float -0.0 -0.0) => (member -0.0)
872                (specifier-type `(member ,lo-val))
873                ;; (float -0.0 +0.0) => (float 0.0 0.0)
874                ;; (float +0.0 -0.0) => (float 0.0 0.0)
875                (make-numeric-type :class (numeric-type-class type)
876                                   :format (numeric-type-format type)
877                                   :complexp :real
878                                   :low hi-val
879                                   :high hi-val)))
880           (lo-float-zero-p
881            (cond
882              ;; (float -0.0 x) => (float 0.0 x)
883              ((and (not (consp lo)) (minusp lo-float-zero-p))
884               (make-numeric-type :class (numeric-type-class type)
885                                  :format (numeric-type-format type)
886                                  :complexp :real
887                                  :low (float 0.0 lo-val)
888                                  :high hi))
889              ;; (float (+0.0) x) => (float (0.0) x)
890              ((and (consp lo) (plusp lo-float-zero-p))
891               (make-numeric-type :class (numeric-type-class type)
892                                  :format (numeric-type-format type)
893                                  :complexp :real
894                                  :low (list (float 0.0 lo-val))
895                                  :high hi))
896              (t
897               ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
898               ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
899               (list (make-member-type :members (list (float 0.0 lo-val)))
900                     (make-numeric-type :class (numeric-type-class type)
901                                        :format (numeric-type-format type)
902                                        :complexp :real
903                                        :low (list (float 0.0 lo-val))
904                                        :high hi)))))
905           (hi-float-zero-p
906            (cond
907              ;; (float x +0.0) => (float x 0.0)
908              ((and (not (consp hi)) (plusp hi-float-zero-p))
909               (make-numeric-type :class (numeric-type-class type)
910                                  :format (numeric-type-format type)
911                                  :complexp :real
912                                  :low lo
913                                  :high (float 0.0 hi-val)))
914              ;; (float x (-0.0)) => (float x (0.0))
915              ((and (consp hi) (minusp hi-float-zero-p))
916               (make-numeric-type :class (numeric-type-class type)
917                                  :format (numeric-type-format type)
918                                  :complexp :real
919                                  :low lo
920                                  :high (list (float 0.0 hi-val))))
921              (t
922               ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
923               ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
924               (list (make-member-type :members (list (float -0.0 hi-val)))
925                     (make-numeric-type :class (numeric-type-class type)
926                                        :format (numeric-type-format type)
927                                        :complexp :real
928                                        :low lo
929                                        :high (list (float 0.0 hi-val)))))))
930           (t
931            type)))
932       ;; not real float
933       type))
934
935 ;;; Convert back a possible list of numeric types.
936 #!-negative-zero-is-not-zero
937 (defun convert-back-numeric-type-list (type-list)
938   (typecase type-list
939     (list
940      (let ((results '()))
941        (dolist (type type-list)
942          (if (numeric-type-p type)
943              (let ((result (convert-back-numeric-type type)))
944                (if (listp result)
945                    (setf results (append results result))
946                    (push result results)))
947              (push type results)))
948        results))
949     (numeric-type
950      (convert-back-numeric-type type-list))
951     (union-type
952      (convert-back-numeric-type-list (union-type-types type-list)))
953     (t
954      type-list)))
955
956 ;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
957 ;;; belong in the kernel's type logic, invoked always, instead of in
958 ;;; the compiler, invoked only during some type optimizations.
959
960 ;;; Take a list of types and return a canonical type specifier,
961 ;;; combining any MEMBER types together. If both positive and negative
962 ;;; MEMBER types are present they are converted to a float type.
963 ;;; XXX This would be far simpler if the type-union methods could handle
964 ;;; member/number unions.
965 (defun make-canonical-union-type (type-list)
966   (let ((members '())
967         (misc-types '()))
968     (dolist (type type-list)
969       (if (member-type-p type)
970           (setf members (union members (member-type-members type)))
971           (push type misc-types)))
972     #!+long-float
973     (when (null (set-difference '(-0l0 0l0) members))
974       #!-negative-zero-is-not-zero
975       (push (specifier-type '(long-float 0l0 0l0)) misc-types)
976       #!+negative-zero-is-not-zero
977       (push (specifier-type '(long-float -0l0 0l0)) misc-types)
978       (setf members (set-difference members '(-0l0 0l0))))
979     (when (null (set-difference '(-0d0 0d0) members))
980       #!-negative-zero-is-not-zero
981       (push (specifier-type '(double-float 0d0 0d0)) misc-types)
982       #!+negative-zero-is-not-zero
983       (push (specifier-type '(double-float -0d0 0d0)) misc-types)
984       (setf members (set-difference members '(-0d0 0d0))))
985     (when (null (set-difference '(-0f0 0f0) members))
986       #!-negative-zero-is-not-zero
987       (push (specifier-type '(single-float 0f0 0f0)) misc-types)
988       #!+negative-zero-is-not-zero
989       (push (specifier-type '(single-float -0f0 0f0)) misc-types)
990       (setf members (set-difference members '(-0f0 0f0))))
991     (if members
992         (apply #'type-union (make-member-type :members members) misc-types)
993         (apply #'type-union misc-types))))
994
995 ;;; Convert a member type with a single member to a numeric type.
996 (defun convert-member-type (arg)
997   (let* ((members (member-type-members arg))
998          (member (first members))
999          (member-type (type-of member)))
1000     (aver (not (rest members)))
1001     (specifier-type `(,(if (subtypep member-type 'integer)
1002                            'integer
1003                            member-type)
1004                       ,member ,member))))
1005
1006 ;;; This is used in defoptimizers for computing the resulting type of
1007 ;;; a function.
1008 ;;;
1009 ;;; Given the continuation ARG, derive the resulting type using the
1010 ;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some
1011 ;;; "atomic" continuation type like numeric-type or member-type
1012 ;;; (containing just one element). It should return the resulting
1013 ;;; type, which can be a list of types.
1014 ;;;
1015 ;;; For the case of member types, if a member-fcn is given it is
1016 ;;; called to compute the result otherwise the member type is first
1017 ;;; converted to a numeric type and the derive-fcn is call.
1018 (defun one-arg-derive-type (arg derive-fcn member-fcn
1019                                 &optional (convert-type t))
1020   (declare (type function derive-fcn)
1021            (type (or null function) member-fcn)
1022            #!+negative-zero-is-not-zero (ignore convert-type))
1023   (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
1024     (when arg-list
1025       (flet ((deriver (x)
1026                (typecase x
1027                  (member-type
1028                   (if member-fcn
1029                       (with-float-traps-masked
1030                           (:underflow :overflow :divide-by-zero)
1031                         (make-member-type
1032                          :members (list
1033                                    (funcall member-fcn
1034                                             (first (member-type-members x))))))
1035                       ;; Otherwise convert to a numeric type.
1036                       (let ((result-type-list
1037                              (funcall derive-fcn (convert-member-type x))))
1038                         #!-negative-zero-is-not-zero
1039                         (if convert-type
1040                             (convert-back-numeric-type-list result-type-list)
1041                             result-type-list)
1042                         #!+negative-zero-is-not-zero
1043                         result-type-list)))
1044                  (numeric-type
1045                   #!-negative-zero-is-not-zero
1046                   (if convert-type
1047                       (convert-back-numeric-type-list
1048                        (funcall derive-fcn (convert-numeric-type x)))
1049                       (funcall derive-fcn x))
1050                   #!+negative-zero-is-not-zero
1051                   (funcall derive-fcn x))
1052                  (t
1053                   *universal-type*))))
1054         ;; Run down the list of args and derive the type of each one,
1055         ;; saving all of the results in a list.
1056         (let ((results nil))
1057           (dolist (arg arg-list)
1058             (let ((result (deriver arg)))
1059               (if (listp result)
1060                   (setf results (append results result))
1061                   (push result results))))
1062           (if (rest results)
1063               (make-canonical-union-type results)
1064               (first results)))))))
1065
1066 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1067 ;;; two arguments. DERIVE-FCN takes 3 args in this case: the two
1068 ;;; original args and a third which is T to indicate if the two args
1069 ;;; really represent the same continuation. This is useful for
1070 ;;; deriving the type of things like (* x x), which should always be
1071 ;;; positive. If we didn't do this, we wouldn't be able to tell.
1072 (defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
1073                                  &optional (convert-type t))
1074   #!+negative-zero-is-not-zero
1075   (declare (ignore convert-type))
1076   (flet (#!-negative-zero-is-not-zero
1077          (deriver (x y same-arg)
1078            (cond ((and (member-type-p x) (member-type-p y))
1079                   (let* ((x (first (member-type-members x)))
1080                          (y (first (member-type-members y)))
1081                          (result (with-float-traps-masked
1082                                      (:underflow :overflow :divide-by-zero
1083                                       :invalid)
1084                                    (funcall fcn x y))))
1085                     (cond ((null result))
1086                           ((and (floatp result) (float-nan-p result))
1087                            (make-numeric-type :class 'float
1088                                               :format (type-of result)
1089                                               :complexp :real))
1090                           (t
1091                            (make-member-type :members (list result))))))
1092                  ((and (member-type-p x) (numeric-type-p y))
1093                   (let* ((x (convert-member-type x))
1094                          (y (if convert-type (convert-numeric-type y) y))
1095                          (result (funcall derive-fcn x y same-arg)))
1096                     (if convert-type
1097                         (convert-back-numeric-type-list result)
1098                         result)))
1099                  ((and (numeric-type-p x) (member-type-p y))
1100                   (let* ((x (if convert-type (convert-numeric-type x) x))
1101                          (y (convert-member-type y))
1102                          (result (funcall derive-fcn x y same-arg)))
1103                     (if convert-type
1104                         (convert-back-numeric-type-list result)
1105                         result)))
1106                  ((and (numeric-type-p x) (numeric-type-p y))
1107                   (let* ((x (if convert-type (convert-numeric-type x) x))
1108                          (y (if convert-type (convert-numeric-type y) y))
1109                          (result (funcall derive-fcn x y same-arg)))
1110                     (if convert-type
1111                         (convert-back-numeric-type-list result)
1112                         result)))
1113                  (t
1114                   *universal-type*)))
1115          #!+negative-zero-is-not-zero
1116          (deriver (x y same-arg)
1117            (cond ((and (member-type-p x) (member-type-p y))
1118                   (let* ((x (first (member-type-members x)))
1119                          (y (first (member-type-members y)))
1120                          (result (with-float-traps-masked
1121                                      (:underflow :overflow :divide-by-zero)
1122                                    (funcall fcn x y))))
1123                     (if result
1124                         (make-member-type :members (list result)))))
1125                  ((and (member-type-p x) (numeric-type-p y))
1126                   (let ((x (convert-member-type x)))
1127                     (funcall derive-fcn x y same-arg)))
1128                  ((and (numeric-type-p x) (member-type-p y))
1129                   (let ((y (convert-member-type y)))
1130                     (funcall derive-fcn x y same-arg)))
1131                  ((and (numeric-type-p x) (numeric-type-p y))
1132                   (funcall derive-fcn x y same-arg))
1133                  (t
1134                   *universal-type*))))
1135     (let ((same-arg (same-leaf-ref-p arg1 arg2))
1136           (a1 (prepare-arg-for-derive-type (continuation-type arg1)))
1137           (a2 (prepare-arg-for-derive-type (continuation-type arg2))))
1138       (when (and a1 a2)
1139         (let ((results nil))
1140           (if same-arg
1141               ;; Since the args are the same continuation, just run
1142               ;; down the lists.
1143               (dolist (x a1)
1144                 (let ((result (deriver x x same-arg)))
1145                   (if (listp result)
1146                       (setf results (append results result))
1147                       (push result results))))
1148               ;; Try all pairwise combinations.
1149               (dolist (x a1)
1150                 (dolist (y a2)
1151                   (let ((result (or (deriver x y same-arg)
1152                                     (numeric-contagion x y))))
1153                     (if (listp result)
1154                         (setf results (append results result))
1155                         (push result results))))))
1156           (if (rest results)
1157               (make-canonical-union-type results)
1158               (first results)))))))
1159 \f
1160 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1161 (progn
1162 (defoptimizer (+ derive-type) ((x y))
1163   (derive-integer-type
1164    x y
1165    #'(lambda (x y)
1166        (flet ((frob (x y)
1167                 (if (and x y)
1168                     (+ x y)
1169                     nil)))
1170          (values (frob (numeric-type-low x) (numeric-type-low y))
1171                  (frob (numeric-type-high x) (numeric-type-high y)))))))
1172
1173 (defoptimizer (- derive-type) ((x y))
1174   (derive-integer-type
1175    x y
1176    #'(lambda (x y)
1177        (flet ((frob (x y)
1178                 (if (and x y)
1179                     (- x y)
1180                     nil)))
1181          (values (frob (numeric-type-low x) (numeric-type-high y))
1182                  (frob (numeric-type-high x) (numeric-type-low y)))))))
1183
1184 (defoptimizer (* derive-type) ((x y))
1185   (derive-integer-type
1186    x y
1187    #'(lambda (x y)
1188        (let ((x-low (numeric-type-low x))
1189              (x-high (numeric-type-high x))
1190              (y-low (numeric-type-low y))
1191              (y-high (numeric-type-high y)))
1192          (cond ((not (and x-low y-low))
1193                 (values nil nil))
1194                ((or (minusp x-low) (minusp y-low))
1195                 (if (and x-high y-high)
1196                     (let ((max (* (max (abs x-low) (abs x-high))
1197                                   (max (abs y-low) (abs y-high)))))
1198                       (values (- max) max))
1199                     (values nil nil)))
1200                (t
1201                 (values (* x-low y-low)
1202                         (if (and x-high y-high)
1203                             (* x-high y-high)
1204                             nil))))))))
1205
1206 (defoptimizer (/ derive-type) ((x y))
1207   (numeric-contagion (continuation-type x) (continuation-type y)))
1208
1209 ) ; PROGN
1210
1211 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1212 (progn
1213 (defun +-derive-type-aux (x y same-arg)
1214   (if (and (numeric-type-real-p x)
1215            (numeric-type-real-p y))
1216       (let ((result
1217              (if same-arg
1218                  (let ((x-int (numeric-type->interval x)))
1219                    (interval-add x-int x-int))
1220                  (interval-add (numeric-type->interval x)
1221                                (numeric-type->interval y))))
1222             (result-type (numeric-contagion x y)))
1223         ;; If the result type is a float, we need to be sure to coerce
1224         ;; the bounds into the correct type.
1225         (when (eq (numeric-type-class result-type) 'float)
1226           (setf result (interval-func
1227                         #'(lambda (x)
1228                             (coerce x (or (numeric-type-format result-type)
1229                                           'float)))
1230                         result)))
1231         (make-numeric-type
1232          :class (if (and (eq (numeric-type-class x) 'integer)
1233                          (eq (numeric-type-class y) 'integer))
1234                     ;; The sum of integers is always an integer.
1235                     'integer
1236                     (numeric-type-class result-type))
1237          :format (numeric-type-format result-type)
1238          :low (interval-low result)
1239          :high (interval-high result)))
1240       ;; general contagion
1241       (numeric-contagion x y)))
1242
1243 (defoptimizer (+ derive-type) ((x y))
1244   (two-arg-derive-type x y #'+-derive-type-aux #'+))
1245
1246 (defun --derive-type-aux (x y same-arg)
1247   (if (and (numeric-type-real-p x)
1248            (numeric-type-real-p y))
1249       (let ((result
1250              ;; (- X X) is always 0.
1251              (if same-arg
1252                  (make-interval :low 0 :high 0)
1253                  (interval-sub (numeric-type->interval x)
1254                                (numeric-type->interval y))))
1255             (result-type (numeric-contagion x y)))
1256         ;; If the result type is a float, we need to be sure to coerce
1257         ;; the bounds into the correct type.
1258         (when (eq (numeric-type-class result-type) 'float)
1259           (setf result (interval-func
1260                         #'(lambda (x)
1261                             (coerce x (or (numeric-type-format result-type)
1262                                           'float)))
1263                         result)))
1264         (make-numeric-type
1265          :class (if (and (eq (numeric-type-class x) 'integer)
1266                          (eq (numeric-type-class y) 'integer))
1267                     ;; The difference of integers is always an integer.
1268                     'integer
1269                     (numeric-type-class result-type))
1270          :format (numeric-type-format result-type)
1271          :low (interval-low result)
1272          :high (interval-high result)))
1273       ;; general contagion
1274       (numeric-contagion x y)))
1275
1276 (defoptimizer (- derive-type) ((x y))
1277   (two-arg-derive-type x y #'--derive-type-aux #'-))
1278
1279 (defun *-derive-type-aux (x y same-arg)
1280   (if (and (numeric-type-real-p x)
1281            (numeric-type-real-p y))
1282       (let ((result
1283              ;; (* X X) is always positive, so take care to do it right.
1284              (if same-arg
1285                  (interval-sqr (numeric-type->interval x))
1286                  (interval-mul (numeric-type->interval x)
1287                                (numeric-type->interval y))))
1288             (result-type (numeric-contagion x y)))
1289         ;; If the result type is a float, we need to be sure to coerce
1290         ;; the bounds into the correct type.
1291         (when (eq (numeric-type-class result-type) 'float)
1292           (setf result (interval-func
1293                         #'(lambda (x)
1294                             (coerce x (or (numeric-type-format result-type)
1295                                           'float)))
1296                         result)))
1297         (make-numeric-type
1298          :class (if (and (eq (numeric-type-class x) 'integer)
1299                          (eq (numeric-type-class y) 'integer))
1300                     ;; The product of integers is always an integer.
1301                     'integer
1302                     (numeric-type-class result-type))
1303          :format (numeric-type-format result-type)
1304          :low (interval-low result)
1305          :high (interval-high result)))
1306       (numeric-contagion x y)))
1307
1308 (defoptimizer (* derive-type) ((x y))
1309   (two-arg-derive-type x y #'*-derive-type-aux #'*))
1310
1311 (defun /-derive-type-aux (x y same-arg)
1312   (if (and (numeric-type-real-p x)
1313            (numeric-type-real-p y))
1314       (let ((result
1315              ;; (/ X X) is always 1, except if X can contain 0. In
1316              ;; that case, we shouldn't optimize the division away
1317              ;; because we want 0/0 to signal an error.
1318              (if (and same-arg
1319                       (not (interval-contains-p
1320                             0 (interval-closure (numeric-type->interval y)))))
1321                  (make-interval :low 1 :high 1)
1322                  (interval-div (numeric-type->interval x)
1323                                (numeric-type->interval y))))
1324             (result-type (numeric-contagion x y)))
1325         ;; If the result type is a float, we need to be sure to coerce
1326         ;; the bounds into the correct type.
1327         (when (eq (numeric-type-class result-type) 'float)
1328           (setf result (interval-func
1329                         #'(lambda (x)
1330                             (coerce x (or (numeric-type-format result-type)
1331                                           'float)))
1332                         result)))
1333         (make-numeric-type :class (numeric-type-class result-type)
1334                            :format (numeric-type-format result-type)
1335                            :low (interval-low result)
1336                            :high (interval-high result)))
1337       (numeric-contagion x y)))
1338
1339 (defoptimizer (/ derive-type) ((x y))
1340   (two-arg-derive-type x y #'/-derive-type-aux #'/))
1341
1342 ) ; PROGN
1343
1344
1345 ;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
1346 ;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
1347 ;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
1348 ;;; and it's hard to avoid that calculation in here.
1349 #-(and cmu sb-xc-host)
1350 (progn
1351
1352 (defun ash-derive-type-aux (n-type shift same-arg)
1353   (declare (ignore same-arg))
1354   (flet ((ash-outer (n s)
1355            (when (and (fixnump s)
1356                       (<= s 64)
1357                       (> s sb!xc:most-negative-fixnum))
1358              (ash n s)))
1359          ;; KLUDGE: The bare 64's here should be related to
1360          ;; symbolic machine word size values somehow.
1361
1362          (ash-inner (n s)
1363            (if (and (fixnump s)
1364                     (> s sb!xc:most-negative-fixnum))
1365              (ash n (min s 64))
1366              (if (minusp n) -1 0))))
1367     (or (and (csubtypep n-type (specifier-type 'integer))
1368              (csubtypep shift (specifier-type 'integer))
1369              (let ((n-low (numeric-type-low n-type))
1370                    (n-high (numeric-type-high n-type))
1371                    (s-low (numeric-type-low shift))
1372                    (s-high (numeric-type-high shift)))
1373                (make-numeric-type :class 'integer  :complexp :real
1374                                   :low (when n-low
1375                                          (if (minusp n-low)
1376                                            (ash-outer n-low s-high)
1377                                            (ash-inner n-low s-low)))
1378                                   :high (when n-high
1379                                           (if (minusp n-high)
1380                                             (ash-inner n-high s-low)
1381                                             (ash-outer n-high s-high))))))
1382         *universal-type*)))
1383
1384 (defoptimizer (ash derive-type) ((n shift))
1385   (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
1386 ) ; PROGN
1387
1388 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1389 (macrolet ((frob (fun)
1390              `#'(lambda (type type2)
1391                   (declare (ignore type2))
1392                   (let ((lo (numeric-type-low type))
1393                         (hi (numeric-type-high type)))
1394                     (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
1395
1396   (defoptimizer (%negate derive-type) ((num))
1397     (derive-integer-type num num (frob -))))
1398
1399 (defoptimizer (lognot derive-type) ((int))
1400   (derive-integer-type int int
1401                        (lambda (type type2)
1402                          (declare (ignore type2))
1403                          (let ((lo (numeric-type-low type))
1404                                (hi (numeric-type-high type)))
1405                            (values (if hi (lognot hi) nil)
1406                                    (if lo (lognot lo) nil)
1407                                    (numeric-type-class type)
1408                                    (numeric-type-format type))))))
1409
1410 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1411 (defoptimizer (%negate derive-type) ((num))
1412   (flet ((negate-bound (b)
1413            (and b
1414                 (set-bound (- (type-bound-number b))
1415                            (consp b)))))
1416     (one-arg-derive-type num
1417                          (lambda (type)
1418                            (modified-numeric-type
1419                             type
1420                             :low (negate-bound (numeric-type-high type))
1421                             :high (negate-bound (numeric-type-low type))))
1422                          #'-)))
1423
1424 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1425 (defoptimizer (abs derive-type) ((num))
1426   (let ((type (continuation-type num)))
1427     (if (and (numeric-type-p type)
1428              (eq (numeric-type-class type) 'integer)
1429              (eq (numeric-type-complexp type) :real))
1430         (let ((lo (numeric-type-low type))
1431               (hi (numeric-type-high type)))
1432           (make-numeric-type :class 'integer :complexp :real
1433                              :low (cond ((and hi (minusp hi))
1434                                          (abs hi))
1435                                         (lo
1436                                          (max 0 lo))
1437                                         (t
1438                                          0))
1439                              :high (if (and hi lo)
1440                                        (max (abs hi) (abs lo))
1441                                        nil)))
1442         (numeric-contagion type type))))
1443
1444 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1445 (defun abs-derive-type-aux (type)
1446   (cond ((eq (numeric-type-complexp type) :complex)
1447          ;; The absolute value of a complex number is always a
1448          ;; non-negative float.
1449          (let* ((format (case (numeric-type-class type)
1450                           ((integer rational) 'single-float)
1451                           (t (numeric-type-format type))))
1452                 (bound-format (or format 'float)))
1453            (make-numeric-type :class 'float
1454                               :format format
1455                               :complexp :real
1456                               :low (coerce 0 bound-format)
1457                               :high nil)))
1458         (t
1459          ;; The absolute value of a real number is a non-negative real
1460          ;; of the same type.
1461          (let* ((abs-bnd (interval-abs (numeric-type->interval type)))
1462                 (class (numeric-type-class type))
1463                 (format (numeric-type-format type))
1464                 (bound-type (or format class 'real)))
1465            (make-numeric-type
1466             :class class
1467             :format format
1468             :complexp :real
1469             :low (coerce-numeric-bound (interval-low abs-bnd) bound-type)
1470             :high (coerce-numeric-bound
1471                    (interval-high abs-bnd) bound-type))))))
1472
1473 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1474 (defoptimizer (abs derive-type) ((num))
1475   (one-arg-derive-type num #'abs-derive-type-aux #'abs))
1476
1477 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1478 (defoptimizer (truncate derive-type) ((number divisor))
1479   (let ((number-type (continuation-type number))
1480         (divisor-type (continuation-type divisor))
1481         (integer-type (specifier-type 'integer)))
1482     (if (and (numeric-type-p number-type)
1483              (csubtypep number-type integer-type)
1484              (numeric-type-p divisor-type)
1485              (csubtypep divisor-type integer-type))
1486         (let ((number-low (numeric-type-low number-type))
1487               (number-high (numeric-type-high number-type))
1488               (divisor-low (numeric-type-low divisor-type))
1489               (divisor-high (numeric-type-high divisor-type)))
1490           (values-specifier-type
1491            `(values ,(integer-truncate-derive-type number-low number-high
1492                                                    divisor-low divisor-high)
1493                     ,(integer-rem-derive-type number-low number-high
1494                                               divisor-low divisor-high))))
1495         *universal-type*)))
1496
1497 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1498 (progn
1499
1500 (defun rem-result-type (number-type divisor-type)
1501   ;; Figure out what the remainder type is. The remainder is an
1502   ;; integer if both args are integers; a rational if both args are
1503   ;; rational; and a float otherwise.
1504   (cond ((and (csubtypep number-type (specifier-type 'integer))
1505               (csubtypep divisor-type (specifier-type 'integer)))
1506          'integer)
1507         ((and (csubtypep number-type (specifier-type 'rational))
1508               (csubtypep divisor-type (specifier-type 'rational)))
1509          'rational)
1510         ((and (csubtypep number-type (specifier-type 'float))
1511               (csubtypep divisor-type (specifier-type 'float)))
1512          ;; Both are floats so the result is also a float, of
1513          ;; the largest type.
1514          (or (float-format-max (numeric-type-format number-type)
1515                                (numeric-type-format divisor-type))
1516              'float))
1517         ((and (csubtypep number-type (specifier-type 'float))
1518               (csubtypep divisor-type (specifier-type 'rational)))
1519          ;; One of the arguments is a float and the other is a
1520          ;; rational. The remainder is a float of the same
1521          ;; type.
1522          (or (numeric-type-format number-type) 'float))
1523         ((and (csubtypep divisor-type (specifier-type 'float))
1524               (csubtypep number-type (specifier-type 'rational)))
1525          ;; One of the arguments is a float and the other is a
1526          ;; rational. The remainder is a float of the same
1527          ;; type.
1528          (or (numeric-type-format divisor-type) 'float))
1529         (t
1530          ;; Some unhandled combination. This usually means both args
1531          ;; are REAL so the result is a REAL.
1532          'real)))
1533
1534 (defun truncate-derive-type-quot (number-type divisor-type)
1535   (let* ((rem-type (rem-result-type number-type divisor-type))
1536          (number-interval (numeric-type->interval number-type))
1537          (divisor-interval (numeric-type->interval divisor-type)))
1538     ;;(declare (type (member '(integer rational float)) rem-type))
1539     ;; We have real numbers now.
1540     (cond ((eq rem-type 'integer)
1541            ;; Since the remainder type is INTEGER, both args are
1542            ;; INTEGERs.
1543            (let* ((res (integer-truncate-derive-type
1544                         (interval-low number-interval)
1545                         (interval-high number-interval)
1546                         (interval-low divisor-interval)
1547                         (interval-high divisor-interval))))
1548              (specifier-type (if (listp res) res 'integer))))
1549           (t
1550            (let ((quot (truncate-quotient-bound
1551                         (interval-div number-interval
1552                                       divisor-interval))))
1553              (specifier-type `(integer ,(or (interval-low quot) '*)
1554                                        ,(or (interval-high quot) '*))))))))
1555
1556 (defun truncate-derive-type-rem (number-type divisor-type)
1557   (let* ((rem-type (rem-result-type number-type divisor-type))
1558          (number-interval (numeric-type->interval number-type))
1559          (divisor-interval (numeric-type->interval divisor-type))
1560          (rem (truncate-rem-bound number-interval divisor-interval)))
1561     ;;(declare (type (member '(integer rational float)) rem-type))
1562     ;; We have real numbers now.
1563     (cond ((eq rem-type 'integer)
1564            ;; Since the remainder type is INTEGER, both args are
1565            ;; INTEGERs.
1566            (specifier-type `(,rem-type ,(or (interval-low rem) '*)
1567                                        ,(or (interval-high rem) '*))))
1568           (t
1569            (multiple-value-bind (class format)
1570                (ecase rem-type
1571                  (integer
1572                   (values 'integer nil))
1573                  (rational
1574                   (values 'rational nil))
1575                  ((or single-float double-float #!+long-float long-float)
1576                   (values 'float rem-type))
1577                  (float
1578                   (values 'float nil))
1579                  (real
1580                   (values nil nil)))
1581              (when (member rem-type '(float single-float double-float
1582                                             #!+long-float long-float))
1583                (setf rem (interval-func #'(lambda (x)
1584                                             (coerce x rem-type))
1585                                         rem)))
1586              (make-numeric-type :class class
1587                                 :format format
1588                                 :low (interval-low rem)
1589                                 :high (interval-high rem)))))))
1590
1591 (defun truncate-derive-type-quot-aux (num div same-arg)
1592   (declare (ignore same-arg))
1593   (if (and (numeric-type-real-p num)
1594            (numeric-type-real-p div))
1595       (truncate-derive-type-quot num div)
1596       *empty-type*))
1597
1598 (defun truncate-derive-type-rem-aux (num div same-arg)
1599   (declare (ignore same-arg))
1600   (if (and (numeric-type-real-p num)
1601            (numeric-type-real-p div))
1602       (truncate-derive-type-rem num div)
1603       *empty-type*))
1604
1605 (defoptimizer (truncate derive-type) ((number divisor))
1606   (let ((quot (two-arg-derive-type number divisor
1607                                    #'truncate-derive-type-quot-aux #'truncate))
1608         (rem (two-arg-derive-type number divisor
1609                                   #'truncate-derive-type-rem-aux #'rem)))
1610     (when (and quot rem)
1611       (make-values-type :required (list quot rem)))))
1612
1613 (defun ftruncate-derive-type-quot (number-type divisor-type)
1614   ;; The bounds are the same as for truncate. However, the first
1615   ;; result is a float of some type. We need to determine what that
1616   ;; type is. Basically it's the more contagious of the two types.
1617   (let ((q-type (truncate-derive-type-quot number-type divisor-type))
1618         (res-type (numeric-contagion number-type divisor-type)))
1619     (make-numeric-type :class 'float
1620                        :format (numeric-type-format res-type)
1621                        :low (numeric-type-low q-type)
1622                        :high (numeric-type-high q-type))))
1623
1624 (defun ftruncate-derive-type-quot-aux (n d same-arg)
1625   (declare (ignore same-arg))
1626   (if (and (numeric-type-real-p n)
1627            (numeric-type-real-p d))
1628       (ftruncate-derive-type-quot n d)
1629       *empty-type*))
1630
1631 (defoptimizer (ftruncate derive-type) ((number divisor))
1632   (let ((quot
1633          (two-arg-derive-type number divisor
1634                               #'ftruncate-derive-type-quot-aux #'ftruncate))
1635         (rem (two-arg-derive-type number divisor
1636                                   #'truncate-derive-type-rem-aux #'rem)))
1637     (when (and quot rem)
1638       (make-values-type :required (list quot rem)))))
1639
1640 (defun %unary-truncate-derive-type-aux (number)
1641   (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
1642
1643 (defoptimizer (%unary-truncate derive-type) ((number))
1644   (one-arg-derive-type number
1645                        #'%unary-truncate-derive-type-aux
1646                        #'%unary-truncate))
1647
1648 ;;; Define optimizers for FLOOR and CEILING.
1649 (macrolet
1650     ((def (name q-name r-name)
1651        (let ((q-aux (symbolicate q-name "-AUX"))
1652              (r-aux (symbolicate r-name "-AUX")))
1653          `(progn
1654            ;; Compute type of quotient (first) result.
1655            (defun ,q-aux (number-type divisor-type)
1656              (let* ((number-interval
1657                      (numeric-type->interval number-type))
1658                     (divisor-interval
1659                      (numeric-type->interval divisor-type))
1660                     (quot (,q-name (interval-div number-interval
1661                                                  divisor-interval))))
1662                (specifier-type `(integer ,(or (interval-low quot) '*)
1663                                          ,(or (interval-high quot) '*)))))
1664            ;; Compute type of remainder.
1665            (defun ,r-aux (number-type divisor-type)
1666              (let* ((divisor-interval
1667                      (numeric-type->interval divisor-type))
1668                     (rem (,r-name divisor-interval))
1669                     (result-type (rem-result-type number-type divisor-type)))
1670                (multiple-value-bind (class format)
1671                    (ecase result-type
1672                      (integer
1673                       (values 'integer nil))
1674                      (rational
1675                       (values 'rational nil))
1676                      ((or single-float double-float #!+long-float long-float)
1677                       (values 'float result-type))
1678                      (float
1679                       (values 'float nil))
1680                      (real
1681                       (values nil nil)))
1682                  (when (member result-type '(float single-float double-float
1683                                              #!+long-float long-float))
1684                    ;; Make sure that the limits on the interval have
1685                    ;; the right type.
1686                    (setf rem (interval-func (lambda (x)
1687                                               (coerce x result-type))
1688                                             rem)))
1689                  (make-numeric-type :class class
1690                                     :format format
1691                                     :low (interval-low rem)
1692                                     :high (interval-high rem)))))
1693            ;; the optimizer itself
1694            (defoptimizer (,name derive-type) ((number divisor))
1695              (flet ((derive-q (n d same-arg)
1696                       (declare (ignore same-arg))
1697                       (if (and (numeric-type-real-p n)
1698                                (numeric-type-real-p d))
1699                           (,q-aux n d)
1700                           *empty-type*))
1701                     (derive-r (n d same-arg)
1702                       (declare (ignore same-arg))
1703                       (if (and (numeric-type-real-p n)
1704                                (numeric-type-real-p d))
1705                           (,r-aux n d)
1706                           *empty-type*)))
1707                (let ((quot (two-arg-derive-type
1708                             number divisor #'derive-q #',name))
1709                      (rem (two-arg-derive-type
1710                            number divisor #'derive-r #'mod)))
1711                  (when (and quot rem)
1712                    (make-values-type :required (list quot rem))))))))))
1713
1714   (def floor floor-quotient-bound floor-rem-bound)
1715   (def ceiling ceiling-quotient-bound ceiling-rem-bound))
1716
1717 ;;; Define optimizers for FFLOOR and FCEILING
1718 (macrolet ((def (name q-name r-name)
1719              (let ((q-aux (symbolicate "F" q-name "-AUX"))
1720                    (r-aux (symbolicate r-name "-AUX")))
1721                `(progn
1722                   ;; Compute type of quotient (first) result.
1723                   (defun ,q-aux (number-type divisor-type)
1724                     (let* ((number-interval
1725                             (numeric-type->interval number-type))
1726                            (divisor-interval
1727                             (numeric-type->interval divisor-type))
1728                            (quot (,q-name (interval-div number-interval
1729                                                         divisor-interval)))
1730                            (res-type (numeric-contagion number-type
1731                                                         divisor-type)))
1732                       (make-numeric-type
1733                        :class (numeric-type-class res-type)
1734                        :format (numeric-type-format res-type)
1735                        :low  (interval-low quot)
1736                        :high (interval-high quot))))
1737
1738                   (defoptimizer (,name derive-type) ((number divisor))
1739                     (flet ((derive-q (n d same-arg)
1740                              (declare (ignore same-arg))
1741                              (if (and (numeric-type-real-p n)
1742                                       (numeric-type-real-p d))
1743                                  (,q-aux n d)
1744                                  *empty-type*))
1745                            (derive-r (n d same-arg)
1746                              (declare (ignore same-arg))
1747                              (if (and (numeric-type-real-p n)
1748                                       (numeric-type-real-p d))
1749                                  (,r-aux n d)
1750                                  *empty-type*)))
1751                       (let ((quot (two-arg-derive-type
1752                                    number divisor #'derive-q #',name))
1753                             (rem (two-arg-derive-type
1754                                   number divisor #'derive-r #'mod)))
1755                         (when (and quot rem)
1756                           (make-values-type :required (list quot rem))))))))))
1757
1758   (def ffloor floor-quotient-bound floor-rem-bound)
1759   (def fceiling ceiling-quotient-bound ceiling-rem-bound))
1760
1761 ;;; functions to compute the bounds on the quotient and remainder for
1762 ;;; the FLOOR function
1763 (defun floor-quotient-bound (quot)
1764   ;; Take the floor of the quotient and then massage it into what we
1765   ;; need.
1766   (let ((lo (interval-low quot))
1767         (hi (interval-high quot)))
1768     ;; Take the floor of the lower bound. The result is always a
1769     ;; closed lower bound.
1770     (setf lo (if lo
1771                  (floor (type-bound-number lo))
1772                  nil))
1773     ;; For the upper bound, we need to be careful.
1774     (setf hi
1775           (cond ((consp hi)
1776                  ;; An open bound. We need to be careful here because
1777                  ;; the floor of '(10.0) is 9, but the floor of
1778                  ;; 10.0 is 10.
1779                  (multiple-value-bind (q r) (floor (first hi))
1780                    (if (zerop r)
1781                        (1- q)
1782                        q)))
1783                 (hi
1784                  ;; A closed bound, so the answer is obvious.
1785                  (floor hi))
1786                 (t
1787                  hi)))
1788     (make-interval :low lo :high hi)))
1789 (defun floor-rem-bound (div)
1790   ;; The remainder depends only on the divisor. Try to get the
1791   ;; correct sign for the remainder if we can.
1792   (case (interval-range-info div)
1793     (+
1794      ;; The divisor is always positive.
1795      (let ((rem (interval-abs div)))
1796        (setf (interval-low rem) 0)
1797        (when (and (numberp (interval-high rem))
1798                   (not (zerop (interval-high rem))))
1799          ;; The remainder never contains the upper bound. However,
1800          ;; watch out for the case where the high limit is zero!
1801          (setf (interval-high rem) (list (interval-high rem))))
1802        rem))
1803     (-
1804      ;; The divisor is always negative.
1805      (let ((rem (interval-neg (interval-abs div))))
1806        (setf (interval-high rem) 0)
1807        (when (numberp (interval-low rem))
1808          ;; The remainder never contains the lower bound.
1809          (setf (interval-low rem) (list (interval-low rem))))
1810        rem))
1811     (otherwise
1812      ;; The divisor can be positive or negative. All bets off. The
1813      ;; magnitude of remainder is the maximum value of the divisor.
1814      (let ((limit (type-bound-number (interval-high (interval-abs div)))))
1815        ;; The bound never reaches the limit, so make the interval open.
1816        (make-interval :low (if limit
1817                                (list (- limit))
1818                                limit)
1819                       :high (list limit))))))
1820 #| Test cases
1821 (floor-quotient-bound (make-interval :low 0.3 :high 10.3))
1822 => #S(INTERVAL :LOW 0 :HIGH 10)
1823 (floor-quotient-bound (make-interval :low 0.3 :high '(10.3)))
1824 => #S(INTERVAL :LOW 0 :HIGH 10)
1825 (floor-quotient-bound (make-interval :low 0.3 :high 10))
1826 => #S(INTERVAL :LOW 0 :HIGH 10)
1827 (floor-quotient-bound (make-interval :low 0.3 :high '(10)))
1828 => #S(INTERVAL :LOW 0 :HIGH 9)
1829 (floor-quotient-bound (make-interval :low '(0.3) :high 10.3))
1830 => #S(INTERVAL :LOW 0 :HIGH 10)
1831 (floor-quotient-bound (make-interval :low '(0.0) :high 10.3))
1832 => #S(INTERVAL :LOW 0 :HIGH 10)
1833 (floor-quotient-bound (make-interval :low '(-1.3) :high 10.3))
1834 => #S(INTERVAL :LOW -2 :HIGH 10)
1835 (floor-quotient-bound (make-interval :low '(-1.0) :high 10.3))
1836 => #S(INTERVAL :LOW -1 :HIGH 10)
1837 (floor-quotient-bound (make-interval :low -1.0 :high 10.3))
1838 => #S(INTERVAL :LOW -1 :HIGH 10)
1839
1840 (floor-rem-bound (make-interval :low 0.3 :high 10.3))
1841 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
1842 (floor-rem-bound (make-interval :low 0.3 :high '(10.3)))
1843 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
1844 (floor-rem-bound (make-interval :low -10 :high -2.3))
1845 #S(INTERVAL :LOW (-10) :HIGH 0)
1846 (floor-rem-bound (make-interval :low 0.3 :high 10))
1847 => #S(INTERVAL :LOW 0 :HIGH '(10))
1848 (floor-rem-bound (make-interval :low '(-1.3) :high 10.3))
1849 => #S(INTERVAL :LOW '(-10.3) :HIGH '(10.3))
1850 (floor-rem-bound (make-interval :low '(-20.3) :high 10.3))
1851 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
1852 |#
1853 \f
1854 ;;; same functions for CEILING
1855 (defun ceiling-quotient-bound (quot)
1856   ;; Take the ceiling of the quotient and then massage it into what we
1857   ;; need.
1858   (let ((lo (interval-low quot))
1859         (hi (interval-high quot)))
1860     ;; Take the ceiling of the upper bound. The result is always a
1861     ;; closed upper bound.
1862     (setf hi (if hi
1863                  (ceiling (type-bound-number hi))
1864                  nil))
1865     ;; For the lower bound, we need to be careful.
1866     (setf lo
1867           (cond ((consp lo)
1868                  ;; An open bound. We need to be careful here because
1869                  ;; the ceiling of '(10.0) is 11, but the ceiling of
1870                  ;; 10.0 is 10.
1871                  (multiple-value-bind (q r) (ceiling (first lo))
1872                    (if (zerop r)
1873                        (1+ q)
1874                        q)))
1875                 (lo
1876                  ;; A closed bound, so the answer is obvious.
1877                  (ceiling lo))
1878                 (t
1879                  lo)))
1880     (make-interval :low lo :high hi)))
1881 (defun ceiling-rem-bound (div)
1882   ;; The remainder depends only on the divisor. Try to get the
1883   ;; correct sign for the remainder if we can.
1884   (case (interval-range-info div)
1885     (+
1886      ;; Divisor is always positive. The remainder is negative.
1887      (let ((rem (interval-neg (interval-abs div))))
1888        (setf (interval-high rem) 0)
1889        (when (and (numberp (interval-low rem))
1890                   (not (zerop (interval-low rem))))
1891          ;; The remainder never contains the upper bound. However,
1892          ;; watch out for the case when the upper bound is zero!
1893          (setf (interval-low rem) (list (interval-low rem))))
1894        rem))
1895     (-
1896      ;; Divisor is always negative. The remainder is positive
1897      (let ((rem (interval-abs div)))
1898        (setf (interval-low rem) 0)
1899        (when (numberp (interval-high rem))
1900          ;; The remainder never contains the lower bound.
1901          (setf (interval-high rem) (list (interval-high rem))))
1902        rem))
1903     (otherwise
1904      ;; The divisor can be positive or negative. All bets off. The
1905      ;; magnitude of remainder is the maximum value of the divisor.
1906      (let ((limit (type-bound-number (interval-high (interval-abs div)))))
1907        ;; The bound never reaches the limit, so make the interval open.
1908        (make-interval :low (if limit
1909                                (list (- limit))
1910                                limit)
1911                       :high (list limit))))))
1912
1913 #| Test cases
1914 (ceiling-quotient-bound (make-interval :low 0.3 :high 10.3))
1915 => #S(INTERVAL :LOW 1 :HIGH 11)
1916 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10.3)))
1917 => #S(INTERVAL :LOW 1 :HIGH 11)
1918 (ceiling-quotient-bound (make-interval :low 0.3 :high 10))
1919 => #S(INTERVAL :LOW 1 :HIGH 10)
1920 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10)))
1921 => #S(INTERVAL :LOW 1 :HIGH 10)
1922 (ceiling-quotient-bound (make-interval :low '(0.3) :high 10.3))
1923 => #S(INTERVAL :LOW 1 :HIGH 11)
1924 (ceiling-quotient-bound (make-interval :low '(0.0) :high 10.3))
1925 => #S(INTERVAL :LOW 1 :HIGH 11)
1926 (ceiling-quotient-bound (make-interval :low '(-1.3) :high 10.3))
1927 => #S(INTERVAL :LOW -1 :HIGH 11)
1928 (ceiling-quotient-bound (make-interval :low '(-1.0) :high 10.3))
1929 => #S(INTERVAL :LOW 0 :HIGH 11)
1930 (ceiling-quotient-bound (make-interval :low -1.0 :high 10.3))
1931 => #S(INTERVAL :LOW -1 :HIGH 11)
1932
1933 (ceiling-rem-bound (make-interval :low 0.3 :high 10.3))
1934 => #S(INTERVAL :LOW (-10.3) :HIGH 0)
1935 (ceiling-rem-bound (make-interval :low 0.3 :high '(10.3)))
1936 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
1937 (ceiling-rem-bound (make-interval :low -10 :high -2.3))
1938 => #S(INTERVAL :LOW 0 :HIGH (10))
1939 (ceiling-rem-bound (make-interval :low 0.3 :high 10))
1940 => #S(INTERVAL :LOW (-10) :HIGH 0)
1941 (ceiling-rem-bound (make-interval :low '(-1.3) :high 10.3))
1942 => #S(INTERVAL :LOW (-10.3) :HIGH (10.3))
1943 (ceiling-rem-bound (make-interval :low '(-20.3) :high 10.3))
1944 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
1945 |#
1946 \f
1947 (defun truncate-quotient-bound (quot)
1948   ;; For positive quotients, truncate is exactly like floor. For
1949   ;; negative quotients, truncate is exactly like ceiling. Otherwise,
1950   ;; it's the union of the two pieces.
1951   (case (interval-range-info quot)
1952     (+
1953      ;; just like FLOOR
1954      (floor-quotient-bound quot))
1955     (-
1956      ;; just like CEILING
1957      (ceiling-quotient-bound quot))
1958     (otherwise
1959      ;; Split the interval into positive and negative pieces, compute
1960      ;; the result for each piece and put them back together.
1961      (destructuring-bind (neg pos) (interval-split 0 quot t t)
1962        (interval-merge-pair (ceiling-quotient-bound neg)
1963                             (floor-quotient-bound pos))))))
1964
1965 (defun truncate-rem-bound (num div)
1966   ;; This is significantly more complicated than FLOOR or CEILING. We
1967   ;; need both the number and the divisor to determine the range. The
1968   ;; basic idea is to split the ranges of NUM and DEN into positive
1969   ;; and negative pieces and deal with each of the four possibilities
1970   ;; in turn.
1971   (case (interval-range-info num)
1972     (+
1973      (case (interval-range-info div)
1974        (+
1975         (floor-rem-bound div))
1976        (-
1977         (ceiling-rem-bound div))
1978        (otherwise
1979         (destructuring-bind (neg pos) (interval-split 0 div t t)
1980           (interval-merge-pair (truncate-rem-bound num neg)
1981                                (truncate-rem-bound num pos))))))
1982     (-
1983      (case (interval-range-info div)
1984        (+
1985         (ceiling-rem-bound div))
1986        (-
1987         (floor-rem-bound div))
1988        (otherwise
1989         (destructuring-bind (neg pos) (interval-split 0 div t t)
1990           (interval-merge-pair (truncate-rem-bound num neg)
1991                                (truncate-rem-bound num pos))))))
1992     (otherwise
1993      (destructuring-bind (neg pos) (interval-split 0 num t t)
1994        (interval-merge-pair (truncate-rem-bound neg div)
1995                             (truncate-rem-bound pos div))))))
1996 ) ; PROGN
1997
1998 ;;; Derive useful information about the range. Returns three values:
1999 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2000 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2001 ;;; - The abs of the maximal value if there is one, or nil if it is
2002 ;;;   unbounded.
2003 (defun numeric-range-info (low high)
2004   (cond ((and low (not (minusp low)))
2005          (values '+ low high))
2006         ((and high (not (plusp high)))
2007          (values '- (- high) (if low (- low) nil)))
2008         (t
2009          (values nil 0 (and low high (max (- low) high))))))
2010
2011 (defun integer-truncate-derive-type
2012        (number-low number-high divisor-low divisor-high)
2013   ;; The result cannot be larger in magnitude than the number, but the
2014   ;; sign might change. If we can determine the sign of either the
2015   ;; number or the divisor, we can eliminate some of the cases.
2016   (multiple-value-bind (number-sign number-min number-max)
2017       (numeric-range-info number-low number-high)
2018     (multiple-value-bind (divisor-sign divisor-min divisor-max)
2019         (numeric-range-info divisor-low divisor-high)
2020       (when (and divisor-max (zerop divisor-max))
2021         ;; We've got a problem: guaranteed division by zero.
2022         (return-from integer-truncate-derive-type t))
2023       (when (zerop divisor-min)
2024         ;; We'll assume that they aren't going to divide by zero.
2025         (incf divisor-min))
2026       (cond ((and number-sign divisor-sign)
2027              ;; We know the sign of both.
2028              (if (eq number-sign divisor-sign)
2029                  ;; Same sign, so the result will be positive.
2030                  `(integer ,(if divisor-max
2031                                 (truncate number-min divisor-max)
2032                                 0)
2033                            ,(if number-max
2034                                 (truncate number-max divisor-min)
2035                                 '*))
2036                  ;; Different signs, the result will be negative.
2037                  `(integer ,(if number-max
2038                                 (- (truncate number-max divisor-min))
2039                                 '*)
2040                            ,(if divisor-max
2041                                 (- (truncate number-min divisor-max))
2042                                 0))))
2043             ((eq divisor-sign '+)
2044              ;; The divisor is positive. Therefore, the number will just
2045              ;; become closer to zero.
2046              `(integer ,(if number-low
2047                             (truncate number-low divisor-min)
2048                             '*)
2049                        ,(if number-high
2050                             (truncate number-high divisor-min)
2051                             '*)))
2052             ((eq divisor-sign '-)
2053              ;; The divisor is negative. Therefore, the absolute value of
2054              ;; the number will become closer to zero, but the sign will also
2055              ;; change.
2056              `(integer ,(if number-high
2057                             (- (truncate number-high divisor-min))
2058                             '*)
2059                        ,(if number-low
2060                             (- (truncate number-low divisor-min))
2061                             '*)))
2062             ;; The divisor could be either positive or negative.
2063             (number-max
2064              ;; The number we are dividing has a bound. Divide that by the
2065              ;; smallest posible divisor.
2066              (let ((bound (truncate number-max divisor-min)))
2067                `(integer ,(- bound) ,bound)))
2068             (t
2069              ;; The number we are dividing is unbounded, so we can't tell
2070              ;; anything about the result.
2071              `integer)))))
2072
2073 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2074 (defun integer-rem-derive-type
2075        (number-low number-high divisor-low divisor-high)
2076   (if (and divisor-low divisor-high)
2077       ;; We know the range of the divisor, and the remainder must be
2078       ;; smaller than the divisor. We can tell the sign of the
2079       ;; remainer if we know the sign of the number.
2080       (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
2081         `(integer ,(if (or (null number-low)
2082                            (minusp number-low))
2083                        (- divisor-max)
2084                        0)
2085                   ,(if (or (null number-high)
2086                            (plusp number-high))
2087                        divisor-max
2088                        0)))
2089       ;; The divisor is potentially either very positive or very
2090       ;; negative. Therefore, the remainer is unbounded, but we might
2091       ;; be able to tell something about the sign from the number.
2092       `(integer ,(if (and number-low (not (minusp number-low)))
2093                      ;; The number we are dividing is positive.
2094                      ;; Therefore, the remainder must be positive.
2095                      0
2096                      '*)
2097                 ,(if (and number-high (not (plusp number-high)))
2098                      ;; The number we are dividing is negative.
2099                      ;; Therefore, the remainder must be negative.
2100                      0
2101                      '*))))
2102
2103 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2104 (defoptimizer (random derive-type) ((bound &optional state))
2105   (let ((type (continuation-type bound)))
2106     (when (numeric-type-p type)
2107       (let ((class (numeric-type-class type))
2108             (high (numeric-type-high type))
2109             (format (numeric-type-format type)))
2110         (make-numeric-type
2111          :class class
2112          :format format
2113          :low (coerce 0 (or format class 'real))
2114          :high (cond ((not high) nil)
2115                      ((eq class 'integer) (max (1- high) 0))
2116                      ((or (consp high) (zerop high)) high)
2117                      (t `(,high))))))))
2118
2119 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2120 (defun random-derive-type-aux (type)
2121   (let ((class (numeric-type-class type))
2122         (high (numeric-type-high type))
2123         (format (numeric-type-format type)))
2124     (make-numeric-type
2125          :class class
2126          :format format
2127          :low (coerce 0 (or format class 'real))
2128          :high (cond ((not high) nil)
2129                      ((eq class 'integer) (max (1- high) 0))
2130                      ((or (consp high) (zerop high)) high)
2131                      (t `(,high))))))
2132
2133 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2134 (defoptimizer (random derive-type) ((bound &optional state))
2135   (one-arg-derive-type bound #'random-derive-type-aux nil))
2136 \f
2137 ;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends
2138
2139 ;;; Return the maximum number of bits an integer of the supplied type
2140 ;;; can take up, or NIL if it is unbounded. The second (third) value
2141 ;;; is T if the integer can be positive (negative) and NIL if not.
2142 ;;; Zero counts as positive.
2143 (defun integer-type-length (type)
2144   (if (numeric-type-p type)
2145       (let ((min (numeric-type-low type))
2146             (max (numeric-type-high type)))
2147         (values (and min max (max (integer-length min) (integer-length max)))
2148                 (or (null max) (not (minusp max)))
2149                 (or (null min) (minusp min))))
2150       (values nil t t)))
2151
2152 (defun logand-derive-type-aux (x y &optional same-leaf)
2153   (declare (ignore same-leaf))
2154   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2155     (declare (ignore x-pos))
2156     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length  y)
2157       (declare (ignore y-pos))
2158       (if (not x-neg)
2159           ;; X must be positive.
2160           (if (not y-neg)
2161               ;; They must both be positive.
2162               (cond ((or (null x-len) (null y-len))
2163                      (specifier-type 'unsigned-byte))
2164                     ((or (zerop x-len) (zerop y-len))
2165                      (specifier-type '(integer 0 0)))
2166                     (t
2167                      (specifier-type `(unsigned-byte ,(min x-len y-len)))))
2168               ;; X is positive, but Y might be negative.
2169               (cond ((null x-len)
2170                      (specifier-type 'unsigned-byte))
2171                     ((zerop x-len)
2172                      (specifier-type '(integer 0 0)))
2173                     (t
2174                      (specifier-type `(unsigned-byte ,x-len)))))
2175           ;; X might be negative.
2176           (if (not y-neg)
2177               ;; Y must be positive.
2178               (cond ((null y-len)
2179                      (specifier-type 'unsigned-byte))
2180                     ((zerop y-len)
2181                      (specifier-type '(integer 0 0)))
2182                     (t
2183                      (specifier-type
2184                       `(unsigned-byte ,y-len))))
2185               ;; Either might be negative.
2186               (if (and x-len y-len)
2187                   ;; The result is bounded.
2188                   (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2189                   ;; We can't tell squat about the result.
2190                   (specifier-type 'integer)))))))
2191
2192 (defun logior-derive-type-aux (x y &optional same-leaf)
2193   (declare (ignore same-leaf))
2194   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2195     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
2196       (cond
2197        ((and (not x-neg) (not y-neg))
2198         ;; Both are positive.
2199         (if (and x-len y-len (zerop x-len) (zerop y-len))
2200             (specifier-type '(integer 0 0))
2201             (specifier-type `(unsigned-byte ,(if (and x-len y-len)
2202                                              (max x-len y-len)
2203                                              '*)))))
2204        ((not x-pos)
2205         ;; X must be negative.
2206         (if (not y-pos)
2207             ;; Both are negative. The result is going to be negative
2208             ;; and be the same length or shorter than the smaller.
2209             (if (and x-len y-len)
2210                 ;; It's bounded.
2211                 (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
2212                 ;; It's unbounded.
2213                 (specifier-type '(integer * -1)))
2214             ;; X is negative, but we don't know about Y. The result
2215             ;; will be negative, but no more negative than X.
2216             (specifier-type
2217              `(integer ,(or (numeric-type-low x) '*)
2218                        -1))))
2219        (t
2220         ;; X might be either positive or negative.
2221         (if (not y-pos)
2222             ;; But Y is negative. The result will be negative.
2223             (specifier-type
2224              `(integer ,(or (numeric-type-low y) '*)
2225                        -1))
2226             ;; We don't know squat about either. It won't get any bigger.
2227             (if (and x-len y-len)
2228                 ;; Bounded.
2229                 (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2230                 ;; Unbounded.
2231                 (specifier-type 'integer))))))))
2232
2233 (defun logxor-derive-type-aux (x y &optional same-leaf)
2234   (declare (ignore same-leaf))
2235   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2236     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
2237       (cond
2238        ((or (and (not x-neg) (not y-neg))
2239             (and (not x-pos) (not y-pos)))
2240         ;; Either both are negative or both are positive. The result
2241         ;; will be positive, and as long as the longer.
2242         (if (and x-len y-len (zerop x-len) (zerop y-len))
2243             (specifier-type '(integer 0 0))
2244             (specifier-type `(unsigned-byte ,(if (and x-len y-len)
2245                                              (max x-len y-len)
2246                                              '*)))))
2247        ((or (and (not x-pos) (not y-neg))
2248             (and (not y-neg) (not y-pos)))
2249         ;; Either X is negative and Y is positive of vice-versa. The
2250         ;; result will be negative.
2251         (specifier-type `(integer ,(if (and x-len y-len)
2252                                        (ash -1 (max x-len y-len))
2253                                        '*)
2254                                   -1)))
2255        ;; We can't tell what the sign of the result is going to be.
2256        ;; All we know is that we don't create new bits.
2257        ((and x-len y-len)
2258         (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
2259        (t
2260         (specifier-type 'integer))))))
2261
2262 (macrolet ((deffrob (logfcn)
2263              (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
2264              `(defoptimizer (,logfcn derive-type) ((x y))
2265                 (two-arg-derive-type x y #',fcn-aux #',logfcn)))))
2266   (deffrob logand)
2267   (deffrob logior)
2268   (deffrob logxor))
2269 \f
2270 ;;;; miscellaneous derive-type methods
2271
2272 (defoptimizer (integer-length derive-type) ((x))
2273   (let ((x-type (continuation-type x)))
2274     (when (and (numeric-type-p x-type)
2275                (csubtypep x-type (specifier-type 'integer)))
2276       ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2277       ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically.  Be
2278       ;; careful about LO or HI being NIL, though.  Also, if 0 is
2279       ;; contained in X, the lower bound is obviously 0.
2280       (flet ((null-or-min (a b)
2281                (and a b (min (integer-length a)
2282                              (integer-length b))))
2283              (null-or-max (a b)
2284                (and a b (max (integer-length a)
2285                              (integer-length b)))))
2286         (let* ((min (numeric-type-low x-type))
2287                (max (numeric-type-high x-type))
2288                (min-len (null-or-min min max))
2289                (max-len (null-or-max min max)))
2290           (when (ctypep 0 x-type)
2291             (setf min-len 0))
2292           (specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
2293
2294 (defoptimizer (code-char derive-type) ((code))
2295   (specifier-type 'base-char))
2296
2297 (defoptimizer (values derive-type) ((&rest values))
2298   (values-specifier-type
2299    `(values ,@(mapcar (lambda (x)
2300                         (type-specifier (continuation-type x)))
2301                       values))))
2302 \f
2303 ;;;; byte operations
2304 ;;;;
2305 ;;;; We try to turn byte operations into simple logical operations.
2306 ;;;; First, we convert byte specifiers into separate size and position
2307 ;;;; arguments passed to internal %FOO functions. We then attempt to
2308 ;;;; transform the %FOO functions into boolean operations when the
2309 ;;;; size and position are constant and the operands are fixnums.
2310
2311 (macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to
2312            ;; expressions that evaluate to the SIZE and POSITION of
2313            ;; the byte-specifier form SPEC. We may wrap a let around
2314            ;; the result of the body to bind some variables.
2315            ;;
2316            ;; If the spec is a BYTE form, then bind the vars to the
2317            ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE
2318            ;; and BYTE-POSITION. The goal of this transformation is to
2319            ;; avoid consing up byte specifiers and then immediately
2320            ;; throwing them away.
2321            (with-byte-specifier ((size-var pos-var spec) &body body)
2322              (once-only ((spec `(macroexpand ,spec))
2323                          (temp '(gensym)))
2324                         `(if (and (consp ,spec)
2325                                   (eq (car ,spec) 'byte)
2326                                   (= (length ,spec) 3))
2327                         (let ((,size-var (second ,spec))
2328                               (,pos-var (third ,spec)))
2329                           ,@body)
2330                         (let ((,size-var `(byte-size ,,temp))
2331                               (,pos-var `(byte-position ,,temp)))
2332                           `(let ((,,temp ,,spec))
2333                              ,,@body))))))
2334
2335   (define-source-transform ldb (spec int)
2336     (with-byte-specifier (size pos spec)
2337       `(%ldb ,size ,pos ,int)))
2338
2339   (define-source-transform dpb (newbyte spec int)
2340     (with-byte-specifier (size pos spec)
2341       `(%dpb ,newbyte ,size ,pos ,int)))
2342
2343   (define-source-transform mask-field (spec int)
2344     (with-byte-specifier (size pos spec)
2345       `(%mask-field ,size ,pos ,int)))
2346
2347   (define-source-transform deposit-field (newbyte spec int)
2348     (with-byte-specifier (size pos spec)
2349       `(%deposit-field ,newbyte ,size ,pos ,int))))
2350
2351 (defoptimizer (%ldb derive-type) ((size posn num))
2352   (let ((size (continuation-type size)))
2353     (if (and (numeric-type-p size)
2354              (csubtypep size (specifier-type 'integer)))
2355         (let ((size-high (numeric-type-high size)))
2356           (if (and size-high (<= size-high sb!vm:n-word-bits))
2357               (specifier-type `(unsigned-byte ,size-high))
2358               (specifier-type 'unsigned-byte)))
2359         *universal-type*)))
2360
2361 (defoptimizer (%mask-field derive-type) ((size posn num))
2362   (let ((size (continuation-type size))
2363         (posn (continuation-type posn)))
2364     (if (and (numeric-type-p size)
2365              (csubtypep size (specifier-type 'integer))
2366              (numeric-type-p posn)
2367              (csubtypep posn (specifier-type 'integer)))
2368         (let ((size-high (numeric-type-high size))
2369               (posn-high (numeric-type-high posn)))
2370           (if (and size-high posn-high
2371                    (<= (+ size-high posn-high) sb!vm:n-word-bits))
2372               (specifier-type `(unsigned-byte ,(+ size-high posn-high)))
2373               (specifier-type 'unsigned-byte)))
2374         *universal-type*)))
2375
2376 (defoptimizer (%dpb derive-type) ((newbyte size posn int))
2377   (let ((size (continuation-type size))
2378         (posn (continuation-type posn))
2379         (int (continuation-type int)))
2380     (if (and (numeric-type-p size)
2381              (csubtypep size (specifier-type 'integer))
2382              (numeric-type-p posn)
2383              (csubtypep posn (specifier-type 'integer))
2384              (numeric-type-p int)
2385              (csubtypep int (specifier-type 'integer)))
2386         (let ((size-high (numeric-type-high size))
2387               (posn-high (numeric-type-high posn))
2388               (high (numeric-type-high int))
2389               (low (numeric-type-low int)))
2390           (if (and size-high posn-high high low
2391                    (<= (+ size-high posn-high) sb!vm:n-word-bits))
2392               (specifier-type
2393                (list (if (minusp low) 'signed-byte 'unsigned-byte)
2394                      (max (integer-length high)
2395                           (integer-length low)
2396                           (+ size-high posn-high))))
2397               *universal-type*))
2398         *universal-type*)))
2399
2400 (defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
2401   (let ((size (continuation-type size))
2402         (posn (continuation-type posn))
2403         (int (continuation-type int)))
2404     (if (and (numeric-type-p size)
2405              (csubtypep size (specifier-type 'integer))
2406              (numeric-type-p posn)
2407              (csubtypep posn (specifier-type 'integer))
2408              (numeric-type-p int)
2409              (csubtypep int (specifier-type 'integer)))
2410         (let ((size-high (numeric-type-high size))
2411               (posn-high (numeric-type-high posn))
2412               (high (numeric-type-high int))
2413               (low (numeric-type-low int)))
2414           (if (and size-high posn-high high low
2415                    (<= (+ size-high posn-high) sb!vm:n-word-bits))
2416               (specifier-type
2417                (list (if (minusp low) 'signed-byte 'unsigned-byte)
2418                      (max (integer-length high)
2419                           (integer-length low)
2420                           (+ size-high posn-high))))
2421               *universal-type*))
2422         *universal-type*)))
2423
2424 (deftransform %ldb ((size posn int)
2425                     (fixnum fixnum integer)
2426                     (unsigned-byte #.sb!vm:n-word-bits))
2427   "convert to inline logical operations"
2428   `(logand (ash int (- posn))
2429            (ash ,(1- (ash 1 sb!vm:n-word-bits))
2430                 (- size ,sb!vm:n-word-bits))))
2431
2432 (deftransform %mask-field ((size posn int)
2433                            (fixnum fixnum integer)
2434                            (unsigned-byte #.sb!vm:n-word-bits))
2435   "convert to inline logical operations"
2436   `(logand int
2437            (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
2438                      (- size ,sb!vm:n-word-bits))
2439                 posn)))
2440
2441 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2442 ;;;   (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2443 ;;; as the result type, as that would allow result types that cover
2444 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2445 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2446
2447 (deftransform %dpb ((new size posn int)
2448                     *
2449                     (unsigned-byte #.sb!vm:n-word-bits))
2450   "convert to inline logical operations"
2451   `(let ((mask (ldb (byte size 0) -1)))
2452      (logior (ash (logand new mask) posn)
2453              (logand int (lognot (ash mask posn))))))
2454
2455 (deftransform %dpb ((new size posn int)
2456                     *
2457                     (signed-byte #.sb!vm:n-word-bits))
2458   "convert to inline logical operations"
2459   `(let ((mask (ldb (byte size 0) -1)))
2460      (logior (ash (logand new mask) posn)
2461              (logand int (lognot (ash mask posn))))))
2462
2463 (deftransform %deposit-field ((new size posn int)
2464                               *
2465                               (unsigned-byte #.sb!vm:n-word-bits))
2466   "convert to inline logical operations"
2467   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2468      (logior (logand new mask)
2469              (logand int (lognot mask)))))
2470
2471 (deftransform %deposit-field ((new size posn int)
2472                               *
2473                               (signed-byte #.sb!vm:n-word-bits))
2474   "convert to inline logical operations"
2475   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2476      (logior (logand new mask)
2477              (logand int (lognot mask)))))
2478 \f
2479 ;;; miscellanous numeric transforms
2480
2481 ;;; If a constant appears as the first arg, swap the args.
2482 (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
2483   (if (and (constant-continuation-p x)
2484            (not (constant-continuation-p y)))
2485       `(,(continuation-fun-name (basic-combination-fun node))
2486         y
2487         ,(continuation-value x))
2488       (give-up-ir1-transform)))
2489
2490 (dolist (x '(= char= + * logior logand logxor))
2491   (%deftransform x '(function * *) #'commutative-arg-swap
2492                  "place constant arg last"))
2493
2494 ;;; Handle the case of a constant BOOLE-CODE.
2495 (deftransform boole ((op x y) * *)
2496   "convert to inline logical operations"
2497   (unless (constant-continuation-p op)
2498     (give-up-ir1-transform "BOOLE code is not a constant."))
2499   (let ((control (continuation-value op)))
2500     (case control
2501       (#.boole-clr 0)
2502       (#.boole-set -1)
2503       (#.boole-1 'x)
2504       (#.boole-2 'y)
2505       (#.boole-c1 '(lognot x))
2506       (#.boole-c2 '(lognot y))
2507       (#.boole-and '(logand x y))
2508       (#.boole-ior '(logior x y))
2509       (#.boole-xor '(logxor x y))
2510       (#.boole-eqv '(logeqv x y))
2511       (#.boole-nand '(lognand x y))
2512       (#.boole-nor '(lognor x y))
2513       (#.boole-andc1 '(logandc1 x y))
2514       (#.boole-andc2 '(logandc2 x y))
2515       (#.boole-orc1 '(logorc1 x y))
2516       (#.boole-orc2 '(logorc2 x y))
2517       (t
2518        (abort-ir1-transform "~S is an illegal control arg to BOOLE."
2519                             control)))))
2520 \f
2521 ;;;; converting special case multiply/divide to shifts
2522
2523 ;;; If arg is a constant power of two, turn * into a shift.
2524 (deftransform * ((x y) (integer integer) *)
2525   "convert x*2^k to shift"
2526   (unless (constant-continuation-p y)
2527     (give-up-ir1-transform))
2528   (let* ((y (continuation-value y))
2529          (y-abs (abs y))
2530          (len (1- (integer-length y-abs))))
2531     (unless (= y-abs (ash 1 len))
2532       (give-up-ir1-transform))
2533     (if (minusp y)
2534         `(- (ash x ,len))
2535         `(ash x ,len))))
2536
2537 ;;; If both arguments and the result are (UNSIGNED-BYTE 32), try to
2538 ;;; come up with a ``better'' multiplication using multiplier
2539 ;;; recoding. There are two different ways the multiplier can be
2540 ;;; recoded. The more obvious is to shift X by the correct amount for
2541 ;;; each bit set in Y and to sum the results. But if there is a string
2542 ;;; of bits that are all set, you can add X shifted by one more then
2543 ;;; the bit position of the first set bit and subtract X shifted by
2544 ;;; the bit position of the last set bit. We can't use this second
2545 ;;; method when the high order bit is bit 31 because shifting by 32
2546 ;;; doesn't work too well.
2547 (deftransform * ((x y)
2548                  ((unsigned-byte 32) (unsigned-byte 32))
2549                  (unsigned-byte 32))
2550   "recode as shift and add"
2551   (unless (constant-continuation-p y)
2552     (give-up-ir1-transform))
2553   (let ((y (continuation-value y))
2554         (result nil)
2555         (first-one nil))
2556     (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
2557              (add (next-factor)
2558                (setf result
2559                      (tub32
2560                       (if result
2561                           `(+ ,result ,(tub32 next-factor))
2562                           next-factor)))))
2563       (declare (inline add))
2564       (dotimes (bitpos 32)
2565         (if first-one
2566             (when (not (logbitp bitpos y))
2567               (add (if (= (1+ first-one) bitpos)
2568                        ;; There is only a single bit in the string.
2569                        `(ash x ,first-one)
2570                        ;; There are at least two.
2571                        `(- ,(tub32 `(ash x ,bitpos))
2572                            ,(tub32 `(ash x ,first-one)))))
2573               (setf first-one nil))
2574             (when (logbitp bitpos y)
2575               (setf first-one bitpos))))
2576       (when first-one
2577         (cond ((= first-one 31))
2578               ((= first-one 30)
2579                (add '(ash x 30)))
2580               (t
2581                (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
2582         (add '(ash x 31))))
2583     (or result 0)))
2584
2585 ;;; If arg is a constant power of two, turn FLOOR into a shift and
2586 ;;; mask. If CEILING, add in (1- (ABS Y)) and then do FLOOR.
2587 (flet ((frob (y ceil-p)
2588          (unless (constant-continuation-p y)
2589            (give-up-ir1-transform))
2590          (let* ((y (continuation-value y))
2591                 (y-abs (abs y))
2592                 (len (1- (integer-length y-abs))))
2593            (unless (= y-abs (ash 1 len))
2594              (give-up-ir1-transform))
2595            (let ((shift (- len))
2596                  (mask (1- y-abs)))
2597              `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
2598                 ,(if (minusp y)
2599                      `(values (ash (- x) ,shift)
2600                               (- (logand (- x) ,mask)))
2601                      `(values (ash x ,shift)
2602                               (logand x ,mask))))))))
2603   (deftransform floor ((x y) (integer integer) *)
2604     "convert division by 2^k to shift"
2605     (frob y nil))
2606   (deftransform ceiling ((x y) (integer integer) *)
2607     "convert division by 2^k to shift"
2608     (frob y t)))
2609
2610 ;;; Do the same for MOD.
2611 (deftransform mod ((x y) (integer integer) *)
2612   "convert remainder mod 2^k to LOGAND"
2613   (unless (constant-continuation-p y)
2614     (give-up-ir1-transform))
2615   (let* ((y (continuation-value y))
2616          (y-abs (abs y))
2617          (len (1- (integer-length y-abs))))
2618     (unless (= y-abs (ash 1 len))
2619       (give-up-ir1-transform))
2620     (let ((mask (1- y-abs)))
2621       (if (minusp y)
2622           `(- (logand (- x) ,mask))
2623           `(logand x ,mask)))))
2624
2625 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
2626 (deftransform truncate ((x y) (integer integer))
2627   "convert division by 2^k to shift"
2628   (unless (constant-continuation-p y)
2629     (give-up-ir1-transform))
2630   (let* ((y (continuation-value y))
2631          (y-abs (abs y))
2632          (len (1- (integer-length y-abs))))
2633     (unless (= y-abs (ash 1 len))
2634       (give-up-ir1-transform))
2635     (let* ((shift (- len))
2636            (mask (1- y-abs)))
2637       `(if (minusp x)
2638            (values ,(if (minusp y)
2639                         `(ash (- x) ,shift)
2640                         `(- (ash (- x) ,shift)))
2641                    (- (logand (- x) ,mask)))
2642            (values ,(if (minusp y)
2643                         `(- (ash (- x) ,shift))
2644                         `(ash x ,shift))
2645                    (logand x ,mask))))))
2646
2647 ;;; And the same for REM.
2648 (deftransform rem ((x y) (integer integer) *)
2649   "convert remainder mod 2^k to LOGAND"
2650   (unless (constant-continuation-p y)
2651     (give-up-ir1-transform))
2652   (let* ((y (continuation-value y))
2653          (y-abs (abs y))
2654          (len (1- (integer-length y-abs))))
2655     (unless (= y-abs (ash 1 len))
2656       (give-up-ir1-transform))
2657     (let ((mask (1- y-abs)))
2658       `(if (minusp x)
2659            (- (logand (- x) ,mask))
2660            (logand x ,mask)))))
2661 \f
2662 ;;;; arithmetic and logical identity operation elimination
2663
2664 ;;; Flush calls to various arith functions that convert to the
2665 ;;; identity function or a constant.
2666 (macrolet ((def (name identity result)
2667              `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *)
2668                 "fold identity operations"
2669                 ',result)))
2670   (def ash 0 x)
2671   (def logand -1 x)
2672   (def logand 0 0)
2673   (def logior 0 x)
2674   (def logior -1 -1)
2675   (def logxor -1 (lognot x))
2676   (def logxor 0 x))
2677
2678 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
2679 ;;; (* 0 -4.0) is -0.0.
2680 (deftransform - ((x y) ((constant-arg (member 0)) rational) *)
2681   "convert (- 0 x) to negate"
2682   '(%negate y))
2683 (deftransform * ((x y) (rational (constant-arg (member 0))) *)
2684   "convert (* x 0) to 0"
2685   0)
2686
2687 ;;; Return T if in an arithmetic op including continuations X and Y,
2688 ;;; the result type is not affected by the type of X. That is, Y is at
2689 ;;; least as contagious as X.
2690 #+nil
2691 (defun not-more-contagious (x y)
2692   (declare (type continuation x y))
2693   (let ((x (continuation-type x))
2694         (y (continuation-type y)))
2695     (values (type= (numeric-contagion x y)
2696                    (numeric-contagion y y)))))
2697 ;;; Patched version by Raymond Toy. dtc: Should be safer although it
2698 ;;; XXX needs more work as valid transforms are missed; some cases are
2699 ;;; specific to particular transform functions so the use of this
2700 ;;; function may need a re-think.
2701 (defun not-more-contagious (x y)
2702   (declare (type continuation x y))
2703   (flet ((simple-numeric-type (num)
2704            (and (numeric-type-p num)
2705                 ;; Return non-NIL if NUM is integer, rational, or a float
2706                 ;; of some type (but not FLOAT)
2707                 (case (numeric-type-class num)
2708                   ((integer rational)
2709                    t)
2710                   (float
2711                    (numeric-type-format num))
2712                   (t
2713                    nil)))))
2714     (let ((x (continuation-type x))
2715           (y (continuation-type y)))
2716       (if (and (simple-numeric-type x)
2717                (simple-numeric-type y))
2718           (values (type= (numeric-contagion x y)
2719                          (numeric-contagion y y)))))))
2720
2721 ;;; Fold (+ x 0).
2722 ;;;
2723 ;;; If y is not constant, not zerop, or is contagious, or a positive
2724 ;;; float +0.0 then give up.
2725 (deftransform + ((x y) (t (constant-arg t)) *)
2726   "fold zero arg"
2727   (let ((val (continuation-value y)))
2728     (unless (and (zerop val)
2729                  (not (and (floatp val) (plusp (float-sign val))))
2730                  (not-more-contagious y x))
2731       (give-up-ir1-transform)))
2732   'x)
2733
2734 ;;; Fold (- x 0).
2735 ;;;
2736 ;;; If y is not constant, not zerop, or is contagious, or a negative
2737 ;;; float -0.0 then give up.
2738 (deftransform - ((x y) (t (constant-arg t)) *)
2739   "fold zero arg"
2740   (let ((val (continuation-value y)))
2741     (unless (and (zerop val)
2742                  (not (and (floatp val) (minusp (float-sign val))))
2743                  (not-more-contagious y x))
2744       (give-up-ir1-transform)))
2745   'x)
2746
2747 ;;; Fold (OP x +/-1)
2748 (macrolet ((def (name result minus-result)
2749              `(deftransform ,name ((x y) (t (constant-arg real)) *)
2750                 "fold identity operations"
2751                 (let ((val (continuation-value y)))
2752                   (unless (and (= (abs val) 1)
2753                                (not-more-contagious y x))
2754                     (give-up-ir1-transform))
2755                   (if (minusp val) ',minus-result ',result)))))
2756   (def * x (%negate x))
2757   (def / x (%negate x))
2758   (def expt x (/ 1 x)))
2759
2760 ;;; Fold (expt x n) into multiplications for small integral values of
2761 ;;; N; convert (expt x 1/2) to sqrt.
2762 (deftransform expt ((x y) (t (constant-arg real)) *)
2763   "recode as multiplication or sqrt"
2764   (let ((val (continuation-value y)))
2765     ;; If Y would cause the result to be promoted to the same type as
2766     ;; Y, we give up. If not, then the result will be the same type
2767     ;; as X, so we can replace the exponentiation with simple
2768     ;; multiplication and division for small integral powers.
2769     (unless (not-more-contagious y x)
2770       (give-up-ir1-transform))
2771     (cond ((zerop val) '(float 1 x))
2772           ((= val 2) '(* x x))
2773           ((= val -2) '(/ (* x x)))
2774           ((= val 3) '(* x x x))
2775           ((= val -3) '(/ (* x x x)))
2776           ((= val 1/2) '(sqrt x))
2777           ((= val -1/2) '(/ (sqrt x)))
2778           (t (give-up-ir1-transform)))))
2779
2780 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
2781 ;;; transformations?
2782 ;;; Perhaps we should have to prove that the denominator is nonzero before
2783 ;;; doing them?  -- WHN 19990917
2784 (macrolet ((def (name)
2785              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
2786                                    *)
2787                 "fold zero arg"
2788                 0)))
2789   (def ash)
2790   (def /))
2791
2792 (macrolet ((def (name)
2793              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
2794                                    *)
2795                 "fold zero arg"
2796                 '(values 0 0))))
2797   (def truncate)
2798   (def round)
2799   (def floor)
2800   (def ceiling))
2801 \f
2802 ;;;; character operations
2803
2804 (deftransform char-equal ((a b) (base-char base-char))
2805   "open code"
2806   '(let* ((ac (char-code a))
2807           (bc (char-code b))
2808           (sum (logxor ac bc)))
2809      (or (zerop sum)
2810          (when (eql sum #x20)
2811            (let ((sum (+ ac bc)))
2812              (and (> sum 161) (< sum 213)))))))
2813
2814 (deftransform char-upcase ((x) (base-char))
2815   "open code"
2816   '(let ((n-code (char-code x)))
2817      (if (and (> n-code #o140)  ; Octal 141 is #\a.
2818               (< n-code #o173)) ; Octal 172 is #\z.
2819          (code-char (logxor #x20 n-code))
2820          x)))
2821
2822 (deftransform char-downcase ((x) (base-char))
2823   "open code"
2824   '(let ((n-code (char-code x)))
2825      (if (and (> n-code 64)     ; 65 is #\A.
2826               (< n-code 91))    ; 90 is #\Z.
2827          (code-char (logxor #x20 n-code))
2828          x)))
2829 \f
2830 ;;;; equality predicate transforms
2831
2832 ;;; Return true if X and Y are continuations whose only use is a
2833 ;;; reference to the same leaf, and the value of the leaf cannot
2834 ;;; change.
2835 (defun same-leaf-ref-p (x y)
2836   (declare (type continuation x y))
2837   (let ((x-use (continuation-use x))
2838         (y-use (continuation-use y)))
2839     (and (ref-p x-use)
2840          (ref-p y-use)
2841          (eq (ref-leaf x-use) (ref-leaf y-use))
2842          (constant-reference-p x-use))))
2843
2844 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
2845 ;;; if there is no intersection between the types of the arguments,
2846 ;;; then the result is definitely false.
2847 (deftransform simple-equality-transform ((x y) * *
2848                                          :defun-only t)
2849   (cond ((same-leaf-ref-p x y)
2850          t)
2851         ((not (types-equal-or-intersect (continuation-type x)
2852                                         (continuation-type y)))
2853          nil)
2854         (t
2855          (give-up-ir1-transform))))
2856
2857 (macrolet ((def (x)
2858              `(%deftransform ',x '(function * *) #'simple-equality-transform)))
2859   (def eq)
2860   (def char=)
2861   (def equal))
2862
2863 ;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
2864 ;;; try to convert to a type-specific predicate or EQ:
2865 ;;; -- If both args are characters, convert to CHAR=. This is better than
2866 ;;;    just converting to EQ, since CHAR= may have special compilation
2867 ;;;    strategies for non-standard representations, etc.
2868 ;;; -- If either arg is definitely not a number, then we can compare
2869 ;;;    with EQ.
2870 ;;; -- Otherwise, we try to put the arg we know more about second. If X
2871 ;;;    is constant then we put it second. If X is a subtype of Y, we put
2872 ;;;    it second. These rules make it easier for the back end to match
2873 ;;;    these interesting cases.
2874 ;;; -- If Y is a fixnum, then we quietly pass because the back end can
2875 ;;;    handle that case, otherwise give an efficiency note.
2876 (deftransform eql ((x y) * *)
2877   "convert to simpler equality predicate"
2878   (let ((x-type (continuation-type x))
2879         (y-type (continuation-type y))
2880         (char-type (specifier-type 'character))
2881         (number-type (specifier-type 'number)))
2882     (cond ((same-leaf-ref-p x y)
2883            t)
2884           ((not (types-equal-or-intersect x-type y-type))
2885            nil)
2886           ((and (csubtypep x-type char-type)
2887                 (csubtypep y-type char-type))
2888            '(char= x y))
2889           ((or (not (types-equal-or-intersect x-type number-type))
2890                (not (types-equal-or-intersect y-type number-type)))
2891            '(eq x y))
2892           ((and (not (constant-continuation-p y))
2893                 (or (constant-continuation-p x)
2894                     (and (csubtypep x-type y-type)
2895                          (not (csubtypep y-type x-type)))))
2896            '(eql y x))
2897           (t
2898            (give-up-ir1-transform)))))
2899
2900 ;;; Convert to EQL if both args are rational and complexp is specified
2901 ;;; and the same for both.
2902 (deftransform = ((x y) * *)
2903   "open code"
2904   (let ((x-type (continuation-type x))
2905         (y-type (continuation-type y)))
2906     (if (and (csubtypep x-type (specifier-type 'number))
2907              (csubtypep y-type (specifier-type 'number)))
2908         (cond ((or (and (csubtypep x-type (specifier-type 'float))
2909                         (csubtypep y-type (specifier-type 'float)))
2910                    (and (csubtypep x-type (specifier-type '(complex float)))
2911                         (csubtypep y-type (specifier-type '(complex float)))))
2912                ;; They are both floats. Leave as = so that -0.0 is
2913                ;; handled correctly.
2914                (give-up-ir1-transform))
2915               ((or (and (csubtypep x-type (specifier-type 'rational))
2916                         (csubtypep y-type (specifier-type 'rational)))
2917                    (and (csubtypep x-type
2918                                    (specifier-type '(complex rational)))
2919                         (csubtypep y-type
2920                                    (specifier-type '(complex rational)))))
2921                ;; They are both rationals and complexp is the same.
2922                ;; Convert to EQL.
2923                '(eql x y))
2924               (t
2925                (give-up-ir1-transform
2926                 "The operands might not be the same type.")))
2927         (give-up-ir1-transform
2928          "The operands might not be the same type."))))
2929
2930 ;;; If CONT's type is a numeric type, then return the type, otherwise
2931 ;;; GIVE-UP-IR1-TRANSFORM.
2932 (defun numeric-type-or-lose (cont)
2933   (declare (type continuation cont))
2934   (let ((res (continuation-type cont)))
2935     (unless (numeric-type-p res) (give-up-ir1-transform))
2936     res))
2937
2938 ;;; See whether we can statically determine (< X Y) using type
2939 ;;; information. If X's high bound is < Y's low, then X < Y.
2940 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
2941 ;;; NIL). If not, at least make sure any constant arg is second.
2942 ;;;
2943 ;;; FIXME: Why should constant argument be second? It would be nice to
2944 ;;; find out and explain.
2945 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2946 (defun ir1-transform-< (x y first second inverse)
2947   (if (same-leaf-ref-p x y)
2948       nil
2949       (let* ((x-type (numeric-type-or-lose x))
2950              (x-lo (numeric-type-low x-type))
2951              (x-hi (numeric-type-high x-type))
2952              (y-type (numeric-type-or-lose y))
2953              (y-lo (numeric-type-low y-type))
2954              (y-hi (numeric-type-high y-type)))
2955         (cond ((and x-hi y-lo (< x-hi y-lo))
2956                t)
2957               ((and y-hi x-lo (>= x-lo y-hi))
2958                nil)
2959               ((and (constant-continuation-p first)
2960                     (not (constant-continuation-p second)))
2961                `(,inverse y x))
2962               (t
2963                (give-up-ir1-transform))))))
2964 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2965 (defun ir1-transform-< (x y first second inverse)
2966   (if (same-leaf-ref-p x y)
2967       nil
2968       (let ((xi (numeric-type->interval (numeric-type-or-lose x)))
2969             (yi (numeric-type->interval (numeric-type-or-lose y))))
2970         (cond ((interval-< xi yi)
2971                t)
2972               ((interval->= xi yi)
2973                nil)
2974               ((and (constant-continuation-p first)
2975                     (not (constant-continuation-p second)))
2976                `(,inverse y x))
2977               (t
2978                (give-up-ir1-transform))))))
2979
2980 (deftransform < ((x y) (integer integer) *)
2981   (ir1-transform-< x y x y '>))
2982
2983 (deftransform > ((x y) (integer integer) *)
2984   (ir1-transform-< y x x y '<))
2985
2986 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2987 (deftransform < ((x y) (float float) *)
2988   (ir1-transform-< x y x y '>))
2989
2990 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2991 (deftransform > ((x y) (float float) *)
2992   (ir1-transform-< y x x y '<))
2993 \f
2994 ;;;; converting N-arg comparisons
2995 ;;;;
2996 ;;;; We convert calls to N-arg comparison functions such as < into
2997 ;;;; two-arg calls. This transformation is enabled for all such
2998 ;;;; comparisons in this file. If any of these predicates are not
2999 ;;;; open-coded, then the transformation should be removed at some
3000 ;;;; point to avoid pessimization.
3001
3002 ;;; This function is used for source transformation of N-arg
3003 ;;; comparison functions other than inequality. We deal both with
3004 ;;; converting to two-arg calls and inverting the sense of the test,
3005 ;;; if necessary. If the call has two args, then we pass or return a
3006 ;;; negated test as appropriate. If it is a degenerate one-arg call,
3007 ;;; then we transform to code that returns true. Otherwise, we bind
3008 ;;; all the arguments and expand into a bunch of IFs.
3009 (declaim (ftype (function (symbol list boolean) *) multi-compare))
3010 (defun multi-compare (predicate args not-p)
3011   (let ((nargs (length args)))
3012     (cond ((< nargs 1) (values nil t))
3013           ((= nargs 1) `(progn ,@args t))
3014           ((= nargs 2)
3015            (if not-p
3016                `(if (,predicate ,(first args) ,(second args)) nil t)
3017                (values nil t)))
3018           (t
3019            (do* ((i (1- nargs) (1- i))
3020                  (last nil current)
3021                  (current (gensym) (gensym))
3022                  (vars (list current) (cons current vars))
3023                  (result t (if not-p
3024                                `(if (,predicate ,current ,last)
3025                                     nil ,result)
3026                                `(if (,predicate ,current ,last)
3027                                     ,result nil))))
3028                ((zerop i)
3029                 `((lambda ,vars ,result) . ,args)))))))
3030
3031 (define-source-transform = (&rest args) (multi-compare '= args nil))
3032 (define-source-transform < (&rest args) (multi-compare '< args nil))
3033 (define-source-transform > (&rest args) (multi-compare '> args nil))
3034 (define-source-transform <= (&rest args) (multi-compare '> args t))
3035 (define-source-transform >= (&rest args) (multi-compare '< args t))
3036
3037 (define-source-transform char= (&rest args) (multi-compare 'char= args nil))
3038 (define-source-transform char< (&rest args) (multi-compare 'char< args nil))
3039 (define-source-transform char> (&rest args) (multi-compare 'char> args nil))
3040 (define-source-transform char<= (&rest args) (multi-compare 'char> args t))
3041 (define-source-transform char>= (&rest args) (multi-compare 'char< args t))
3042
3043 (define-source-transform char-equal (&rest args)
3044   (multi-compare 'char-equal args nil))
3045 (define-source-transform char-lessp (&rest args)
3046   (multi-compare 'char-lessp args nil))
3047 (define-source-transform char-greaterp (&rest args)
3048   (multi-compare 'char-greaterp args nil))
3049 (define-source-transform char-not-greaterp (&rest args)
3050   (multi-compare 'char-greaterp args t))
3051 (define-source-transform char-not-lessp (&rest args)
3052   (multi-compare 'char-lessp args t))
3053
3054 ;;; This function does source transformation of N-arg inequality
3055 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
3056 ;;; arg cases. If there are more than two args, then we expand into
3057 ;;; the appropriate n^2 comparisons only when speed is important.
3058 (declaim (ftype (function (symbol list) *) multi-not-equal))
3059 (defun multi-not-equal (predicate args)
3060   (let ((nargs (length args)))
3061     (cond ((< nargs 1) (values nil t))
3062           ((= nargs 1) `(progn ,@args t))
3063           ((= nargs 2)
3064            `(if (,predicate ,(first args) ,(second args)) nil t))
3065           ((not (policy *lexenv*
3066                         (and (>= speed space)
3067                              (>= speed compilation-speed))))
3068            (values nil t))
3069           (t
3070            (let ((vars (make-gensym-list nargs)))
3071              (do ((var vars next)
3072                   (next (cdr vars) (cdr next))
3073                   (result t))
3074                  ((null next)
3075                   `((lambda ,vars ,result) . ,args))
3076                (let ((v1 (first var)))
3077                  (dolist (v2 next)
3078                    (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
3079
3080 (define-source-transform /= (&rest args) (multi-not-equal '= args))
3081 (define-source-transform char/= (&rest args) (multi-not-equal 'char= args))
3082 (define-source-transform char-not-equal (&rest args)
3083   (multi-not-equal 'char-equal args))
3084
3085 ;;; Expand MAX and MIN into the obvious comparisons.
3086 (define-source-transform max (arg &rest more-args)
3087   (if (null more-args)
3088       `(values ,arg)
3089       (once-only ((arg1 arg)
3090                   (arg2 `(max ,@more-args)))
3091         `(if (> ,arg1 ,arg2)
3092              ,arg1 ,arg2))))
3093 (define-source-transform min (arg &rest more-args)
3094   (if (null more-args)
3095       `(values ,arg)
3096       (once-only ((arg1 arg)
3097                   (arg2 `(min ,@more-args)))
3098         `(if (< ,arg1 ,arg2)
3099              ,arg1 ,arg2))))
3100 \f
3101 ;;;; converting N-arg arithmetic functions
3102 ;;;;
3103 ;;;; N-arg arithmetic and logic functions are associated into two-arg
3104 ;;;; versions, and degenerate cases are flushed.
3105
3106 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
3107 (declaim (ftype (function (symbol t list) list) associate-args))
3108 (defun associate-args (function first-arg more-args)
3109   (let ((next (rest more-args))
3110         (arg (first more-args)))
3111     (if (null next)
3112         `(,function ,first-arg ,arg)
3113         (associate-args function `(,function ,first-arg ,arg) next))))
3114
3115 ;;; Do source transformations for transitive functions such as +.
3116 ;;; One-arg cases are replaced with the arg and zero arg cases with
3117 ;;; the identity. If LEAF-FUN is true, then replace two-arg calls with
3118 ;;; a call to that function.
3119 (defun source-transform-transitive (fun args identity &optional leaf-fun)
3120   (declare (symbol fun leaf-fun) (list args))
3121   (case (length args)
3122     (0 identity)
3123     (1 `(values ,(first args)))
3124     (2 (if leaf-fun
3125            `(,leaf-fun ,(first args) ,(second args))
3126            (values nil t)))
3127     (t
3128      (associate-args fun (first args) (rest args)))))
3129
3130 (define-source-transform + (&rest args)
3131   (source-transform-transitive '+ args 0))
3132 (define-source-transform * (&rest args)
3133   (source-transform-transitive '* args 1))
3134 (define-source-transform logior (&rest args)
3135   (source-transform-transitive 'logior args 0))
3136 (define-source-transform logxor (&rest args)
3137   (source-transform-transitive 'logxor args 0))
3138 (define-source-transform logand (&rest args)
3139   (source-transform-transitive 'logand args -1))
3140
3141 (define-source-transform logeqv (&rest args)
3142   (if (evenp (length args))
3143       `(lognot (logxor ,@args))
3144       `(logxor ,@args)))
3145
3146 ;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM
3147 ;;; because when they are given one argument, they return its absolute
3148 ;;; value.
3149
3150 (define-source-transform gcd (&rest args)
3151   (case (length args)
3152     (0 0)
3153     (1 `(abs (the integer ,(first args))))
3154     (2 (values nil t))
3155     (t (associate-args 'gcd (first args) (rest args)))))
3156
3157 (define-source-transform lcm (&rest args)
3158   (case (length args)
3159     (0 1)
3160     (1 `(abs (the integer ,(first args))))
3161     (2 (values nil t))
3162     (t (associate-args 'lcm (first args) (rest args)))))
3163
3164 ;;; Do source transformations for intransitive n-arg functions such as
3165 ;;; /. With one arg, we form the inverse. With two args we pass.
3166 ;;; Otherwise we associate into two-arg calls.
3167 (declaim (ftype (function (symbol list t) list) source-transform-intransitive))
3168 (defun source-transform-intransitive (function args inverse)
3169   (case (length args)
3170     ((0 2) (values nil t))
3171     (1 `(,@inverse ,(first args)))
3172     (t (associate-args function (first args) (rest args)))))
3173
3174 (define-source-transform - (&rest args)
3175   (source-transform-intransitive '- args '(%negate)))
3176 (define-source-transform / (&rest args)
3177   (source-transform-intransitive '/ args '(/ 1)))
3178 \f
3179 ;;;; transforming APPLY
3180
3181 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
3182 ;;; only needs to understand one kind of variable-argument call. It is
3183 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
3184 (define-source-transform apply (fun arg &rest more-args)
3185   (let ((args (cons arg more-args)))
3186     `(multiple-value-call ,fun
3187        ,@(mapcar (lambda (x)
3188                    `(values ,x))
3189                  (butlast args))
3190        (values-list ,(car (last args))))))
3191 \f
3192 ;;;; transforming FORMAT
3193 ;;;;
3194 ;;;; If the control string is a compile-time constant, then replace it
3195 ;;;; with a use of the FORMATTER macro so that the control string is
3196 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
3197 ;;;; or T and the control string is a function (i.e. FORMATTER), then
3198 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
3199
3200 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
3201                       :policy (> speed space))
3202   (unless (constant-continuation-p control)
3203     (give-up-ir1-transform "The control string is not a constant."))
3204   (let ((arg-names (make-gensym-list (length args))))
3205     `(lambda (dest control ,@arg-names)
3206        (declare (ignore control))
3207        (format dest (formatter ,(continuation-value control)) ,@arg-names))))
3208
3209 (deftransform format ((stream control &rest args) (stream function &rest t) *
3210                       :policy (> speed space))
3211   (let ((arg-names (make-gensym-list (length args))))
3212     `(lambda (stream control ,@arg-names)
3213        (funcall control stream ,@arg-names)
3214        nil)))
3215
3216 (deftransform format ((tee control &rest args) ((member t) function &rest t) *
3217                       :policy (> speed space))
3218   (let ((arg-names (make-gensym-list (length args))))
3219     `(lambda (tee control ,@arg-names)
3220        (declare (ignore tee))
3221        (funcall control *standard-output* ,@arg-names)
3222        nil)))
3223
3224 (defoptimizer (coerce derive-type) ((value type))
3225   (let ((value-type (continuation-type value))
3226         (type-type (continuation-type type)))
3227     (labels
3228         ((good-cons-type-p (cons-type)
3229            ;; Make sure the cons-type we're looking at is something
3230            ;; we're prepared to handle which is basically something
3231            ;; that array-element-type can return.
3232            (or (and (member-type-p cons-type)
3233                     (null (rest (member-type-members cons-type)))
3234                     (null (first (member-type-members cons-type))))
3235                (let ((car-type (cons-type-car-type cons-type)))
3236                  (and (member-type-p car-type)
3237                       (null (rest (member-type-members car-type)))
3238                       (or (symbolp (first (member-type-members car-type)))
3239                           (numberp (first (member-type-members car-type)))
3240                           (and (listp (first (member-type-members car-type)))
3241                                (numberp (first (first (member-type-members
3242                                                        car-type))))))
3243                       (good-cons-type-p (cons-type-cdr-type cons-type))))))
3244          (unconsify-type (good-cons-type)
3245            ;; Convert the "printed" respresentation of a cons
3246            ;; specifier into a type specifier.  That is, the specifier
3247            ;; (cons (eql signed-byte) (cons (eql 16) null)) is
3248            ;; converted to (signed-byte 16).
3249            (cond ((or (null good-cons-type)
3250                       (eq good-cons-type 'null))
3251                    nil)
3252                  ((and (eq (first good-cons-type) 'cons)
3253                        (eq (first (second good-cons-type)) 'member))
3254                    `(,(second (second good-cons-type))
3255                      ,@(unconsify-type (caddr good-cons-type))))))
3256          (coerceable-p (c-type)
3257            ;; Can the value be coerced to the given type?  Coerce is
3258            ;; complicated, so we don't handle every possible case
3259            ;; here---just the most common and easiest cases:
3260            ;;
3261            ;; o Any real can be coerced to a float type.
3262            ;; o Any number can be coerced to a complex single/double-float.
3263            ;; o An integer can be coerced to an integer.
3264            (let ((coerced-type c-type))
3265              (or (and (subtypep coerced-type 'float)
3266                       (csubtypep value-type (specifier-type 'real)))
3267                  (and (subtypep coerced-type
3268                                 '(or (complex single-float)
3269                                   (complex double-float)))
3270                       (csubtypep value-type (specifier-type 'number)))
3271                  (and (subtypep coerced-type 'integer)
3272                       (csubtypep value-type (specifier-type 'integer))))))
3273          (process-types (type)
3274            ;; FIXME:
3275            ;; This needs some work because we should be able to derive
3276            ;; the resulting type better than just the type arg of
3277            ;; coerce.  That is, if x is (integer 10 20), the (coerce x
3278            ;; 'double-float) should say (double-float 10d0 20d0)
3279            ;; instead of just double-float.
3280            (cond ((member-type-p type)
3281                    (let ((members (member-type-members type)))
3282                      (if (every #'coerceable-p members)
3283                        (specifier-type `(or ,@members))
3284                        *universal-type*)))
3285                  ((and (cons-type-p type)
3286                        (good-cons-type-p type))
3287                    (let ((c-type (unconsify-type (type-specifier type))))
3288                      (if (coerceable-p c-type)
3289                        (specifier-type c-type)
3290                        *universal-type*)))
3291                  (t
3292                    *universal-type*))))
3293       (cond ((union-type-p type-type)
3294               (apply #'type-union (mapcar #'process-types
3295                                           (union-type-types type-type))))
3296             ((or (member-type-p type-type)
3297                  (cons-type-p type-type))
3298               (process-types type-type))
3299             (t
3300               *universal-type*)))))
3301
3302 (defoptimizer (array-element-type derive-type) ((array))
3303   (let* ((array-type (continuation-type array)))
3304     (labels ((consify (list)
3305               (if (endp list)
3306                   '(eql nil)
3307                   `(cons (eql ,(car list)) ,(consify (rest list)))))
3308             (get-element-type (a)
3309               (let ((element-type
3310                      (type-specifier (array-type-specialized-element-type a))))
3311                 (cond ((eq element-type '*)
3312                        (specifier-type 'type-specifier))
3313                       ((symbolp element-type)
3314                        (make-member-type :members (list element-type)))
3315                       ((consp element-type)
3316                        (specifier-type (consify element-type)))
3317                       (t
3318                        (error "can't understand type ~S~%" element-type))))))
3319       (cond ((array-type-p array-type)
3320              (get-element-type array-type))
3321             ((union-type-p array-type)             
3322              (apply #'type-union
3323                     (mapcar #'get-element-type (union-type-types array-type))))
3324             (t
3325              *universal-type*)))))
3326 \f
3327 ;;;; debuggers' little helpers
3328
3329 ;;; for debugging when transforms are behaving mysteriously,
3330 ;;; e.g. when debugging a problem with an ASH transform
3331 ;;;   (defun foo (&optional s)
3332 ;;;     (sb-c::/report-continuation s "S outside WHEN")
3333 ;;;     (when (and (integerp s) (> s 3))
3334 ;;;       (sb-c::/report-continuation s "S inside WHEN")
3335 ;;;       (let ((bound (ash 1 (1- s))))
3336 ;;;         (sb-c::/report-continuation bound "BOUND")
3337 ;;;         (let ((x (- bound))
3338 ;;;               (y (1- bound)))
3339 ;;;           (sb-c::/report-continuation x "X")
3340 ;;;           (sb-c::/report-continuation x "Y"))
3341 ;;;         `(integer ,(- bound) ,(1- bound)))))
3342 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
3343 ;;; and the function doesn't do anything at all.)
3344 #!+sb-show
3345 (progn
3346   (defknown /report-continuation (t t) null)
3347   (deftransform /report-continuation ((x message) (t t))
3348     (format t "~%/in /REPORT-CONTINUATION~%")
3349     (format t "/(CONTINUATION-TYPE X)=~S~%" (continuation-type x))
3350     (when (constant-continuation-p x)
3351       (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
3352     (format t "/MESSAGE=~S~%" (continuation-value message))
3353     (give-up-ir1-transform "not a real transform"))
3354   (defun /report-continuation (&rest rest)
3355     (declare (ignore rest))))