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