inhibit &REST -> &MORE conversion when DEBUG is 3
[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. FIXME: 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
33 ;;; CONSTANTLY is pretty much never worth transforming, but it's good to get the type.
34 (defoptimizer (constantly derive-type) ((value))
35   (specifier-type
36    `(function (&rest t) (values ,(type-specifier (lvar-type value)) &optional))))
37
38 ;;; If the function has a known number of arguments, then return a
39 ;;; lambda with the appropriate fixed number of args. If the
40 ;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
41 ;;; MV optimization figure things out.
42 (deftransform complement ((fun) * * :node node)
43   "open code"
44   (multiple-value-bind (min max)
45       (fun-type-nargs (lvar-type fun))
46     (cond
47      ((and min (eql min max))
48       (let ((dums (make-gensym-list min)))
49         `#'(lambda ,dums (not (funcall fun ,@dums)))))
50      ((awhen (node-lvar node)
51         (let ((dest (lvar-dest it)))
52           (and (combination-p dest)
53                (eq (combination-fun dest) it))))
54       '#'(lambda (&rest args)
55            (not (apply fun args))))
56      (t
57       (give-up-ir1-transform
58        "The function doesn't have a fixed argument count.")))))
59 \f
60 ;;;; SYMBOL-VALUE &co
61 (defun derive-symbol-value-type (lvar node)
62   (if (constant-lvar-p lvar)
63       (let* ((sym (lvar-value lvar))
64              (var (maybe-find-free-var sym))
65              (local-type (when var
66                            (let ((*lexenv* (node-lexenv node)))
67                              (lexenv-find var type-restrictions))))
68              (global-type (info :variable :type sym)))
69         (if local-type
70             (type-intersection local-type global-type)
71             global-type))
72       *universal-type*))
73
74 (defoptimizer (symbol-value derive-type) ((symbol) node)
75   (derive-symbol-value-type symbol node))
76
77 (defoptimizer (symbol-global-value derive-type) ((symbol) node)
78   (derive-symbol-value-type symbol node))
79 \f
80 ;;;; list hackery
81
82 ;;; Translate CxR into CAR/CDR combos.
83 (defun source-transform-cxr (form)
84   (if (/= (length form) 2)
85       (values nil t)
86       (let* ((name (car form))
87              (string (symbol-name
88                       (etypecase name
89                         (symbol name)
90                         (leaf (leaf-source-name name))))))
91         (do ((i (- (length string) 2) (1- i))
92              (res (cadr form)
93                   `(,(ecase (char string i)
94                        (#\A 'car)
95                        (#\D 'cdr))
96                     ,res)))
97             ((zerop i) res)))))
98
99 ;;; Make source transforms to turn CxR forms into combinations of CAR
100 ;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
101 ;;; defined.
102 (/show0 "about to set CxR source transforms")
103 (loop for i of-type index from 2 upto 4 do
104       ;; Iterate over BUF = all names CxR where x = an I-element
105       ;; string of #\A or #\D characters.
106       (let ((buf (make-string (+ 2 i))))
107         (setf (aref buf 0) #\C
108               (aref buf (1+ i)) #\R)
109         (dotimes (j (ash 2 i))
110           (declare (type index j))
111           (dotimes (k i)
112             (declare (type index k))
113             (setf (aref buf (1+ k))
114                   (if (logbitp k j) #\A #\D)))
115           (setf (info :function :source-transform (intern buf))
116                 #'source-transform-cxr))))
117 (/show0 "done setting CxR source transforms")
118
119 ;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
120 ;;; whatever is right for them is right for us. FIFTH..TENTH turn into
121 ;;; Nth, which can be expanded into a CAR/CDR later on if policy
122 ;;; favors it.
123 (define-source-transform first (x) `(car ,x))
124 (define-source-transform rest (x) `(cdr ,x))
125 (define-source-transform second (x) `(cadr ,x))
126 (define-source-transform third (x) `(caddr ,x))
127 (define-source-transform fourth (x) `(cadddr ,x))
128 (define-source-transform fifth (x) `(nth 4 ,x))
129 (define-source-transform sixth (x) `(nth 5 ,x))
130 (define-source-transform seventh (x) `(nth 6 ,x))
131 (define-source-transform eighth (x) `(nth 7 ,x))
132 (define-source-transform ninth (x) `(nth 8 ,x))
133 (define-source-transform tenth (x) `(nth 9 ,x))
134
135 ;;; LIST with one arg is an extremely common operation (at least inside
136 ;;; SBCL itself); translate it to CONS to take advantage of common
137 ;;; allocation routines.
138 (define-source-transform list (&rest args)
139   (case (length args)
140     (1 `(cons ,(first args) nil))
141     (t (values nil t))))
142
143 ;;; And similarly for LIST*.
144 (define-source-transform list* (arg &rest others)
145   (cond ((not others) arg)
146         ((not (cdr others)) `(cons ,arg ,(car others)))
147         (t (values nil t))))
148
149 (defoptimizer (list* derive-type) ((arg &rest args))
150   (if args
151       (specifier-type 'cons)
152       (lvar-type arg)))
153
154 ;;; Translate RPLACx to LET and SETF.
155 (define-source-transform rplaca (x y)
156   (once-only ((n-x x))
157     `(progn
158        (setf (car ,n-x) ,y)
159        ,n-x)))
160 (define-source-transform rplacd (x y)
161   (once-only ((n-x x))
162     `(progn
163        (setf (cdr ,n-x) ,y)
164        ,n-x)))
165
166 (define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
167
168 (deftransform last ((list &optional n) (t &optional t))
169   (let ((c (constant-lvar-p n)))
170     (cond ((or (not n)
171                (and c (eql 1 (lvar-value n))))
172            '(%last1 list))
173           ((and c (eql 0 (lvar-value n)))
174            '(%last0 list))
175           (t
176            (let ((type (lvar-type n)))
177              (cond ((csubtypep type (specifier-type 'fixnum))
178                     '(%lastn/fixnum list n))
179                    ((csubtypep type (specifier-type 'bignum))
180                     '(%lastn/bignum list n))
181                    (t
182                     (give-up-ir1-transform "second argument type too vague"))))))))
183
184 (define-source-transform gethash (&rest args)
185   (case (length args)
186    (2 `(sb!impl::gethash3 ,@args nil))
187    (3 `(sb!impl::gethash3 ,@args))
188    (t (values nil t))))
189 (define-source-transform get (&rest args)
190   (case (length args)
191    (2 `(sb!impl::get2 ,@args))
192    (3 `(sb!impl::get3 ,@args))
193    (t (values nil t))))
194
195 (defvar *default-nthcdr-open-code-limit* 6)
196 (defvar *extreme-nthcdr-open-code-limit* 20)
197
198 (deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
199   "convert NTHCDR to CAxxR"
200   (unless (constant-lvar-p n)
201     (give-up-ir1-transform))
202   (let ((n (lvar-value n)))
203     (when (> n
204              (if (policy node (and (= speed 3) (= space 0)))
205                  *extreme-nthcdr-open-code-limit*
206                  *default-nthcdr-open-code-limit*))
207       (give-up-ir1-transform))
208
209     (labels ((frob (n)
210                (if (zerop n)
211                    'l
212                    `(cdr ,(frob (1- n))))))
213       (frob n))))
214 \f
215 ;;;; arithmetic and numerology
216
217 (define-source-transform plusp (x) `(> ,x 0))
218 (define-source-transform minusp (x) `(< ,x 0))
219 (define-source-transform zerop (x) `(= ,x 0))
220
221 (define-source-transform 1+ (x) `(+ ,x 1))
222 (define-source-transform 1- (x) `(- ,x 1))
223
224 (define-source-transform oddp (x) `(logtest ,x 1))
225 (define-source-transform evenp (x) `(not (logtest ,x 1)))
226
227 ;;; Note that all the integer division functions are available for
228 ;;; inline expansion.
229
230 (macrolet ((deffrob (fun)
231              `(define-source-transform ,fun (x &optional (y nil y-p))
232                 (declare (ignore y))
233                 (if y-p
234                     (values nil t)
235                     `(,',fun ,x 1)))))
236   (deffrob truncate)
237   (deffrob round)
238   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
239   (deffrob floor)
240   #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
241   (deffrob ceiling))
242
243 ;;; This used to be a source transform (hence the lack of restrictions
244 ;;; on the argument types), but we make it a regular transform so that
245 ;;; the VM has a chance to see the bare LOGTEST and potentiall choose
246 ;;; to implement it differently.  --njf, 06-02-2006
247 (deftransform logtest ((x y) * *)
248   `(not (zerop (logand x y))))
249
250 (deftransform logbitp
251     ((index integer) (unsigned-byte (or (signed-byte #.sb!vm:n-word-bits)
252                                         (unsigned-byte #.sb!vm:n-word-bits))))
253   `(if (>= index #.sb!vm:n-word-bits)
254        (minusp integer)
255        (not (zerop (logand integer (ash 1 index))))))
256
257 (define-source-transform byte (size position)
258   `(cons ,size ,position))
259 (define-source-transform byte-size (spec) `(car ,spec))
260 (define-source-transform byte-position (spec) `(cdr ,spec))
261 (define-source-transform ldb-test (bytespec integer)
262   `(not (zerop (mask-field ,bytespec ,integer))))
263
264 ;;; With the ratio and complex accessors, we pick off the "identity"
265 ;;; case, and use a primitive to handle the cell access case.
266 (define-source-transform numerator (num)
267   (once-only ((n-num `(the rational ,num)))
268     `(if (ratiop ,n-num)
269          (%numerator ,n-num)
270          ,n-num)))
271 (define-source-transform denominator (num)
272   (once-only ((n-num `(the rational ,num)))
273     `(if (ratiop ,n-num)
274          (%denominator ,n-num)
275          1)))
276 \f
277 ;;;; interval arithmetic for computing bounds
278 ;;;;
279 ;;;; This is a set of routines for operating on intervals. It
280 ;;;; implements a simple interval arithmetic package. Although SBCL
281 ;;;; has an interval type in NUMERIC-TYPE, we choose to use our own
282 ;;;; for two reasons:
283 ;;;;
284 ;;;;   1. This package is simpler than NUMERIC-TYPE.
285 ;;;;
286 ;;;;   2. It makes debugging much easier because you can just strip
287 ;;;;   out these routines and test them independently of SBCL. (This is a
288 ;;;;   big win!)
289 ;;;;
290 ;;;; One disadvantage is a probable increase in consing because we
291 ;;;; have to create these new interval structures even though
292 ;;;; numeric-type has everything we want to know. Reason 2 wins for
293 ;;;; now.
294
295 ;;; Support operations that mimic real arithmetic comparison
296 ;;; operators, but imposing a total order on the floating points such
297 ;;; that negative zeros are strictly less than positive zeros.
298 (macrolet ((def (name op)
299              `(defun ,name (x y)
300                 (declare (real x y))
301                 (if (and (floatp x) (floatp y) (zerop x) (zerop y))
302                     (,op (float-sign x) (float-sign y))
303                     (,op x y)))))
304   (def signed-zero->= >=)
305   (def signed-zero-> >)
306   (def signed-zero-= =)
307   (def signed-zero-< <)
308   (def signed-zero-<= <=))
309
310 ;;; The basic interval type. It can handle open and closed intervals.
311 ;;; A bound is open if it is a list containing a number, just like
312 ;;; Lisp says. NIL means unbounded.
313 (defstruct (interval (:constructor %make-interval)
314                      (:copier nil))
315   low high)
316
317 (defun make-interval (&key low high)
318   (labels ((normalize-bound (val)
319              (cond #-sb-xc-host
320                    ((and (floatp val)
321                          (float-infinity-p val))
322                     ;; Handle infinities.
323                     nil)
324                    ((or (numberp val)
325                         (eq val nil))
326                     ;; Handle any closed bounds.
327                     val)
328                    ((listp val)
329                     ;; We have an open bound. Normalize the numeric
330                     ;; bound. If the normalized bound is still a number
331                     ;; (not nil), keep the bound open. Otherwise, the
332                     ;; bound is really unbounded, so drop the openness.
333                     (let ((new-val (normalize-bound (first val))))
334                       (when new-val
335                         ;; The bound exists, so keep it open still.
336                         (list new-val))))
337                    (t
338                     (error "unknown bound type in MAKE-INTERVAL")))))
339     (%make-interval :low (normalize-bound low)
340                     :high (normalize-bound high))))
341
342 ;;; Given a number X, create a form suitable as a bound for an
343 ;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
344 #!-sb-fluid (declaim (inline set-bound))
345 (defun set-bound (x open-p)
346   (if (and x open-p) (list x) x))
347
348 ;;; Apply the function F to a bound X. If X is an open bound, then
349 ;;; the result will be open. IF X is NIL, the result is NIL.
350 (defun bound-func (f x)
351   (declare (type function f))
352   (and x
353        (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
354          ;; With these traps masked, we might get things like infinity
355          ;; or negative infinity returned. Check for this and return
356          ;; NIL to indicate unbounded.
357          (let ((y (funcall f (type-bound-number x))))
358            (if (and (floatp y)
359                     (float-infinity-p y))
360                nil
361                (set-bound y (consp x)))))))
362
363 (defun safe-double-coercion-p (x)
364   (or (typep x 'double-float)
365       (<= most-negative-double-float x most-positive-double-float)))
366
367 (defun safe-single-coercion-p (x)
368   (or (typep x 'single-float)
369       ;; Fix for bug 420, and related issues: during type derivation we often
370       ;; end up deriving types for both
371       ;;
372       ;;   (some-op <int> <single>)
373       ;; and
374       ;;   (some-op (coerce <int> 'single-float) <single>)
375       ;;
376       ;; or other equivalent transformed forms. The problem with this is that
377       ;; on some platforms like x86 (+ <int> <single>) is on the machine level
378       ;; equivalent of
379       ;;
380       ;;   (coerce (+ (coerce <int> 'double-float)
381       ;;              (coerce <single> 'double-float))
382       ;;           'single-float)
383       ;;
384       ;; so if the result of (coerce <int> 'single-float) is not exact, the
385       ;; derived types for the transformed forms will have an empty
386       ;; intersection -- which in turn means that the compiler will conclude
387       ;; that the call never returns, and all hell breaks lose when it *does*
388       ;; return at runtime. (This affects not just +, but other operators are
389       ;; well.)
390       (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum))
391                               (integer (,most-positive-exactly-single-float-fixnum) *))))
392            (<= most-negative-single-float x most-positive-single-float))))
393
394 ;;; Apply a binary operator OP to two bounds X and Y. The result is
395 ;;; NIL if either is NIL. Otherwise bound is computed and the result
396 ;;; is open if either X or Y is open.
397 ;;;
398 ;;; FIXME: only used in this file, not needed in target runtime
399
400 ;;; ANSI contaigon specifies coercion to floating point if one of the
401 ;;; arguments is floating point. Here we should check to be sure that
402 ;;; the other argument is within the bounds of that floating point
403 ;;; type.
404
405 (defmacro safely-binop (op x y)
406   `(cond
407      ((typep ,x 'double-float)
408       (when (safe-double-coercion-p ,y)
409         (,op ,x ,y)))
410      ((typep ,y 'double-float)
411       (when (safe-double-coercion-p ,x)
412         (,op ,x ,y)))
413      ((typep ,x 'single-float)
414       (when (safe-single-coercion-p ,y)
415         (,op ,x ,y)))
416      ((typep ,y 'single-float)
417       (when (safe-single-coercion-p ,x)
418         (,op ,x ,y)))
419      (t (,op ,x ,y))))
420
421 (defmacro bound-binop (op x y)
422   (with-unique-names (xb yb res)
423     `(and ,x ,y
424           (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
425             (let* ((,xb (type-bound-number ,x))
426                    (,yb (type-bound-number ,y))
427                    (,res (safely-binop ,op ,xb ,yb)))
428               (set-bound ,res
429                          (and (or (consp ,x) (consp ,y))
430                               ;; Open bounds can very easily be messed up
431                               ;; by FP rounding, so take care here.
432                               ,(case op
433                                  (*
434                                   ;; Multiplying a greater-than-zero with
435                                   ;; less than one can round to zero.
436                                   `(or (not (fp-zero-p ,res))
437                                        (cond ((and (consp ,x) (fp-zero-p ,xb))
438                                               (>= (abs ,yb) 1))
439                                              ((and (consp ,y) (fp-zero-p ,yb))
440                                               (>= (abs ,xb) 1)))))
441                                  (/
442                                   ;; Dividing a greater-than-zero with
443                                   ;; greater than one can round to zero.
444                                   `(or (not (fp-zero-p ,res))
445                                        (cond ((and (consp ,x) (fp-zero-p ,xb))
446                                               (<= (abs ,yb) 1))
447                                              ((and (consp ,y) (fp-zero-p ,yb))
448                                               (<= (abs ,xb) 1)))))
449                                  ((+ -)
450                                   ;; Adding or subtracting greater-than-zero
451                                   ;; can end up with identity.
452                                   `(and (not (fp-zero-p ,xb))
453                                         (not (fp-zero-p ,yb))))))))))))
454
455 (defun coerce-for-bound (val type)
456   (if (consp val)
457       (list (coerce-for-bound (car val) type))
458       (cond
459         ((subtypep type 'double-float)
460          (if (<= most-negative-double-float val most-positive-double-float)
461              (coerce val type)))
462         ((or (subtypep type 'single-float) (subtypep type 'float))
463          ;; coerce to float returns a single-float
464          (if (<= most-negative-single-float val most-positive-single-float)
465              (coerce val type)))
466         (t (coerce val type)))))
467
468 (defun coerce-and-truncate-floats (val type)
469   (when val
470     (if (consp val)
471         (list (coerce-and-truncate-floats (car val) type))
472         (cond
473           ((subtypep type 'double-float)
474            (if (<= most-negative-double-float val most-positive-double-float)
475                (coerce val type)
476                (if (< val most-negative-double-float)
477                    most-negative-double-float most-positive-double-float)))
478           ((or (subtypep type 'single-float) (subtypep type 'float))
479            ;; coerce to float returns a single-float
480            (if (<= most-negative-single-float val most-positive-single-float)
481                (coerce val type)
482                (if (< val most-negative-single-float)
483                    most-negative-single-float most-positive-single-float)))
484           (t (coerce val type))))))
485
486 ;;; Convert a numeric-type object to an interval object.
487 (defun numeric-type->interval (x)
488   (declare (type numeric-type x))
489   (make-interval :low (numeric-type-low x)
490                  :high (numeric-type-high x)))
491
492 (defun type-approximate-interval (type)
493   (declare (type ctype type))
494   (let ((types (prepare-arg-for-derive-type type))
495         (result nil))
496     (dolist (type types)
497       (let ((type (if (member-type-p type)
498                       (convert-member-type type)
499                       type)))
500         (unless (numeric-type-p type)
501           (return-from type-approximate-interval nil))
502         (let ((interval (numeric-type->interval type)))
503           (setq result
504                 (if result
505                     (interval-approximate-union result interval)
506                     interval)))))
507     result))
508
509 (defun copy-interval-limit (limit)
510   (if (numberp limit)
511       limit
512       (copy-list limit)))
513
514 (defun copy-interval (x)
515   (declare (type interval x))
516   (make-interval :low (copy-interval-limit (interval-low x))
517                  :high (copy-interval-limit (interval-high x))))
518
519 ;;; Given a point P contained in the interval X, split X into two
520 ;;; interval at the point P. If CLOSE-LOWER is T, then the left
521 ;;; interval contains P. If CLOSE-UPPER is T, the right interval
522 ;;; contains P. You can specify both to be T or NIL.
523 (defun interval-split (p x &optional close-lower close-upper)
524   (declare (type number p)
525            (type interval x))
526   (list (make-interval :low (copy-interval-limit (interval-low x))
527                        :high (if close-lower p (list p)))
528         (make-interval :low (if close-upper (list p) p)
529                        :high (copy-interval-limit (interval-high x)))))
530
531 ;;; Return the closure of the interval. That is, convert open bounds
532 ;;; to closed bounds.
533 (defun interval-closure (x)
534   (declare (type interval x))
535   (make-interval :low (type-bound-number (interval-low x))
536                  :high (type-bound-number (interval-high x))))
537
538 ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
539 ;;; '-. Otherwise return NIL.
540 (defun interval-range-info (x &optional (point 0))
541   (declare (type interval x))
542   (let ((lo (interval-low x))
543         (hi (interval-high x)))
544     (cond ((and lo (signed-zero->= (type-bound-number lo) point))
545            '+)
546           ((and hi (signed-zero->= point (type-bound-number hi)))
547            '-)
548           (t
549            nil))))
550
551 ;;; Test to see whether the interval X is bounded. HOW determines the
552 ;;; test, and should be either ABOVE, BELOW, or BOTH.
553 (defun interval-bounded-p (x how)
554   (declare (type interval x))
555   (ecase how
556     (above
557      (interval-high x))
558     (below
559      (interval-low x))
560     (both
561      (and (interval-low x) (interval-high x)))))
562
563 ;;; See whether the interval X contains the number P, taking into
564 ;;; account that the interval might not be closed.
565 (defun interval-contains-p (p x)
566   (declare (type number p)
567            (type interval x))
568   ;; Does the interval X contain the number P?  This would be a lot
569   ;; easier if all intervals were closed!
570   (let ((lo (interval-low x))
571         (hi (interval-high x)))
572     (cond ((and lo hi)
573            ;; The interval is bounded
574            (if (and (signed-zero-<= (type-bound-number lo) p)
575                     (signed-zero-<= p (type-bound-number hi)))
576                ;; P is definitely in the closure of the interval.
577                ;; We just need to check the end points now.
578                (cond ((signed-zero-= p (type-bound-number lo))
579                       (numberp lo))
580                      ((signed-zero-= p (type-bound-number hi))
581                       (numberp hi))
582                      (t t))
583                nil))
584           (hi
585            ;; Interval with upper bound
586            (if (signed-zero-< p (type-bound-number hi))
587                t
588                (and (numberp hi) (signed-zero-= p hi))))
589           (lo
590            ;; Interval with lower bound
591            (if (signed-zero-> p (type-bound-number lo))
592                t
593                (and (numberp lo) (signed-zero-= p lo))))
594           (t
595            ;; Interval with no bounds
596            t))))
597
598 ;;; Determine whether two intervals X and Y intersect. Return T if so.
599 ;;; If CLOSED-INTERVALS-P is T, the treat the intervals as if they
600 ;;; were closed. Otherwise the intervals are treated as they are.
601 ;;;
602 ;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
603 ;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
604 ;;; is T, then they do intersect because we use the closure of X = [0,
605 ;;; 1] and Y = [1, 2] to determine intersection.
606 (defun interval-intersect-p (x y &optional closed-intervals-p)
607   (declare (type interval x y))
608   (and (interval-intersection/difference (if closed-intervals-p
609                                              (interval-closure x)
610                                              x)
611                                          (if closed-intervals-p
612                                              (interval-closure y)
613                                              y))
614        t))
615
616 ;;; Are the two intervals adjacent?  That is, is there a number
617 ;;; between the two intervals that is not an element of either
618 ;;; interval?  If so, they are not adjacent. For example [0, 1) and
619 ;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
620 ;;; between both intervals.
621 (defun interval-adjacent-p (x y)
622   (declare (type interval x y))
623   (flet ((adjacent (lo hi)
624            ;; Check to see whether lo and hi are adjacent. If either is
625            ;; nil, they can't be adjacent.
626            (when (and lo hi (= (type-bound-number lo) (type-bound-number hi)))
627              ;; The bounds are equal. They are adjacent if one of
628              ;; them is closed (a number). If both are open (consp),
629              ;; then there is a number that lies between them.
630              (or (numberp lo) (numberp hi)))))
631     (or (adjacent (interval-low y) (interval-high x))
632         (adjacent (interval-low x) (interval-high y)))))
633
634 ;;; Compute the intersection and difference between two intervals.
635 ;;; Two values are returned: the intersection and the difference.
636 ;;;
637 ;;; Let the two intervals be X and Y, and let I and D be the two
638 ;;; values returned by this function. Then I = X intersect Y. If I
639 ;;; is NIL (the empty set), then D is X union Y, represented as the
640 ;;; list of X and Y. If I is not the empty set, then D is (X union Y)
641 ;;; - I, which is a list of two intervals.
642 ;;;
643 ;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
644 ;;; [-1,1) union [3,5], which is returned as a list of two intervals.
645 (defun interval-intersection/difference (x y)
646   (declare (type interval x y))
647   (let ((x-lo (interval-low x))
648         (x-hi (interval-high x))
649         (y-lo (interval-low y))
650         (y-hi (interval-high y)))
651     (labels
652         ((opposite-bound (p)
653            ;; If p is an open bound, make it closed. If p is a closed
654            ;; bound, make it open.
655            (if (listp p)
656                (first p)
657                (list p)))
658          (test-number (p int bound)
659            ;; Test whether P is in the interval.
660            (let ((pn (type-bound-number p)))
661              (when (interval-contains-p pn (interval-closure int))
662                ;; Check for endpoints.
663                (let* ((lo (interval-low int))
664                       (hi (interval-high int))
665                       (lon (type-bound-number lo))
666                       (hin (type-bound-number hi)))
667                  (cond
668                    ;; Interval may be a point.
669                    ((and lon hin (= lon hin pn))
670                     (and (numberp p) (numberp lo) (numberp hi)))
671                    ;; Point matches the low end.
672                    ;; [P] [P,?} => TRUE     [P] (P,?} => FALSE
673                    ;; (P  [P,?} => TRUE      P) [P,?} => FALSE
674                    ;; (P  (P,?} => TRUE      P) (P,?} => FALSE
675                    ((and lon (= pn lon))
676                     (or (and (numberp p) (numberp lo))
677                         (and (consp p) (eq :low bound))))
678                    ;; [P] {?,P] => TRUE     [P] {?,P) => FALSE
679                    ;;  P) {?,P] => TRUE     (P  {?,P] => FALSE
680                    ;;  P) {?,P) => TRUE     (P  {?,P) => FALSE
681                    ((and hin (= pn hin))
682                     (or (and (numberp p) (numberp hi))
683                         (and (consp p) (eq :high bound))))
684                    ;; Not an endpoint, all is well.
685                    (t
686                     t))))))
687          (test-lower-bound (p int)
688            ;; P is a lower bound of an interval.
689            (if p
690                (test-number p int :low)
691                (not (interval-bounded-p int 'below))))
692          (test-upper-bound (p int)
693            ;; P is an upper bound of an interval.
694            (if p
695                (test-number p int :high)
696                (not (interval-bounded-p int 'above)))))
697       (let ((x-lo-in-y (test-lower-bound x-lo y))
698             (x-hi-in-y (test-upper-bound x-hi y))
699             (y-lo-in-x (test-lower-bound y-lo x))
700             (y-hi-in-x (test-upper-bound y-hi x)))
701         (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x)
702                ;; Intervals intersect. Let's compute the intersection
703                ;; and the difference.
704                (multiple-value-bind (lo left-lo left-hi)
705                    (cond (x-lo-in-y (values x-lo y-lo (opposite-bound x-lo)))
706                          (y-lo-in-x (values y-lo x-lo (opposite-bound y-lo))))
707                  (multiple-value-bind (hi right-lo right-hi)
708                      (cond (x-hi-in-y
709                             (values x-hi (opposite-bound x-hi) y-hi))
710                            (y-hi-in-x
711                             (values y-hi (opposite-bound y-hi) x-hi)))
712                    (values (make-interval :low lo :high hi)
713                            (list (make-interval :low left-lo
714                                                 :high left-hi)
715                                  (make-interval :low right-lo
716                                                 :high right-hi))))))
717               (t
718                (values nil (list x y))))))))
719
720 ;;; If intervals X and Y intersect, return a new interval that is the
721 ;;; union of the two. If they do not intersect, return NIL.
722 (defun interval-merge-pair (x y)
723   (declare (type interval x y))
724   ;; If x and y intersect or are adjacent, create the union.
725   ;; Otherwise return nil
726   (when (or (interval-intersect-p x y)
727             (interval-adjacent-p x y))
728     (flet ((select-bound (x1 x2 min-op max-op)
729              (let ((x1-val (type-bound-number x1))
730                    (x2-val (type-bound-number x2)))
731                (cond ((and x1 x2)
732                       ;; Both bounds are finite. Select the right one.
733                       (cond ((funcall min-op x1-val x2-val)
734                              ;; x1 is definitely better.
735                              x1)
736                             ((funcall max-op x1-val x2-val)
737                              ;; x2 is definitely better.
738                              x2)
739                             (t
740                              ;; Bounds are equal. Select either
741                              ;; value and make it open only if
742                              ;; both were open.
743                              (set-bound x1-val (and (consp x1) (consp x2))))))
744                      (t
745                       ;; At least one bound is not finite. The
746                       ;; non-finite bound always wins.
747                       nil)))))
748       (let* ((x-lo (copy-interval-limit (interval-low x)))
749              (x-hi (copy-interval-limit (interval-high x)))
750              (y-lo (copy-interval-limit (interval-low y)))
751              (y-hi (copy-interval-limit (interval-high y))))
752         (make-interval :low (select-bound x-lo y-lo #'< #'>)
753                        :high (select-bound x-hi y-hi #'> #'<))))))
754
755 ;;; return the minimal interval, containing X and Y
756 (defun interval-approximate-union (x y)
757   (cond ((interval-merge-pair x y))
758         ((interval-< x y)
759          (make-interval :low (copy-interval-limit (interval-low x))
760                         :high (copy-interval-limit (interval-high y))))
761         (t
762          (make-interval :low (copy-interval-limit (interval-low y))
763                         :high (copy-interval-limit (interval-high x))))))
764
765 ;;; basic arithmetic operations on intervals. We probably should do
766 ;;; true interval arithmetic here, but it's complicated because we
767 ;;; have float and integer types and bounds can be open or closed.
768
769 ;;; the negative of an interval
770 (defun interval-neg (x)
771   (declare (type interval x))
772   (make-interval :low (bound-func #'- (interval-high x))
773                  :high (bound-func #'- (interval-low x))))
774
775 ;;; Add two intervals.
776 (defun interval-add (x y)
777   (declare (type interval x y))
778   (make-interval :low (bound-binop + (interval-low x) (interval-low y))
779                  :high (bound-binop + (interval-high x) (interval-high y))))
780
781 ;;; Subtract two intervals.
782 (defun interval-sub (x y)
783   (declare (type interval x y))
784   (make-interval :low (bound-binop - (interval-low x) (interval-high y))
785                  :high (bound-binop - (interval-high x) (interval-low y))))
786
787 ;;; Multiply two intervals.
788 (defun interval-mul (x y)
789   (declare (type interval x y))
790   (flet ((bound-mul (x y)
791            (cond ((or (null x) (null y))
792                   ;; Multiply by infinity is infinity
793                   nil)
794                  ((or (and (numberp x) (zerop x))
795                       (and (numberp y) (zerop y)))
796                   ;; Multiply by closed zero is special. The result
797                   ;; is always a closed bound. But don't replace this
798                   ;; with zero; we want the multiplication to produce
799                   ;; the correct signed zero, if needed. Use SIGNUM
800                   ;; to avoid trying to multiply huge bignums with 0.0.
801                   (* (signum (type-bound-number x)) (signum (type-bound-number y))))
802                  ((or (and (floatp x) (float-infinity-p x))
803                       (and (floatp y) (float-infinity-p y)))
804                   ;; Infinity times anything is infinity
805                   nil)
806                  (t
807                   ;; General multiply. The result is open if either is open.
808                   (bound-binop * x y)))))
809     (let ((x-range (interval-range-info x))
810           (y-range (interval-range-info y)))
811       (cond ((null x-range)
812              ;; Split x into two and multiply each separately
813              (destructuring-bind (x- x+) (interval-split 0 x t t)
814                (interval-merge-pair (interval-mul x- y)
815                                     (interval-mul x+ y))))
816             ((null y-range)
817              ;; Split y into two and multiply each separately
818              (destructuring-bind (y- y+) (interval-split 0 y t t)
819                (interval-merge-pair (interval-mul x y-)
820                                     (interval-mul x y+))))
821             ((eq x-range '-)
822              (interval-neg (interval-mul (interval-neg x) y)))
823             ((eq y-range '-)
824              (interval-neg (interval-mul x (interval-neg y))))
825             ((and (eq x-range '+) (eq y-range '+))
826              ;; If we are here, X and Y are both positive.
827              (make-interval
828               :low (bound-mul (interval-low x) (interval-low y))
829               :high (bound-mul (interval-high x) (interval-high y))))
830             (t
831              (bug "excluded case in INTERVAL-MUL"))))))
832
833 ;;; Divide two intervals.
834 (defun interval-div (top bot)
835   (declare (type interval top bot))
836   (flet ((bound-div (x y y-low-p)
837            ;; Compute x/y
838            (cond ((null y)
839                   ;; Divide by infinity means result is 0. However,
840                   ;; we need to watch out for the sign of the result,
841                   ;; to correctly handle signed zeros. We also need
842                   ;; to watch out for positive or negative infinity.
843                   (if (floatp (type-bound-number x))
844                       (if y-low-p
845                           (- (float-sign (type-bound-number x) 0.0))
846                           (float-sign (type-bound-number x) 0.0))
847                       0))
848                  ((zerop (type-bound-number y))
849                   ;; Divide by zero means result is infinity
850                   nil)
851                  ((and (numberp x) (zerop x))
852                   ;; Zero divided by anything is zero.
853                   x)
854                  (t
855                   (bound-binop / x y)))))
856     (let ((top-range (interval-range-info top))
857           (bot-range (interval-range-info bot)))
858       (cond ((null bot-range)
859              ;; The denominator contains zero, so anything goes!
860              (make-interval :low nil :high nil))
861             ((eq bot-range '-)
862              ;; Denominator is negative so flip the sign, compute the
863              ;; result, and flip it back.
864              (interval-neg (interval-div top (interval-neg bot))))
865             ((null top-range)
866              ;; Split top into two positive and negative parts, and
867              ;; divide each separately
868              (destructuring-bind (top- top+) (interval-split 0 top t t)
869                (interval-merge-pair (interval-div top- bot)
870                                     (interval-div top+ bot))))
871             ((eq top-range '-)
872              ;; Top is negative so flip the sign, divide, and flip the
873              ;; sign of the result.
874              (interval-neg (interval-div (interval-neg top) bot)))
875             ((and (eq top-range '+) (eq bot-range '+))
876              ;; the easy case
877              (make-interval
878               :low (bound-div (interval-low top) (interval-high bot) t)
879               :high (bound-div (interval-high top) (interval-low bot) nil)))
880             (t
881              (bug "excluded case in INTERVAL-DIV"))))))
882
883 ;;; Apply the function F to the interval X. If X = [a, b], then the
884 ;;; result is [f(a), f(b)]. It is up to the user to make sure the
885 ;;; result makes sense. It will if F is monotonic increasing (or
886 ;;; non-decreasing).
887 (defun interval-func (f x)
888   (declare (type function f)
889            (type interval x))
890   (let ((lo (bound-func f (interval-low x)))
891         (hi (bound-func f (interval-high x))))
892     (make-interval :low lo :high hi)))
893
894 ;;; Return T if X < Y. That is every number in the interval X is
895 ;;; always less than any number in the interval Y.
896 (defun interval-< (x y)
897   (declare (type interval x y))
898   ;; X < Y only if X is bounded above, Y is bounded below, and they
899   ;; don't overlap.
900   (when (and (interval-bounded-p x 'above)
901              (interval-bounded-p y 'below))
902     ;; Intervals are bounded in the appropriate way. Make sure they
903     ;; don't overlap.
904     (let ((left (interval-high x))
905           (right (interval-low y)))
906       (cond ((> (type-bound-number left)
907                 (type-bound-number right))
908              ;; The intervals definitely overlap, so result is NIL.
909              nil)
910             ((< (type-bound-number left)
911                 (type-bound-number right))
912              ;; The intervals definitely don't touch, so result is T.
913              t)
914             (t
915              ;; Limits are equal. Check for open or closed bounds.
916              ;; Don't overlap if one or the other are open.
917              (or (consp left) (consp right)))))))
918
919 ;;; Return T if X >= Y. That is, every number in the interval X is
920 ;;; always greater than any number in the interval Y.
921 (defun interval->= (x y)
922   (declare (type interval x y))
923   ;; X >= Y if lower bound of X >= upper bound of Y
924   (when (and (interval-bounded-p x 'below)
925              (interval-bounded-p y 'above))
926     (>= (type-bound-number (interval-low x))
927         (type-bound-number (interval-high y)))))
928
929 ;;; Return T if X = Y.
930 (defun interval-= (x y)
931   (declare (type interval x y))
932   (and (interval-bounded-p x 'both)
933        (interval-bounded-p y 'both)
934        (flet ((bound (v)
935                 (if (numberp v)
936                     v
937                     ;; Open intervals cannot be =
938                     (return-from interval-= nil))))
939          ;; Both intervals refer to the same point
940          (= (bound (interval-high x)) (bound (interval-low x))
941             (bound (interval-high y)) (bound (interval-low y))))))
942
943 ;;; Return T if X /= Y
944 (defun interval-/= (x y)
945   (not (interval-intersect-p x y)))
946
947 ;;; Return an interval that is the absolute value of X. Thus, if
948 ;;; X = [-1 10], the result is [0, 10].
949 (defun interval-abs (x)
950   (declare (type interval x))
951   (case (interval-range-info x)
952     (+
953      (copy-interval x))
954     (-
955      (interval-neg x))
956     (t
957      (destructuring-bind (x- x+) (interval-split 0 x t t)
958        (interval-merge-pair (interval-neg x-) x+)))))
959
960 ;;; Compute the square of an interval.
961 (defun interval-sqr (x)
962   (declare (type interval x))
963   (interval-func (lambda (x) (* x x))
964                  (interval-abs x)))
965 \f
966 ;;;; numeric DERIVE-TYPE methods
967
968 ;;; a utility for defining derive-type methods of integer operations. If
969 ;;; the types of both X and Y are integer types, then we compute a new
970 ;;; integer type with bounds determined Fun when applied to X and Y.
971 ;;; Otherwise, we use NUMERIC-CONTAGION.
972 (defun derive-integer-type-aux (x y fun)
973   (declare (type function fun))
974   (if (and (numeric-type-p x) (numeric-type-p y)
975            (eq (numeric-type-class x) 'integer)
976            (eq (numeric-type-class y) 'integer)
977            (eq (numeric-type-complexp x) :real)
978            (eq (numeric-type-complexp y) :real))
979       (multiple-value-bind (low high) (funcall fun x y)
980         (make-numeric-type :class 'integer
981                            :complexp :real
982                            :low low
983                            :high high))
984       (numeric-contagion x y)))
985
986 (defun derive-integer-type (x y fun)
987   (declare (type lvar x y) (type function fun))
988   (let ((x (lvar-type x))
989         (y (lvar-type y)))
990     (derive-integer-type-aux x y fun)))
991
992 ;;; simple utility to flatten a list
993 (defun flatten-list (x)
994   (labels ((flatten-and-append (tree list)
995              (cond ((null tree) list)
996                    ((atom tree) (cons tree list))
997                    (t (flatten-and-append
998                        (car tree) (flatten-and-append (cdr tree) list))))))
999     (flatten-and-append x nil)))
1000
1001 ;;; Take some type of lvar and massage it so that we get a list of the
1002 ;;; constituent types. If ARG is *EMPTY-TYPE*, return NIL to indicate
1003 ;;; failure.
1004 (defun prepare-arg-for-derive-type (arg)
1005   (flet ((listify (arg)
1006            (typecase arg
1007              (numeric-type
1008               (list arg))
1009              (union-type
1010               (union-type-types arg))
1011              (t
1012               (list arg)))))
1013     (unless (eq arg *empty-type*)
1014       ;; Make sure all args are some type of numeric-type. For member
1015       ;; types, convert the list of members into a union of equivalent
1016       ;; single-element member-type's.
1017       (let ((new-args nil))
1018         (dolist (arg (listify arg))
1019           (if (member-type-p arg)
1020               ;; Run down the list of members and convert to a list of
1021               ;; member types.
1022               (mapc-member-type-members
1023                (lambda (member)
1024                  (push (if (numberp member)
1025                            (make-member-type :members (list member))
1026                            *empty-type*)
1027                        new-args))
1028                arg)
1029               (push arg new-args)))
1030         (unless (member *empty-type* new-args)
1031           new-args)))))
1032
1033 ;;; Convert from the standard type convention for which -0.0 and 0.0
1034 ;;; are equal to an intermediate convention for which they are
1035 ;;; considered different which is more natural for some of the
1036 ;;; optimisers.
1037 (defun convert-numeric-type (type)
1038   (declare (type numeric-type type))
1039   ;;; Only convert real float interval delimiters types.
1040   (if (eq (numeric-type-complexp type) :real)
1041       (let* ((lo (numeric-type-low type))
1042              (lo-val (type-bound-number lo))
1043              (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0)))
1044              (hi (numeric-type-high type))
1045              (hi-val (type-bound-number hi))
1046              (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0))))
1047         (if (or lo-float-zero-p hi-float-zero-p)
1048             (make-numeric-type
1049              :class (numeric-type-class type)
1050              :format (numeric-type-format type)
1051              :complexp :real
1052              :low (if lo-float-zero-p
1053                       (if (consp lo)
1054                           (list (float 0.0 lo-val))
1055                           (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val))
1056                       lo)
1057              :high (if hi-float-zero-p
1058                        (if (consp hi)
1059                            (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))
1060                            (float 0.0 hi-val))
1061                        hi))
1062             type))
1063       ;; Not real float.
1064       type))
1065
1066 ;;; Convert back from the intermediate convention for which -0.0 and
1067 ;;; 0.0 are considered different to the standard type convention for
1068 ;;; which and equal.
1069 (defun convert-back-numeric-type (type)
1070   (declare (type numeric-type type))
1071   ;;; Only convert real float interval delimiters types.
1072   (if (eq (numeric-type-complexp type) :real)
1073       (let* ((lo (numeric-type-low type))
1074              (lo-val (type-bound-number lo))
1075              (lo-float-zero-p
1076               (and lo (floatp lo-val) (= lo-val 0.0)
1077                    (float-sign lo-val)))
1078              (hi (numeric-type-high type))
1079              (hi-val (type-bound-number hi))
1080              (hi-float-zero-p
1081               (and hi (floatp hi-val) (= hi-val 0.0)
1082                    (float-sign hi-val))))
1083         (cond
1084           ;; (float +0.0 +0.0) => (member 0.0)
1085           ;; (float -0.0 -0.0) => (member -0.0)
1086           ((and lo-float-zero-p hi-float-zero-p)
1087            ;; shouldn't have exclusive bounds here..
1088            (aver (and (not (consp lo)) (not (consp hi))))
1089            (if (= lo-float-zero-p hi-float-zero-p)
1090                ;; (float +0.0 +0.0) => (member 0.0)
1091                ;; (float -0.0 -0.0) => (member -0.0)
1092                (specifier-type `(member ,lo-val))
1093                ;; (float -0.0 +0.0) => (float 0.0 0.0)
1094                ;; (float +0.0 -0.0) => (float 0.0 0.0)
1095                (make-numeric-type :class (numeric-type-class type)
1096                                   :format (numeric-type-format type)
1097                                   :complexp :real
1098                                   :low hi-val
1099                                   :high hi-val)))
1100           (lo-float-zero-p
1101            (cond
1102              ;; (float -0.0 x) => (float 0.0 x)
1103              ((and (not (consp lo)) (minusp lo-float-zero-p))
1104               (make-numeric-type :class (numeric-type-class type)
1105                                  :format (numeric-type-format type)
1106                                  :complexp :real
1107                                  :low (float 0.0 lo-val)
1108                                  :high hi))
1109              ;; (float (+0.0) x) => (float (0.0) x)
1110              ((and (consp lo) (plusp lo-float-zero-p))
1111               (make-numeric-type :class (numeric-type-class type)
1112                                  :format (numeric-type-format type)
1113                                  :complexp :real
1114                                  :low (list (float 0.0 lo-val))
1115                                  :high hi))
1116              (t
1117               ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
1118               ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
1119               (list (make-member-type :members (list (float 0.0 lo-val)))
1120                     (make-numeric-type :class (numeric-type-class type)
1121                                        :format (numeric-type-format type)
1122                                        :complexp :real
1123                                        :low (list (float 0.0 lo-val))
1124                                        :high hi)))))
1125           (hi-float-zero-p
1126            (cond
1127              ;; (float x +0.0) => (float x 0.0)
1128              ((and (not (consp hi)) (plusp hi-float-zero-p))
1129               (make-numeric-type :class (numeric-type-class type)
1130                                  :format (numeric-type-format type)
1131                                  :complexp :real
1132                                  :low lo
1133                                  :high (float 0.0 hi-val)))
1134              ;; (float x (-0.0)) => (float x (0.0))
1135              ((and (consp hi) (minusp hi-float-zero-p))
1136               (make-numeric-type :class (numeric-type-class type)
1137                                  :format (numeric-type-format type)
1138                                  :complexp :real
1139                                  :low lo
1140                                  :high (list (float 0.0 hi-val))))
1141              (t
1142               ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
1143               ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
1144               (list (make-member-type :members (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val)))
1145                     (make-numeric-type :class (numeric-type-class type)
1146                                        :format (numeric-type-format type)
1147                                        :complexp :real
1148                                        :low lo
1149                                        :high (list (float 0.0 hi-val)))))))
1150           (t
1151            type)))
1152       ;; not real float
1153       type))
1154
1155 ;;; Convert back a possible list of numeric types.
1156 (defun convert-back-numeric-type-list (type-list)
1157   (typecase type-list
1158     (list
1159      (let ((results '()))
1160        (dolist (type type-list)
1161          (if (numeric-type-p type)
1162              (let ((result (convert-back-numeric-type type)))
1163                (if (listp result)
1164                    (setf results (append results result))
1165                    (push result results)))
1166              (push type results)))
1167        results))
1168     (numeric-type
1169      (convert-back-numeric-type type-list))
1170     (union-type
1171      (convert-back-numeric-type-list (union-type-types type-list)))
1172     (t
1173      type-list)))
1174
1175 ;;; Take a list of types and return a canonical type specifier,
1176 ;;; combining any MEMBER types together. If both positive and negative
1177 ;;; MEMBER types are present they are converted to a float type.
1178 ;;; XXX This would be far simpler if the type-union methods could handle
1179 ;;; member/number unions.
1180 ;;;
1181 ;;; If we're about to generate an overly complex union of numeric types, start
1182 ;;; collapse the ranges together.
1183 ;;;
1184 ;;; FIXME: The MEMBER canonicalization parts of MAKE-DERIVED-UNION-TYPE and
1185 ;;; entire CONVERT-MEMBER-TYPE probably belong in the kernel's type logic,
1186 ;;; invoked always, instead of in the compiler, invoked only during some type
1187 ;;; optimizations.
1188 (defvar *derived-numeric-union-complexity-limit* 6)
1189
1190 (defun make-derived-union-type (type-list)
1191   (let ((xset (alloc-xset))
1192         (fp-zeroes '())
1193         (misc-types '())
1194         (numeric-type *empty-type*))
1195     (dolist (type type-list)
1196       (cond ((member-type-p type)
1197              (mapc-member-type-members
1198               (lambda (member)
1199                 (if (fp-zero-p member)
1200                     (unless (member member fp-zeroes)
1201                       (pushnew member fp-zeroes))
1202                     (add-to-xset member xset)))
1203               type))
1204             ((numeric-type-p type)
1205              (let ((*approximate-numeric-unions*
1206                     (when (and (union-type-p numeric-type)
1207                                (nthcdr *derived-numeric-union-complexity-limit*
1208                                        (union-type-types numeric-type)))
1209                       t)))
1210                (setf numeric-type (type-union type numeric-type))))
1211             (t
1212              (push type misc-types))))
1213     (if (and (xset-empty-p xset) (not fp-zeroes))
1214         (apply #'type-union numeric-type misc-types)
1215         (apply #'type-union (make-member-type :xset xset :fp-zeroes fp-zeroes)
1216                numeric-type misc-types))))
1217
1218 ;;; Convert a member type with a single member to a numeric type.
1219 (defun convert-member-type (arg)
1220   (let* ((members (member-type-members arg))
1221          (member (first members))
1222          (member-type (type-of member)))
1223     (aver (not (rest members)))
1224     (specifier-type (cond ((typep member 'integer)
1225                            `(integer ,member ,member))
1226                           ((memq member-type '(short-float single-float
1227                                                double-float long-float))
1228                            `(,member-type ,member ,member))
1229                           (t
1230                            member-type)))))
1231
1232 ;;; This is used in defoptimizers for computing the resulting type of
1233 ;;; a function.
1234 ;;;
1235 ;;; Given the lvar ARG, derive the resulting type using the
1236 ;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some
1237 ;;; "atomic" lvar type like numeric-type or member-type (containing
1238 ;;; just one element). It should return the resulting type, which can
1239 ;;; be a list of types.
1240 ;;;
1241 ;;; For the case of member types, if a MEMBER-FUN is given it is
1242 ;;; called to compute the result otherwise the member type is first
1243 ;;; converted to a numeric type and the DERIVE-FUN is called.
1244 (defun one-arg-derive-type (arg derive-fun member-fun
1245                                 &optional (convert-type t))
1246   (declare (type function derive-fun)
1247            (type (or null function) member-fun))
1248   (let ((arg-list (prepare-arg-for-derive-type (lvar-type arg))))
1249     (when arg-list
1250       (flet ((deriver (x)
1251                (typecase x
1252                  (member-type
1253                   (if member-fun
1254                       (with-float-traps-masked
1255                           (:underflow :overflow :divide-by-zero)
1256                         (specifier-type
1257                          `(eql ,(funcall member-fun
1258                                          (first (member-type-members x))))))
1259                       ;; Otherwise convert to a numeric type.
1260                       (let ((result-type-list
1261                              (funcall derive-fun (convert-member-type x))))
1262                         (if convert-type
1263                             (convert-back-numeric-type-list result-type-list)
1264                             result-type-list))))
1265                  (numeric-type
1266                   (if convert-type
1267                       (convert-back-numeric-type-list
1268                        (funcall derive-fun (convert-numeric-type x)))
1269                       (funcall derive-fun x)))
1270                  (t
1271                   *universal-type*))))
1272         ;; Run down the list of args and derive the type of each one,
1273         ;; saving all of the results in a list.
1274         (let ((results nil))
1275           (dolist (arg arg-list)
1276             (let ((result (deriver arg)))
1277               (if (listp result)
1278                   (setf results (append results result))
1279                   (push result results))))
1280           (if (rest results)
1281               (make-derived-union-type results)
1282               (first results)))))))
1283
1284 ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
1285 ;;; two arguments. DERIVE-FUN takes 3 args in this case: the two
1286 ;;; original args and a third which is T to indicate if the two args
1287 ;;; really represent the same lvar. This is useful for deriving the
1288 ;;; type of things like (* x x), which should always be positive. If
1289 ;;; we didn't do this, we wouldn't be able to tell.
1290 (defun two-arg-derive-type (arg1 arg2 derive-fun fun
1291                                  &optional (convert-type t))
1292   (declare (type function derive-fun fun))
1293   (flet ((deriver (x y same-arg)
1294            (cond ((and (member-type-p x) (member-type-p y))
1295                   (let* ((x (first (member-type-members x)))
1296                          (y (first (member-type-members y)))
1297                          (result (ignore-errors
1298                                    (with-float-traps-masked
1299                                        (:underflow :overflow :divide-by-zero
1300                                                    :invalid)
1301                                      (funcall fun x y)))))
1302                     (cond ((null result) *empty-type*)
1303                           ((and (floatp result) (float-nan-p result))
1304                            (make-numeric-type :class 'float
1305                                               :format (type-of result)
1306                                               :complexp :real))
1307                           (t
1308                            (specifier-type `(eql ,result))))))
1309                  ((and (member-type-p x) (numeric-type-p y))
1310                   (let* ((x (convert-member-type x))
1311                          (y (if convert-type (convert-numeric-type y) y))
1312                          (result (funcall derive-fun x y same-arg)))
1313                     (if convert-type
1314                         (convert-back-numeric-type-list result)
1315                         result)))
1316                  ((and (numeric-type-p x) (member-type-p y))
1317                   (let* ((x (if convert-type (convert-numeric-type x) x))
1318                          (y (convert-member-type y))
1319                          (result (funcall derive-fun x y same-arg)))
1320                     (if convert-type
1321                         (convert-back-numeric-type-list result)
1322                         result)))
1323                  ((and (numeric-type-p x) (numeric-type-p y))
1324                   (let* ((x (if convert-type (convert-numeric-type x) x))
1325                          (y (if convert-type (convert-numeric-type y) y))
1326                          (result (funcall derive-fun x y same-arg)))
1327                     (if convert-type
1328                         (convert-back-numeric-type-list result)
1329                         result)))
1330                  (t
1331                   *universal-type*))))
1332     (let ((same-arg (same-leaf-ref-p arg1 arg2))
1333           (a1 (prepare-arg-for-derive-type (lvar-type arg1)))
1334           (a2 (prepare-arg-for-derive-type (lvar-type arg2))))
1335       (when (and a1 a2)
1336         (let ((results nil))
1337           (if same-arg
1338               ;; Since the args are the same LVARs, just run down the
1339               ;; lists.
1340               (dolist (x a1)
1341                 (let ((result (deriver x x same-arg)))
1342                   (if (listp result)
1343                       (setf results (append results result))
1344                       (push result results))))
1345               ;; Try all pairwise combinations.
1346               (dolist (x a1)
1347                 (dolist (y a2)
1348                   (let ((result (or (deriver x y same-arg)
1349                                     (numeric-contagion x y))))
1350                     (if (listp result)
1351                         (setf results (append results result))
1352                         (push result results))))))
1353           (if (rest results)
1354               (make-derived-union-type results)
1355               (first results)))))))
1356 \f
1357 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1358 (progn
1359 (defoptimizer (+ derive-type) ((x y))
1360   (derive-integer-type
1361    x y
1362    #'(lambda (x y)
1363        (flet ((frob (x y)
1364                 (if (and x y)
1365                     (+ x y)
1366                     nil)))
1367          (values (frob (numeric-type-low x) (numeric-type-low y))
1368                  (frob (numeric-type-high x) (numeric-type-high y)))))))
1369
1370 (defoptimizer (- derive-type) ((x y))
1371   (derive-integer-type
1372    x y
1373    #'(lambda (x y)
1374        (flet ((frob (x y)
1375                 (if (and x y)
1376                     (- x y)
1377                     nil)))
1378          (values (frob (numeric-type-low x) (numeric-type-high y))
1379                  (frob (numeric-type-high x) (numeric-type-low y)))))))
1380
1381 (defoptimizer (* derive-type) ((x y))
1382   (derive-integer-type
1383    x y
1384    #'(lambda (x y)
1385        (let ((x-low (numeric-type-low x))
1386              (x-high (numeric-type-high x))
1387              (y-low (numeric-type-low y))
1388              (y-high (numeric-type-high y)))
1389          (cond ((not (and x-low y-low))
1390                 (values nil nil))
1391                ((or (minusp x-low) (minusp y-low))
1392                 (if (and x-high y-high)
1393                     (let ((max (* (max (abs x-low) (abs x-high))
1394                                   (max (abs y-low) (abs y-high)))))
1395                       (values (- max) max))
1396                     (values nil nil)))
1397                (t
1398                 (values (* x-low y-low)
1399                         (if (and x-high y-high)
1400                             (* x-high y-high)
1401                             nil))))))))
1402
1403 (defoptimizer (/ derive-type) ((x y))
1404   (numeric-contagion (lvar-type x) (lvar-type y)))
1405
1406 ) ; PROGN
1407
1408 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1409 (progn
1410 (defun +-derive-type-aux (x y same-arg)
1411   (if (and (numeric-type-real-p x)
1412            (numeric-type-real-p y))
1413       (let ((result
1414              (if same-arg
1415                  (let ((x-int (numeric-type->interval x)))
1416                    (interval-add x-int x-int))
1417                  (interval-add (numeric-type->interval x)
1418                                (numeric-type->interval y))))
1419             (result-type (numeric-contagion x y)))
1420         ;; If the result type is a float, we need to be sure to coerce
1421         ;; the bounds into the correct type.
1422         (when (eq (numeric-type-class result-type) 'float)
1423           (setf result (interval-func
1424                         #'(lambda (x)
1425                             (coerce-for-bound x (or (numeric-type-format result-type)
1426                                                     'float)))
1427                         result)))
1428         (make-numeric-type
1429          :class (if (and (eq (numeric-type-class x) 'integer)
1430                          (eq (numeric-type-class y) 'integer))
1431                     ;; The sum of integers is always an integer.
1432                     'integer
1433                     (numeric-type-class result-type))
1434          :format (numeric-type-format result-type)
1435          :low (interval-low result)
1436          :high (interval-high result)))
1437       ;; general contagion
1438       (numeric-contagion x y)))
1439
1440 (defoptimizer (+ derive-type) ((x y))
1441   (two-arg-derive-type x y #'+-derive-type-aux #'+))
1442
1443 (defun --derive-type-aux (x y same-arg)
1444   (if (and (numeric-type-real-p x)
1445            (numeric-type-real-p y))
1446       (let ((result
1447              ;; (- X X) is always 0.
1448              (if same-arg
1449                  (make-interval :low 0 :high 0)
1450                  (interval-sub (numeric-type->interval x)
1451                                (numeric-type->interval y))))
1452             (result-type (numeric-contagion x y)))
1453         ;; If the result type is a float, we need to be sure to coerce
1454         ;; the bounds into the correct type.
1455         (when (eq (numeric-type-class result-type) 'float)
1456           (setf result (interval-func
1457                         #'(lambda (x)
1458                             (coerce-for-bound x (or (numeric-type-format result-type)
1459                                                     'float)))
1460                         result)))
1461         (make-numeric-type
1462          :class (if (and (eq (numeric-type-class x) 'integer)
1463                          (eq (numeric-type-class y) 'integer))
1464                     ;; The difference of integers is always an integer.
1465                     'integer
1466                     (numeric-type-class result-type))
1467          :format (numeric-type-format result-type)
1468          :low (interval-low result)
1469          :high (interval-high result)))
1470       ;; general contagion
1471       (numeric-contagion x y)))
1472
1473 (defoptimizer (- derive-type) ((x y))
1474   (two-arg-derive-type x y #'--derive-type-aux #'-))
1475
1476 (defun *-derive-type-aux (x y same-arg)
1477   (if (and (numeric-type-real-p x)
1478            (numeric-type-real-p y))
1479       (let ((result
1480              ;; (* X X) is always positive, so take care to do it right.
1481              (if same-arg
1482                  (interval-sqr (numeric-type->interval x))
1483                  (interval-mul (numeric-type->interval x)
1484                                (numeric-type->interval y))))
1485             (result-type (numeric-contagion x y)))
1486         ;; If the result type is a float, we need to be sure to coerce
1487         ;; the bounds into the correct type.
1488         (when (eq (numeric-type-class result-type) 'float)
1489           (setf result (interval-func
1490                         #'(lambda (x)
1491                             (coerce-for-bound x (or (numeric-type-format result-type)
1492                                                     'float)))
1493                         result)))
1494         (make-numeric-type
1495          :class (if (and (eq (numeric-type-class x) 'integer)
1496                          (eq (numeric-type-class y) 'integer))
1497                     ;; The product of integers is always an integer.
1498                     'integer
1499                     (numeric-type-class result-type))
1500          :format (numeric-type-format result-type)
1501          :low (interval-low result)
1502          :high (interval-high result)))
1503       (numeric-contagion x y)))
1504
1505 (defoptimizer (* derive-type) ((x y))
1506   (two-arg-derive-type x y #'*-derive-type-aux #'*))
1507
1508 (defun /-derive-type-aux (x y same-arg)
1509   (if (and (numeric-type-real-p x)
1510            (numeric-type-real-p y))
1511       (let ((result
1512              ;; (/ X X) is always 1, except if X can contain 0. In
1513              ;; that case, we shouldn't optimize the division away
1514              ;; because we want 0/0 to signal an error.
1515              (if (and same-arg
1516                       (not (interval-contains-p
1517                             0 (interval-closure (numeric-type->interval y)))))
1518                  (make-interval :low 1 :high 1)
1519                  (interval-div (numeric-type->interval x)
1520                                (numeric-type->interval y))))
1521             (result-type (numeric-contagion x y)))
1522         ;; If the result type is a float, we need to be sure to coerce
1523         ;; the bounds into the correct type.
1524         (when (eq (numeric-type-class result-type) 'float)
1525           (setf result (interval-func
1526                         #'(lambda (x)
1527                             (coerce-for-bound x (or (numeric-type-format result-type)
1528                                                     'float)))
1529                         result)))
1530         (make-numeric-type :class (numeric-type-class result-type)
1531                            :format (numeric-type-format result-type)
1532                            :low (interval-low result)
1533                            :high (interval-high result)))
1534       (numeric-contagion x y)))
1535
1536 (defoptimizer (/ derive-type) ((x y))
1537   (two-arg-derive-type x y #'/-derive-type-aux #'/))
1538
1539 ) ; PROGN
1540
1541 (defun ash-derive-type-aux (n-type shift same-arg)
1542   (declare (ignore same-arg))
1543   ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
1544   ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
1545   ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
1546   ;; two bignums yielding zero) and it's hard to avoid that
1547   ;; calculation in here.
1548   #+(and cmu sb-xc-host)
1549   (when (and (or (typep (numeric-type-low n-type) 'bignum)
1550                  (typep (numeric-type-high n-type) 'bignum))
1551              (or (typep (numeric-type-low shift) 'bignum)
1552                  (typep (numeric-type-high shift) 'bignum)))
1553     (return-from ash-derive-type-aux *universal-type*))
1554   (flet ((ash-outer (n s)
1555            (when (and (fixnump s)
1556                       (<= s 64)
1557                       (> s sb!xc:most-negative-fixnum))
1558              (ash n s)))
1559          ;; KLUDGE: The bare 64's here should be related to
1560          ;; symbolic machine word size values somehow.
1561
1562          (ash-inner (n s)
1563            (if (and (fixnump s)
1564                     (> s sb!xc:most-negative-fixnum))
1565              (ash n (min s 64))
1566              (if (minusp n) -1 0))))
1567     (or (and (csubtypep n-type (specifier-type 'integer))
1568              (csubtypep shift (specifier-type 'integer))
1569              (let ((n-low (numeric-type-low n-type))
1570                    (n-high (numeric-type-high n-type))
1571                    (s-low (numeric-type-low shift))
1572                    (s-high (numeric-type-high shift)))
1573                (make-numeric-type :class 'integer  :complexp :real
1574                                   :low (when n-low
1575                                          (if (minusp n-low)
1576                                            (ash-outer n-low s-high)
1577                                            (ash-inner n-low s-low)))
1578                                   :high (when n-high
1579                                           (if (minusp n-high)
1580                                             (ash-inner n-high s-low)
1581                                             (ash-outer n-high s-high))))))
1582         *universal-type*)))
1583
1584 (defoptimizer (ash derive-type) ((n shift))
1585   (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
1586
1587 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1588 (macrolet ((frob (fun)
1589              `#'(lambda (type type2)
1590                   (declare (ignore type2))
1591                   (let ((lo (numeric-type-low type))
1592                         (hi (numeric-type-high type)))
1593                     (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
1594
1595   (defoptimizer (%negate derive-type) ((num))
1596     (derive-integer-type num num (frob -))))
1597
1598 (defun lognot-derive-type-aux (int)
1599   (derive-integer-type-aux int int
1600                            (lambda (type type2)
1601                              (declare (ignore type2))
1602                              (let ((lo (numeric-type-low type))
1603                                    (hi (numeric-type-high type)))
1604                                (values (if hi (lognot hi) nil)
1605                                        (if lo (lognot lo) nil)
1606                                        (numeric-type-class type)
1607                                        (numeric-type-format type))))))
1608
1609 (defoptimizer (lognot derive-type) ((int))
1610   (lognot-derive-type-aux (lvar-type int)))
1611
1612 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1613 (defoptimizer (%negate derive-type) ((num))
1614   (flet ((negate-bound (b)
1615            (and b
1616                 (set-bound (- (type-bound-number b))
1617                            (consp b)))))
1618     (one-arg-derive-type num
1619                          (lambda (type)
1620                            (modified-numeric-type
1621                             type
1622                             :low (negate-bound (numeric-type-high type))
1623                             :high (negate-bound (numeric-type-low type))))
1624                          #'-)))
1625
1626 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1627 (defoptimizer (abs derive-type) ((num))
1628   (let ((type (lvar-type num)))
1629     (if (and (numeric-type-p type)
1630              (eq (numeric-type-class type) 'integer)
1631              (eq (numeric-type-complexp type) :real))
1632         (let ((lo (numeric-type-low type))
1633               (hi (numeric-type-high type)))
1634           (make-numeric-type :class 'integer :complexp :real
1635                              :low (cond ((and hi (minusp hi))
1636                                          (abs hi))
1637                                         (lo
1638                                          (max 0 lo))
1639                                         (t
1640                                          0))
1641                              :high (if (and hi lo)
1642                                        (max (abs hi) (abs lo))
1643                                        nil)))
1644         (numeric-contagion type type))))
1645
1646 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1647 (defun abs-derive-type-aux (type)
1648   (cond ((eq (numeric-type-complexp type) :complex)
1649          ;; The absolute value of a complex number is always a
1650          ;; non-negative float.
1651          (let* ((format (case (numeric-type-class type)
1652                           ((integer rational) 'single-float)
1653                           (t (numeric-type-format type))))
1654                 (bound-format (or format 'float)))
1655            (make-numeric-type :class 'float
1656                               :format format
1657                               :complexp :real
1658                               :low (coerce 0 bound-format)
1659                               :high nil)))
1660         (t
1661          ;; The absolute value of a real number is a non-negative real
1662          ;; of the same type.
1663          (let* ((abs-bnd (interval-abs (numeric-type->interval type)))
1664                 (class (numeric-type-class type))
1665                 (format (numeric-type-format type))
1666                 (bound-type (or format class 'real)))
1667            (make-numeric-type
1668             :class class
1669             :format format
1670             :complexp :real
1671             :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type)
1672             :high (coerce-and-truncate-floats
1673                    (interval-high abs-bnd) bound-type))))))
1674
1675 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1676 (defoptimizer (abs derive-type) ((num))
1677   (one-arg-derive-type num #'abs-derive-type-aux #'abs))
1678
1679 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1680 (defoptimizer (truncate derive-type) ((number divisor))
1681   (let ((number-type (lvar-type number))
1682         (divisor-type (lvar-type divisor))
1683         (integer-type (specifier-type 'integer)))
1684     (if (and (numeric-type-p number-type)
1685              (csubtypep number-type integer-type)
1686              (numeric-type-p divisor-type)
1687              (csubtypep divisor-type integer-type))
1688         (let ((number-low (numeric-type-low number-type))
1689               (number-high (numeric-type-high number-type))
1690               (divisor-low (numeric-type-low divisor-type))
1691               (divisor-high (numeric-type-high divisor-type)))
1692           (values-specifier-type
1693            `(values ,(integer-truncate-derive-type number-low number-high
1694                                                    divisor-low divisor-high)
1695                     ,(integer-rem-derive-type number-low number-high
1696                                               divisor-low divisor-high))))
1697         *universal-type*)))
1698
1699 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1700 (progn
1701
1702 (defun rem-result-type (number-type divisor-type)
1703   ;; Figure out what the remainder type is. The remainder is an
1704   ;; integer if both args are integers; a rational if both args are
1705   ;; rational; and a float otherwise.
1706   (cond ((and (csubtypep number-type (specifier-type 'integer))
1707               (csubtypep divisor-type (specifier-type 'integer)))
1708          'integer)
1709         ((and (csubtypep number-type (specifier-type 'rational))
1710               (csubtypep divisor-type (specifier-type 'rational)))
1711          'rational)
1712         ((and (csubtypep number-type (specifier-type 'float))
1713               (csubtypep divisor-type (specifier-type 'float)))
1714          ;; Both are floats so the result is also a float, of
1715          ;; the largest type.
1716          (or (float-format-max (numeric-type-format number-type)
1717                                (numeric-type-format divisor-type))
1718              'float))
1719         ((and (csubtypep number-type (specifier-type 'float))
1720               (csubtypep divisor-type (specifier-type 'rational)))
1721          ;; One of the arguments is a float and the other is a
1722          ;; rational. The remainder is a float of the same
1723          ;; type.
1724          (or (numeric-type-format number-type) 'float))
1725         ((and (csubtypep divisor-type (specifier-type 'float))
1726               (csubtypep number-type (specifier-type 'rational)))
1727          ;; One of the arguments is a float and the other is a
1728          ;; rational. The remainder is a float of the same
1729          ;; type.
1730          (or (numeric-type-format divisor-type) 'float))
1731         (t
1732          ;; Some unhandled combination. This usually means both args
1733          ;; are REAL so the result is a REAL.
1734          'real)))
1735
1736 (defun truncate-derive-type-quot (number-type divisor-type)
1737   (let* ((rem-type (rem-result-type number-type divisor-type))
1738          (number-interval (numeric-type->interval number-type))
1739          (divisor-interval (numeric-type->interval divisor-type)))
1740     ;;(declare (type (member '(integer rational float)) rem-type))
1741     ;; We have real numbers now.
1742     (cond ((eq rem-type 'integer)
1743            ;; Since the remainder type is INTEGER, both args are
1744            ;; INTEGERs.
1745            (let* ((res (integer-truncate-derive-type
1746                         (interval-low number-interval)
1747                         (interval-high number-interval)
1748                         (interval-low divisor-interval)
1749                         (interval-high divisor-interval))))
1750              (specifier-type (if (listp res) res 'integer))))
1751           (t
1752            (let ((quot (truncate-quotient-bound
1753                         (interval-div number-interval
1754                                       divisor-interval))))
1755              (specifier-type `(integer ,(or (interval-low quot) '*)
1756                                        ,(or (interval-high quot) '*))))))))
1757
1758 (defun truncate-derive-type-rem (number-type divisor-type)
1759   (let* ((rem-type (rem-result-type number-type divisor-type))
1760          (number-interval (numeric-type->interval number-type))
1761          (divisor-interval (numeric-type->interval divisor-type))
1762          (rem (truncate-rem-bound number-interval divisor-interval)))
1763     ;;(declare (type (member '(integer rational float)) rem-type))
1764     ;; We have real numbers now.
1765     (cond ((eq rem-type 'integer)
1766            ;; Since the remainder type is INTEGER, both args are
1767            ;; INTEGERs.
1768            (specifier-type `(,rem-type ,(or (interval-low rem) '*)
1769                                        ,(or (interval-high rem) '*))))
1770           (t
1771            (multiple-value-bind (class format)
1772                (ecase rem-type
1773                  (integer
1774                   (values 'integer nil))
1775                  (rational
1776                   (values 'rational nil))
1777                  ((or single-float double-float #!+long-float long-float)
1778                   (values 'float rem-type))
1779                  (float
1780                   (values 'float nil))
1781                  (real
1782                   (values nil nil)))
1783              (when (member rem-type '(float single-float double-float
1784                                             #!+long-float long-float))
1785                (setf rem (interval-func #'(lambda (x)
1786                                             (coerce-for-bound x rem-type))
1787                                         rem)))
1788              (make-numeric-type :class class
1789                                 :format format
1790                                 :low (interval-low rem)
1791                                 :high (interval-high rem)))))))
1792
1793 (defun truncate-derive-type-quot-aux (num div same-arg)
1794   (declare (ignore same-arg))
1795   (if (and (numeric-type-real-p num)
1796            (numeric-type-real-p div))
1797       (truncate-derive-type-quot num div)
1798       *empty-type*))
1799
1800 (defun truncate-derive-type-rem-aux (num div same-arg)
1801   (declare (ignore same-arg))
1802   (if (and (numeric-type-real-p num)
1803            (numeric-type-real-p div))
1804       (truncate-derive-type-rem num div)
1805       *empty-type*))
1806
1807 (defoptimizer (truncate derive-type) ((number divisor))
1808   (let ((quot (two-arg-derive-type number divisor
1809                                    #'truncate-derive-type-quot-aux #'truncate))
1810         (rem (two-arg-derive-type number divisor
1811                                   #'truncate-derive-type-rem-aux #'rem)))
1812     (when (and quot rem)
1813       (make-values-type :required (list quot rem)))))
1814
1815 (defun ftruncate-derive-type-quot (number-type divisor-type)
1816   ;; The bounds are the same as for truncate. However, the first
1817   ;; result is a float of some type. We need to determine what that
1818   ;; type is. Basically it's the more contagious of the two types.
1819   (let ((q-type (truncate-derive-type-quot number-type divisor-type))
1820         (res-type (numeric-contagion number-type divisor-type)))
1821     (make-numeric-type :class 'float
1822                        :format (numeric-type-format res-type)
1823                        :low (numeric-type-low q-type)
1824                        :high (numeric-type-high q-type))))
1825
1826 (defun ftruncate-derive-type-quot-aux (n d same-arg)
1827   (declare (ignore same-arg))
1828   (if (and (numeric-type-real-p n)
1829            (numeric-type-real-p d))
1830       (ftruncate-derive-type-quot n d)
1831       *empty-type*))
1832
1833 (defoptimizer (ftruncate derive-type) ((number divisor))
1834   (let ((quot
1835          (two-arg-derive-type number divisor
1836                               #'ftruncate-derive-type-quot-aux #'ftruncate))
1837         (rem (two-arg-derive-type number divisor
1838                                   #'truncate-derive-type-rem-aux #'rem)))
1839     (when (and quot rem)
1840       (make-values-type :required (list quot rem)))))
1841
1842 (defun %unary-truncate-derive-type-aux (number)
1843   (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
1844
1845 (defoptimizer (%unary-truncate derive-type) ((number))
1846   (one-arg-derive-type number
1847                        #'%unary-truncate-derive-type-aux
1848                        #'%unary-truncate))
1849
1850 (defoptimizer (%unary-truncate/single-float derive-type) ((number))
1851   (one-arg-derive-type number
1852                        #'%unary-truncate-derive-type-aux
1853                        #'%unary-truncate))
1854
1855 (defoptimizer (%unary-truncate/double-float derive-type) ((number))
1856   (one-arg-derive-type number
1857                        #'%unary-truncate-derive-type-aux
1858                        #'%unary-truncate))
1859
1860 (defoptimizer (%unary-ftruncate derive-type) ((number))
1861   (let ((divisor (specifier-type '(integer 1 1))))
1862     (one-arg-derive-type number
1863                          #'(lambda (n)
1864                              (ftruncate-derive-type-quot-aux n divisor nil))
1865                          #'%unary-ftruncate)))
1866
1867 (defoptimizer (%unary-round derive-type) ((number))
1868   (one-arg-derive-type number
1869                        (lambda (n)
1870                          (block nil
1871                            (unless (numeric-type-real-p n)
1872                              (return *empty-type*))
1873                            (let* ((interval (numeric-type->interval n))
1874                                   (low      (interval-low interval))
1875                                   (high     (interval-high interval)))
1876                              (when (consp low)
1877                                (setf low (car low)))
1878                              (when (consp high)
1879                                (setf high (car high)))
1880                              (specifier-type
1881                               `(integer ,(if low
1882                                              (round low)
1883                                              '*)
1884                                         ,(if high
1885                                              (round high)
1886                                              '*))))))
1887                        #'%unary-round))
1888
1889 ;;; Define optimizers for FLOOR and CEILING.
1890 (macrolet
1891     ((def (name q-name r-name)
1892        (let ((q-aux (symbolicate q-name "-AUX"))
1893              (r-aux (symbolicate r-name "-AUX")))
1894          `(progn
1895            ;; Compute type of quotient (first) result.
1896            (defun ,q-aux (number-type divisor-type)
1897              (let* ((number-interval
1898                      (numeric-type->interval number-type))
1899                     (divisor-interval
1900                      (numeric-type->interval divisor-type))
1901                     (quot (,q-name (interval-div number-interval
1902                                                  divisor-interval))))
1903                (specifier-type `(integer ,(or (interval-low quot) '*)
1904                                          ,(or (interval-high quot) '*)))))
1905            ;; Compute type of remainder.
1906            (defun ,r-aux (number-type divisor-type)
1907              (let* ((divisor-interval
1908                      (numeric-type->interval divisor-type))
1909                     (rem (,r-name divisor-interval))
1910                     (result-type (rem-result-type number-type divisor-type)))
1911                (multiple-value-bind (class format)
1912                    (ecase result-type
1913                      (integer
1914                       (values 'integer nil))
1915                      (rational
1916                       (values 'rational nil))
1917                      ((or single-float double-float #!+long-float long-float)
1918                       (values 'float result-type))
1919                      (float
1920                       (values 'float nil))
1921                      (real
1922                       (values nil nil)))
1923                  (when (member result-type '(float single-float double-float
1924                                              #!+long-float long-float))
1925                    ;; Make sure that the limits on the interval have
1926                    ;; the right type.
1927                    (setf rem (interval-func (lambda (x)
1928                                               (coerce-for-bound x result-type))
1929                                             rem)))
1930                  (make-numeric-type :class class
1931                                     :format format
1932                                     :low (interval-low rem)
1933                                     :high (interval-high rem)))))
1934            ;; the optimizer itself
1935            (defoptimizer (,name derive-type) ((number divisor))
1936              (flet ((derive-q (n d same-arg)
1937                       (declare (ignore same-arg))
1938                       (if (and (numeric-type-real-p n)
1939                                (numeric-type-real-p d))
1940                           (,q-aux n d)
1941                           *empty-type*))
1942                     (derive-r (n d same-arg)
1943                       (declare (ignore same-arg))
1944                       (if (and (numeric-type-real-p n)
1945                                (numeric-type-real-p d))
1946                           (,r-aux n d)
1947                           *empty-type*)))
1948                (let ((quot (two-arg-derive-type
1949                             number divisor #'derive-q #',name))
1950                      (rem (two-arg-derive-type
1951                            number divisor #'derive-r #'mod)))
1952                  (when (and quot rem)
1953                    (make-values-type :required (list quot rem))))))))))
1954
1955   (def floor floor-quotient-bound floor-rem-bound)
1956   (def ceiling ceiling-quotient-bound ceiling-rem-bound))
1957
1958 ;;; Define optimizers for FFLOOR and FCEILING
1959 (macrolet ((def (name q-name r-name)
1960              (let ((q-aux (symbolicate "F" q-name "-AUX"))
1961                    (r-aux (symbolicate r-name "-AUX")))
1962                `(progn
1963                   ;; Compute type of quotient (first) result.
1964                   (defun ,q-aux (number-type divisor-type)
1965                     (let* ((number-interval
1966                             (numeric-type->interval number-type))
1967                            (divisor-interval
1968                             (numeric-type->interval divisor-type))
1969                            (quot (,q-name (interval-div number-interval
1970                                                         divisor-interval)))
1971                            (res-type (numeric-contagion number-type
1972                                                         divisor-type)))
1973                       (make-numeric-type
1974                        :class (numeric-type-class res-type)
1975                        :format (numeric-type-format res-type)
1976                        :low  (interval-low quot)
1977                        :high (interval-high quot))))
1978
1979                   (defoptimizer (,name derive-type) ((number divisor))
1980                     (flet ((derive-q (n d same-arg)
1981                              (declare (ignore same-arg))
1982                              (if (and (numeric-type-real-p n)
1983                                       (numeric-type-real-p d))
1984                                  (,q-aux n d)
1985                                  *empty-type*))
1986                            (derive-r (n d same-arg)
1987                              (declare (ignore same-arg))
1988                              (if (and (numeric-type-real-p n)
1989                                       (numeric-type-real-p d))
1990                                  (,r-aux n d)
1991                                  *empty-type*)))
1992                       (let ((quot (two-arg-derive-type
1993                                    number divisor #'derive-q #',name))
1994                             (rem (two-arg-derive-type
1995                                   number divisor #'derive-r #'mod)))
1996                         (when (and quot rem)
1997                           (make-values-type :required (list quot rem))))))))))
1998
1999   (def ffloor floor-quotient-bound floor-rem-bound)
2000   (def fceiling ceiling-quotient-bound ceiling-rem-bound))
2001
2002 ;;; functions to compute the bounds on the quotient and remainder for
2003 ;;; the FLOOR function
2004 (defun floor-quotient-bound (quot)
2005   ;; Take the floor of the quotient and then massage it into what we
2006   ;; need.
2007   (let ((lo (interval-low quot))
2008         (hi (interval-high quot)))
2009     ;; Take the floor of the lower bound. The result is always a
2010     ;; closed lower bound.
2011     (setf lo (if lo
2012                  (floor (type-bound-number lo))
2013                  nil))
2014     ;; For the upper bound, we need to be careful.
2015     (setf hi
2016           (cond ((consp hi)
2017                  ;; An open bound. We need to be careful here because
2018                  ;; the floor of '(10.0) is 9, but the floor of
2019                  ;; 10.0 is 10.
2020                  (multiple-value-bind (q r) (floor (first hi))
2021                    (if (zerop r)
2022                        (1- q)
2023                        q)))
2024                 (hi
2025                  ;; A closed bound, so the answer is obvious.
2026                  (floor hi))
2027                 (t
2028                  hi)))
2029     (make-interval :low lo :high hi)))
2030 (defun floor-rem-bound (div)
2031   ;; The remainder depends only on the divisor. Try to get the
2032   ;; correct sign for the remainder if we can.
2033   (case (interval-range-info div)
2034     (+
2035      ;; The divisor is always positive.
2036      (let ((rem (interval-abs div)))
2037        (setf (interval-low rem) 0)
2038        (when (and (numberp (interval-high rem))
2039                   (not (zerop (interval-high rem))))
2040          ;; The remainder never contains the upper bound. However,
2041          ;; watch out for the case where the high limit is zero!
2042          (setf (interval-high rem) (list (interval-high rem))))
2043        rem))
2044     (-
2045      ;; The divisor is always negative.
2046      (let ((rem (interval-neg (interval-abs div))))
2047        (setf (interval-high rem) 0)
2048        (when (numberp (interval-low rem))
2049          ;; The remainder never contains the lower bound.
2050          (setf (interval-low rem) (list (interval-low rem))))
2051        rem))
2052     (otherwise
2053      ;; The divisor can be positive or negative. All bets off. The
2054      ;; magnitude of remainder is the maximum value of the divisor.
2055      (let ((limit (type-bound-number (interval-high (interval-abs div)))))
2056        ;; The bound never reaches the limit, so make the interval open.
2057        (make-interval :low (if limit
2058                                (list (- limit))
2059                                limit)
2060                       :high (list limit))))))
2061 #| Test cases
2062 (floor-quotient-bound (make-interval :low 0.3 :high 10.3))
2063 => #S(INTERVAL :LOW 0 :HIGH 10)
2064 (floor-quotient-bound (make-interval :low 0.3 :high '(10.3)))
2065 => #S(INTERVAL :LOW 0 :HIGH 10)
2066 (floor-quotient-bound (make-interval :low 0.3 :high 10))
2067 => #S(INTERVAL :LOW 0 :HIGH 10)
2068 (floor-quotient-bound (make-interval :low 0.3 :high '(10)))
2069 => #S(INTERVAL :LOW 0 :HIGH 9)
2070 (floor-quotient-bound (make-interval :low '(0.3) :high 10.3))
2071 => #S(INTERVAL :LOW 0 :HIGH 10)
2072 (floor-quotient-bound (make-interval :low '(0.0) :high 10.3))
2073 => #S(INTERVAL :LOW 0 :HIGH 10)
2074 (floor-quotient-bound (make-interval :low '(-1.3) :high 10.3))
2075 => #S(INTERVAL :LOW -2 :HIGH 10)
2076 (floor-quotient-bound (make-interval :low '(-1.0) :high 10.3))
2077 => #S(INTERVAL :LOW -1 :HIGH 10)
2078 (floor-quotient-bound (make-interval :low -1.0 :high 10.3))
2079 => #S(INTERVAL :LOW -1 :HIGH 10)
2080
2081 (floor-rem-bound (make-interval :low 0.3 :high 10.3))
2082 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
2083 (floor-rem-bound (make-interval :low 0.3 :high '(10.3)))
2084 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
2085 (floor-rem-bound (make-interval :low -10 :high -2.3))
2086 #S(INTERVAL :LOW (-10) :HIGH 0)
2087 (floor-rem-bound (make-interval :low 0.3 :high 10))
2088 => #S(INTERVAL :LOW 0 :HIGH '(10))
2089 (floor-rem-bound (make-interval :low '(-1.3) :high 10.3))
2090 => #S(INTERVAL :LOW '(-10.3) :HIGH '(10.3))
2091 (floor-rem-bound (make-interval :low '(-20.3) :high 10.3))
2092 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
2093 |#
2094 \f
2095 ;;; same functions for CEILING
2096 (defun ceiling-quotient-bound (quot)
2097   ;; Take the ceiling of the quotient and then massage it into what we
2098   ;; need.
2099   (let ((lo (interval-low quot))
2100         (hi (interval-high quot)))
2101     ;; Take the ceiling of the upper bound. The result is always a
2102     ;; closed upper bound.
2103     (setf hi (if hi
2104                  (ceiling (type-bound-number hi))
2105                  nil))
2106     ;; For the lower bound, we need to be careful.
2107     (setf lo
2108           (cond ((consp lo)
2109                  ;; An open bound. We need to be careful here because
2110                  ;; the ceiling of '(10.0) is 11, but the ceiling of
2111                  ;; 10.0 is 10.
2112                  (multiple-value-bind (q r) (ceiling (first lo))
2113                    (if (zerop r)
2114                        (1+ q)
2115                        q)))
2116                 (lo
2117                  ;; A closed bound, so the answer is obvious.
2118                  (ceiling lo))
2119                 (t
2120                  lo)))
2121     (make-interval :low lo :high hi)))
2122 (defun ceiling-rem-bound (div)
2123   ;; The remainder depends only on the divisor. Try to get the
2124   ;; correct sign for the remainder if we can.
2125   (case (interval-range-info div)
2126     (+
2127      ;; Divisor is always positive. The remainder is negative.
2128      (let ((rem (interval-neg (interval-abs div))))
2129        (setf (interval-high rem) 0)
2130        (when (and (numberp (interval-low rem))
2131                   (not (zerop (interval-low rem))))
2132          ;; The remainder never contains the upper bound. However,
2133          ;; watch out for the case when the upper bound is zero!
2134          (setf (interval-low rem) (list (interval-low rem))))
2135        rem))
2136     (-
2137      ;; Divisor is always negative. The remainder is positive
2138      (let ((rem (interval-abs div)))
2139        (setf (interval-low rem) 0)
2140        (when (numberp (interval-high rem))
2141          ;; The remainder never contains the lower bound.
2142          (setf (interval-high rem) (list (interval-high rem))))
2143        rem))
2144     (otherwise
2145      ;; The divisor can be positive or negative. All bets off. The
2146      ;; magnitude of remainder is the maximum value of the divisor.
2147      (let ((limit (type-bound-number (interval-high (interval-abs div)))))
2148        ;; The bound never reaches the limit, so make the interval open.
2149        (make-interval :low (if limit
2150                                (list (- limit))
2151                                limit)
2152                       :high (list limit))))))
2153
2154 #| Test cases
2155 (ceiling-quotient-bound (make-interval :low 0.3 :high 10.3))
2156 => #S(INTERVAL :LOW 1 :HIGH 11)
2157 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10.3)))
2158 => #S(INTERVAL :LOW 1 :HIGH 11)
2159 (ceiling-quotient-bound (make-interval :low 0.3 :high 10))
2160 => #S(INTERVAL :LOW 1 :HIGH 10)
2161 (ceiling-quotient-bound (make-interval :low 0.3 :high '(10)))
2162 => #S(INTERVAL :LOW 1 :HIGH 10)
2163 (ceiling-quotient-bound (make-interval :low '(0.3) :high 10.3))
2164 => #S(INTERVAL :LOW 1 :HIGH 11)
2165 (ceiling-quotient-bound (make-interval :low '(0.0) :high 10.3))
2166 => #S(INTERVAL :LOW 1 :HIGH 11)
2167 (ceiling-quotient-bound (make-interval :low '(-1.3) :high 10.3))
2168 => #S(INTERVAL :LOW -1 :HIGH 11)
2169 (ceiling-quotient-bound (make-interval :low '(-1.0) :high 10.3))
2170 => #S(INTERVAL :LOW 0 :HIGH 11)
2171 (ceiling-quotient-bound (make-interval :low -1.0 :high 10.3))
2172 => #S(INTERVAL :LOW -1 :HIGH 11)
2173
2174 (ceiling-rem-bound (make-interval :low 0.3 :high 10.3))
2175 => #S(INTERVAL :LOW (-10.3) :HIGH 0)
2176 (ceiling-rem-bound (make-interval :low 0.3 :high '(10.3)))
2177 => #S(INTERVAL :LOW 0 :HIGH '(10.3))
2178 (ceiling-rem-bound (make-interval :low -10 :high -2.3))
2179 => #S(INTERVAL :LOW 0 :HIGH (10))
2180 (ceiling-rem-bound (make-interval :low 0.3 :high 10))
2181 => #S(INTERVAL :LOW (-10) :HIGH 0)
2182 (ceiling-rem-bound (make-interval :low '(-1.3) :high 10.3))
2183 => #S(INTERVAL :LOW (-10.3) :HIGH (10.3))
2184 (ceiling-rem-bound (make-interval :low '(-20.3) :high 10.3))
2185 => #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
2186 |#
2187 \f
2188 (defun truncate-quotient-bound (quot)
2189   ;; For positive quotients, truncate is exactly like floor. For
2190   ;; negative quotients, truncate is exactly like ceiling. Otherwise,
2191   ;; it's the union of the two pieces.
2192   (case (interval-range-info quot)
2193     (+
2194      ;; just like FLOOR
2195      (floor-quotient-bound quot))
2196     (-
2197      ;; just like CEILING
2198      (ceiling-quotient-bound quot))
2199     (otherwise
2200      ;; Split the interval into positive and negative pieces, compute
2201      ;; the result for each piece and put them back together.
2202      (destructuring-bind (neg pos) (interval-split 0 quot t t)
2203        (interval-merge-pair (ceiling-quotient-bound neg)
2204                             (floor-quotient-bound pos))))))
2205
2206 (defun truncate-rem-bound (num div)
2207   ;; This is significantly more complicated than FLOOR or CEILING. We
2208   ;; need both the number and the divisor to determine the range. The
2209   ;; basic idea is to split the ranges of NUM and DEN into positive
2210   ;; and negative pieces and deal with each of the four possibilities
2211   ;; in turn.
2212   (case (interval-range-info num)
2213     (+
2214      (case (interval-range-info div)
2215        (+
2216         (floor-rem-bound div))
2217        (-
2218         (ceiling-rem-bound div))
2219        (otherwise
2220         (destructuring-bind (neg pos) (interval-split 0 div t t)
2221           (interval-merge-pair (truncate-rem-bound num neg)
2222                                (truncate-rem-bound num pos))))))
2223     (-
2224      (case (interval-range-info div)
2225        (+
2226         (ceiling-rem-bound div))
2227        (-
2228         (floor-rem-bound div))
2229        (otherwise
2230         (destructuring-bind (neg pos) (interval-split 0 div t t)
2231           (interval-merge-pair (truncate-rem-bound num neg)
2232                                (truncate-rem-bound num pos))))))
2233     (otherwise
2234      (destructuring-bind (neg pos) (interval-split 0 num t t)
2235        (interval-merge-pair (truncate-rem-bound neg div)
2236                             (truncate-rem-bound pos div))))))
2237 ) ; PROGN
2238
2239 ;;; Derive useful information about the range. Returns three values:
2240 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
2241 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
2242 ;;; - The abs of the maximal value if there is one, or nil if it is
2243 ;;;   unbounded.
2244 (defun numeric-range-info (low high)
2245   (cond ((and low (not (minusp low)))
2246          (values '+ low high))
2247         ((and high (not (plusp high)))
2248          (values '- (- high) (if low (- low) nil)))
2249         (t
2250          (values nil 0 (and low high (max (- low) high))))))
2251
2252 (defun integer-truncate-derive-type
2253        (number-low number-high divisor-low divisor-high)
2254   ;; The result cannot be larger in magnitude than the number, but the
2255   ;; sign might change. If we can determine the sign of either the
2256   ;; number or the divisor, we can eliminate some of the cases.
2257   (multiple-value-bind (number-sign number-min number-max)
2258       (numeric-range-info number-low number-high)
2259     (multiple-value-bind (divisor-sign divisor-min divisor-max)
2260         (numeric-range-info divisor-low divisor-high)
2261       (when (and divisor-max (zerop divisor-max))
2262         ;; We've got a problem: guaranteed division by zero.
2263         (return-from integer-truncate-derive-type t))
2264       (when (zerop divisor-min)
2265         ;; We'll assume that they aren't going to divide by zero.
2266         (incf divisor-min))
2267       (cond ((and number-sign divisor-sign)
2268              ;; We know the sign of both.
2269              (if (eq number-sign divisor-sign)
2270                  ;; Same sign, so the result will be positive.
2271                  `(integer ,(if divisor-max
2272                                 (truncate number-min divisor-max)
2273                                 0)
2274                            ,(if number-max
2275                                 (truncate number-max divisor-min)
2276                                 '*))
2277                  ;; Different signs, the result will be negative.
2278                  `(integer ,(if number-max
2279                                 (- (truncate number-max divisor-min))
2280                                 '*)
2281                            ,(if divisor-max
2282                                 (- (truncate number-min divisor-max))
2283                                 0))))
2284             ((eq divisor-sign '+)
2285              ;; The divisor is positive. Therefore, the number will just
2286              ;; become closer to zero.
2287              `(integer ,(if number-low
2288                             (truncate number-low divisor-min)
2289                             '*)
2290                        ,(if number-high
2291                             (truncate number-high divisor-min)
2292                             '*)))
2293             ((eq divisor-sign '-)
2294              ;; The divisor is negative. Therefore, the absolute value of
2295              ;; the number will become closer to zero, but the sign will also
2296              ;; change.
2297              `(integer ,(if number-high
2298                             (- (truncate number-high divisor-min))
2299                             '*)
2300                        ,(if number-low
2301                             (- (truncate number-low divisor-min))
2302                             '*)))
2303             ;; The divisor could be either positive or negative.
2304             (number-max
2305              ;; The number we are dividing has a bound. Divide that by the
2306              ;; smallest posible divisor.
2307              (let ((bound (truncate number-max divisor-min)))
2308                `(integer ,(- bound) ,bound)))
2309             (t
2310              ;; The number we are dividing is unbounded, so we can't tell
2311              ;; anything about the result.
2312              `integer)))))
2313
2314 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2315 (defun integer-rem-derive-type
2316        (number-low number-high divisor-low divisor-high)
2317   (if (and divisor-low divisor-high)
2318       ;; We know the range of the divisor, and the remainder must be
2319       ;; smaller than the divisor. We can tell the sign of the
2320       ;; remainer if we know the sign of the number.
2321       (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
2322         `(integer ,(if (or (null number-low)
2323                            (minusp number-low))
2324                        (- divisor-max)
2325                        0)
2326                   ,(if (or (null number-high)
2327                            (plusp number-high))
2328                        divisor-max
2329                        0)))
2330       ;; The divisor is potentially either very positive or very
2331       ;; negative. Therefore, the remainer is unbounded, but we might
2332       ;; be able to tell something about the sign from the number.
2333       `(integer ,(if (and number-low (not (minusp number-low)))
2334                      ;; The number we are dividing is positive.
2335                      ;; Therefore, the remainder must be positive.
2336                      0
2337                      '*)
2338                 ,(if (and number-high (not (plusp number-high)))
2339                      ;; The number we are dividing is negative.
2340                      ;; Therefore, the remainder must be negative.
2341                      0
2342                      '*))))
2343
2344 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2345 (defoptimizer (random derive-type) ((bound &optional state))
2346   (let ((type (lvar-type bound)))
2347     (when (numeric-type-p type)
2348       (let ((class (numeric-type-class type))
2349             (high (numeric-type-high type))
2350             (format (numeric-type-format type)))
2351         (make-numeric-type
2352          :class class
2353          :format format
2354          :low (coerce 0 (or format class 'real))
2355          :high (cond ((not high) nil)
2356                      ((eq class 'integer) (max (1- high) 0))
2357                      ((or (consp high) (zerop high)) high)
2358                      (t `(,high))))))))
2359
2360 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2361 (defun random-derive-type-aux (type)
2362   (let ((class (numeric-type-class type))
2363         (high (numeric-type-high type))
2364         (format (numeric-type-format type)))
2365     (make-numeric-type
2366          :class class
2367          :format format
2368          :low (coerce 0 (or format class 'real))
2369          :high (cond ((not high) nil)
2370                      ((eq class 'integer) (max (1- high) 0))
2371                      ((or (consp high) (zerop high)) high)
2372                      (t `(,high))))))
2373
2374 #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
2375 (defoptimizer (random derive-type) ((bound &optional state))
2376   (one-arg-derive-type bound #'random-derive-type-aux nil))
2377 \f
2378 ;;;; DERIVE-TYPE methods for LOGAND, LOGIOR, and friends
2379
2380 ;;; Return the maximum number of bits an integer of the supplied type
2381 ;;; can take up, or NIL if it is unbounded. The second (third) value
2382 ;;; is T if the integer can be positive (negative) and NIL if not.
2383 ;;; Zero counts as positive.
2384 (defun integer-type-length (type)
2385   (if (numeric-type-p type)
2386       (let ((min (numeric-type-low type))
2387             (max (numeric-type-high type)))
2388         (values (and min max (max (integer-length min) (integer-length max)))
2389                 (or (null max) (not (minusp max)))
2390                 (or (null min) (minusp min))))
2391       (values nil t t)))
2392
2393 ;;; See _Hacker's Delight_, Henry S. Warren, Jr. pp 58-63 for an
2394 ;;; explanation of LOG{AND,IOR,XOR}-DERIVE-UNSIGNED-{LOW,HIGH}-BOUND.
2395 ;;; Credit also goes to Raymond Toy for writing (and debugging!) similar
2396 ;;; versions in CMUCL, from which these functions copy liberally.
2397
2398 (defun logand-derive-unsigned-low-bound (x y)
2399   (let ((a (numeric-type-low x))
2400         (b (numeric-type-high x))
2401         (c (numeric-type-low y))
2402         (d (numeric-type-high y)))
2403     (loop for m = (ash 1 (integer-length (lognor a c))) then (ash m -1)
2404           until (zerop m) do
2405           (unless (zerop (logand m (lognot a) (lognot c)))
2406             (let ((temp (logandc2 (logior a m) (1- m))))
2407               (when (<= temp b)
2408                 (setf a temp)
2409                 (loop-finish))
2410               (setf temp (logandc2 (logior c m) (1- m)))
2411               (when (<= temp d)
2412                 (setf c temp)
2413                 (loop-finish))))
2414           finally (return (logand a c)))))
2415
2416 (defun logand-derive-unsigned-high-bound (x y)
2417   (let ((a (numeric-type-low x))
2418         (b (numeric-type-high x))
2419         (c (numeric-type-low y))
2420         (d (numeric-type-high y)))
2421     (loop for m = (ash 1 (integer-length (logxor b d))) then (ash m -1)
2422           until (zerop m) do
2423           (cond
2424             ((not (zerop (logand b (lognot d) m)))
2425              (let ((temp (logior (logandc2 b m) (1- m))))
2426                (when (>= temp a)
2427                  (setf b temp)
2428                  (loop-finish))))
2429             ((not (zerop (logand (lognot b) d m)))
2430              (let ((temp (logior (logandc2 d m) (1- m))))
2431                (when (>= temp c)
2432                  (setf d temp)
2433                  (loop-finish)))))
2434           finally (return (logand b d)))))
2435
2436 (defun logand-derive-type-aux (x y &optional same-leaf)
2437   (when same-leaf
2438     (return-from logand-derive-type-aux x))
2439   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2440     (declare (ignore x-pos))
2441     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
2442       (declare (ignore y-pos))
2443       (if (not x-neg)
2444           ;; X must be positive.
2445           (if (not y-neg)
2446               ;; They must both be positive.
2447               (cond ((and (null x-len) (null y-len))
2448                      (specifier-type 'unsigned-byte))
2449                     ((null x-len)
2450                      (specifier-type `(unsigned-byte* ,y-len)))
2451                     ((null y-len)
2452                      (specifier-type `(unsigned-byte* ,x-len)))
2453                     (t
2454                      (let ((low (logand-derive-unsigned-low-bound x y))
2455                            (high (logand-derive-unsigned-high-bound x y)))
2456                        (specifier-type `(integer ,low ,high)))))
2457               ;; X is positive, but Y might be negative.
2458               (cond ((null x-len)
2459                      (specifier-type 'unsigned-byte))
2460                     (t
2461                      (specifier-type `(unsigned-byte* ,x-len)))))
2462           ;; X might be negative.
2463           (if (not y-neg)
2464               ;; Y must be positive.
2465               (cond ((null y-len)
2466                      (specifier-type 'unsigned-byte))
2467                     (t (specifier-type `(unsigned-byte* ,y-len))))
2468               ;; Either might be negative.
2469               (if (and x-len y-len)
2470                   ;; The result is bounded.
2471                   (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2472                   ;; We can't tell squat about the result.
2473                   (specifier-type 'integer)))))))
2474
2475 (defun logior-derive-unsigned-low-bound (x y)
2476   (let ((a (numeric-type-low x))
2477         (b (numeric-type-high x))
2478         (c (numeric-type-low y))
2479         (d (numeric-type-high y)))
2480     (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
2481           until (zerop m) do
2482           (cond
2483             ((not (zerop (logandc2 (logand c m) a)))
2484              (let ((temp (logand (logior a m) (1+ (lognot m)))))
2485                (when (<= temp b)
2486                  (setf a temp)
2487                  (loop-finish))))
2488             ((not (zerop (logandc2 (logand a m) c)))
2489              (let ((temp (logand (logior c m) (1+ (lognot m)))))
2490                (when (<= temp d)
2491                  (setf c temp)
2492                  (loop-finish)))))
2493           finally (return (logior a c)))))
2494
2495 (defun logior-derive-unsigned-high-bound (x y)
2496   (let ((a (numeric-type-low x))
2497         (b (numeric-type-high x))
2498         (c (numeric-type-low y))
2499         (d (numeric-type-high y)))
2500     (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
2501           until (zerop m) do
2502           (unless (zerop (logand b d m))
2503             (let ((temp (logior (- b m) (1- m))))
2504               (when (>= temp a)
2505                 (setf b temp)
2506                 (loop-finish))
2507               (setf temp (logior (- d m) (1- m)))
2508               (when (>= temp c)
2509                 (setf d temp)
2510                 (loop-finish))))
2511           finally (return (logior b d)))))
2512
2513 (defun logior-derive-type-aux (x y &optional same-leaf)
2514   (when same-leaf
2515     (return-from logior-derive-type-aux x))
2516   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2517     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
2518       (cond
2519        ((and (not x-neg) (not y-neg))
2520         ;; Both are positive.
2521         (if (and x-len y-len)
2522             (let ((low (logior-derive-unsigned-low-bound x y))
2523                   (high (logior-derive-unsigned-high-bound x y)))
2524               (specifier-type `(integer ,low ,high)))
2525             (specifier-type `(unsigned-byte* *))))
2526        ((not x-pos)
2527         ;; X must be negative.
2528         (if (not y-pos)
2529             ;; Both are negative. The result is going to be negative
2530             ;; and be the same length or shorter than the smaller.
2531             (if (and x-len y-len)
2532                 ;; It's bounded.
2533                 (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
2534                 ;; It's unbounded.
2535                 (specifier-type '(integer * -1)))
2536             ;; X is negative, but we don't know about Y. The result
2537             ;; will be negative, but no more negative than X.
2538             (specifier-type
2539              `(integer ,(or (numeric-type-low x) '*)
2540                        -1))))
2541        (t
2542         ;; X might be either positive or negative.
2543         (if (not y-pos)
2544             ;; But Y is negative. The result will be negative.
2545             (specifier-type
2546              `(integer ,(or (numeric-type-low y) '*)
2547                        -1))
2548             ;; We don't know squat about either. It won't get any bigger.
2549             (if (and x-len y-len)
2550                 ;; Bounded.
2551                 (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
2552                 ;; Unbounded.
2553                 (specifier-type 'integer))))))))
2554
2555 (defun logxor-derive-unsigned-low-bound (x y)
2556   (let ((a (numeric-type-low x))
2557         (b (numeric-type-high x))
2558         (c (numeric-type-low y))
2559         (d (numeric-type-high y)))
2560     (loop for m = (ash 1 (integer-length (logxor a c))) then (ash m -1)
2561           until (zerop m) do
2562           (cond
2563             ((not (zerop (logandc2 (logand c m) a)))
2564              (let ((temp (logand (logior a m)
2565                                  (1+ (lognot m)))))
2566                (when (<= temp b)
2567                  (setf a temp))))
2568             ((not (zerop (logandc2 (logand a m) c)))
2569              (let ((temp (logand (logior c m)
2570                                  (1+ (lognot m)))))
2571                (when (<= temp d)
2572                  (setf c temp)))))
2573           finally (return (logxor a c)))))
2574
2575 (defun logxor-derive-unsigned-high-bound (x y)
2576   (let ((a (numeric-type-low x))
2577         (b (numeric-type-high x))
2578         (c (numeric-type-low y))
2579         (d (numeric-type-high y)))
2580     (loop for m = (ash 1 (integer-length (logand b d))) then (ash m -1)
2581           until (zerop m) do
2582           (unless (zerop (logand b d m))
2583             (let ((temp (logior (- b m) (1- m))))
2584               (cond
2585                 ((>= temp a) (setf b temp))
2586                 (t (let ((temp (logior (- d m) (1- m))))
2587                      (when (>= temp c)
2588                        (setf d temp)))))))
2589           finally (return (logxor b d)))))
2590
2591 (defun logxor-derive-type-aux (x y &optional same-leaf)
2592   (when same-leaf
2593     (return-from logxor-derive-type-aux (specifier-type '(eql 0))))
2594   (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
2595     (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
2596       (cond
2597         ((and (not x-neg) (not y-neg))
2598          ;; Both are positive
2599          (if (and x-len y-len)
2600              (let ((low (logxor-derive-unsigned-low-bound x y))
2601                    (high (logxor-derive-unsigned-high-bound x y)))
2602                (specifier-type `(integer ,low ,high)))
2603              (specifier-type '(unsigned-byte* *))))
2604         ((and (not x-pos) (not y-pos))
2605          ;; Both are negative.  The result will be positive, and as long
2606          ;; as the longer.
2607          (specifier-type `(unsigned-byte* ,(if (and x-len y-len)
2608                                                (max x-len y-len)
2609                                                '*))))
2610         ((or (and (not x-pos) (not y-neg))
2611              (and (not y-pos) (not x-neg)))
2612          ;; Either X is negative and Y is positive or vice-versa. The
2613          ;; result will be negative.
2614          (specifier-type `(integer ,(if (and x-len y-len)
2615                                         (ash -1 (max x-len y-len))
2616                                         '*)
2617                            -1)))
2618         ;; We can't tell what the sign of the result is going to be.
2619         ;; All we know is that we don't create new bits.
2620         ((and x-len y-len)
2621          (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
2622         (t
2623          (specifier-type 'integer))))))
2624
2625 (macrolet ((deffrob (logfun)
2626              (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX")))
2627              `(defoptimizer (,logfun derive-type) ((x y))
2628                 (two-arg-derive-type x y #',fun-aux #',logfun)))))
2629   (deffrob logand)
2630   (deffrob logior)
2631   (deffrob logxor))
2632
2633 (defoptimizer (logeqv derive-type) ((x y))
2634   (two-arg-derive-type x y (lambda (x y same-leaf)
2635                              (lognot-derive-type-aux
2636                               (logxor-derive-type-aux x y same-leaf)))
2637                        #'logeqv))
2638 (defoptimizer (lognand derive-type) ((x y))
2639   (two-arg-derive-type x y (lambda (x y same-leaf)
2640                              (lognot-derive-type-aux
2641                               (logand-derive-type-aux x y same-leaf)))
2642                        #'lognand))
2643 (defoptimizer (lognor derive-type) ((x y))
2644   (two-arg-derive-type x y (lambda (x y same-leaf)
2645                              (lognot-derive-type-aux
2646                               (logior-derive-type-aux x y same-leaf)))
2647                        #'lognor))
2648 (defoptimizer (logandc1 derive-type) ((x y))
2649   (two-arg-derive-type x y (lambda (x y same-leaf)
2650                              (if same-leaf
2651                                  (specifier-type '(eql 0))
2652                                  (logand-derive-type-aux
2653                                   (lognot-derive-type-aux x) y nil)))
2654                        #'logandc1))
2655 (defoptimizer (logandc2 derive-type) ((x y))
2656   (two-arg-derive-type x y (lambda (x y same-leaf)
2657                              (if same-leaf
2658                                  (specifier-type '(eql 0))
2659                                  (logand-derive-type-aux
2660                                   x (lognot-derive-type-aux y) nil)))
2661                        #'logandc2))
2662 (defoptimizer (logorc1 derive-type) ((x y))
2663   (two-arg-derive-type x y (lambda (x y same-leaf)
2664                              (if same-leaf
2665                                  (specifier-type '(eql -1))
2666                                  (logior-derive-type-aux
2667                                   (lognot-derive-type-aux x) y nil)))
2668                        #'logorc1))
2669 (defoptimizer (logorc2 derive-type) ((x y))
2670   (two-arg-derive-type x y (lambda (x y same-leaf)
2671                              (if same-leaf
2672                                  (specifier-type '(eql -1))
2673                                  (logior-derive-type-aux
2674                                   x (lognot-derive-type-aux y) nil)))
2675                        #'logorc2))
2676 \f
2677 ;;;; miscellaneous derive-type methods
2678
2679 (defoptimizer (integer-length derive-type) ((x))
2680   (let ((x-type (lvar-type x)))
2681     (when (numeric-type-p x-type)
2682       ;; If the X is of type (INTEGER LO HI), then the INTEGER-LENGTH
2683       ;; of X is (INTEGER (MIN lo hi) (MAX lo hi), basically.  Be
2684       ;; careful about LO or HI being NIL, though.  Also, if 0 is
2685       ;; contained in X, the lower bound is obviously 0.
2686       (flet ((null-or-min (a b)
2687                (and a b (min (integer-length a)
2688                              (integer-length b))))
2689              (null-or-max (a b)
2690                (and a b (max (integer-length a)
2691                              (integer-length b)))))
2692         (let* ((min (numeric-type-low x-type))
2693                (max (numeric-type-high x-type))
2694                (min-len (null-or-min min max))
2695                (max-len (null-or-max min max)))
2696           (when (ctypep 0 x-type)
2697             (setf min-len 0))
2698           (specifier-type `(integer ,(or min-len '*) ,(or max-len '*))))))))
2699
2700 (defoptimizer (isqrt derive-type) ((x))
2701   (let ((x-type (lvar-type x)))
2702     (when (numeric-type-p x-type)
2703       (let* ((lo (numeric-type-low x-type))
2704              (hi (numeric-type-high x-type))
2705              (lo-res (if lo (isqrt lo) '*))
2706              (hi-res (if hi (isqrt hi) '*)))
2707         (specifier-type `(integer ,lo-res ,hi-res))))))
2708
2709 (defoptimizer (char-code derive-type) ((char))
2710   (let ((type (type-intersection (lvar-type char) (specifier-type 'character))))
2711     (cond ((member-type-p type)
2712            (specifier-type
2713             `(member
2714               ,@(loop for member in (member-type-members type)
2715                       when (characterp member)
2716                       collect (char-code member)))))
2717           ((sb!kernel::character-set-type-p type)
2718            (specifier-type
2719             `(or
2720               ,@(loop for (low . high)
2721                       in (character-set-type-pairs type)
2722                       collect `(integer ,low ,high)))))
2723           ((csubtypep type (specifier-type 'base-char))
2724            (specifier-type
2725             `(mod ,base-char-code-limit)))
2726           (t
2727            (specifier-type
2728             `(mod ,char-code-limit))))))
2729
2730 (defoptimizer (code-char derive-type) ((code))
2731   (let ((type (lvar-type code)))
2732     ;; FIXME: unions of integral ranges?  It ought to be easier to do
2733     ;; this, given that CHARACTER-SET is basically an integral range
2734     ;; type.  -- CSR, 2004-10-04
2735     (when (numeric-type-p type)
2736       (let* ((lo (numeric-type-low type))
2737              (hi (numeric-type-high type))
2738              (type (specifier-type `(character-set ((,lo . ,hi))))))
2739         (cond
2740           ;; KLUDGE: when running on the host, we lose a slight amount
2741           ;; of precision so that we don't have to "unparse" types
2742           ;; that formally we can't, such as (CHARACTER-SET ((0
2743           ;; . 0))).  -- CSR, 2004-10-06
2744           #+sb-xc-host
2745           ((csubtypep type (specifier-type 'standard-char)) type)
2746           #+sb-xc-host
2747           ((csubtypep type (specifier-type 'base-char))
2748            (specifier-type 'base-char))
2749           #+sb-xc-host
2750           ((csubtypep type (specifier-type 'extended-char))
2751            (specifier-type 'extended-char))
2752           (t #+sb-xc-host (specifier-type 'character)
2753              #-sb-xc-host type))))))
2754
2755 (defoptimizer (values derive-type) ((&rest values))
2756   (make-values-type :required (mapcar #'lvar-type values)))
2757
2758 (defun signum-derive-type-aux (type)
2759   (if (eq (numeric-type-complexp type) :complex)
2760       (let* ((format (case (numeric-type-class type)
2761                           ((integer rational) 'single-float)
2762                           (t (numeric-type-format type))))
2763                 (bound-format (or format 'float)))
2764            (make-numeric-type :class 'float
2765                               :format format
2766                               :complexp :complex
2767                               :low (coerce -1 bound-format)
2768                               :high (coerce 1 bound-format)))
2769       (let* ((interval (numeric-type->interval type))
2770              (range-info (interval-range-info interval))
2771              (contains-0-p (interval-contains-p 0 interval))
2772              (class (numeric-type-class type))
2773              (format (numeric-type-format type))
2774              (one (coerce 1 (or format class 'real)))
2775              (zero (coerce 0 (or format class 'real)))
2776              (minus-one (coerce -1 (or format class 'real)))
2777              (plus (make-numeric-type :class class :format format
2778                                       :low one :high one))
2779              (minus (make-numeric-type :class class :format format
2780                                        :low minus-one :high minus-one))
2781              ;; KLUDGE: here we have a fairly horrible hack to deal
2782              ;; with the schizophrenia in the type derivation engine.
2783              ;; The problem is that the type derivers reinterpret
2784              ;; numeric types as being exact; so (DOUBLE-FLOAT 0d0
2785              ;; 0d0) within the derivation mechanism doesn't include
2786              ;; -0d0.  Ugh.  So force it in here, instead.
2787              (zero (make-numeric-type :class class :format format
2788                                       :low (- zero) :high zero)))
2789         (case range-info
2790           (+ (if contains-0-p (type-union plus zero) plus))
2791           (- (if contains-0-p (type-union minus zero) minus))
2792           (t (type-union minus zero plus))))))
2793
2794 (defoptimizer (signum derive-type) ((num))
2795   (one-arg-derive-type num #'signum-derive-type-aux nil))
2796 \f
2797 ;;;; byte operations
2798 ;;;;
2799 ;;;; We try to turn byte operations into simple logical operations.
2800 ;;;; First, we convert byte specifiers into separate size and position
2801 ;;;; arguments passed to internal %FOO functions. We then attempt to
2802 ;;;; transform the %FOO functions into boolean operations when the
2803 ;;;; size and position are constant and the operands are fixnums.
2804
2805 (macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to
2806            ;; expressions that evaluate to the SIZE and POSITION of
2807            ;; the byte-specifier form SPEC. We may wrap a let around
2808            ;; the result of the body to bind some variables.
2809            ;;
2810            ;; If the spec is a BYTE form, then bind the vars to the
2811            ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE
2812            ;; and BYTE-POSITION. The goal of this transformation is to
2813            ;; avoid consing up byte specifiers and then immediately
2814            ;; throwing them away.
2815            (with-byte-specifier ((size-var pos-var spec) &body body)
2816              (once-only ((spec `(macroexpand ,spec))
2817                          (temp '(gensym)))
2818                         `(if (and (consp ,spec)
2819                                   (eq (car ,spec) 'byte)
2820                                   (= (length ,spec) 3))
2821                         (let ((,size-var (second ,spec))
2822                               (,pos-var (third ,spec)))
2823                           ,@body)
2824                         (let ((,size-var `(byte-size ,,temp))
2825                               (,pos-var `(byte-position ,,temp)))
2826                           `(let ((,,temp ,,spec))
2827                              ,,@body))))))
2828
2829   (define-source-transform ldb (spec int)
2830     (with-byte-specifier (size pos spec)
2831       `(%ldb ,size ,pos ,int)))
2832
2833   (define-source-transform dpb (newbyte spec int)
2834     (with-byte-specifier (size pos spec)
2835       `(%dpb ,newbyte ,size ,pos ,int)))
2836
2837   (define-source-transform mask-field (spec int)
2838     (with-byte-specifier (size pos spec)
2839       `(%mask-field ,size ,pos ,int)))
2840
2841   (define-source-transform deposit-field (newbyte spec int)
2842     (with-byte-specifier (size pos spec)
2843       `(%deposit-field ,newbyte ,size ,pos ,int))))
2844
2845 (defoptimizer (%ldb derive-type) ((size posn num))
2846   (let ((size (lvar-type size)))
2847     (if (and (numeric-type-p size)
2848              (csubtypep size (specifier-type 'integer)))
2849         (let ((size-high (numeric-type-high size)))
2850           (if (and size-high (<= size-high sb!vm:n-word-bits))
2851               (specifier-type `(unsigned-byte* ,size-high))
2852               (specifier-type 'unsigned-byte)))
2853         *universal-type*)))
2854
2855 (defoptimizer (%mask-field derive-type) ((size posn num))
2856   (let ((size (lvar-type size))
2857         (posn (lvar-type posn)))
2858     (if (and (numeric-type-p size)
2859              (csubtypep size (specifier-type 'integer))
2860              (numeric-type-p posn)
2861              (csubtypep posn (specifier-type 'integer)))
2862         (let ((size-high (numeric-type-high size))
2863               (posn-high (numeric-type-high posn)))
2864           (if (and size-high posn-high
2865                    (<= (+ size-high posn-high) sb!vm:n-word-bits))
2866               (specifier-type `(unsigned-byte* ,(+ size-high posn-high)))
2867               (specifier-type 'unsigned-byte)))
2868         *universal-type*)))
2869
2870 (defun %deposit-field-derive-type-aux (size posn int)
2871   (let ((size (lvar-type size))
2872         (posn (lvar-type posn))
2873         (int (lvar-type int)))
2874     (when (and (numeric-type-p size)
2875                (numeric-type-p posn)
2876                (numeric-type-p int))
2877       (let ((size-high (numeric-type-high size))
2878             (posn-high (numeric-type-high posn))
2879             (high (numeric-type-high int))
2880             (low (numeric-type-low int)))
2881         (when (and size-high posn-high high low
2882                    ;; KLUDGE: we need this cutoff here, otherwise we
2883                    ;; will merrily derive the type of %DPB as
2884                    ;; (UNSIGNED-BYTE 1073741822), and then attempt to
2885                    ;; canonicalize this type to (INTEGER 0 (1- (ASH 1
2886                    ;; 1073741822))), with hilarious consequences.  We
2887                    ;; cutoff at 4*SB!VM:N-WORD-BITS to allow inference
2888                    ;; over a reasonable amount of shifting, even on
2889                    ;; the alpha/32 port, where N-WORD-BITS is 32 but
2890                    ;; machine integers are 64-bits.  -- CSR,
2891                    ;; 2003-09-12
2892                    (<= (+ size-high posn-high) (* 4 sb!vm:n-word-bits)))
2893           (let ((raw-bit-count (max (integer-length high)
2894                                     (integer-length low)
2895                                     (+ size-high posn-high))))
2896             (specifier-type
2897              (if (minusp low)
2898                  `(signed-byte ,(1+ raw-bit-count))
2899                  `(unsigned-byte* ,raw-bit-count)))))))))
2900
2901 (defoptimizer (%dpb derive-type) ((newbyte size posn int))
2902   (%deposit-field-derive-type-aux size posn int))
2903
2904 (defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
2905   (%deposit-field-derive-type-aux size posn int))
2906
2907 (deftransform %ldb ((size posn int)
2908                     (fixnum fixnum integer)
2909                     (unsigned-byte #.sb!vm:n-word-bits))
2910   "convert to inline logical operations"
2911   `(logand (ash int (- posn))
2912            (ash ,(1- (ash 1 sb!vm:n-word-bits))
2913                 (- size ,sb!vm:n-word-bits))))
2914
2915 (deftransform %mask-field ((size posn int)
2916                            (fixnum fixnum integer)
2917                            (unsigned-byte #.sb!vm:n-word-bits))
2918   "convert to inline logical operations"
2919   `(logand int
2920            (ash (ash ,(1- (ash 1 sb!vm:n-word-bits))
2921                      (- size ,sb!vm:n-word-bits))
2922                 posn)))
2923
2924 ;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
2925 ;;;   (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
2926 ;;; as the result type, as that would allow result types that cover
2927 ;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
2928 ;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
2929
2930 (deftransform %dpb ((new size posn int)
2931                     *
2932                     (unsigned-byte #.sb!vm:n-word-bits))
2933   "convert to inline logical operations"
2934   `(let ((mask (ldb (byte size 0) -1)))
2935      (logior (ash (logand new mask) posn)
2936              (logand int (lognot (ash mask posn))))))
2937
2938 (deftransform %dpb ((new size posn int)
2939                     *
2940                     (signed-byte #.sb!vm:n-word-bits))
2941   "convert to inline logical operations"
2942   `(let ((mask (ldb (byte size 0) -1)))
2943      (logior (ash (logand new mask) posn)
2944              (logand int (lognot (ash mask posn))))))
2945
2946 (deftransform %deposit-field ((new size posn int)
2947                               *
2948                               (unsigned-byte #.sb!vm:n-word-bits))
2949   "convert to inline logical operations"
2950   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2951      (logior (logand new mask)
2952              (logand int (lognot mask)))))
2953
2954 (deftransform %deposit-field ((new size posn int)
2955                               *
2956                               (signed-byte #.sb!vm:n-word-bits))
2957   "convert to inline logical operations"
2958   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
2959      (logior (logand new mask)
2960              (logand int (lognot mask)))))
2961
2962 (defoptimizer (mask-signed-field derive-type) ((size x))
2963   (let ((size (lvar-type size)))
2964     (if (numeric-type-p size)
2965         (let ((size-high (numeric-type-high size)))
2966           (if (and size-high (<= 1 size-high sb!vm:n-word-bits))
2967               (specifier-type `(signed-byte ,size-high))
2968               *universal-type*))
2969         *universal-type*)))
2970
2971 \f
2972 ;;; Modular functions
2973
2974 ;;; (ldb (byte s 0) (foo                 x  y ...)) =
2975 ;;; (ldb (byte s 0) (foo (ldb (byte s 0) x) y ...))
2976 ;;;
2977 ;;; and similar for other arguments.
2978
2979 (defun make-modular-fun-type-deriver (prototype kind width signedp)
2980   (declare (ignore kind))
2981   #!-sb-fluid
2982   (binding* ((info (info :function :info prototype) :exit-if-null)
2983              (fun (fun-info-derive-type info) :exit-if-null)
2984              (mask-type (specifier-type
2985                          (ecase signedp
2986                              ((nil) (let ((mask (1- (ash 1 width))))
2987                                       `(integer ,mask ,mask)))
2988                              ((t) `(signed-byte ,width))))))
2989     (lambda (call)
2990       (let ((res (funcall fun call)))
2991         (when res
2992           (if (eq signedp nil)
2993               (logand-derive-type-aux res mask-type))))))
2994   #!+sb-fluid
2995   (lambda (call)
2996     (binding* ((info (info :function :info prototype) :exit-if-null)
2997                (fun (fun-info-derive-type info) :exit-if-null)
2998                (res (funcall fun call) :exit-if-null)
2999                (mask-type (specifier-type
3000                            (ecase signedp
3001                              ((nil) (let ((mask (1- (ash 1 width))))
3002                                       `(integer ,mask ,mask)))
3003                              ((t) `(signed-byte ,width))))))
3004       (if (eq signedp nil)
3005           (logand-derive-type-aux res mask-type)))))
3006
3007 ;;; Try to recursively cut all uses of LVAR to WIDTH bits.
3008 ;;;
3009 ;;; For good functions, we just recursively cut arguments; their
3010 ;;; "goodness" means that the result will not increase (in the
3011 ;;; (unsigned-byte +infinity) sense). An ordinary modular function is
3012 ;;; replaced with the version, cutting its result to WIDTH or more
3013 ;;; bits. For most functions (e.g. for +) we cut all arguments; for
3014 ;;; others (e.g. for ASH) we have "optimizers", cutting only necessary
3015 ;;; arguments (maybe to a different width) and returning the name of a
3016 ;;; modular version, if it exists, or NIL. If we have changed
3017 ;;; anything, we need to flush old derived types, because they have
3018 ;;; nothing in common with the new code.
3019 (defun cut-to-width (lvar kind width signedp)
3020   (declare (type lvar lvar) (type (integer 0) width))
3021   (let ((type (specifier-type (if (zerop width)
3022                                   '(eql 0)
3023                                   `(,(ecase signedp
3024                                        ((nil) 'unsigned-byte)
3025                                        ((t) 'signed-byte))
3026                                      ,width)))))
3027     (labels ((reoptimize-node (node name)
3028                (setf (node-derived-type node)
3029                      (fun-type-returns
3030                       (info :function :type name)))
3031                (setf (lvar-%derived-type (node-lvar node)) nil)
3032                (setf (node-reoptimize node) t)
3033                (setf (block-reoptimize (node-block node)) t)
3034                (reoptimize-component (node-component node) :maybe))
3035              (cut-node (node &aux did-something)
3036                (when (and (not (block-delete-p (node-block node)))
3037                           (combination-p node)
3038                           (eq (basic-combination-kind node) :known))
3039                  (let* ((fun-ref (lvar-use (combination-fun node)))
3040                         (fun-name (leaf-source-name (ref-leaf fun-ref)))
3041                         (modular-fun (find-modular-version fun-name kind signedp width)))
3042                    (when (and modular-fun
3043                               (not (and (eq fun-name 'logand)
3044                                         (csubtypep
3045                                          (single-value-type (node-derived-type node))
3046                                          type))))
3047                      (binding* ((name (etypecase modular-fun
3048                                         ((eql :good) fun-name)
3049                                         (modular-fun-info
3050                                          (modular-fun-info-name modular-fun))
3051                                         (function
3052                                          (funcall modular-fun node width)))
3053                                       :exit-if-null))
3054                                (unless (eql modular-fun :good)
3055                                  (setq did-something t)
3056                                  (change-ref-leaf
3057                                   fun-ref
3058                                   (find-free-fun name "in a strange place"))
3059                                  (setf (combination-kind node) :full))
3060                                (unless (functionp modular-fun)
3061                                  (dolist (arg (basic-combination-args node))
3062                                    (when (cut-lvar arg)
3063                                      (setq did-something t))))
3064                                (when did-something
3065                                  (reoptimize-node node name))
3066                                did-something)))))
3067              (cut-lvar (lvar &aux did-something)
3068                (do-uses (node lvar)
3069                  (when (cut-node node)
3070                    (setq did-something t)))
3071                did-something))
3072       (cut-lvar lvar))))
3073
3074 (defun best-modular-version (width signedp)
3075   ;; 1. exact width-matched :untagged
3076   ;; 2. >/>= width-matched :tagged
3077   ;; 3. >/>= width-matched :untagged
3078   (let* ((uuwidths (modular-class-widths *untagged-unsigned-modular-class*))
3079          (uswidths (modular-class-widths *untagged-signed-modular-class*))
3080          (uwidths (merge 'list uuwidths uswidths #'< :key #'car))
3081          (twidths (modular-class-widths *tagged-modular-class*)))
3082     (let ((exact (find (cons width signedp) uwidths :test #'equal)))
3083       (when exact
3084         (return-from best-modular-version (values width :untagged signedp))))
3085     (flet ((inexact-match (w)
3086              (cond
3087                ((eq signedp (cdr w)) (<= width (car w)))
3088                ((eq signedp nil) (< width (car w))))))
3089       (let ((tgt (find-if #'inexact-match twidths)))
3090         (when tgt
3091           (return-from best-modular-version
3092             (values (car tgt) :tagged (cdr tgt)))))
3093       (let ((ugt (find-if #'inexact-match uwidths)))
3094         (when ugt
3095           (return-from best-modular-version
3096             (values (car ugt) :untagged (cdr ugt))))))))
3097
3098 (defoptimizer (logand optimizer) ((x y) node)
3099   (let ((result-type (single-value-type (node-derived-type node))))
3100     (when (numeric-type-p result-type)
3101       (let ((low (numeric-type-low result-type))
3102             (high (numeric-type-high result-type)))
3103         (when (and (numberp low)
3104                    (numberp high)
3105                    (>= low 0))
3106           (let ((width (integer-length high)))
3107             (multiple-value-bind (w kind signedp)
3108                 (best-modular-version width nil)
3109               (when w
3110                 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP).
3111                 (cut-to-width x kind width signedp)
3112                 (cut-to-width y kind width signedp)
3113                 nil ; After fixing above, replace with T.
3114                 ))))))))
3115
3116 (defoptimizer (mask-signed-field optimizer) ((width x) node)
3117   (let ((result-type (single-value-type (node-derived-type node))))
3118     (when (numeric-type-p result-type)
3119       (let ((low (numeric-type-low result-type))
3120             (high (numeric-type-high result-type)))
3121         (when (and (numberp low) (numberp high))
3122           (let ((width (max (integer-length high) (integer-length low))))
3123             (multiple-value-bind (w kind)
3124                 (best-modular-version width t)
3125               (when w
3126                 ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T).
3127                 (cut-to-width x kind width t)
3128                 nil ; After fixing above, replace with T.
3129                 ))))))))
3130 \f
3131 ;;; miscellanous numeric transforms
3132
3133 ;;; If a constant appears as the first arg, swap the args.
3134 (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
3135   (if (and (constant-lvar-p x)
3136            (not (constant-lvar-p y)))
3137       `(,(lvar-fun-name (basic-combination-fun node))
3138         y
3139         ,(lvar-value x))
3140       (give-up-ir1-transform)))
3141
3142 (dolist (x '(= char= + * logior logand logxor))
3143   (%deftransform x '(function * *) #'commutative-arg-swap
3144                  "place constant arg last"))
3145
3146 ;;; Handle the case of a constant BOOLE-CODE.
3147 (deftransform boole ((op x y) * *)
3148   "convert to inline logical operations"
3149   (unless (constant-lvar-p op)
3150     (give-up-ir1-transform "BOOLE code is not a constant."))
3151   (let ((control (lvar-value op)))
3152     (case control
3153       (#.sb!xc:boole-clr 0)
3154       (#.sb!xc:boole-set -1)
3155       (#.sb!xc:boole-1 'x)
3156       (#.sb!xc:boole-2 'y)
3157       (#.sb!xc:boole-c1 '(lognot x))
3158       (#.sb!xc:boole-c2 '(lognot y))
3159       (#.sb!xc:boole-and '(logand x y))
3160       (#.sb!xc:boole-ior '(logior x y))
3161       (#.sb!xc:boole-xor '(logxor x y))
3162       (#.sb!xc:boole-eqv '(logeqv x y))
3163       (#.sb!xc:boole-nand '(lognand x y))
3164       (#.sb!xc:boole-nor '(lognor x y))
3165       (#.sb!xc:boole-andc1 '(logandc1 x y))
3166       (#.sb!xc:boole-andc2 '(logandc2 x y))
3167       (#.sb!xc:boole-orc1 '(logorc1 x y))
3168       (#.sb!xc:boole-orc2 '(logorc2 x y))
3169       (t
3170        (abort-ir1-transform "~S is an illegal control arg to BOOLE."
3171                             control)))))
3172 \f
3173 ;;;; converting special case multiply/divide to shifts
3174
3175 ;;; If arg is a constant power of two, turn * into a shift.
3176 (deftransform * ((x y) (integer integer) *)
3177   "convert x*2^k to shift"
3178   (unless (constant-lvar-p y)
3179     (give-up-ir1-transform))
3180   (let* ((y (lvar-value y))
3181          (y-abs (abs y))
3182          (len (1- (integer-length y-abs))))
3183     (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3184       (give-up-ir1-transform))
3185     (if (minusp y)
3186         `(- (ash x ,len))
3187         `(ash x ,len))))
3188
3189 ;;; If arg is a constant power of two, turn FLOOR into a shift and
3190 ;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
3191 ;;; remainder.
3192 (flet ((frob (y ceil-p)
3193          (unless (constant-lvar-p y)
3194            (give-up-ir1-transform))
3195          (let* ((y (lvar-value y))
3196                 (y-abs (abs y))
3197                 (len (1- (integer-length y-abs))))
3198            (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3199              (give-up-ir1-transform))
3200            (let ((shift (- len))
3201                  (mask (1- y-abs))
3202                  (delta (if ceil-p (* (signum y) (1- y-abs)) 0)))
3203              `(let ((x (+ x ,delta)))
3204                 ,(if (minusp y)
3205                      `(values (ash (- x) ,shift)
3206                               (- (- (logand (- x) ,mask)) ,delta))
3207                      `(values (ash x ,shift)
3208                               (- (logand x ,mask) ,delta))))))))
3209   (deftransform floor ((x y) (integer integer) *)
3210     "convert division by 2^k to shift"
3211     (frob y nil))
3212   (deftransform ceiling ((x y) (integer integer) *)
3213     "convert division by 2^k to shift"
3214     (frob y t)))
3215
3216 ;;; Do the same for MOD.
3217 (deftransform mod ((x y) (integer integer) *)
3218   "convert remainder mod 2^k to LOGAND"
3219   (unless (constant-lvar-p y)
3220     (give-up-ir1-transform))
3221   (let* ((y (lvar-value y))
3222          (y-abs (abs y))
3223          (len (1- (integer-length y-abs))))
3224     (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3225       (give-up-ir1-transform))
3226     (let ((mask (1- y-abs)))
3227       (if (minusp y)
3228           `(- (logand (- x) ,mask))
3229           `(logand x ,mask)))))
3230
3231 ;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
3232 (deftransform truncate ((x y) (integer integer))
3233   "convert division by 2^k to shift"
3234   (unless (constant-lvar-p y)
3235     (give-up-ir1-transform))
3236   (let* ((y (lvar-value y))
3237          (y-abs (abs y))
3238          (len (1- (integer-length y-abs))))
3239     (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3240       (give-up-ir1-transform))
3241     (let* ((shift (- len))
3242            (mask (1- y-abs)))
3243       `(if (minusp x)
3244            (values ,(if (minusp y)
3245                         `(ash (- x) ,shift)
3246                         `(- (ash (- x) ,shift)))
3247                    (- (logand (- x) ,mask)))
3248            (values ,(if (minusp y)
3249                         `(ash (- ,mask x) ,shift)
3250                         `(ash x ,shift))
3251                    (logand x ,mask))))))
3252
3253 ;;; And the same for REM.
3254 (deftransform rem ((x y) (integer integer) *)
3255   "convert remainder mod 2^k to LOGAND"
3256   (unless (constant-lvar-p y)
3257     (give-up-ir1-transform))
3258   (let* ((y (lvar-value y))
3259          (y-abs (abs y))
3260          (len (1- (integer-length y-abs))))
3261     (unless (and (> y-abs 0) (= y-abs (ash 1 len)))
3262       (give-up-ir1-transform))
3263     (let ((mask (1- y-abs)))
3264       `(if (minusp x)
3265            (- (logand (- x) ,mask))
3266            (logand x ,mask)))))
3267 \f
3268 ;;;; arithmetic and logical identity operation elimination
3269
3270 ;;; Flush calls to various arith functions that convert to the
3271 ;;; identity function or a constant.
3272 (macrolet ((def (name identity result)
3273              `(deftransform ,name ((x y) (* (constant-arg (member ,identity))) *)
3274                 "fold identity operations"
3275                 ',result)))
3276   (def ash 0 x)
3277   (def logand -1 x)
3278   (def logand 0 0)
3279   (def logior 0 x)
3280   (def logior -1 -1)
3281   (def logxor -1 (lognot x))
3282   (def logxor 0 x))
3283
3284 (deftransform logand ((x y) (* (constant-arg t)) *)
3285   "fold identity operation"
3286   (let ((y (lvar-value y)))
3287     (unless (and (plusp y)
3288                  (= y (1- (ash 1 (integer-length y)))))
3289       (give-up-ir1-transform))
3290     (unless (csubtypep (lvar-type x)
3291                        (specifier-type `(integer 0 ,y)))
3292       (give-up-ir1-transform))
3293     'x))
3294
3295 (deftransform mask-signed-field ((size x) ((constant-arg t) *) *)
3296   "fold identity operation"
3297   (let ((size (lvar-value size)))
3298     (unless (csubtypep (lvar-type x) (specifier-type `(signed-byte ,size)))
3299       (give-up-ir1-transform))
3300     'x))
3301
3302 ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
3303 ;;; (* 0 -4.0) is -0.0.
3304 (deftransform - ((x y) ((constant-arg (member 0)) rational) *)
3305   "convert (- 0 x) to negate"
3306   '(%negate y))
3307 (deftransform * ((x y) (rational (constant-arg (member 0))) *)
3308   "convert (* x 0) to 0"
3309   0)
3310
3311 ;;; Return T if in an arithmetic op including lvars X and Y, the
3312 ;;; result type is not affected by the type of X. That is, Y is at
3313 ;;; least as contagious as X.
3314 #+nil
3315 (defun not-more-contagious (x y)
3316   (declare (type continuation x y))
3317   (let ((x (lvar-type x))
3318         (y (lvar-type y)))
3319     (values (type= (numeric-contagion x y)
3320                    (numeric-contagion y y)))))
3321 ;;; Patched version by Raymond Toy. dtc: Should be safer although it
3322 ;;; XXX needs more work as valid transforms are missed; some cases are
3323 ;;; specific to particular transform functions so the use of this
3324 ;;; function may need a re-think.
3325 (defun not-more-contagious (x y)
3326   (declare (type lvar x y))
3327   (flet ((simple-numeric-type (num)
3328            (and (numeric-type-p num)
3329                 ;; Return non-NIL if NUM is integer, rational, or a float
3330                 ;; of some type (but not FLOAT)
3331                 (case (numeric-type-class num)
3332                   ((integer rational)
3333                    t)
3334                   (float
3335                    (numeric-type-format num))
3336                   (t
3337                    nil)))))
3338     (let ((x (lvar-type x))
3339           (y (lvar-type y)))
3340       (if (and (simple-numeric-type x)
3341                (simple-numeric-type y))
3342           (values (type= (numeric-contagion x y)
3343                          (numeric-contagion y y)))))))
3344
3345 (def!type exact-number ()
3346   '(or rational (complex rational)))
3347
3348 ;;; Fold (+ x 0).
3349 ;;;
3350 ;;; Only safely applicable for exact numbers. For floating-point
3351 ;;; x, one would have to first show that neither x or y are signed
3352 ;;; 0s, and that x isn't an SNaN.
3353 (deftransform + ((x y) (exact-number (constant-arg (eql 0))) *)
3354   "fold zero arg"
3355   'x)
3356
3357 ;;; Fold (- x 0).
3358 (deftransform - ((x y) (exact-number (constant-arg (eql 0))) *)
3359   "fold zero arg"
3360   'x)
3361
3362 ;;; Fold (OP x +/-1)
3363 ;;;
3364 ;;; %NEGATE might not always signal correctly.
3365 (macrolet
3366     ((def (name result minus-result)
3367          `(deftransform ,name ((x y)
3368                                (exact-number (constant-arg (member 1 -1))))
3369             "fold identity operations"
3370             (if (minusp (lvar-value y)) ',minus-result ',result))))
3371   (def * x (%negate x))
3372   (def / x (%negate x))
3373   (def expt x (/ 1 x)))
3374
3375 ;;; Fold (expt x n) into multiplications for small integral values of
3376 ;;; N; convert (expt x 1/2) to sqrt.
3377 (deftransform expt ((x y) (t (constant-arg real)) *)
3378   "recode as multiplication or sqrt"
3379   (let ((val (lvar-value y)))
3380     ;; If Y would cause the result to be promoted to the same type as
3381     ;; Y, we give up. If not, then the result will be the same type
3382     ;; as X, so we can replace the exponentiation with simple
3383     ;; multiplication and division for small integral powers.
3384     (unless (not-more-contagious y x)
3385       (give-up-ir1-transform))
3386     (cond ((zerop val)
3387            (let ((x-type (lvar-type x)))
3388              (cond ((csubtypep x-type (specifier-type '(or rational
3389                                                         (complex rational))))
3390                     '1)
3391                    ((csubtypep x-type (specifier-type 'real))
3392                     `(if (rationalp x)
3393                          1
3394                          (float 1 x)))
3395                    ((csubtypep x-type (specifier-type 'complex))
3396                     ;; both parts are float
3397                     `(1+ (* x ,val)))
3398                    (t (give-up-ir1-transform)))))
3399           ((= val 2) '(* x x))
3400           ((= val -2) '(/ (* x x)))
3401           ((= val 3) '(* x x x))
3402           ((= val -3) '(/ (* x x x)))
3403           ((= val 1/2) '(sqrt x))
3404           ((= val -1/2) '(/ (sqrt x)))
3405           (t (give-up-ir1-transform)))))
3406
3407 (deftransform expt ((x y) ((constant-arg (member -1 -1.0 -1.0d0)) integer) *)
3408   "recode as an ODDP check"
3409   (let ((val (lvar-value x)))
3410     (if (eql -1 val)
3411         '(- 1 (* 2 (logand 1 y)))
3412         `(if (oddp y)
3413              ,val
3414              ,(abs val)))))
3415
3416 ;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
3417 ;;; transformations?
3418 ;;; Perhaps we should have to prove that the denominator is nonzero before
3419 ;;; doing them?  -- WHN 19990917
3420 (macrolet ((def (name)
3421              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
3422                                    *)
3423                 "fold zero arg"
3424                 0)))
3425   (def ash)
3426   (def /))
3427
3428 (macrolet ((def (name)
3429              `(deftransform ,name ((x y) ((constant-arg (integer 0 0)) integer)
3430                                    *)
3431                 "fold zero arg"
3432                 '(values 0 0))))
3433   (def truncate)
3434   (def round)
3435   (def floor)
3436   (def ceiling))
3437 \f
3438 ;;;; character operations
3439
3440 (deftransform char-equal ((a b) (base-char base-char))
3441   "open code"
3442   '(let* ((ac (char-code a))
3443           (bc (char-code b))
3444           (sum (logxor ac bc)))
3445      (or (zerop sum)
3446          (when (eql sum #x20)
3447            (let ((sum (+ ac bc)))
3448              (or (and (> sum 161) (< sum 213))
3449                  (and (> sum 415) (< sum 461))
3450                  (and (> sum 463) (< sum 477))))))))
3451
3452 (deftransform char-upcase ((x) (base-char))
3453   "open code"
3454   '(let ((n-code (char-code x)))
3455      (if (or (and (> n-code #o140)      ; Octal 141 is #\a.
3456                   (< n-code #o173))     ; Octal 172 is #\z.
3457              (and (> n-code #o337)
3458                   (< n-code #o367))
3459              (and (> n-code #o367)
3460                   (< n-code #o377)))
3461          (code-char (logxor #x20 n-code))
3462          x)))
3463
3464 (deftransform char-downcase ((x) (base-char))
3465   "open code"
3466   '(let ((n-code (char-code x)))
3467      (if (or (and (> n-code 64)         ; 65 is #\A.
3468                   (< n-code 91))        ; 90 is #\Z.
3469              (and (> n-code 191)
3470                   (< n-code 215))
3471              (and (> n-code 215)
3472                   (< n-code 223)))
3473          (code-char (logxor #x20 n-code))
3474          x)))
3475 \f
3476 ;;;; equality predicate transforms
3477
3478 ;;; Return true if X and Y are lvars whose only use is a
3479 ;;; reference to the same leaf, and the value of the leaf cannot
3480 ;;; change.
3481 (defun same-leaf-ref-p (x y)
3482   (declare (type lvar x y))
3483   (let ((x-use (principal-lvar-use x))
3484         (y-use (principal-lvar-use y)))
3485     (and (ref-p x-use)
3486          (ref-p y-use)
3487          (eq (ref-leaf x-use) (ref-leaf y-use))
3488          (constant-reference-p x-use))))
3489
3490 ;;; If X and Y are the same leaf, then the result is true. Otherwise,
3491 ;;; if there is no intersection between the types of the arguments,
3492 ;;; then the result is definitely false.
3493 (deftransform simple-equality-transform ((x y) * *
3494                                          :defun-only t)
3495   (cond
3496     ((same-leaf-ref-p x y) t)
3497     ((not (types-equal-or-intersect (lvar-type x) (lvar-type y)))
3498          nil)
3499     (t (give-up-ir1-transform))))
3500
3501 (macrolet ((def (x)
3502              `(%deftransform ',x '(function * *) #'simple-equality-transform)))
3503   (def eq)
3504   (def char=))
3505
3506 ;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
3507 ;;; try to convert to a type-specific predicate or EQ:
3508 ;;; -- If both args are characters, convert to CHAR=. This is better than
3509 ;;;    just converting to EQ, since CHAR= may have special compilation
3510 ;;;    strategies for non-standard representations, etc.
3511 ;;; -- If either arg is definitely a fixnum, we check to see if X is
3512 ;;;    constant and if so, put X second. Doing this results in better
3513 ;;;    code from the backend, since the backend assumes that any constant
3514 ;;;    argument comes second.
3515 ;;; -- If either arg is definitely not a number or a fixnum, then we
3516 ;;;    can compare with EQ.
3517 ;;; -- Otherwise, we try to put the arg we know more about second. If X
3518 ;;;    is constant then we put it second. If X is a subtype of Y, we put
3519 ;;;    it second. These rules make it easier for the back end to match
3520 ;;;    these interesting cases.
3521 (deftransform eql ((x y) * * :node node)
3522   "convert to simpler equality predicate"
3523   (let ((x-type (lvar-type x))
3524         (y-type (lvar-type y))
3525         (char-type (specifier-type 'character)))
3526     (flet ((fixnum-type-p (type)
3527              (csubtypep type (specifier-type 'fixnum))))
3528       (cond
3529         ((same-leaf-ref-p x y) t)
3530         ((not (types-equal-or-intersect x-type y-type))
3531          nil)
3532         ((and (csubtypep x-type char-type)
3533               (csubtypep y-type char-type))
3534          '(char= x y))
3535         ((or (fixnum-type-p x-type) (fixnum-type-p y-type))
3536          (commutative-arg-swap node))
3537         ((or (eq-comparable-type-p x-type) (eq-comparable-type-p y-type))
3538          '(eq x y))
3539         ((and (not (constant-lvar-p y))
3540               (or (constant-lvar-p x)
3541                   (and (csubtypep x-type y-type)
3542                        (not (csubtypep y-type x-type)))))
3543          '(eql y x))
3544         (t
3545          (give-up-ir1-transform))))))
3546
3547 ;;; similarly to the EQL transform above, we attempt to constant-fold
3548 ;;; or convert to a simpler predicate: mostly we have to be careful
3549 ;;; with strings and bit-vectors.
3550 (deftransform equal ((x y) * *)
3551   "convert to simpler equality predicate"
3552   (let ((x-type (lvar-type x))
3553         (y-type (lvar-type y))
3554         (string-type (specifier-type 'string))
3555         (bit-vector-type (specifier-type 'bit-vector)))
3556     (cond
3557       ((same-leaf-ref-p x y) t)
3558       ((and (csubtypep x-type string-type)
3559             (csubtypep y-type string-type))
3560        '(string= x y))
3561       ((and (csubtypep x-type bit-vector-type)
3562             (csubtypep y-type bit-vector-type))
3563        '(bit-vector-= x y))
3564       ;; if at least one is not a string, and at least one is not a
3565       ;; bit-vector, then we can reason from types.
3566       ((and (not (and (types-equal-or-intersect x-type string-type)
3567                       (types-equal-or-intersect y-type string-type)))
3568             (not (and (types-equal-or-intersect x-type bit-vector-type)
3569                       (types-equal-or-intersect y-type bit-vector-type)))
3570             (not (types-equal-or-intersect x-type y-type)))
3571        nil)
3572       (t (give-up-ir1-transform)))))
3573
3574 ;;; Convert to EQL if both args are rational and complexp is specified
3575 ;;; and the same for both.
3576 (deftransform = ((x y) (number number) *)
3577   "open code"
3578   (let ((x-type (lvar-type x))
3579         (y-type (lvar-type y)))
3580     (cond ((or (and (csubtypep x-type (specifier-type 'float))
3581                     (csubtypep y-type (specifier-type 'float)))
3582                (and (csubtypep x-type (specifier-type '(complex float)))
3583                     (csubtypep y-type (specifier-type '(complex float))))
3584                #!+complex-float-vops
3585                (and (csubtypep x-type (specifier-type '(or single-float (complex single-float))))
3586                     (csubtypep y-type (specifier-type '(or single-float (complex single-float)))))
3587                #!+complex-float-vops
3588                (and (csubtypep x-type (specifier-type '(or double-float (complex double-float))))
3589                     (csubtypep y-type (specifier-type '(or double-float (complex double-float))))))
3590            ;; They are both floats. Leave as = so that -0.0 is
3591            ;; handled correctly.
3592            (give-up-ir1-transform))
3593           ((or (and (csubtypep x-type (specifier-type 'rational))
3594                     (csubtypep y-type (specifier-type 'rational)))
3595                (and (csubtypep x-type
3596                                (specifier-type '(complex rational)))
3597                     (csubtypep y-type
3598                                (specifier-type '(complex rational)))))
3599            ;; They are both rationals and complexp is the same.
3600            ;; Convert to EQL.
3601            '(eql x y))
3602           (t
3603            (give-up-ir1-transform
3604             "The operands might not be the same type.")))))
3605
3606 (defun maybe-float-lvar-p (lvar)
3607   (neq *empty-type* (type-intersection (specifier-type 'float)
3608                                        (lvar-type lvar))))
3609
3610 (flet ((maybe-invert (node op inverted x y)
3611          ;; Don't invert if either argument can be a float (NaNs)
3612          (cond
3613            ((or (maybe-float-lvar-p x) (maybe-float-lvar-p y))
3614             (delay-ir1-transform node :constraint)
3615             `(or (,op x y) (= x y)))
3616            (t
3617             `(if (,inverted x y) nil t)))))
3618   (deftransform >= ((x y) (number number) * :node node)
3619     "invert or open code"
3620     (maybe-invert node '> '< x y))
3621   (deftransform <= ((x y) (number number) * :node node)
3622     "invert or open code"
3623     (maybe-invert node '< '> x y)))
3624
3625 ;;; See whether we can statically determine (< X Y) using type
3626 ;;; information. If X's high bound is < Y's low, then X < Y.
3627 ;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
3628 ;;; NIL). If not, at least make sure any constant arg is second.
3629 (macrolet ((def (name inverse reflexive-p surely-true surely-false)
3630              `(deftransform ,name ((x y))
3631                 "optimize using intervals"
3632                 (if (and (same-leaf-ref-p x y)
3633                          ;; For non-reflexive functions we don't need
3634                          ;; to worry about NaNs: (non-ref-op NaN NaN) => false,
3635                          ;; but with reflexive ones we don't know...
3636                          ,@(when reflexive-p
3637                                  '((and (not (maybe-float-lvar-p x))
3638                                         (not (maybe-float-lvar-p y))))))
3639                     ,reflexive-p
3640                     (let ((ix (or (type-approximate-interval (lvar-type x))
3641                                   (give-up-ir1-transform)))
3642                           (iy (or (type-approximate-interval (lvar-type y))
3643                                   (give-up-ir1-transform))))
3644                       (cond (,surely-true
3645                              t)
3646                             (,surely-false
3647                              nil)
3648                             ((and (constant-lvar-p x)
3649                                   (not (constant-lvar-p y)))
3650                              `(,',inverse y x))
3651                             (t
3652                              (give-up-ir1-transform))))))))
3653   (def = = t (interval-= ix iy) (interval-/= ix iy))
3654   (def /= /= nil (interval-/= ix iy) (interval-= ix iy))
3655   (def < > nil (interval-< ix iy) (interval->= ix iy))
3656   (def > < nil (interval-< iy ix) (interval->= iy ix))
3657   (def <= >= t (interval->= iy ix) (interval-< iy ix))
3658   (def >= <= t (interval->= ix iy) (interval-< ix iy)))
3659
3660 (defun ir1-transform-char< (x y first second inverse)
3661   (cond
3662     ((same-leaf-ref-p x y) nil)
3663     ;; If we had interval representation of character types, as we
3664     ;; might eventually have to to support 2^21 characters, then here
3665     ;; we could do some compile-time computation as in transforms for
3666     ;; < above. -- CSR, 2003-07-01
3667     ((and (constant-lvar-p first)
3668           (not (constant-lvar-p second)))
3669      `(,inverse y x))
3670     (t (give-up-ir1-transform))))
3671
3672 (deftransform char< ((x y) (character character) *)
3673   (ir1-transform-char< x y x y 'char>))
3674
3675 (deftransform char> ((x y) (character character) *)
3676   (ir1-transform-char< y x x y 'char<))
3677 \f
3678 ;;;; converting N-arg comparisons
3679 ;;;;
3680 ;;;; We convert calls to N-arg comparison functions such as < into
3681 ;;;; two-arg calls. This transformation is enabled for all such
3682 ;;;; comparisons in this file. If any of these predicates are not
3683 ;;;; open-coded, then the transformation should be removed at some
3684 ;;;; point to avoid pessimization.
3685
3686 ;;; This function is used for source transformation of N-arg
3687 ;;; comparison functions other than inequality. We deal both with
3688 ;;; converting to two-arg calls and inverting the sense of the test,
3689 ;;; if necessary. If the call has two args, then we pass or return a
3690 ;;; negated test as appropriate. If it is a degenerate one-arg call,
3691 ;;; then we transform to code that returns true. Otherwise, we bind
3692 ;;; all the arguments and expand into a bunch of IFs.
3693 (defun multi-compare (predicate args not-p type &optional force-two-arg-p)
3694   (let ((nargs (length args)))
3695     (cond ((< nargs 1) (values nil t))
3696           ((= nargs 1) `(progn (the ,type ,@args) t))
3697           ((= nargs 2)
3698            (if not-p
3699                `(if (,predicate ,(first args) ,(second args)) nil t)
3700                (if force-two-arg-p
3701                    `(,predicate ,(first args) ,(second args))
3702                    (values nil t))))
3703           (t
3704            (do* ((i (1- nargs) (1- i))
3705                  (last nil current)
3706                  (current (gensym) (gensym))
3707                  (vars (list current) (cons current vars))
3708                  (result t (if not-p
3709                                `(if (,predicate ,current ,last)
3710                                     nil ,result)
3711                                `(if (,predicate ,current ,last)
3712                                     ,result nil))))
3713                ((zerop i)
3714                 `((lambda ,vars (declare (type ,type ,@vars)) ,result)
3715                   ,@args)))))))
3716
3717 (define-source-transform = (&rest args) (multi-compare '= args nil 'number))
3718 (define-source-transform < (&rest args) (multi-compare '< args nil 'real))
3719 (define-source-transform > (&rest args) (multi-compare '> args nil 'real))
3720 ;;; We cannot do the inversion for >= and <= here, since both
3721 ;;;   (< NaN X) and (> NaN X)
3722 ;;; are false, and we don't have type-inforation available yet. The
3723 ;;; deftransforms for two-argument versions of >= and <= takes care of
3724 ;;; the inversion to > and < when possible.
3725 (define-source-transform <= (&rest args) (multi-compare '<= args nil 'real))
3726 (define-source-transform >= (&rest args) (multi-compare '>= args nil 'real))
3727
3728 (define-source-transform char= (&rest args) (multi-compare 'char= args nil
3729                                                            'character))
3730 (define-source-transform char< (&rest args) (multi-compare 'char< args nil
3731                                                            'character))
3732 (define-source-transform char> (&rest args) (multi-compare 'char> args nil
3733                                                            'character))
3734 (define-source-transform char<= (&rest args) (multi-compare 'char> args t
3735                                                             'character))
3736 (define-source-transform char>= (&rest args) (multi-compare 'char< args t
3737                                                             'character))
3738
3739 (define-source-transform char-equal (&rest args)
3740   (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t))
3741 (define-source-transform char-lessp (&rest args)
3742   (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t))
3743 (define-source-transform char-greaterp (&rest args)
3744   (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t))
3745 (define-source-transform char-not-greaterp (&rest args)
3746   (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t))
3747 (define-source-transform char-not-lessp (&rest args)
3748   (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t))
3749
3750 ;;; This function does source transformation of N-arg inequality
3751 ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3
3752 ;;; arg cases. If there are more than two args, then we expand into
3753 ;;; the appropriate n^2 comparisons only when speed is important.
3754 (declaim (ftype (function (symbol list t) *) multi-not-equal))
3755 (defun multi-not-equal (predicate args type)
3756   (let ((nargs (length args)))
3757     (cond ((< nargs 1) (values nil t))
3758           ((= nargs 1) `(progn (the ,type ,@args) t))
3759           ((= nargs 2)
3760            `(if (,predicate ,(first args) ,(second args)) nil t))
3761           ((not (policy *lexenv*
3762                         (and (>= speed space)
3763                              (>= speed compilation-speed))))
3764            (values nil t))
3765           (t
3766            (let ((vars (make-gensym-list nargs)))
3767              (do ((var vars next)
3768                   (next (cdr vars) (cdr next))
3769                   (result t))
3770                  ((null next)
3771                   `((lambda ,vars (declare (type ,type ,@vars)) ,result)
3772                     ,@args))
3773                (let ((v1 (first var)))
3774                  (dolist (v2 next)
3775                    (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
3776
3777 (define-source-transform /= (&rest args)
3778   (multi-not-equal '= args 'number))
3779 (define-source-transform char/= (&rest args)
3780   (multi-not-equal 'char= args 'character))
3781 (define-source-transform char-not-equal (&rest args)
3782   (multi-not-equal 'char-equal args 'character))
3783
3784 ;;; Expand MAX and MIN into the obvious comparisons.
3785 (define-source-transform max (arg0 &rest rest)
3786   (once-only ((arg0 arg0))
3787     (if (null rest)
3788         `(values (the real ,arg0))
3789         `(let ((maxrest (max ,@rest)))
3790           (if (>= ,arg0 maxrest) ,arg0 maxrest)))))
3791 (define-source-transform min (arg0 &rest rest)
3792   (once-only ((arg0 arg0))
3793     (if (null rest)
3794         `(values (the real ,arg0))
3795         `(let ((minrest (min ,@rest)))
3796           (if (<= ,arg0 minrest) ,arg0 minrest)))))
3797 \f
3798 ;;;; converting N-arg arithmetic functions
3799 ;;;;
3800 ;;;; N-arg arithmetic and logic functions are associated into two-arg
3801 ;;;; versions, and degenerate cases are flushed.
3802
3803 ;;; Left-associate FIRST-ARG and MORE-ARGS using FUNCTION.
3804 (declaim (ftype (sfunction (symbol t list t) list) associate-args))
3805 (defun associate-args (fun first-arg more-args identity)
3806   (let ((next (rest more-args))
3807         (arg (first more-args)))
3808     (if (null next)
3809         `(,fun ,first-arg ,(if arg arg identity))
3810         (associate-args fun `(,fun ,first-arg ,arg) next identity))))
3811
3812 ;;; Reduce constants in ARGS list.
3813 (declaim (ftype (sfunction (symbol list t symbol) list) reduce-constants))
3814 (defun reduce-constants (fun args identity one-arg-result-type)
3815   (let ((one-arg-constant-p (ecase one-arg-result-type
3816                               (number #'numberp)
3817                               (integer #'integerp)))
3818         (reduced-value identity)
3819         (reduced-p nil))
3820     (collect ((not-constants))
3821       (dolist (arg args)
3822         (if (funcall one-arg-constant-p arg)
3823             (setf reduced-value (funcall fun reduced-value arg)
3824                   reduced-p t)
3825             (not-constants arg)))
3826       ;; It is tempting to drop constants reduced to identity here,
3827       ;; but if X is SNaN in (* X 1), we cannot drop the 1.
3828       (if (not-constants)
3829           (if reduced-p
3830               `(,reduced-value ,@(not-constants))
3831               (not-constants))
3832           `(,reduced-value)))))
3833
3834 ;;; Do source transformations for transitive functions such as +.
3835 ;;; One-arg cases are replaced with the arg and zero arg cases with
3836 ;;; the identity. ONE-ARG-RESULT-TYPE is the type to ensure (with THE)
3837 ;;; that the argument in one-argument calls is.
3838 (declaim (ftype (function (symbol list t &optional symbol list)
3839                           (values t &optional (member nil t)))
3840                 source-transform-transitive))
3841 (defun source-transform-transitive (fun args identity
3842                                     &optional (one-arg-result-type 'number)
3843                                               (one-arg-prefixes '(values)))
3844   (case (length args)
3845     (0 identity)
3846     (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
3847     (2 (values nil t))
3848     (t (let ((reduced-args (reduce-constants fun args identity one-arg-result-type)))
3849          (associate-args fun (first reduced-args) (rest reduced-args) identity)))))
3850
3851 (define-source-transform + (&rest args)
3852   (source-transform-transitive '+ args 0))
3853 (define-source-transform * (&rest args)
3854   (source-transform-transitive '* args 1))
3855 (define-source-transform logior (&rest args)
3856   (source-transform-transitive 'logior args 0 'integer))
3857 (define-source-transform logxor (&rest args)
3858   (source-transform-transitive 'logxor args 0 'integer))
3859 (define-source-transform logand (&rest args)
3860   (source-transform-transitive 'logand args -1 'integer))
3861 (define-source-transform logeqv (&rest args)
3862   (source-transform-transitive 'logeqv args -1 'integer))
3863 (define-source-transform gcd (&rest args)
3864   (source-transform-transitive 'gcd args 0 'integer '(abs)))
3865 (define-source-transform lcm (&rest args)
3866   (source-transform-transitive 'lcm args 1 'integer '(abs)))
3867
3868 ;;; Do source transformations for intransitive n-arg functions such as
3869 ;;; /. With one arg, we form the inverse. With two args we pass.
3870 ;;; Otherwise we associate into two-arg calls.
3871 (declaim (ftype (function (symbol symbol list t list &optional symbol)
3872                           (values list &optional (member nil t)))
3873                 source-transform-intransitive))
3874 (defun source-transform-intransitive (fun fun* args identity one-arg-prefixes
3875                                       &optional (one-arg-result-type 'number))
3876   (case (length args)
3877     ((0 2) (values nil t))
3878     (1 `(,@one-arg-prefixes (the ,one-arg-result-type ,(first args))))
3879     (t (let ((reduced-args
3880               (reduce-constants fun* (rest args) identity one-arg-result-type)))
3881          (associate-args fun (first args) reduced-args identity)))))
3882
3883 (define-source-transform - (&rest args)
3884   (source-transform-intransitive '- '+ args 0 '(%negate)))
3885 (define-source-transform / (&rest args)
3886   (source-transform-intransitive '/ '* args 1 '(/ 1)))
3887 \f
3888 ;;;; transforming APPLY
3889
3890 ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
3891 ;;; only needs to understand one kind of variable-argument call. It is
3892 ;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
3893 (define-source-transform apply (fun arg &rest more-args)
3894   (let ((args (cons arg more-args)))
3895     `(multiple-value-call ,fun
3896        ,@(mapcar (lambda (x) `(values ,x)) (butlast args))
3897        (values-list ,(car (last args))))))
3898
3899 ;;; When &REST argument are at play, we also have extra context and count
3900 ;;; arguments -- convert to %VALUES-LIST-OR-CONTEXT when possible, so that the
3901 ;;; deftransform can decide what to do after everything has been converted.
3902 (define-source-transform values-list (list)
3903   (if (symbolp list)
3904       (let* ((var (lexenv-find list vars))
3905              (info (when (lambda-var-p var)
3906                      (lambda-var-arg-info var))))
3907         (if (and info
3908                  (eq :rest (arg-info-kind info))
3909                  (consp (arg-info-default info)))
3910             (destructuring-bind (context count &optional used) (arg-info-default info)
3911               (declare (ignore used))
3912               `(%values-list-or-context ,list ,context ,count))
3913             (values nil t)))
3914       (values nil t)))
3915
3916 (deftransform %values-list-or-context ((list context count) * * :node node)
3917   (let* ((use (lvar-use list))
3918          (var (when (ref-p use) (ref-leaf use)))
3919          (home (when (lambda-var-p var) (lambda-var-home var)))
3920          (info (when (lambda-var-p var) (lambda-var-arg-info var))))
3921     (flet ((ref-good-for-more-context-p (ref)
3922              (let ((dest (principal-lvar-end (node-lvar ref))))
3923                (and (combination-p dest)
3924                     ;; Uses outside VALUES-LIST will require a &REST list anyways,
3925                     ;; to it's no use saving effort here -- plus they might modify
3926                     ;; the list destructively.
3927                     (eq '%values-list-or-context (lvar-fun-name (combination-fun dest)))
3928                     ;; If the home lambda is different and isn't DX, it might
3929                     ;; escape -- in which case using the more context isn't safe.
3930                     (let ((clambda (node-home-lambda dest)))
3931                       (or (eq home clambda)
3932                           (leaf-dynamic-extent clambda)))))))
3933       (let ((context-ok
3934               (and info
3935                    (consp (arg-info-default info))
3936                    (not (lambda-var-specvar var))
3937                    (not (lambda-var-sets var))
3938                    (every #'ref-good-for-more-context-p (lambda-var-refs var))
3939                    (policy node (= 3 rest-conversion)))))
3940         (cond (context-ok
3941                (destructuring-bind (context count &optional used) (arg-info-default info)
3942                  (declare (ignore used))
3943                  (setf (arg-info-default info) (list context count t)))
3944                `(%more-arg-values context 0 count))
3945               (t
3946                (when info
3947                  (setf (arg-info-default info) t))
3948                `(values-list list)))))))
3949
3950 \f
3951 ;;;; transforming FORMAT
3952 ;;;;
3953 ;;;; If the control string is a compile-time constant, then replace it
3954 ;;;; with a use of the FORMATTER macro so that the control string is
3955 ;;;; ``compiled.'' Furthermore, if the destination is either a stream
3956 ;;;; or T and the control string is a function (i.e. FORMATTER), then
3957 ;;;; convert the call to FORMAT to just a FUNCALL of that function.
3958
3959 ;;; for compile-time argument count checking.
3960 ;;;
3961 ;;; FIXME II: In some cases, type information could be correlated; for
3962 ;;; instance, ~{ ... ~} requires a list argument, so if the lvar-type
3963 ;;; of a corresponding argument is known and does not intersect the
3964 ;;; list type, a warning could be signalled.
3965 (defun check-format-args (string args fun)
3966   (declare (type string string))
3967   (unless (typep string 'simple-string)
3968     (setq string (coerce string 'simple-string)))
3969   (multiple-value-bind (min max)
3970       (handler-case (sb!format:%compiler-walk-format-string string args)
3971         (sb!format:format-error (c)
3972           (compiler-warn "~A" c)))
3973     (when min
3974       (let ((nargs (length args)))
3975         (cond
3976           ((< nargs min)
3977            (warn 'format-too-few-args-warning
3978                  :format-control
3979                  "Too few arguments (~D) to ~S ~S: requires at least ~D."
3980                  :format-arguments (list nargs fun string min)))
3981           ((> nargs max)
3982            (warn 'format-too-many-args-warning
3983                  :format-control
3984                  "Too many arguments (~D) to ~S ~S: uses at most ~D."
3985                  :format-arguments (list nargs fun string max))))))))
3986
3987 (defoptimizer (format optimizer) ((dest control &rest args))
3988   (when (constant-lvar-p control)
3989     (let ((x (lvar-value control)))
3990       (when (stringp x)
3991         (check-format-args x args 'format)))))
3992
3993 ;;; We disable this transform in the cross-compiler to save memory in
3994 ;;; the target image; most of the uses of FORMAT in the compiler are for
3995 ;;; error messages, and those don't need to be particularly fast.
3996 #+sb-xc
3997 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
3998                       :policy (>= speed space))
3999   (unless (constant-lvar-p control)
4000     (give-up-ir1-transform "The control string is not a constant."))
4001   (let ((arg-names (make-gensym-list (length args))))
4002     `(lambda (dest control ,@arg-names)
4003        (declare (ignore control))
4004        (format dest (formatter ,(lvar-value control)) ,@arg-names))))
4005
4006 (deftransform format ((stream control &rest args) (stream function &rest t))
4007   (let ((arg-names (make-gensym-list (length args))))
4008     `(lambda (stream control ,@arg-names)
4009        (funcall control stream ,@arg-names)
4010        nil)))
4011
4012 (deftransform format ((tee control &rest args) ((member t) function &rest t))
4013   (let ((arg-names (make-gensym-list (length args))))
4014     `(lambda (tee control ,@arg-names)
4015        (declare (ignore tee))
4016        (funcall control *standard-output* ,@arg-names)
4017        nil)))
4018
4019 (deftransform pathname ((pathspec) (pathname) *)
4020   'pathspec)
4021
4022 (deftransform pathname ((pathspec) (string) *)
4023   '(values (parse-namestring pathspec)))
4024
4025 (macrolet
4026     ((def (name)
4027          `(defoptimizer (,name optimizer) ((control &rest args))
4028             (when (constant-lvar-p control)
4029               (let ((x (lvar-value control)))
4030                 (when (stringp x)
4031                   (check-format-args x args ',name)))))))
4032   (def error)
4033   (def warn)
4034   #+sb-xc-host ; Only we should be using these
4035   (progn
4036     (def style-warn)
4037     (def compiler-error)
4038     (def compiler-warn)
4039     (def compiler-style-warn)
4040     (def compiler-notify)
4041     (def maybe-compiler-notify)
4042     (def bug)))
4043
4044 (defoptimizer (cerror optimizer) ((report control &rest args))
4045   (when (and (constant-lvar-p control)
4046              (constant-lvar-p report))
4047     (let ((x (lvar-value control))
4048           (y (lvar-value report)))
4049       (when (and (stringp x) (stringp y))
4050         (multiple-value-bind (min1 max1)
4051             (handler-case
4052                 (sb!format:%compiler-walk-format-string x args)
4053               (sb!format:format-error (c)
4054                 (compiler-warn "~A" c)))
4055           (when min1
4056             (multiple-value-bind (min2 max2)
4057                 (handler-case
4058                     (sb!format:%compiler-walk-format-string y args)
4059                   (sb!format:format-error (c)
4060                     (compiler-warn "~A" c)))
4061               (when min2
4062                 (let ((nargs (length args)))
4063                   (cond
4064                     ((< nargs (min min1 min2))
4065                      (warn 'format-too-few-args-warning
4066                            :format-control
4067                            "Too few arguments (~D) to ~S ~S ~S: ~
4068                             requires at least ~D."
4069                            :format-arguments
4070                            (list nargs 'cerror y x (min min1 min2))))
4071                     ((> nargs (max max1 max2))
4072                      (warn 'format-too-many-args-warning
4073                            :format-control
4074                            "Too many arguments (~D) to ~S ~S ~S: ~
4075                             uses at most ~D."
4076                            :format-arguments
4077                            (list nargs 'cerror y x (max max1 max2))))))))))))))
4078
4079 (defoptimizer (coerce derive-type) ((value type) node)
4080   (cond
4081     ((constant-lvar-p type)
4082      ;; This branch is essentially (RESULT-TYPE-SPECIFIER-NTH-ARG 2),
4083      ;; but dealing with the niggle that complex canonicalization gets
4084      ;; in the way: (COERCE 1 'COMPLEX) returns 1, which is not of
4085      ;; type COMPLEX.
4086      (let* ((specifier (lvar-value type))
4087             (result-typeoid (careful-specifier-type specifier)))
4088        (cond
4089          ((null result-typeoid) nil)
4090          ((csubtypep result-typeoid (specifier-type 'number))
4091           ;; the difficult case: we have to cope with ANSI 12.1.5.3
4092           ;; Rule of Canonical Representation for Complex Rationals,
4093           ;; which is a truly nasty delivery to field.
4094           (cond
4095             ((csubtypep result-typeoid (specifier-type 'real))
4096              ;; cleverness required here: it would be nice to deduce
4097              ;; that something of type (INTEGER 2 3) coerced to type
4098              ;; DOUBLE-FLOAT should return (DOUBLE-FLOAT 2.0d0 3.0d0).
4099              ;; FLOAT gets its own clause because it's implemented as
4100              ;; a UNION-TYPE, so we don't catch it in the NUMERIC-TYPE
4101              ;; logic below.
4102              result-typeoid)
4103             ((and (numeric-type-p result-typeoid)
4104                   (eq (numeric-type-complexp result-typeoid) :real))
4105              ;; FIXME: is this clause (a) necessary or (b) useful?
4106              result-typeoid)
4107             ((or (csubtypep result-typeoid
4108                             (specifier-type '(complex single-float)))
4109                  (csubtypep result-typeoid
4110                             (specifier-type '(complex double-float)))
4111                  #!+long-float
4112                  (csubtypep result-typeoid
4113                             (specifier-type '(complex long-float))))
4114              ;; float complex types are never canonicalized.
4115              result-typeoid)
4116             (t
4117              ;; if it's not a REAL, or a COMPLEX FLOAToid, it's
4118              ;; probably just a COMPLEX or equivalent.  So, in that
4119              ;; case, we will return a complex or an object of the
4120              ;; provided type if it's rational:
4121              (type-union result-typeoid
4122                          (type-intersection (lvar-type value)
4123                                             (specifier-type 'rational))))))
4124          ((and (policy node (zerop safety))
4125                (csubtypep result-typeoid (specifier-type '(array * (*)))))
4126           ;; At zero safety the deftransform for COERCE can elide dimension
4127           ;; checks for the things like (COERCE X '(SIMPLE-VECTOR 5)) -- so we
4128           ;; need to simplify the type to drop the dimension information.
4129           (let ((vtype (simplify-vector-type result-typeoid)))
4130             (if vtype
4131                 (specifier-type vtype)
4132                 result-typeoid)))
4133          (t
4134           result-typeoid))))
4135     (t
4136      ;; OK, the result-type argument isn't constant.  However, there
4137      ;; are common uses where we can still do better than just
4138      ;; *UNIVERSAL-TYPE*: e.g. (COERCE X (ARRAY-ELEMENT-TYPE Y)),
4139      ;; where Y is of a known type.  See messages on cmucl-imp
4140      ;; 2001-02-14 and sbcl-devel 2002-12-12.  We only worry here
4141      ;; about types that can be returned by (ARRAY-ELEMENT-TYPE Y), on
4142      ;; the basis that it's unlikely that other uses are both
4143      ;; time-critical and get to this branch of the COND (non-constant
4144      ;; second argument to COERCE).  -- CSR, 2002-12-16
4145      (let ((value-type (lvar-type value))
4146            (type-type (lvar-type type)))
4147        (labels
4148            ((good-cons-type-p (cons-type)
4149               ;; Make sure the cons-type we're looking at is something
4150               ;; we're prepared to handle which is basically something
4151               ;; that array-element-type can return.
4152               (or (and (member-type-p cons-type)
4153                        (eql 1 (member-type-size cons-type))
4154                        (null (first (member-type-members cons-type))))
4155                   (let ((car-type (cons-type-car-type cons-type)))
4156                     (and (member-type-p car-type)
4157                          (eql 1 (member-type-members car-type))
4158                          (let ((elt (first (member-type-members car-type))))
4159                            (or (symbolp elt)
4160                                (numberp elt)
4161                                (and (listp elt)
4162                                     (numberp (first elt)))))
4163                          (good-cons-type-p (cons-type-cdr-type cons-type))))))
4164             (unconsify-type (good-cons-type)
4165               ;; Convert the "printed" respresentation of a cons
4166               ;; specifier into a type specifier.  That is, the
4167               ;; specifier (CONS (EQL SIGNED-BYTE) (CONS (EQL 16)
4168               ;; NULL)) is converted to (SIGNED-BYTE 16).
4169               (cond ((or (null good-cons-type)
4170                          (eq good-cons-type 'null))
4171                      nil)
4172                     ((and (eq (first good-cons-type) 'cons)
4173                           (eq (first (second good-cons-type)) 'member))
4174                      `(,(second (second good-cons-type))
4175                        ,@(unconsify-type (caddr good-cons-type))))))
4176             (coerceable-p (part)
4177               ;; Can the value be coerced to the given type?  Coerce is
4178               ;; complicated, so we don't handle every possible case
4179               ;; here---just the most common and easiest cases:
4180               ;;
4181               ;; * Any REAL can be coerced to a FLOAT type.
4182               ;; * Any NUMBER can be coerced to a (COMPLEX
4183               ;;   SINGLE/DOUBLE-FLOAT).
4184               ;;
4185               ;; FIXME I: we should also be able to deal with characters
4186               ;; here.
4187               ;;
4188               ;; FIXME II: I'm not sure that anything is necessary
4189               ;; here, at least while COMPLEX is not a specialized
4190               ;; array element type in the system.  Reasoning: if
4191               ;; something cannot be coerced to the requested type, an
4192               ;; error will be raised (and so any downstream compiled
4193               ;; code on the assumption of the returned type is
4194               ;; unreachable).  If something can, then it will be of
4195               ;; the requested type, because (by assumption) COMPLEX
4196               ;; (and other difficult types like (COMPLEX INTEGER)
4197               ;; aren't specialized types.
4198               (let ((coerced-type (careful-specifier-type part)))
4199                 (when coerced-type
4200                   (or (and (csubtypep coerced-type (specifier-type 'float))
4201                            (csubtypep value-type (specifier-type 'real)))
4202                       (and (csubtypep coerced-type
4203                                       (specifier-type `(or (complex single-float)
4204                                                            (complex double-float))))
4205                           (csubtypep value-type (specifier-type 'number)))))))
4206             (process-types (type)
4207               ;; FIXME: This needs some work because we should be able
4208               ;; to derive the resulting type better than just the
4209               ;; type arg of coerce.  That is, if X is (INTEGER 10
4210               ;; 20), then (COERCE X 'DOUBLE-FLOAT) should say
4211               ;; (DOUBLE-FLOAT 10d0 20d0) instead of just
4212               ;; double-float.
4213               (cond ((member-type-p type)
4214                      (block punt
4215                        (let (members)
4216                          (mapc-member-type-members
4217                           (lambda (member)
4218                             (if (coerceable-p member)
4219                                 (push member members)
4220                                 (return-from punt *universal-type*)))
4221                           type)
4222                          (specifier-type `(or ,@members)))))
4223                     ((and (cons-type-p type)
4224                           (good-cons-type-p type))
4225                      (let ((c-type (unconsify-type (type-specifier type))))
4226                        (if (coerceable-p c-type)
4227                            (specifier-type c-type)
4228                            *universal-type*)))
4229                     (t
4230                      *universal-type*))))
4231          (cond ((union-type-p type-type)
4232                 (apply #'type-union (mapcar #'process-types
4233                                             (union-type-types type-type))))
4234                ((or (member-type-p type-type)
4235                     (cons-type-p type-type))
4236                 (process-types type-type))
4237                (t
4238                 *universal-type*)))))))
4239
4240 (defoptimizer (compile derive-type) ((nameoid function))
4241   (when (csubtypep (lvar-type nameoid)
4242                    (specifier-type 'null))
4243     (values-specifier-type '(values function boolean boolean))))
4244
4245 ;;; FIXME: Maybe also STREAM-ELEMENT-TYPE should be given some loving
4246 ;;; treatment along these lines? (See discussion in COERCE DERIVE-TYPE
4247 ;;; optimizer, above).
4248 (defoptimizer (array-element-type derive-type) ((array))
4249   (let ((array-type (lvar-type array)))
4250     (labels ((consify (list)
4251               (if (endp list)
4252                   '(eql nil)
4253                   `(cons (eql ,(car list)) ,(consify (rest list)))))
4254             (get-element-type (a)
4255               (let ((element-type
4256                      (type-specifier (array-type-specialized-element-type a))))
4257                 (cond ((eq element-type '*)
4258                        (specifier-type 'type-specifier))
4259                       ((symbolp element-type)
4260                        (make-member-type :members (list element-type)))
4261                       ((consp element-type)
4262                        (specifier-type (consify element-type)))
4263                       (t
4264                        (error "can't understand type ~S~%" element-type))))))
4265       (labels ((recurse (type)
4266                   (cond ((array-type-p type)
4267                          (get-element-type type))
4268                         ((union-type-p type)
4269                          (apply #'type-union
4270                                 (mapcar #'recurse (union-type-types type))))
4271                         (t
4272                          *universal-type*))))
4273         (recurse array-type)))))
4274
4275 (define-source-transform sb!impl::sort-vector (vector start end predicate key)
4276   ;; Like CMU CL, we use HEAPSORT. However, other than that, this code
4277   ;; isn't really related to the CMU CL code, since instead of trying
4278   ;; to generalize the CMU CL code to allow START and END values, this
4279   ;; code has been written from scratch following Chapter 7 of
4280   ;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
4281   `(macrolet ((%index (x) `(truly-the index ,x))
4282               (%parent (i) `(ash ,i -1))
4283               (%left (i) `(%index (ash ,i 1)))
4284               (%right (i) `(%index (1+ (ash ,i 1))))
4285               (%heapify (i)
4286                `(do* ((i ,i)
4287                       (left (%left i) (%left i)))
4288                  ((> left current-heap-size))
4289                  (declare (type index i left))
4290                  (let* ((i-elt (%elt i))
4291                         (i-key (funcall keyfun i-elt))
4292                         (left-elt (%elt left))
4293                         (left-key (funcall keyfun left-elt)))
4294                    (multiple-value-bind (large large-elt large-key)
4295                        (if (funcall ,',predicate i-key left-key)
4296                            (values left left-elt left-key)
4297                            (values i i-elt i-key))
4298                      (let ((right (%right i)))
4299                        (multiple-value-bind (largest largest-elt)
4300                            (if (> right current-heap-size)
4301                                (values large large-elt)
4302                                (let* ((right-elt (%elt right))
4303                                       (right-key (funcall keyfun right-elt)))
4304                                  (if (funcall ,',predicate large-key right-key)
4305                                      (values right right-elt)
4306                                      (values large large-elt))))
4307                          (cond ((= largest i)
4308                                 (return))
4309                                (t
4310                                 (setf (%elt i) largest-elt
4311                                       (%elt largest) i-elt
4312                                       i largest)))))))))
4313               (%sort-vector (keyfun &optional (vtype 'vector))
4314                `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had
4315                            ;; trouble getting type inference to
4316                            ;; propagate all the way through this
4317                            ;; tangled mess of inlining. The TRULY-THE
4318                            ;; here works around that. -- WHN
4319                            (%elt (i)
4320                             `(aref (truly-the ,',vtype ,',',vector)
4321                               (%index (+ (%index ,i) start-1)))))
4322                  (let (;; Heaps prefer 1-based addressing.
4323                        (start-1 (1- ,',start))
4324                        (current-heap-size (- ,',end ,',start))
4325                        (keyfun ,keyfun))
4326                    (declare (type (integer -1 #.(1- sb!xc:most-positive-fixnum))
4327                                   start-1))
4328                    (declare (type index current-heap-size))
4329                    (declare (type function keyfun))
4330                    (loop for i of-type index
4331                          from (ash current-heap-size -1) downto 1 do
4332                          (%heapify i))
4333                    (loop
4334                     (when (< current-heap-size 2)
4335                       (return))
4336                     (rotatef (%elt 1) (%elt current-heap-size))
4337                     (decf current-heap-size)
4338                     (%heapify 1))))))
4339     (if (typep ,vector 'simple-vector)
4340         ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
4341         ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
4342         (if (null ,key)
4343             ;; Special-casing the KEY=NIL case lets us avoid some
4344             ;; function calls.
4345             (%sort-vector #'identity simple-vector)
4346             (%sort-vector ,key simple-vector))
4347         ;; It's hard to anticipate many speed-critical applications for
4348         ;; sorting vector types other than (VECTOR T), so we just lump
4349         ;; them all together in one slow dynamically typed mess.
4350         (locally
4351           (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
4352           (%sort-vector (or ,key #'identity))))))
4353 \f
4354 ;;;; debuggers' little helpers
4355
4356 ;;; for debugging when transforms are behaving mysteriously,
4357 ;;; e.g. when debugging a problem with an ASH transform
4358 ;;;   (defun foo (&optional s)
4359 ;;;     (sb-c::/report-lvar s "S outside WHEN")
4360 ;;;     (when (and (integerp s) (> s 3))
4361 ;;;       (sb-c::/report-lvar s "S inside WHEN")
4362 ;;;       (let ((bound (ash 1 (1- s))))
4363 ;;;         (sb-c::/report-lvar bound "BOUND")
4364 ;;;         (let ((x (- bound))
4365 ;;;               (y (1- bound)))
4366 ;;;           (sb-c::/report-lvar x "X")
4367 ;;;           (sb-c::/report-lvar x "Y"))
4368 ;;;         `(integer ,(- bound) ,(1- bound)))))
4369 ;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
4370 ;;; and the function doesn't do anything at all.)
4371 #!+sb-show
4372 (progn
4373   (defknown /report-lvar (t t) null)
4374   (deftransform /report-lvar ((x message) (t t))
4375     (format t "~%/in /REPORT-LVAR~%")
4376     (format t "/(LVAR-TYPE X)=~S~%" (lvar-type x))
4377     (when (constant-lvar-p x)
4378       (format t "/(LVAR-VALUE X)=~S~%" (lvar-value x)))
4379     (format t "/MESSAGE=~S~%" (lvar-value message))
4380     (give-up-ir1-transform "not a real transform"))
4381   (defun /report-lvar (x message)
4382     (declare (ignore x message))))
4383
4384 \f
4385 ;;;; Transforms for internal compiler utilities
4386
4387 ;;; If QUALITY-NAME is constant and a valid name, don't bother
4388 ;;; checking that it's still valid at run-time.
4389 (deftransform policy-quality ((policy quality-name)
4390                               (t symbol))
4391   (unless (and (constant-lvar-p quality-name)
4392                (policy-quality-name-p (lvar-value quality-name)))
4393     (give-up-ir1-transform))
4394   '(%policy-quality policy quality-name))