eb540a84cb4e95442086f68acc9dea896c652eef
[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 :when :both)
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              (error "internal error 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              (error "internal error 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!vm:*target-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!vm:*target-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     ((frob-opt (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   ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
1715   (frob-opt floor floor-quotient-bound floor-rem-bound)
1716   (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
1717
1718 ;;; Define optimizers for FFLOOR and FCEILING
1719 (macrolet
1720     ((frob-opt (name q-name r-name)
1721        (let ((q-aux (symbolicate "F" q-name "-AUX"))
1722              (r-aux (symbolicate r-name "-AUX")))
1723          `(progn
1724            ;; Compute type of quotient (first) result.
1725            (defun ,q-aux (number-type divisor-type)
1726              (let* ((number-interval
1727                      (numeric-type->interval number-type))
1728                     (divisor-interval
1729                      (numeric-type->interval divisor-type))
1730                     (quot (,q-name (interval-div number-interval
1731                                                  divisor-interval)))
1732                     (res-type (numeric-contagion number-type divisor-type)))
1733                (make-numeric-type
1734                 :class (numeric-type-class res-type)
1735                 :format (numeric-type-format res-type)
1736                 :low  (interval-low quot)
1737                 :high (interval-high quot))))
1738
1739            (defoptimizer (,name derive-type) ((number divisor))
1740              (flet ((derive-q (n d same-arg)
1741                       (declare (ignore same-arg))
1742                       (if (and (numeric-type-real-p n)
1743                                (numeric-type-real-p d))
1744                           (,q-aux n d)
1745                           *empty-type*))
1746                     (derive-r (n d same-arg)
1747                       (declare (ignore same-arg))
1748                       (if (and (numeric-type-real-p n)
1749                                (numeric-type-real-p d))
1750                           (,r-aux n d)
1751                           *empty-type*)))
1752                (let ((quot (two-arg-derive-type
1753                             number divisor #'derive-q #',name))
1754                      (rem (two-arg-derive-type
1755                            number divisor #'derive-r #'mod)))
1756                  (when (and quot rem)
1757                    (make-values-type :required (list quot rem))))))))))
1758
1759   ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
1760   (frob-opt ffloor floor-quotient-bound floor-rem-bound)
1761   (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
1762
1763 ;;; functions to compute the bounds on the quotient and remainder for
1764 ;;; the FLOOR function
1765 (defun floor-quotient-bound (quot)
1766   ;; Take the floor of the quotient and then massage it into what we
1767   ;; need.
1768   (let ((lo (interval-low quot))
1769         (hi (interval-high quot)))
1770     ;; Take the floor of the lower bound. The result is always a
1771     ;; closed lower bound.
1772     (setf lo (if lo
1773                  (floor (type-bound-number lo))
1774                  nil))
1775     ;; For the upper bound, we need to be careful.
1776     (setf hi
1777           (cond ((consp hi)
1778                  ;; An open bound. We need to be careful here because
1779                  ;; the floor of '(10.0) is 9, but the floor of
1780                  ;; 10.0 is 10.
1781                  (multiple-value-bind (q r) (floor (first hi))
1782                    (if (zerop r)
1783                        (1- q)
1784                        q)))
1785                 (hi
1786                  ;; A closed bound, so the answer is obvious.
1787                  (floor hi))
1788                 (t
1789                  hi)))
1790     (make-interval :low lo :high hi)))
1791 (defun floor-rem-bound (div)
1792   ;; The remainder depends only on the divisor. Try to get the
1793   ;; correct sign for the remainder if we can.
1794   (case (interval-range-info div)
1795     (+
1796      ;; The divisor is always positive.
1797      (let ((rem (interval-abs div)))
1798        (setf (interval-low rem) 0)
1799        (when (and (numberp (interval-high rem))
1800                   (not (zerop (interval-high rem))))
1801          ;; The remainder never contains the upper bound. However,
1802          ;; watch out for the case where the high limit is zero!
1803          (setf (interval-high rem) (list (interval-high rem))))
1804        rem))
1805     (-
1806      ;; The divisor is always negative.
1807      (let ((rem (interval-neg (interval-abs div))))
1808        (setf (interval-high rem) 0)
1809        (when (numberp (interval-low rem))
1810          ;; The remainder never contains the lower bound.
1811          (setf (interval-low rem) (list (interval-low rem))))
1812        rem))
1813     (otherwise
1814      ;; The divisor can be positive or negative. All bets off. The
1815      ;; magnitude of remainder is the maximum value of the divisor.
1816      (let ((limit (type-bound-number (interval-high (interval-abs div)))))
1817        ;; The bound never reaches the limit, so make the interval open.
1818        (make-interval :low (if limit
1819                                (list (- limit))
1820                                limit)
1821                       :high (list limit))))))
1822 #| Test cases
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.3)))
1826 => #S(INTERVAL :LOW 0 :HIGH 10)
1827 (floor-quotient-bound (make-interval :low 0.3 :high 10))
1828 => #S(INTERVAL :LOW 0 :HIGH 10)
1829 (floor-quotient-bound (make-interval :low 0.3 :high '(10)))
1830 => #S(INTERVAL :LOW 0 :HIGH 9)
1831 (floor-quotient-bound (make-interval :low '(0.3) :high 10.3))
1832 => #S(INTERVAL :LOW 0 :HIGH 10)
1833 (floor-quotient-bound (make-interval :low '(0.0) :high 10.3))
1834 => #S(INTERVAL :LOW 0 :HIGH 10)
1835 (floor-quotient-bound (make-interval :low '(-1.3) :high 10.3))
1836 => #S(INTERVAL :LOW -2 :HIGH 10)
1837 (floor-quotient-bound (make-interval :low '(-1.0) :high 10.3))
1838 => #S(INTERVAL :LOW -1 :HIGH 10)
1839 (floor-quotient-bound (make-interval :low -1.0 :high 10.3))
1840 => #S(INTERVAL :LOW -1 :HIGH 10)
1841
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 0.3 :high '(10.3)))
1845 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
1846 (floor-rem-bound (make-interval :low -10 :high -2.3))
1847 #S(INTERVAL :LOW (-10) :HIGH 0)
1848 (floor-rem-bound (make-interval :low 0.3 :high 10))
1849 => #S(INTERVAL :LOW 0 :HIGH '(10))
1850 (floor-rem-bound (make-interval :low '(-1.3) :high 10.3))
1851 => #S(INTERVAL :LOW '(-10.3) :HIGH '(10.3))
1852 (floor-rem-bound (make-interval :low '(-20.3) :high 10.3))
1853 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
1854 |#
1855 \f
1856 ;;; same functions for CEILING
1857 (defun ceiling-quotient-bound (quot)
1858   ;; Take the ceiling of the quotient and then massage it into what we
1859   ;; need.
1860   (let ((lo (interval-low quot))
1861         (hi (interval-high quot)))
1862     ;; Take the ceiling of the upper bound. The result is always a
1863     ;; closed upper bound.
1864     (setf hi (if hi
1865                  (ceiling (type-bound-number hi))
1866                  nil))
1867     ;; For the lower bound, we need to be careful.
1868     (setf lo
1869           (cond ((consp lo)
1870                  ;; An open bound. We need to be careful here because
1871                  ;; the ceiling of '(10.0) is 11, but the ceiling of
1872                  ;; 10.0 is 10.
1873                  (multiple-value-bind (q r) (ceiling (first lo))
1874                    (if (zerop r)
1875                        (1+ q)
1876                        q)))
1877                 (lo
1878                  ;; A closed bound, so the answer is obvious.
1879                  (ceiling lo))
1880                 (t
1881                  lo)))
1882     (make-interval :low lo :high hi)))
1883 (defun ceiling-rem-bound (div)
1884   ;; The remainder depends only on the divisor. Try to get the
1885   ;; correct sign for the remainder if we can.
1886   (case (interval-range-info div)
1887     (+
1888      ;; Divisor is always positive. The remainder is negative.
1889      (let ((rem (interval-neg (interval-abs div))))
1890        (setf (interval-high rem) 0)
1891        (when (and (numberp (interval-low rem))
1892                   (not (zerop (interval-low rem))))
1893          ;; The remainder never contains the upper bound. However,
1894          ;; watch out for the case when the upper bound is zero!
1895          (setf (interval-low rem) (list (interval-low rem))))
1896        rem))
1897     (-
1898      ;; Divisor is always negative. The remainder is positive
1899      (let ((rem (interval-abs div)))
1900        (setf (interval-low rem) 0)
1901        (when (numberp (interval-high rem))
1902          ;; The remainder never contains the lower bound.
1903          (setf (interval-high rem) (list (interval-high rem))))
1904        rem))
1905     (otherwise
1906      ;; The divisor can be positive or negative. All bets off. The
1907      ;; magnitude of remainder is the maximum value of the divisor.
1908      (let ((limit (type-bound-number (interval-high (interval-abs div)))))
1909        ;; The bound never reaches the limit, so make the interval open.
1910        (make-interval :low (if limit
1911                                (list (- limit))
1912                                limit)
1913                       :high (list limit))))))
1914
1915 #| Test cases
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.3)))
1919 => #S(INTERVAL :LOW 1 :HIGH 11)
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)))
1923 => #S(INTERVAL :LOW 1 :HIGH 10)
1924 (ceiling-quotient-bound (make-interval :low '(0.3) :high 10.3))
1925 => #S(INTERVAL :LOW 1 :HIGH 11)
1926 (ceiling-quotient-bound (make-interval :low '(0.0) :high 10.3))
1927 => #S(INTERVAL :LOW 1 :HIGH 11)
1928 (ceiling-quotient-bound (make-interval :low '(-1.3) :high 10.3))
1929 => #S(INTERVAL :LOW -1 :HIGH 11)
1930 (ceiling-quotient-bound (make-interval :low '(-1.0) :high 10.3))
1931 => #S(INTERVAL :LOW 0 :HIGH 11)
1932 (ceiling-quotient-bound (make-interval :low -1.0 :high 10.3))
1933 => #S(INTERVAL :LOW -1 :HIGH 11)
1934
1935 (ceiling-rem-bound (make-interval :low 0.3 :high 10.3))
1936 => #S(INTERVAL :LOW (-10.3) :HIGH 0)
1937 (ceiling-rem-bound (make-interval :low 0.3 :high '(10.3)))
1938 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
1939 (ceiling-rem-bound (make-interval :low -10 :high -2.3))
1940 => #S(INTERVAL :LOW 0 :HIGH (10))
1941 (ceiling-rem-bound (make-interval :low 0.3 :high 10))
1942 => #S(INTERVAL :LOW (-10) :HIGH 0)
1943 (ceiling-rem-bound (make-interval :low '(-1.3) :high 10.3))
1944 => #S(INTERVAL :LOW (-10.3) :HIGH (10.3))
1945 (ceiling-rem-bound (make-interval :low '(-20.3) :high 10.3))
1946 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
1947 |#
1948 \f
1949 (defun truncate-quotient-bound (quot)
1950   ;; For positive quotients, truncate is exactly like floor. For
1951   ;; negative quotients, truncate is exactly like ceiling. Otherwise,
1952   ;; it's the union of the two pieces.
1953   (case (interval-range-info quot)
1954     (+
1955      ;; just like FLOOR
1956      (floor-quotient-bound quot))
1957     (-
1958      ;; just like CEILING
1959      (ceiling-quotient-bound quot))
1960     (otherwise
1961      ;; Split the interval into positive and negative pieces, compute
1962      ;; the result for each piece and put them back together.
1963      (destructuring-bind (neg pos) (interval-split 0 quot t t)
1964        (interval-merge-pair (ceiling-quotient-bound neg)
1965                             (floor-quotient-bound pos))))))
1966
1967 (defun truncate-rem-bound (num div)
1968   ;; This is significantly more complicated than FLOOR or CEILING. We
1969   ;; need both the number and the divisor to determine the range. The
1970   ;; basic idea is to split the ranges of NUM and DEN into positive
1971   ;; and negative pieces and deal with each of the four possibilities
1972   ;; in turn.
1973   (case (interval-range-info num)
1974     (+
1975      (case (interval-range-info div)
1976        (+
1977         (floor-rem-bound div))
1978        (-
1979         (ceiling-rem-bound div))
1980        (otherwise
1981         (destructuring-bind (neg pos) (interval-split 0 div t t)
1982           (interval-merge-pair (truncate-rem-bound num neg)
1983                                (truncate-rem-bound num pos))))))
1984     (-
1985      (case (interval-range-info div)
1986        (+
1987         (ceiling-rem-bound div))
1988        (-
1989         (floor-rem-bound div))
1990        (otherwise
1991         (destructuring-bind (neg pos) (interval-split 0 div t t)
1992           (interval-merge-pair (truncate-rem-bound num neg)
1993                                (truncate-rem-bound num pos))))))
1994     (otherwise
1995      (destructuring-bind (neg pos) (interval-split 0 num t t)
1996        (interval-merge-pair (truncate-rem-bound neg div)
1997                             (truncate-rem-bound pos div))))))
1998 ) ; PROGN
1999
2000 ;;; Derive useful information about the range. Returns three values:
2001 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2002 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2003 ;;; - The abs of the maximal value if there is one, or nil if it is
2004 ;;;   unbounded.
2005 (defun numeric-range-info (low high)
2006   (cond ((and low (not (minusp low)))
2007          (values '+ low high))
2008         ((and high (not (plusp high)))
2009          (values '- (- high) (if low (- low) nil)))
2010         (t
2011          (values nil 0 (and low high (max (- low) high))))))
2012
2013 (defun integer-truncate-derive-type
2014        (number-low number-high divisor-low divisor-high)
2015   ;; The result cannot be larger in magnitude than the number, but the
2016   ;; sign might change. If we can determine the sign of either the
2017   ;; number or the divisor, we can eliminate some of the cases.
2018   (multiple-value-bind (number-sign number-min number-max)
2019       (numeric-range-info number-low number-high)
2020     (multiple-value-bind (divisor-sign divisor-min divisor-max)
2021         (numeric-range-info divisor-low divisor-high)
2022       (when (and divisor-max (zerop divisor-max))
2023         ;; We've got a problem: guaranteed division by zero.
2024         (return-from integer-truncate-derive-type t))
2025       (when (zerop divisor-min)
2026         ;; We'll assume that they aren't going to divide by zero.
2027         (incf divisor-min))
2028       (cond ((and number-sign divisor-sign)
2029              ;; We know the sign of both.
2030              (if (eq number-sign divisor-sign)
2031                  ;; Same sign, so the result will be positive.
2032                  `(integer ,(if divisor-max
2033                                 (truncate number-min divisor-max)
2034                                 0)
2035                            ,(if number-max
2036                                 (truncate number-max divisor-min)
2037                                 '*))
2038                  ;; Different signs, the result will be negative.
2039                  `(integer ,(if number-max
2040                                 (- (truncate number-max divisor-min))
2041                                 '*)
2042                            ,(if divisor-max
2043                                 (- (truncate number-min divisor-max))
2044                                 0))))
2045             ((eq divisor-sign '+)
2046              ;; The divisor is positive. Therefore, the number will just
2047              ;; become closer to zero.
2048              `(integer ,(if number-low
2049                             (truncate number-low divisor-min)
2050                             '*)
2051                        ,(if number-high
2052                             (truncate number-high divisor-min)
2053                             '*)))
2054             ((eq divisor-sign '-)
2055              ;; The divisor is negative. Therefore, the absolute value of
2056              ;; the number will become closer to zero, but the sign will also
2057              ;; change.
2058              `(integer ,(if number-high
2059                             (- (truncate number-high divisor-min))
2060                             '*)
2061                        ,(if number-low
2062                             (- (truncate number-low divisor-min))
2063                             '*)))
2064             ;; The divisor could be either positive or negative.
2065             (number-max
2066              ;; The number we are dividing has a bound. Divide that by the
2067              ;; smallest posible divisor.
2068              (let ((bound (truncate number-max divisor-min)))
2069                `(integer ,(- bound) ,bound)))
2070             (t
2071              ;; The number we are dividing is unbounded, so we can't tell
2072              ;; anything about the result.
2073              `integer)))))
2074
2075 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2076 (defun integer-rem-derive-type
2077        (number-low number-high divisor-low divisor-high)
2078   (if (and divisor-low divisor-high)
2079       ;; We know the range of the divisor, and the remainder must be
2080       ;; smaller than the divisor. We can tell the sign of the
2081       ;; remainer if we know the sign of the number.
2082       (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
2083         `(integer ,(if (or (null number-low)
2084                            (minusp number-low))
2085                        (- divisor-max)
2086                        0)
2087                   ,(if (or (null number-high)
2088                            (plusp number-high))
2089                        divisor-max
2090                        0)))
2091       ;; The divisor is potentially either very positive or very
2092       ;; negative. Therefore, the remainer is unbounded, but we might
2093       ;; be able to tell something about the sign from the number.
2094       `(integer ,(if (and number-low (not (minusp number-low)))
2095                      ;; The number we are dividing is positive.
2096                      ;; Therefore, the remainder must be positive.
2097                      0
2098                      '*)
2099                 ,(if (and number-high (not (plusp number-high)))
2100                      ;; The number we are dividing is negative.
2101                      ;; Therefore, the remainder must be negative.
2102                      0
2103                      '*))))
2104
2105 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2106 (defoptimizer (random derive-type) ((bound &optional state))
2107   (let ((type (continuation-type bound)))
2108     (when (numeric-type-p type)
2109       (let ((class (numeric-type-class type))
2110             (high (numeric-type-high type))
2111             (format (numeric-type-format type)))
2112         (make-numeric-type
2113          :class class
2114          :format format
2115          :low (coerce 0 (or format class 'real))
2116          :high (cond ((not high) nil)
2117                      ((eq class 'integer) (max (1- high) 0))
2118                      ((or (consp high) (zerop high)) high)
2119                      (t `(,high))))))))
2120
2121 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2122 (defun random-derive-type-aux (type)
2123   (let ((class (numeric-type-class type))
2124         (high (numeric-type-high type))
2125         (format (numeric-type-format type)))
2126     (make-numeric-type
2127          :class class
2128          :format format
2129          :low (coerce 0 (or format class 'real))
2130          :high (cond ((not high) nil)
2131                      ((eq class 'integer) (max (1- high) 0))
2132                      ((or (consp high) (zerop high)) high)
2133                      (t `(,high))))))
2134
2135 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2136 (defoptimizer (random derive-type) ((bound &optional state))
2137   (one-arg-derive-type bound #'random-derive-type-aux nil))
2138 \f
2139 ;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends
2140
2141 ;;; Return the maximum number of bits an integer of the supplied type
2142 ;;; can take up, or NIL if it is unbounded. The second (third) value
2143 ;;; is T if the integer can be positive (negative) and NIL if not.
2144 ;;; Zero counts as positive.
2145 (defun integer-type-length (type)
2146   (if (numeric-type-p type)
2147       (let ((min (numeric-type-low type))
2148             (max (numeric-type-high type)))
2149         (values (and min max (max (integer-length min) (integer-length max)))
2150                 (or (null max) (not (minusp max)))
2151                 (or (null min) (minusp min))))
2152       (values nil t t)))
2153
2154 (defun logand-derive-type-aux (x y &optional same-leaf)
2155   (declare (ignore same-leaf))
2156   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2157     (declare (ignore x-pos))
2158     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length  y)
2159       (declare (ignore y-pos))
2160       (if (not x-neg)
2161           ;; X must be positive.
2162           (if (not y-neg)
2163               ;; They must both be positive.
2164               (cond ((or (null x-len) (null y-len))
2165                      (specifier-type 'unsigned-byte))
2166                     ((or (zerop x-len) (zerop y-len))
2167                      (specifier-type '(integer 0 0)))
2168                     (t
2169                      (specifier-type `(unsigned-byte ,(min x-len y-len)))))
2170               ;; X is positive, but Y might be negative.
2171               (cond ((null x-len)
2172                      (specifier-type 'unsigned-byte))
2173                     ((zerop x-len)
2174                      (specifier-type '(integer 0 0)))
2175                     (t
2176                      (specifier-type `(unsigned-byte ,x-len)))))
2177           ;; X might be negative.
2178           (if (not y-neg)
2179               ;; Y must be positive.
2180               (cond ((null y-len)
2181                      (specifier-type 'unsigned-byte))
2182                     ((zerop y-len)
2183                      (specifier-type '(integer 0 0)))
2184                     (t
2185                      (specifier-type
2186                       `(unsigned-byte ,y-len))))
2187               ;; Either might be negative.
2188               (if (and x-len y-len)
2189                   ;; The result is bounded.
2190                   (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2191                   ;; We can't tell squat about the result.
2192                   (specifier-type 'integer)))))))
2193
2194 (defun logior-derive-type-aux (x y &optional same-leaf)
2195   (declare (ignore same-leaf))
2196   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2197     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
2198       (cond
2199        ((and (not x-neg) (not y-neg))
2200         ;; Both are positive.
2201         (if (and x-len y-len (zerop x-len) (zerop y-len))
2202             (specifier-type '(integer 0 0))
2203             (specifier-type `(unsigned-byte ,(if (and x-len y-len)
2204                                              (max x-len y-len)
2205                                              '*)))))
2206        ((not x-pos)
2207         ;; X must be negative.
2208         (if (not y-pos)
2209             ;; Both are negative. The result is going to be negative
2210             ;; and be the same length or shorter than the smaller.
2211             (if (and x-len y-len)
2212                 ;; It's bounded.
2213                 (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
2214                 ;; It's unbounded.
2215                 (specifier-type '(integer * -1)))
2216             ;; X is negative, but we don't know about Y. The result
2217             ;; will be negative, but no more negative than X.
2218             (specifier-type
2219              `(integer ,(or (numeric-type-low x) '*)
2220                        -1))))
2221        (t
2222         ;; X might be either positive or negative.
2223         (if (not y-pos)
2224             ;; But Y is negative. The result will be negative.
2225             (specifier-type
2226              `(integer ,(or (numeric-type-low y) '*)
2227                        -1))
2228             ;; We don't know squat about either. It won't get any bigger.
2229             (if (and x-len y-len)
2230                 ;; Bounded.
2231                 (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2232                 ;; Unbounded.
2233                 (specifier-type 'integer))))))))
2234
2235 (defun logxor-derive-type-aux (x y &optional same-leaf)
2236   (declare (ignore same-leaf))
2237   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2238     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
2239       (cond
2240        ((or (and (not x-neg) (not y-neg))
2241             (and (not x-pos) (not y-pos)))
2242         ;; Either both are negative or both are positive. The result
2243         ;; will be positive, and as long as the longer.
2244         (if (and x-len y-len (zerop x-len) (zerop y-len))
2245             (specifier-type '(integer 0 0))
2246             (specifier-type `(unsigned-byte ,(if (and x-len y-len)
2247                                              (max x-len y-len)
2248                                              '*)))))
2249        ((or (and (not x-pos) (not y-neg))
2250             (and (not y-neg) (not y-pos)))
2251         ;; Either X is negative and Y is positive of vice-versa. The
2252         ;; result will be negative.
2253         (specifier-type `(integer ,(if (and x-len y-len)
2254                                        (ash -1 (max x-len y-len))
2255                                        '*)
2256                                   -1)))
2257        ;; We can't tell what the sign of the result is going to be.
2258        ;; All we know is that we don't create new bits.
2259        ((and x-len y-len)
2260         (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
2261        (t
2262         (specifier-type 'integer))))))
2263
2264 (macrolet ((deffrob (logfcn)
2265              (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
2266              `(defoptimizer (,logfcn derive-type) ((x y))
2267                 (two-arg-derive-type x y #',fcn-aux #',logfcn)))))
2268   (deffrob logand)
2269   (deffrob logior)
2270   (deffrob logxor))
2271 \f
2272 ;;;; miscellaneous derive-type methods
2273
2274 (defoptimizer (integer-length derive-type) ((x))
2275   (let ((x-type (continuation-type x)))
2276     (when (and (numeric-type-p x-type)
2277                (csubtypep x-type (specifier-type 'integer)))
2278       ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2279       ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically.  Be
2280       ;; careful about LO or HI being NIL, though.  Also, if 0 is
2281       ;; contained in X, the lower bound is obviously 0.
2282       (flet ((null-or-min (a b)
2283                (and a b (min (integer-length a)
2284                              (integer-length b))))
2285              (null-or-max (a b)
2286                (and a b (max (integer-length a)
2287                              (integer-length b)))))
2288         (let* ((min (numeric-type-low x-type))
2289                (max (numeric-type-high x-type))
2290                (min-len (null-or-min min max))
2291                (max-len (null-or-max min max)))
2292           (when (ctypep 0 x-type)
2293             (setf min-len 0))
2294           (specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
2295
2296 (defoptimizer (code-char derive-type) ((code))
2297   (specifier-type 'base-char))
2298
2299 (defoptimizer (values derive-type) ((&rest values))
2300   (values-specifier-type
2301    `(values ,@(mapcar (lambda (x)
2302                         (type-specifier (continuation-type x)))
2303                       values))))
2304 \f
2305 ;;;; byte operations
2306 ;;;;
2307 ;;;; We try to turn byte operations into simple logical operations.
2308 ;;;; First, we convert byte specifiers into separate size and position
2309 ;;;; arguments passed to internal %FOO functions. We then attempt to
2310 ;;;; transform the %FOO functions into boolean operations when the
2311 ;;;; size and position are constant and the operands are fixnums.
2312
2313 (macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to
2314            ;; expressions that evaluate to the SIZE and POSITION of
2315            ;; the byte-specifier form SPEC. We may wrap a let around
2316            ;; the result of the body to bind some variables.
2317            ;;
2318            ;; If the spec is a BYTE form, then bind the vars to the
2319            ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE
2320            ;; and BYTE-POSITION. The goal of this transformation is to
2321            ;; avoid consing up byte specifiers and then immediately
2322            ;; throwing them away.
2323            (with-byte-specifier ((size-var pos-var spec) &body body)
2324              (once-only ((spec `(macroexpand ,spec))
2325                          (temp '(gensym)))
2326                         `(if (and (consp ,spec)
2327                                   (eq (car ,spec) 'byte)
2328                                   (= (length ,spec) 3))
2329                         (let ((,size-var (second ,spec))
2330                               (,pos-var (third ,spec)))
2331                           ,@body)
2332                         (let ((,size-var `(byte-size ,,temp))
2333                               (,pos-var `(byte-position ,,temp)))
2334                           `(let ((,,temp ,,spec))
2335                              ,,@body))))))
2336
2337   (define-source-transform ldb (spec int)
2338     (with-byte-specifier (size pos spec)
2339       `(%ldb ,size ,pos ,int)))
2340
2341   (define-source-transform dpb (newbyte spec int)
2342     (with-byte-specifier (size pos spec)
2343       `(%dpb ,newbyte ,size ,pos ,int)))
2344
2345   (define-source-transform mask-field (spec int)
2346     (with-byte-specifier (size pos spec)
2347       `(%mask-field ,size ,pos ,int)))
2348
2349   (define-source-transform deposit-field (newbyte spec int)
2350     (with-byte-specifier (size pos spec)
2351       `(%deposit-field ,newbyte ,size ,pos ,int))))
2352
2353 (defoptimizer (%ldb derive-type) ((size posn num))
2354   (let ((size (continuation-type size)))
2355     (if (and (numeric-type-p size)
2356              (csubtypep size (specifier-type 'integer)))
2357         (let ((size-high (numeric-type-high size)))
2358           (if (and size-high (<= size-high sb!vm:n-word-bits))
2359               (specifier-type `(unsigned-byte ,size-high))
2360               (specifier-type 'unsigned-byte)))
2361         *universal-type*)))
2362
2363 (defoptimizer (%mask-field derive-type) ((size posn num))
2364   (let ((size (continuation-type size))
2365         (posn (continuation-type posn)))
2366     (if (and (numeric-type-p size)
2367              (csubtypep size (specifier-type 'integer))
2368              (numeric-type-p posn)
2369              (csubtypep posn (specifier-type 'integer)))
2370         (let ((size-high (numeric-type-high size))
2371               (posn-high (numeric-type-high posn)))
2372           (if (and size-high posn-high
2373                    (<= (+ size-high posn-high) sb!vm:n-word-bits))
2374               (specifier-type `(unsigned-byte ,(+ size-high posn-high)))
2375               (specifier-type 'unsigned-byte)))
2376         *universal-type*)))
2377
2378 (defoptimizer (%dpb derive-type) ((newbyte size posn int))
2379   (let ((size (continuation-type size))
2380         (posn (continuation-type posn))
2381         (int (continuation-type int)))
2382     (if (and (numeric-type-p size)
2383              (csubtypep size (specifier-type 'integer))
2384              (numeric-type-p posn)
2385              (csubtypep posn (specifier-type 'integer))
2386              (numeric-type-p int)
2387              (csubtypep int (specifier-type 'integer)))
2388         (let ((size-high (numeric-type-high size))
2389               (posn-high (numeric-type-high posn))
2390               (high (numeric-type-high int))
2391               (low (numeric-type-low int)))
2392           (if (and size-high posn-high high low
2393                    (<= (+ size-high posn-high) sb!vm:n-word-bits))
2394               (specifier-type
2395                (list (if (minusp low) 'signed-byte 'unsigned-byte)
2396                      (max (integer-length high)
2397                           (integer-length low)
2398                           (+ size-high posn-high))))
2399               *universal-type*))
2400         *universal-type*)))
2401
2402 (defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
2403   (let ((size (continuation-type size))
2404         (posn (continuation-type posn))
2405         (int (continuation-type int)))
2406     (if (and (numeric-type-p size)
2407              (csubtypep size (specifier-type 'integer))
2408              (numeric-type-p posn)
2409              (csubtypep posn (specifier-type 'integer))
2410              (numeric-type-p int)
2411              (csubtypep int (specifier-type 'integer)))
2412         (let ((size-high (numeric-type-high size))
2413               (posn-high (numeric-type-high posn))
2414               (high (numeric-type-high int))
2415               (low (numeric-type-low int)))
2416           (if (and size-high posn-high high low
2417                    (<= (+ size-high posn-high) sb!vm:n-word-bits))
2418               (specifier-type
2419                (list (if (minusp low) 'signed-byte 'unsigned-byte)
2420                      (max (integer-length high)
2421                           (integer-length low)
2422                           (+ size-high posn-high))))
2423               *universal-type*))
2424         *universal-type*)))
2425
2426 (deftransform %ldb ((size posn int)
2427                     (fixnum fixnum integer)
2428                     (unsigned-byte #.sb!vm:n-word-bits))
2429   "convert to inline logical operations"
2430   `(logand (ash int (- posn))
2431            (ash ,(1- (ash 1 sb!vm:n-word-bits))
2432                 (- size ,sb!vm:n-word-bits))))
2433
2434 (deftransform %mask-field ((size posn int)
2435                            (fixnum fixnum integer)
2436                            (unsigned-byte #.sb!vm:n-word-bits))
2437   "convert to inline logical operations"
2438   `(logand int
2439            (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
2440                      (- size ,sb!vm:n-word-bits))
2441                 posn)))
2442
2443 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2444 ;;;   (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2445 ;;; as the result type, as that would allow result types that cover
2446 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2447 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2448
2449 (deftransform %dpb ((new size posn int)
2450                     *
2451                     (unsigned-byte #.sb!vm:n-word-bits))
2452   "convert to inline logical operations"
2453   `(let ((mask (ldb (byte size 0) -1)))
2454      (logior (ash (logand new mask) posn)
2455              (logand int (lognot (ash mask posn))))))
2456
2457 (deftransform %dpb ((new size posn int)
2458                     *
2459                     (signed-byte #.sb!vm:n-word-bits))
2460   "convert to inline logical operations"
2461   `(let ((mask (ldb (byte size 0) -1)))
2462      (logior (ash (logand new mask) posn)
2463              (logand int (lognot (ash mask posn))))))
2464
2465 (deftransform %deposit-field ((new size posn int)
2466                               *
2467                               (unsigned-byte #.sb!vm:n-word-bits))
2468   "convert to inline logical operations"
2469   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2470      (logior (logand new mask)
2471              (logand int (lognot mask)))))
2472
2473 (deftransform %deposit-field ((new size posn int)
2474                               *
2475                               (signed-byte #.sb!vm:n-word-bits))
2476   "convert to inline logical operations"
2477   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2478      (logior (logand new mask)
2479              (logand int (lognot mask)))))
2480 \f
2481 ;;; miscellanous numeric transforms
2482
2483 ;;; If a constant appears as the first arg, swap the args.
2484 (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
2485   (if (and (constant-continuation-p x)
2486            (not (constant-continuation-p y)))
2487       `(,(continuation-fun-name (basic-combination-fun node))
2488         y
2489         ,(continuation-value x))
2490       (give-up-ir1-transform)))
2491
2492 (dolist (x '(= char= + * logior logand logxor))
2493   (%deftransform x '(function * *) #'commutative-arg-swap
2494                  "place constant arg last"))
2495
2496 ;;; Handle the case of a constant BOOLE-CODE.
2497 (deftransform boole ((op x y) * * :when :both)
2498   "convert to inline logical operations"
2499   (unless (constant-continuation-p op)
2500     (give-up-ir1-transform "BOOLE code is not a constant."))
2501   (let ((control (continuation-value op)))
2502     (case control
2503       (#.boole-clr 0)
2504       (#.boole-set -1)
2505       (#.boole-1 'x)
2506       (#.boole-2 'y)
2507       (#.boole-c1 '(lognot x))
2508       (#.boole-c2 '(lognot y))
2509       (#.boole-and '(logand x y))
2510       (#.boole-ior '(logior x y))
2511       (#.boole-xor '(logxor x y))
2512       (#.boole-eqv '(logeqv x y))
2513       (#.boole-nand '(lognand x y))
2514       (#.boole-nor '(lognor x y))
2515       (#.boole-andc1 '(logandc1 x y))
2516       (#.boole-andc2 '(logandc2 x y))
2517       (#.boole-orc1 '(logorc1 x y))
2518       (#.boole-orc2 '(logorc2 x y))
2519       (t
2520        (abort-ir1-transform "~S is an illegal control arg to BOOLE."
2521                             control)))))
2522 \f
2523 ;;;; converting special case multiply/divide to shifts
2524
2525 ;;; If arg is a constant power of two, turn * into a shift.
2526 (deftransform * ((x y) (integer integer) * :when :both)
2527   "convert x*2^k to shift"
2528   (unless (constant-continuation-p y)
2529     (give-up-ir1-transform))
2530   (let* ((y (continuation-value y))
2531          (y-abs (abs y))
2532          (len (1- (integer-length y-abs))))
2533     (unless (= y-abs (ash 1 len))
2534       (give-up-ir1-transform))
2535     (if (minusp y)
2536         `(- (ash x ,len))
2537         `(ash x ,len))))
2538
2539 ;;; If both arguments and the result are (UNSIGNED-BYTE 32), try to
2540 ;;; come up with a ``better'' multiplication using multiplier
2541 ;;; recoding. There are two different ways the multiplier can be
2542 ;;; recoded. The more obvious is to shift X by the correct amount for
2543 ;;; each bit set in Y and to sum the results. But if there is a string
2544 ;;; of bits that are all set, you can add X shifted by one more then
2545 ;;; the bit position of the first set bit and subtract X shifted by
2546 ;;; the bit position of the last set bit. We can't use this second
2547 ;;; method when the high order bit is bit 31 because shifting by 32
2548 ;;; doesn't work too well.
2549 (deftransform * ((x y)
2550                  ((unsigned-byte 32) (unsigned-byte 32))
2551                  (unsigned-byte 32))
2552   "recode as shift and add"
2553   (unless (constant-continuation-p y)
2554     (give-up-ir1-transform))
2555   (let ((y (continuation-value y))
2556         (result nil)
2557         (first-one nil))
2558     (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
2559              (add (next-factor)
2560                (setf result
2561                      (tub32
2562                       (if result
2563                           `(+ ,result ,(tub32 next-factor))
2564                           next-factor)))))
2565       (declare (inline add))
2566       (dotimes (bitpos 32)
2567         (if first-one
2568             (when (not (logbitp bitpos y))
2569               (add (if (= (1+ first-one) bitpos)
2570                        ;; There is only a single bit in the string.
2571                        `(ash x ,first-one)
2572                        ;; There are at least two.
2573                        `(- ,(tub32 `(ash x ,bitpos))
2574                            ,(tub32 `(ash x ,first-one)))))
2575               (setf first-one nil))
2576             (when (logbitp bitpos y)
2577               (setf first-one bitpos))))
2578       (when first-one
2579         (cond ((= first-one 31))
2580               ((= first-one 30)
2581                (add '(ash x 30)))
2582               (t
2583                (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
2584         (add '(ash x 31))))
2585     (or result 0)))
2586
2587 ;;; If arg is a constant power of two, turn FLOOR into a shift and
2588 ;;; mask. If CEILING, add in (1- (ABS Y)) and then do FLOOR.
2589 (flet ((frob (y ceil-p)
2590          (unless (constant-continuation-p y)
2591            (give-up-ir1-transform))
2592          (let* ((y (continuation-value y))
2593                 (y-abs (abs y))
2594                 (len (1- (integer-length y-abs))))
2595            (unless (= y-abs (ash 1 len))
2596              (give-up-ir1-transform))
2597            (let ((shift (- len))
2598                  (mask (1- y-abs)))
2599              `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
2600                 ,(if (minusp y)
2601                      `(values (ash (- x) ,shift)
2602                               (- (logand (- x) ,mask)))
2603                      `(values (ash x ,shift)
2604                               (logand x ,mask))))))))
2605   (deftransform floor ((x y) (integer integer) *)
2606     "convert division by 2^k to shift"
2607     (frob y nil))
2608   (deftransform ceiling ((x y) (integer integer) *)
2609     "convert division by 2^k to shift"
2610     (frob y t)))
2611
2612 ;;; Do the same for MOD.
2613 (deftransform mod ((x y) (integer integer) * :when :both)
2614   "convert remainder mod 2^k to LOGAND"
2615   (unless (constant-continuation-p y)
2616     (give-up-ir1-transform))
2617   (let* ((y (continuation-value y))
2618          (y-abs (abs y))
2619          (len (1- (integer-length y-abs))))
2620     (unless (= y-abs (ash 1 len))
2621       (give-up-ir1-transform))
2622     (let ((mask (1- y-abs)))
2623       (if (minusp y)
2624           `(- (logand (- x) ,mask))
2625           `(logand x ,mask)))))
2626
2627 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
2628 (deftransform truncate ((x y) (integer integer))
2629   "convert division by 2^k to shift"
2630   (unless (constant-continuation-p y)
2631     (give-up-ir1-transform))
2632   (let* ((y (continuation-value y))
2633          (y-abs (abs y))
2634          (len (1- (integer-length y-abs))))
2635     (unless (= y-abs (ash 1 len))
2636       (give-up-ir1-transform))
2637     (let* ((shift (- len))
2638            (mask (1- y-abs)))
2639       `(if (minusp x)
2640            (values ,(if (minusp y)
2641                         `(ash (- x) ,shift)
2642                         `(- (ash (- x) ,shift)))
2643                    (- (logand (- x) ,mask)))
2644            (values ,(if (minusp y)
2645                         `(- (ash (- x) ,shift))
2646                         `(ash x ,shift))
2647                    (logand x ,mask))))))
2648
2649 ;;; And the same for REM.
2650 (deftransform rem ((x y) (integer integer) * :when :both)
2651   "convert remainder mod 2^k to LOGAND"
2652   (unless (constant-continuation-p y)
2653     (give-up-ir1-transform))
2654   (let* ((y (continuation-value y))
2655          (y-abs (abs y))
2656          (len (1- (integer-length y-abs))))
2657     (unless (= y-abs (ash 1 len))
2658       (give-up-ir1-transform))
2659     (let ((mask (1- y-abs)))
2660       `(if (minusp x)
2661            (- (logand (- x) ,mask))
2662            (logand x ,mask)))))
2663 \f
2664 ;;;; arithmetic and logical identity operation elimination
2665
2666 ;;; Flush calls to various arith functions that convert to the
2667 ;;; identity function or a constant.
2668 (macrolet ((def-frob (name identity result)
2669              `(deftransform ,name ((x y) (* (constant-arg (member ,identity)))
2670                                     * :when :both)
2671                 "fold identity operations"
2672                 ',result)))
2673   (def-frob ash 0 x)
2674   (def-frob logand -1 x)
2675   (def-frob logand 0 0)
2676   (def-frob logior 0 x)
2677   (def-frob logior -1 -1)
2678   (def-frob logxor -1 (lognot x))
2679   (def-frob logxor 0 x))
2680
2681 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
2682 ;;; (* 0 -4.0) is -0.0.
2683 (deftransform - ((x y) ((constant-arg (member 0)) rational) *
2684                  :when :both)
2685   "convert (- 0 x) to negate"
2686   '(%negate y))
2687 (deftransform * ((x y) (rational (constant-arg (member 0))) *
2688                  :when :both)
2689   "convert (* x 0) to 0"
2690   0)
2691
2692 ;;; Return T if in an arithmetic op including continuations X and Y,
2693 ;;; the result type is not affected by the type of X. That is, Y is at
2694 ;;; least as contagious as X.
2695 #+nil
2696 (defun not-more-contagious (x y)
2697   (declare (type continuation x y))
2698   (let ((x (continuation-type x))
2699         (y (continuation-type y)))
2700     (values (type= (numeric-contagion x y)
2701                    (numeric-contagion y y)))))
2702 ;;; Patched version by Raymond Toy. dtc: Should be safer although it
2703 ;;; XXX needs more work as valid transforms are missed; some cases are
2704 ;;; specific to particular transform functions so the use of this
2705 ;;; function may need a re-think.
2706 (defun not-more-contagious (x y)
2707   (declare (type continuation x y))
2708   (flet ((simple-numeric-type (num)
2709            (and (numeric-type-p num)
2710                 ;; Return non-NIL if NUM is integer, rational, or a float
2711                 ;; of some type (but not FLOAT)
2712                 (case (numeric-type-class num)
2713                   ((integer rational)
2714                    t)
2715                   (float
2716                    (numeric-type-format num))
2717                   (t
2718                    nil)))))
2719     (let ((x (continuation-type x))
2720           (y (continuation-type y)))
2721       (if (and (simple-numeric-type x)
2722                (simple-numeric-type y))
2723           (values (type= (numeric-contagion x y)
2724                          (numeric-contagion y y)))))))
2725
2726 ;;; Fold (+ x 0).
2727 ;;;
2728 ;;; If y is not constant, not zerop, or is contagious, or a positive
2729 ;;; float +0.0 then give up.
2730 (deftransform + ((x y) (t (constant-arg t)) * :when :both)
2731   "fold zero arg"
2732   (let ((val (continuation-value y)))
2733     (unless (and (zerop val)
2734                  (not (and (floatp val) (plusp (float-sign val))))
2735                  (not-more-contagious y x))
2736       (give-up-ir1-transform)))
2737   'x)
2738
2739 ;;; Fold (- x 0).
2740 ;;;
2741 ;;; If y is not constant, not zerop, or is contagious, or a negative
2742 ;;; float -0.0 then give up.
2743 (deftransform - ((x y) (t (constant-arg t)) * :when :both)
2744   "fold zero arg"
2745   (let ((val (continuation-value y)))
2746     (unless (and (zerop val)
2747                  (not (and (floatp val) (minusp (float-sign val))))
2748                  (not-more-contagious y x))
2749       (give-up-ir1-transform)))
2750   'x)
2751
2752 ;;; Fold (OP x +/-1)
2753 (macrolet ((def-frob (name result minus-result)
2754              `(deftransform ,name ((x y) (t (constant-arg real))
2755                                     * :when :both)
2756                 "fold identity operations"
2757                 (let ((val (continuation-value y)))
2758                   (unless (and (= (abs val) 1)
2759                                (not-more-contagious y x))
2760                     (give-up-ir1-transform))
2761                   (if (minusp val) ',minus-result ',result)))))
2762   (def-frob * x (%negate x))
2763   (def-frob / x (%negate x))
2764   (def-frob expt x (/ 1 x)))
2765
2766 ;;; Fold (expt x n) into multiplications for small integral values of
2767 ;;; N; convert (expt x 1/2) to sqrt.
2768 (deftransform expt ((x y) (t (constant-arg real)) *)
2769   "recode as multiplication or sqrt"
2770   (let ((val (continuation-value y)))
2771     ;; If Y would cause the result to be promoted to the same type as
2772     ;; Y, we give up. If not, then the result will be the same type
2773     ;; as X, so we can replace the exponentiation with simple
2774     ;; multiplication and division for small integral powers.
2775     (unless (not-more-contagious y x)
2776       (give-up-ir1-transform))
2777     (cond ((zerop val) '(float 1 x))
2778           ((= val 2) '(* x x))
2779           ((= val -2) '(/ (* x x)))
2780           ((= val 3) '(* x x x))
2781           ((= val -3) '(/ (* x x x)))
2782           ((= val 1/2) '(sqrt x))
2783           ((= val -1/2) '(/ (sqrt x)))
2784           (t (give-up-ir1-transform)))))
2785
2786 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
2787 ;;; transformations?
2788 ;;; Perhaps we should have to prove that the denominator is nonzero before
2789 ;;; doing them?  -- WHN 19990917
2790 (macrolet ((def-frob (name)
2791              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
2792                                    * :when :both)
2793                 "fold zero arg"
2794                 0)))
2795   (def-frob ash)
2796   (def-frob /))
2797
2798 (macrolet ((def-frob (name)
2799              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
2800                                    * :when :both)
2801                 "fold zero arg"
2802                 '(values 0 0))))
2803   (def-frob truncate)
2804   (def-frob round)
2805   (def-frob floor)
2806   (def-frob ceiling))
2807
2808 \f
2809 ;;;; character operations
2810
2811 (deftransform char-equal ((a b) (base-char base-char))
2812   "open code"
2813   '(let* ((ac (char-code a))
2814           (bc (char-code b))
2815           (sum (logxor ac bc)))
2816      (or (zerop sum)
2817          (when (eql sum #x20)
2818            (let ((sum (+ ac bc)))
2819              (and (> sum 161) (< sum 213)))))))
2820
2821 (deftransform char-upcase ((x) (base-char))
2822   "open code"
2823   '(let ((n-code (char-code x)))
2824      (if (and (> n-code #o140)  ; Octal 141 is #\a.
2825               (< n-code #o173)) ; Octal 172 is #\z.
2826          (code-char (logxor #x20 n-code))
2827          x)))
2828
2829 (deftransform char-downcase ((x) (base-char))
2830   "open code"
2831   '(let ((n-code (char-code x)))
2832      (if (and (> n-code 64)     ; 65 is #\A.
2833               (< n-code 91))    ; 90 is #\Z.
2834          (code-char (logxor #x20 n-code))
2835          x)))
2836 \f
2837 ;;;; equality predicate transforms
2838
2839 ;;; Return true if X and Y are continuations whose only use is a
2840 ;;; reference to the same leaf, and the value of the leaf cannot
2841 ;;; change.
2842 (defun same-leaf-ref-p (x y)
2843   (declare (type continuation x y))
2844   (let ((x-use (continuation-use x))
2845         (y-use (continuation-use y)))
2846     (and (ref-p x-use)
2847          (ref-p y-use)
2848          (eq (ref-leaf x-use) (ref-leaf y-use))
2849          (constant-reference-p x-use))))
2850
2851 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
2852 ;;; if there is no intersection between the types of the arguments,
2853 ;;; then the result is definitely false.
2854 (deftransform simple-equality-transform ((x y) * *
2855                                          :defun-only t
2856                                          :when :both)
2857   (cond ((same-leaf-ref-p x y)
2858          t)
2859         ((not (types-equal-or-intersect (continuation-type x)
2860                                         (continuation-type y)))
2861          nil)
2862         (t
2863          (give-up-ir1-transform))))
2864
2865 (macrolet ((def-frob (x)
2866              `(%deftransform ',x '(function * *) #'simple-equality-transform)))
2867   (def-frob eq)
2868   (def-frob char=)
2869   (def-frob equal))
2870
2871 ;;; This is similar to SIMPLE-EQUALITY-PREDICATE, except that we also
2872 ;;; try to convert to a type-specific predicate or EQ:
2873 ;;; -- If both args are characters, convert to CHAR=. This is better than
2874 ;;;    just converting to EQ, since CHAR= may have special compilation
2875 ;;;    strategies for non-standard representations, etc.
2876 ;;; -- If either arg is definitely not a number, then we can compare
2877 ;;;    with EQ.
2878 ;;; -- Otherwise, we try to put the arg we know more about second. If X
2879 ;;;    is constant then we put it second. If X is a subtype of Y, we put
2880 ;;;    it second. These rules make it easier for the back end to match
2881 ;;;    these interesting cases.
2882 ;;; -- If Y is a fixnum, then we quietly pass because the back end can
2883 ;;;    handle that case, otherwise give an efficiency note.
2884 (deftransform eql ((x y) * * :when :both)
2885   "convert to simpler equality predicate"
2886   (let ((x-type (continuation-type x))
2887         (y-type (continuation-type y))
2888         (char-type (specifier-type 'character))
2889         (number-type (specifier-type 'number)))
2890     (cond ((same-leaf-ref-p x y)
2891            t)
2892           ((not (types-equal-or-intersect x-type y-type))
2893            nil)
2894           ((and (csubtypep x-type char-type)
2895                 (csubtypep y-type char-type))
2896            '(char= x y))
2897           ((or (not (types-equal-or-intersect x-type number-type))
2898                (not (types-equal-or-intersect y-type number-type)))
2899            '(eq x y))
2900           ((and (not (constant-continuation-p y))
2901                 (or (constant-continuation-p x)
2902                     (and (csubtypep x-type y-type)
2903                          (not (csubtypep y-type x-type)))))
2904            '(eql y x))
2905           (t
2906            (give-up-ir1-transform)))))
2907
2908 ;;; Convert to EQL if both args are rational and complexp is specified
2909 ;;; and the same for both.
2910 (deftransform = ((x y) * * :when :both)
2911   "open code"
2912   (let ((x-type (continuation-type x))
2913         (y-type (continuation-type y)))
2914     (if (and (csubtypep x-type (specifier-type 'number))
2915              (csubtypep y-type (specifier-type 'number)))
2916         (cond ((or (and (csubtypep x-type (specifier-type 'float))
2917                         (csubtypep y-type (specifier-type 'float)))
2918                    (and (csubtypep x-type (specifier-type '(complex float)))
2919                         (csubtypep y-type (specifier-type '(complex float)))))
2920                ;; They are both floats. Leave as = so that -0.0 is
2921                ;; handled correctly.
2922                (give-up-ir1-transform))
2923               ((or (and (csubtypep x-type (specifier-type 'rational))
2924                         (csubtypep y-type (specifier-type 'rational)))
2925                    (and (csubtypep x-type
2926                                    (specifier-type '(complex rational)))
2927                         (csubtypep y-type
2928                                    (specifier-type '(complex rational)))))
2929                ;; They are both rationals and complexp is the same.
2930                ;; Convert to EQL.
2931                '(eql x y))
2932               (t
2933                (give-up-ir1-transform
2934                 "The operands might not be the same type.")))
2935         (give-up-ir1-transform
2936          "The operands might not be the same type."))))
2937
2938 ;;; If CONT's type is a numeric type, then return the type, otherwise
2939 ;;; GIVE-UP-IR1-TRANSFORM.
2940 (defun numeric-type-or-lose (cont)
2941   (declare (type continuation cont))
2942   (let ((res (continuation-type cont)))
2943     (unless (numeric-type-p res) (give-up-ir1-transform))
2944     res))
2945
2946 ;;; See whether we can statically determine (< X Y) using type
2947 ;;; information. If X's high bound is < Y's low, then X < Y.
2948 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
2949 ;;; NIL). If not, at least make sure any constant arg is second.
2950 ;;;
2951 ;;; FIXME: Why should constant argument be second? It would be nice to
2952 ;;; find out and explain.
2953 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2954 (defun ir1-transform-< (x y first second inverse)
2955   (if (same-leaf-ref-p x y)
2956       nil
2957       (let* ((x-type (numeric-type-or-lose x))
2958              (x-lo (numeric-type-low x-type))
2959              (x-hi (numeric-type-high x-type))
2960              (y-type (numeric-type-or-lose y))
2961              (y-lo (numeric-type-low y-type))
2962              (y-hi (numeric-type-high y-type)))
2963         (cond ((and x-hi y-lo (< x-hi y-lo))
2964                t)
2965               ((and y-hi x-lo (>= x-lo y-hi))
2966                nil)
2967               ((and (constant-continuation-p first)
2968                     (not (constant-continuation-p second)))
2969                `(,inverse y x))
2970               (t
2971                (give-up-ir1-transform))))))
2972 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2973 (defun ir1-transform-< (x y first second inverse)
2974   (if (same-leaf-ref-p x y)
2975       nil
2976       (let ((xi (numeric-type->interval (numeric-type-or-lose x)))
2977             (yi (numeric-type->interval (numeric-type-or-lose y))))
2978         (cond ((interval-< xi yi)
2979                t)
2980               ((interval->= xi yi)
2981                nil)
2982               ((and (constant-continuation-p first)
2983                     (not (constant-continuation-p second)))
2984                `(,inverse y x))
2985               (t
2986                (give-up-ir1-transform))))))
2987
2988 (deftransform < ((x y) (integer integer) * :when :both)
2989   (ir1-transform-< x y x y '>))
2990
2991 (deftransform > ((x y) (integer integer) * :when :both)
2992   (ir1-transform-< y x x y '<))
2993
2994 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2995 (deftransform < ((x y) (float float) * :when :both)
2996   (ir1-transform-< x y x y '>))
2997
2998 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2999 (deftransform > ((x y) (float float) * :when :both)
3000   (ir1-transform-< y x x y '<))
3001 \f
3002 ;;;; converting N-arg comparisons
3003 ;;;;
3004 ;;;; We convert calls to N-arg comparison functions such as < into
3005 ;;;; two-arg calls. This transformation is enabled for all such
3006 ;;;; comparisons in this file. If any of these predicates are not
3007 ;;;; open-coded, then the transformation should be removed at some
3008 ;;;; point to avoid pessimization.
3009
3010 ;;; This function is used for source transformation of N-arg
3011 ;;; comparison functions other than inequality. We deal both with
3012 ;;; converting to two-arg calls and inverting the sense of the test,
3013 ;;; if necessary. If the call has two args, then we pass or return a
3014 ;;; negated test as appropriate. If it is a degenerate one-arg call,
3015 ;;; then we transform to code that returns true. Otherwise, we bind
3016 ;;; all the arguments and expand into a bunch of IFs.
3017 (declaim (ftype (function (symbol list boolean) *) multi-compare))
3018 (defun multi-compare (predicate args not-p)
3019   (let ((nargs (length args)))
3020     (cond ((< nargs 1) (values nil t))
3021           ((= nargs 1) `(progn ,@args t))
3022           ((= nargs 2)
3023            (if not-p
3024                `(if (,predicate ,(first args) ,(second args)) nil t)
3025                (values nil t)))
3026           (t
3027            (do* ((i (1- nargs) (1- i))
3028                  (last nil current)
3029                  (current (gensym) (gensym))
3030                  (vars (list current) (cons current vars))
3031                  (result t (if not-p
3032                                `(if (,predicate ,current ,last)
3033                                     nil ,result)
3034                                `(if (,predicate ,current ,last)
3035                                     ,result nil))))
3036                ((zerop i)
3037                 `((lambda ,vars ,result) . ,args)))))))
3038
3039 (define-source-transform = (&rest args) (multi-compare '= args nil))
3040 (define-source-transform < (&rest args) (multi-compare '< args nil))
3041 (define-source-transform > (&rest args) (multi-compare '> args nil))
3042 (define-source-transform <= (&rest args) (multi-compare '> args t))
3043 (define-source-transform >= (&rest args) (multi-compare '< args t))
3044
3045 (define-source-transform char= (&rest args) (multi-compare 'char= args nil))
3046 (define-source-transform char< (&rest args) (multi-compare 'char< args nil))
3047 (define-source-transform char> (&rest args) (multi-compare 'char> args nil))
3048 (define-source-transform char<= (&rest args) (multi-compare 'char> args t))
3049 (define-source-transform char>= (&rest args) (multi-compare 'char< args t))
3050
3051 (define-source-transform char-equal (&rest args)
3052   (multi-compare 'char-equal args nil))
3053 (define-source-transform char-lessp (&rest args)
3054   (multi-compare 'char-lessp args nil))
3055 (define-source-transform char-greaterp (&rest args)
3056   (multi-compare 'char-greaterp args nil))
3057 (define-source-transform char-not-greaterp (&rest args)
3058   (multi-compare 'char-greaterp args t))
3059 (define-source-transform char-not-lessp (&rest args)
3060   (multi-compare 'char-lessp args t))
3061
3062 ;;; This function does source transformation of N-arg inequality
3063 ;;; functions such as /=. This is similar to Multi-Compare in the <3
3064 ;;; arg cases. If there are more than two args, then we expand into
3065 ;;; the appropriate n^2 comparisons only when speed is important.
3066 (declaim (ftype (function (symbol list) *) multi-not-equal))
3067 (defun multi-not-equal (predicate args)
3068   (let ((nargs (length args)))
3069     (cond ((< nargs 1) (values nil t))
3070           ((= nargs 1) `(progn ,@args t))
3071           ((= nargs 2)
3072            `(if (,predicate ,(first args) ,(second args)) nil t))
3073           ((not (policy *lexenv*
3074                         (and (>= speed space)
3075                              (>= speed compilation-speed))))
3076            (values nil t))
3077           (t
3078            (let ((vars (make-gensym-list nargs)))
3079              (do ((var vars next)
3080                   (next (cdr vars) (cdr next))
3081                   (result t))
3082                  ((null next)
3083                   `((lambda ,vars ,result) . ,args))
3084                (let ((v1 (first var)))
3085                  (dolist (v2 next)
3086                    (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
3087
3088 (define-source-transform /= (&rest args) (multi-not-equal '= args))
3089 (define-source-transform char/= (&rest args) (multi-not-equal 'char= args))
3090 (define-source-transform char-not-equal (&rest args)
3091   (multi-not-equal 'char-equal args))
3092
3093 ;;; Expand MAX and MIN into the obvious comparisons.
3094 (define-source-transform max (arg &rest more-args)
3095   (if (null more-args)
3096       `(values ,arg)
3097       (once-only ((arg1 arg)
3098                   (arg2 `(max ,@more-args)))
3099         `(if (> ,arg1 ,arg2)
3100              ,arg1 ,arg2))))
3101 (define-source-transform min (arg &rest more-args)
3102   (if (null more-args)
3103       `(values ,arg)
3104       (once-only ((arg1 arg)
3105                   (arg2 `(min ,@more-args)))
3106         `(if (< ,arg1 ,arg2)
3107              ,arg1 ,arg2))))
3108 \f
3109 ;;;; converting N-arg arithmetic functions
3110 ;;;;
3111 ;;;; N-arg arithmetic and logic functions are associated into two-arg
3112 ;;;; versions, and degenerate cases are flushed.
3113
3114 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
3115 (declaim (ftype (function (symbol t list) list) associate-args))
3116 (defun associate-args (function first-arg more-args)
3117   (let ((next (rest more-args))
3118         (arg (first more-args)))
3119     (if (null next)
3120         `(,function ,first-arg ,arg)
3121         (associate-args function `(,function ,first-arg ,arg) next))))
3122
3123 ;;; Do source transformations for transitive functions such as +.
3124 ;;; One-arg cases are replaced with the arg and zero arg cases with
3125 ;;; the identity. If LEAF-FUN is true, then replace two-arg calls with
3126 ;;; a call to that function.
3127 (defun source-transform-transitive (fun args identity &optional leaf-fun)
3128   (declare (symbol fun leaf-fun) (list args))
3129   (case (length args)
3130     (0 identity)
3131     (1 `(values ,(first args)))
3132     (2 (if leaf-fun
3133            `(,leaf-fun ,(first args) ,(second args))
3134            (values nil t)))
3135     (t
3136      (associate-args fun (first args) (rest args)))))
3137
3138 (define-source-transform + (&rest args)
3139   (source-transform-transitive '+ args 0))
3140 (define-source-transform * (&rest args)
3141   (source-transform-transitive '* args 1))
3142 (define-source-transform logior (&rest args)
3143   (source-transform-transitive 'logior args 0))
3144 (define-source-transform logxor (&rest args)
3145   (source-transform-transitive 'logxor args 0))
3146 (define-source-transform logand (&rest args)
3147   (source-transform-transitive 'logand args -1))
3148
3149 (define-source-transform logeqv (&rest args)
3150   (if (evenp (length args))
3151       `(lognot (logxor ,@args))
3152       `(logxor ,@args)))
3153
3154 ;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM
3155 ;;; because when they are given one argument, they return its absolute
3156 ;;; value.
3157
3158 (define-source-transform gcd (&rest args)
3159   (case (length args)
3160     (0 0)
3161     (1 `(abs (the integer ,(first args))))
3162     (2 (values nil t))
3163     (t (associate-args 'gcd (first args) (rest args)))))
3164
3165 (define-source-transform lcm (&rest args)
3166   (case (length args)
3167     (0 1)
3168     (1 `(abs (the integer ,(first args))))
3169     (2 (values nil t))
3170     (t (associate-args 'lcm (first args) (rest args)))))
3171
3172 ;;; Do source transformations for intransitive n-arg functions such as
3173 ;;; /. With one arg, we form the inverse. With two args we pass.
3174 ;;; Otherwise we associate into two-arg calls.
3175 (declaim (ftype (function (symbol list t) list) source-transform-intransitive))
3176 (defun source-transform-intransitive (function args inverse)
3177   (case (length args)
3178     ((0 2) (values nil t))
3179     (1 `(,@inverse ,(first args)))
3180     (t (associate-args function (first args) (rest args)))))
3181
3182 (define-source-transform - (&rest args)
3183   (source-transform-intransitive '- args '(%negate)))
3184 (define-source-transform / (&rest args)
3185   (source-transform-intransitive '/ args '(/ 1)))
3186 \f
3187 ;;;; transforming APPLY
3188
3189 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
3190 ;;; only needs to understand one kind of variable-argument call. It is
3191 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
3192 (define-source-transform apply (fun arg &rest more-args)
3193   (let ((args (cons arg more-args)))
3194     `(multiple-value-call ,fun
3195        ,@(mapcar (lambda (x)
3196                    `(values ,x))
3197                  (butlast args))
3198        (values-list ,(car (last args))))))
3199 \f
3200 ;;;; transforming FORMAT
3201 ;;;;
3202 ;;;; If the control string is a compile-time constant, then replace it
3203 ;;;; with a use of the FORMATTER macro so that the control string is
3204 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
3205 ;;;; or T and the control string is a function (i.e. FORMATTER), then
3206 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
3207
3208 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
3209                       :policy (> speed space))
3210   (unless (constant-continuation-p control)
3211     (give-up-ir1-transform "The control string is not a constant."))
3212   (let ((arg-names (make-gensym-list (length args))))
3213     `(lambda (dest control ,@arg-names)
3214        (declare (ignore control))
3215        (format dest (formatter ,(continuation-value control)) ,@arg-names))))
3216
3217 (deftransform format ((stream control &rest args) (stream function &rest t) *
3218                       :policy (> speed space))
3219   (let ((arg-names (make-gensym-list (length args))))
3220     `(lambda (stream control ,@arg-names)
3221        (funcall control stream ,@arg-names)
3222        nil)))
3223
3224 (deftransform format ((tee control &rest args) ((member t) function &rest t) *
3225                       :policy (> speed space))
3226   (let ((arg-names (make-gensym-list (length args))))
3227     `(lambda (tee control ,@arg-names)
3228        (declare (ignore tee))
3229        (funcall control *standard-output* ,@arg-names)
3230        nil)))
3231
3232 (defoptimizer (coerce derive-type) ((value type))
3233   (let ((value-type (continuation-type value))
3234         (type-type (continuation-type type)))
3235     (labels
3236         ((good-cons-type-p (cons-type)
3237            ;; Make sure the cons-type we're looking at is something
3238            ;; we're prepared to handle which is basically something
3239            ;; that array-element-type can return.
3240            (or (and (member-type-p cons-type)
3241                     (null (rest (member-type-members cons-type)))
3242                     (null (first (member-type-members cons-type))))
3243                (let ((car-type (cons-type-car-type cons-type)))
3244                  (and (member-type-p car-type)
3245                       (null (rest (member-type-members car-type)))
3246                       (or (symbolp (first (member-type-members car-type)))
3247                           (numberp (first (member-type-members car-type)))
3248                           (and (listp (first (member-type-members car-type)))
3249                                (numberp (first (first (member-type-members
3250                                                        car-type))))))
3251                       (good-cons-type-p (cons-type-cdr-type cons-type))))))
3252          (unconsify-type (good-cons-type)
3253            ;; Convert the "printed" respresentation of a cons
3254            ;; specifier into a type specifier.  That is, the specifier
3255            ;; (cons (eql signed-byte) (cons (eql 16) null)) is
3256            ;; converted to (signed-byte 16).
3257            (cond ((or (null good-cons-type)
3258                       (eq good-cons-type 'null))
3259                    nil)
3260                  ((and (eq (first good-cons-type) 'cons)
3261                        (eq (first (second good-cons-type)) 'member))
3262                    `(,(second (second good-cons-type))
3263                      ,@(unconsify-type (caddr good-cons-type))))))
3264          (coerceable-p (c-type)
3265            ;; Can the value be coerced to the given type?  Coerce is
3266            ;; complicated, so we don't handle every possible case
3267            ;; here---just the most common and easiest cases:
3268            ;;
3269            ;; o Any real can be coerced to a float type.
3270            ;; o Any number can be coerced to a complex single/double-float.
3271            ;; o An integer can be coerced to an integer.
3272            (let ((coerced-type c-type))
3273              (or (and (subtypep coerced-type 'float)
3274                       (csubtypep value-type (specifier-type 'real)))
3275                  (and (subtypep coerced-type
3276                                 '(or (complex single-float)
3277                                   (complex double-float)))
3278                       (csubtypep value-type (specifier-type 'number)))
3279                  (and (subtypep coerced-type 'integer)
3280                       (csubtypep value-type (specifier-type 'integer))))))
3281          (process-types (type)
3282            ;; FIXME:
3283            ;; This needs some work because we should be able to derive
3284            ;; the resulting type better than just the type arg of
3285            ;; coerce.  That is, if x is (integer 10 20), the (coerce x
3286            ;; 'double-float) should say (double-float 10d0 20d0)
3287            ;; instead of just double-float.
3288            (cond ((member-type-p type)
3289                    (let ((members (member-type-members type)))
3290                      (if (every #'coerceable-p members)
3291                        (specifier-type `(or ,@members))
3292                        *universal-type*)))
3293                  ((and (cons-type-p type)
3294                        (good-cons-type-p type))
3295                    (let ((c-type (unconsify-type (type-specifier type))))
3296                      (if (coerceable-p c-type)
3297                        (specifier-type c-type)
3298                        *universal-type*)))
3299                  (t
3300                    *universal-type*))))
3301       (cond ((union-type-p type-type)
3302               (apply #'type-union (mapcar #'process-types
3303                                           (union-type-types type-type))))
3304             ((or (member-type-p type-type)
3305                  (cons-type-p type-type))
3306               (process-types type-type))
3307             (t
3308               *universal-type*)))))
3309
3310 (defoptimizer (array-element-type derive-type) ((array))
3311   (let* ((array-type (continuation-type array)))
3312     (labels ((consify (list)
3313               (if (endp list)
3314                   '(eql nil)
3315                   `(cons (eql ,(car list)) ,(consify (rest list)))))
3316             (get-element-type (a)
3317               (let ((element-type
3318                      (type-specifier (array-type-specialized-element-type a))))
3319                 (cond ((eq element-type '*)
3320                        (specifier-type 'type-specifier))
3321                       ((symbolp element-type)
3322                        (make-member-type :members (list element-type)))
3323                       ((consp element-type)
3324                        (specifier-type (consify element-type)))
3325                       (t
3326                        (error "can't understand type ~S~%" element-type))))))
3327       (cond ((array-type-p array-type)
3328              (get-element-type array-type))
3329             ((union-type-p array-type)             
3330              (apply #'type-union
3331                     (mapcar #'get-element-type (union-type-types array-type))))
3332             (t
3333              *universal-type*)))))
3334 \f
3335 ;;;; debuggers' little helpers
3336
3337 ;;; for debugging when transforms are behaving mysteriously,
3338 ;;; e.g. when debugging a problem with an ASH transform
3339 ;;;   (defun foo (&optional s)
3340 ;;;     (sb-c::/report-continuation s "S outside WHEN")
3341 ;;;     (when (and (integerp s) (> s 3))
3342 ;;;       (sb-c::/report-continuation s "S inside WHEN")
3343 ;;;       (let ((bound (ash 1 (1- s))))
3344 ;;;         (sb-c::/report-continuation bound "BOUND")
3345 ;;;         (let ((x (- bound))
3346 ;;;               (y (1- bound)))
3347 ;;;           (sb-c::/report-continuation x "X")
3348 ;;;           (sb-c::/report-continuation x "Y"))
3349 ;;;         `(integer ,(- bound) ,(1- bound)))))
3350 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
3351 ;;; and the function doesn't do anything at all.)
3352 #!+sb-show
3353 (progn
3354   (defknown /report-continuation (t t) null)
3355   (deftransform /report-continuation ((x message) (t t))
3356     (format t "~%/in /REPORT-CONTINUATION~%")
3357     (format t "/(CONTINUATION-TYPE X)=~S~%" (continuation-type x))
3358     (when (constant-continuation-p x)
3359       (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
3360     (format t "/MESSAGE=~S~%" (continuation-value message))
3361     (give-up-ir1-transform "not a real transform"))
3362   (defun /report-continuation (&rest rest)
3363     (declare (ignore rest))))