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