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