1 ;;;; This file contains floating-point-specific transforms, and may be
2 ;;;; somewhat implementation-dependent in its assumptions of what the
5 ;;;; This software is part of the SBCL system. See the README file for
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.
18 (defknown %single-float
(real) single-float
(movable foldable flushable
))
19 (defknown %double-float
(real) double-float
(movable foldable flushable
))
21 (deftransform float
((n f
) (* single-float
) *)
24 (deftransform float
((n f
) (* double-float
) *)
27 (deftransform float
((n) *)
32 (deftransform %single-float
((n) (single-float) *)
35 (deftransform %double-float
((n) (double-float) *)
39 (macrolet ((frob (fun type
)
40 `(deftransform random
((num &optional state
)
41 (,type
&optional
*) *)
42 "Use inline float operations."
43 '(,fun num
(or state
*random-state
*)))))
44 (frob %random-single-float single-float
)
45 (frob %random-double-float double-float
))
47 ;;; Mersenne Twister RNG
49 ;;; FIXME: It's unpleasant to have RANDOM functionality scattered
50 ;;; through the code this way. It would be nice to move this into the
51 ;;; same file as the other RANDOM definitions.
52 (deftransform random
((num &optional state
)
53 ((integer 1 #.
(expt 2 32)) &optional
*))
54 ;; FIXME: I almost conditionalized this as #!+sb-doc. Find some way
55 ;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM
56 ;; to let me scan for places that I made this mistake and didn't
58 "use inline (UNSIGNED-BYTE 32) operations"
59 (let ((num-high (numeric-type-high (lvar-type num
))))
61 (give-up-ir1-transform))
62 (cond ((constant-lvar-p num
)
63 ;; Check the worst case sum absolute error for the random number
65 (let ((rem (rem (expt 2 32) num-high
)))
66 (unless (< (/ (* 2 rem
(- num-high rem
)) num-high
(expt 2 32))
67 (expt 2 (- sb
!kernel
::random-integer-extra-bits
)))
68 (give-up-ir1-transform
69 "The random number expectations are inaccurate."))
70 (if (= num-high
(expt 2 32))
71 '(random-chunk (or state
*random-state
*))
72 #!-x86
'(rem (random-chunk (or state
*random-state
*)) num
)
74 ;; Use multiplication, which is faster.
75 '(values (sb!bignum
::%multiply
76 (random-chunk (or state
*random-state
*))
78 ((> num-high random-fixnum-max
)
79 (give-up-ir1-transform
80 "The range is too large to ensure an accurate result."))
82 ((< num-high
(expt 2 32))
83 '(values (sb!bignum
::%multiply
(random-chunk (or state
87 '(rem (random-chunk (or state
*random-state
*)) num
)))))
91 (defknown make-single-float
((signed-byte 32)) single-float
92 (movable foldable flushable
))
94 (defknown make-double-float
((signed-byte 32) (unsigned-byte 32)) double-float
95 (movable foldable flushable
))
97 (defknown single-float-bits
(single-float) (signed-byte 32)
98 (movable foldable flushable
))
100 (defknown double-float-high-bits
(double-float) (signed-byte 32)
101 (movable foldable flushable
))
103 (defknown double-float-low-bits
(double-float) (unsigned-byte 32)
104 (movable foldable flushable
))
106 (deftransform float-sign
((float &optional float2
)
107 (single-float &optional single-float
) *)
109 (let ((temp (gensym)))
110 `(let ((,temp
(abs float2
)))
111 (if (minusp (single-float-bits float
)) (- ,temp
) ,temp
)))
112 '(if (minusp (single-float-bits float
)) -
1f0
1f0
)))
114 (deftransform float-sign
((float &optional float2
)
115 (double-float &optional double-float
) *)
117 (let ((temp (gensym)))
118 `(let ((,temp
(abs float2
)))
119 (if (minusp (double-float-high-bits float
)) (- ,temp
) ,temp
)))
120 '(if (minusp (double-float-high-bits float
)) -
1d0
1d0
)))
122 ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, and SCALE-FLOAT
124 (defknown decode-single-float
(single-float)
125 (values single-float single-float-exponent
(single-float -
1f0
1f0
))
126 (movable foldable flushable
))
128 (defknown decode-double-float
(double-float)
129 (values double-float double-float-exponent
(double-float -
1d0
1d0
))
130 (movable foldable flushable
))
132 (defknown integer-decode-single-float
(single-float)
133 (values single-float-significand single-float-int-exponent
(integer -
1 1))
134 (movable foldable flushable
))
136 (defknown integer-decode-double-float
(double-float)
137 (values double-float-significand double-float-int-exponent
(integer -
1 1))
138 (movable foldable flushable
))
140 (defknown scale-single-float
(single-float fixnum
) single-float
141 (movable foldable flushable
))
143 (defknown scale-double-float
(double-float fixnum
) double-float
144 (movable foldable flushable
))
146 (deftransform decode-float
((x) (single-float) *)
147 '(decode-single-float x
))
149 (deftransform decode-float
((x) (double-float) *)
150 '(decode-double-float x
))
152 (deftransform integer-decode-float
((x) (single-float) *)
153 '(integer-decode-single-float x
))
155 (deftransform integer-decode-float
((x) (double-float) *)
156 '(integer-decode-double-float x
))
158 (deftransform scale-float
((f ex
) (single-float *) *)
159 (if (and #!+x86 t
#!-x86 nil
160 (csubtypep (lvar-type ex
)
161 (specifier-type '(signed-byte 32))))
162 '(coerce (%scalbn
(coerce f
'double-float
) ex
) 'single-float
)
163 '(scale-single-float f ex
)))
165 (deftransform scale-float
((f ex
) (double-float *) *)
166 (if (and #!+x86 t
#!-x86 nil
167 (csubtypep (lvar-type ex
)
168 (specifier-type '(signed-byte 32))))
170 '(scale-double-float f ex
)))
172 ;;; What is the CROSS-FLOAT-INFINITY-KLUDGE?
174 ;;; SBCL's own implementation of floating point supports floating
175 ;;; point infinities. Some of the old CMU CL :PROPAGATE-FLOAT-TYPE and
176 ;;; :PROPAGATE-FUN-TYPE code, like the DEFOPTIMIZERs below, uses this
177 ;;; floating point support. Thus, we have to avoid running it on the
178 ;;; cross-compilation host, since we're not guaranteed that the
179 ;;; cross-compilation host will support floating point infinities.
181 ;;; If we wanted to live dangerously, we could conditionalize the code
182 ;;; with #+(OR SBCL SB-XC) instead. That way, if the cross-compilation
183 ;;; host happened to be SBCL, we'd be able to run the infinity-using
185 ;;; * SBCL itself gets built with more complete optimization.
187 ;;; * You get a different SBCL depending on what your cross-compilation
189 ;;; So far the pros and cons seem seem to be mostly academic, since
190 ;;; AFAIK (WHN 2001-08-28) the propagate-foo-type optimizations aren't
191 ;;; actually important in compiling SBCL itself. If this changes, then
192 ;;; we have to decide:
193 ;;; * Go for simplicity, leaving things as they are.
194 ;;; * Go for performance at the expense of conceptual clarity,
195 ;;; using #+(OR SBCL SB-XC) and otherwise leaving the build
197 ;;; * Go for performance at the expense of build time, using
198 ;;; #+(OR SBCL SB-XC) and also making SBCL do not just
199 ;;; make-host-1.sh and make-host-2.sh, but a third step
200 ;;; make-host-3.sh where it builds itself under itself. (Such a
201 ;;; 3-step build process could also help with other things, e.g.
202 ;;; using specialized arrays to represent debug information.)
203 ;;; * Rewrite the code so that it doesn't depend on unportable
204 ;;; floating point infinities.
206 ;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds
207 ;;; are computed for the result, if possible.
208 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
211 (defun scale-float-derive-type-aux (f ex same-arg
)
212 (declare (ignore same-arg
))
213 (flet ((scale-bound (x n
)
214 ;; We need to be a bit careful here and catch any overflows
215 ;; that might occur. We can ignore underflows which become
219 (scale-float (type-bound-number x
) n
)
220 (floating-point-overflow ()
223 (when (and (numeric-type-p f
) (numeric-type-p ex
))
224 (let ((f-lo (numeric-type-low f
))
225 (f-hi (numeric-type-high f
))
226 (ex-lo (numeric-type-low ex
))
227 (ex-hi (numeric-type-high ex
))
230 (when (and f-hi ex-hi
)
231 (setf new-hi
(scale-bound f-hi ex-hi
)))
232 (when (and f-lo ex-lo
)
233 (setf new-lo
(scale-bound f-lo ex-lo
)))
234 (make-numeric-type :class
(numeric-type-class f
)
235 :format
(numeric-type-format f
)
239 (defoptimizer (scale-single-float derive-type
) ((f ex
))
240 (two-arg-derive-type f ex
#'scale-float-derive-type-aux
241 #'scale-single-float t
))
242 (defoptimizer (scale-double-float derive-type
) ((f ex
))
243 (two-arg-derive-type f ex
#'scale-float-derive-type-aux
244 #'scale-double-float t
))
246 ;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the
247 ;;; FLOAT function return the correct ranges if the input has some
248 ;;; defined range. Quite useful if we want to convert some type of
249 ;;; bounded integer into a float.
252 (let ((aux-name (symbolicate fun
"-DERIVE-TYPE-AUX")))
254 (defun ,aux-name
(num)
255 ;; When converting a number to a float, the limits are
257 (let* ((lo (bound-func (lambda (x)
259 (numeric-type-low num
)))
260 (hi (bound-func (lambda (x)
262 (numeric-type-high num
))))
263 (specifier-type `(,',type
,(or lo
'*) ,(or hi
'*)))))
265 (defoptimizer (,fun derive-type
) ((num))
266 (one-arg-derive-type num
#',aux-name
#',fun
))))))
267 (frob %single-float single-float
)
268 (frob %double-float double-float
))
273 ;;; Do some stuff to recognize when the loser is doing mixed float and
274 ;;; rational arithmetic, or different float types, and fix it up. If
275 ;;; we don't, he won't even get so much as an efficiency note.
276 (deftransform float-contagion-arg1
((x y
) * * :defun-only t
:node node
)
277 `(,(lvar-fun-name (basic-combination-fun node
))
279 (deftransform float-contagion-arg2
((x y
) * * :defun-only t
:node node
)
280 `(,(lvar-fun-name (basic-combination-fun node
))
283 (dolist (x '(+ * / -
))
284 (%deftransform x
'(function (rational float
) *) #'float-contagion-arg1
)
285 (%deftransform x
'(function (float rational
) *) #'float-contagion-arg2
))
287 (dolist (x '(= < > + * / -
))
288 (%deftransform x
'(function (single-float double-float
) *)
289 #'float-contagion-arg1
)
290 (%deftransform x
'(function (double-float single-float
) *)
291 #'float-contagion-arg2
))
293 ;;; Prevent ZEROP, PLUSP, and MINUSP from losing horribly. We can't in
294 ;;; general float rational args to comparison, since Common Lisp
295 ;;; semantics says we are supposed to compare as rationals, but we can
296 ;;; do it for any rational that has a precise representation as a
297 ;;; float (such as 0).
298 (macrolet ((frob (op)
299 `(deftransform ,op
((x y
) (float rational
) *)
300 "open-code FLOAT to RATIONAL comparison"
301 (unless (constant-lvar-p y
)
302 (give-up-ir1-transform
303 "The RATIONAL value isn't known at compile time."))
304 (let ((val (lvar-value y
)))
305 (unless (eql (rational (float val
)) val
)
306 (give-up-ir1-transform
307 "~S doesn't have a precise float representation."
309 `(,',op x
(float y x
)))))
314 ;;;; irrational derive-type methods
316 ;;; Derive the result to be float for argument types in the
317 ;;; appropriate domain.
318 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
319 (dolist (stuff '((asin (real -
1.0 1.0))
320 (acos (real -
1.0 1.0))
322 (atanh (real -
1.0 1.0))
324 (destructuring-bind (name type
) stuff
325 (let ((type (specifier-type type
)))
326 (setf (fun-info-derive-type (fun-info-or-lose name
))
328 (declare (type combination call
))
329 (when (csubtypep (lvar-type
330 (first (combination-args call
)))
332 (specifier-type 'float
)))))))
334 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
335 (defoptimizer (log derive-type
) ((x &optional y
))
336 (when (and (csubtypep (lvar-type x
)
337 (specifier-type '(real 0.0)))
339 (csubtypep (lvar-type y
)
340 (specifier-type '(real 0.0)))))
341 (specifier-type 'float
)))
343 ;;;; irrational transforms
345 (defknown (%tan %sinh %asinh %atanh %log %logb %log10 %tan-quick
)
346 (double-float) double-float
347 (movable foldable flushable
))
349 (defknown (%sin %cos %tanh %sin-quick %cos-quick
)
350 (double-float) (double-float -
1.0d0
1.0d0
)
351 (movable foldable flushable
))
353 (defknown (%asin %atan
)
355 (double-float #.
(coerce (- (/ pi
2)) 'double-float
)
356 #.
(coerce (/ pi
2) 'double-float
))
357 (movable foldable flushable
))
360 (double-float) (double-float 0.0d0
#.
(coerce pi
'double-float
))
361 (movable foldable flushable
))
364 (double-float) (double-float 1.0d0
)
365 (movable foldable flushable
))
367 (defknown (%acosh %exp %sqrt
)
368 (double-float) (double-float 0.0d0
)
369 (movable foldable flushable
))
372 (double-float) (double-float -
1d0
)
373 (movable foldable flushable
))
376 (double-float double-float
) (double-float 0d0
)
377 (movable foldable flushable
))
380 (double-float double-float
) double-float
381 (movable foldable flushable
))
384 (double-float double-float
)
385 (double-float #.
(coerce (- pi
) 'double-float
)
386 #.
(coerce pi
'double-float
))
387 (movable foldable flushable
))
390 (double-float double-float
) double-float
391 (movable foldable flushable
))
394 (double-float (signed-byte 32)) double-float
395 (movable foldable flushable
))
398 (double-float) double-float
399 (movable foldable flushable
))
401 (macrolet ((def (name prim rtype
)
403 (deftransform ,name
((x) (single-float) ,rtype
)
404 `(coerce (,',prim
(coerce x
'double-float
)) 'single-float
))
405 (deftransform ,name
((x) (double-float) ,rtype
)
409 (def sqrt %sqrt float
)
410 (def asin %asin float
)
411 (def acos %acos float
)
417 (def acosh %acosh float
)
418 (def atanh %atanh float
))
420 ;;; The argument range is limited on the x86 FP trig. functions. A
421 ;;; post-test can detect a failure (and load a suitable result), but
422 ;;; this test is avoided if possible.
423 (macrolet ((def (name prim prim-quick
)
424 (declare (ignorable prim-quick
))
426 (deftransform ,name
((x) (single-float) *)
427 #!+x86
(cond ((csubtypep (lvar-type x
)
428 (specifier-type '(single-float
429 (#.
(- (expt 2f0
64)))
431 `(coerce (,',prim-quick
(coerce x
'double-float
))
435 "unable to avoid inline argument range check~@
436 because the argument range (~S) was not within 2^64"
437 (type-specifier (lvar-type x
)))
438 `(coerce (,',prim
(coerce x
'double-float
)) 'single-float
)))
439 #!-x86
`(coerce (,',prim
(coerce x
'double-float
)) 'single-float
))
440 (deftransform ,name
((x) (double-float) *)
441 #!+x86
(cond ((csubtypep (lvar-type x
)
442 (specifier-type '(double-float
443 (#.
(- (expt 2d0
64)))
448 "unable to avoid inline argument range check~@
449 because the argument range (~S) was not within 2^64"
450 (type-specifier (lvar-type x
)))
452 #!-x86
`(,',prim x
)))))
453 (def sin %sin %sin-quick
)
454 (def cos %cos %cos-quick
)
455 (def tan %tan %tan-quick
))
457 (deftransform atan
((x y
) (single-float single-float
) *)
458 `(coerce (%atan2
(coerce x
'double-float
) (coerce y
'double-float
))
460 (deftransform atan
((x y
) (double-float double-float
) *)
463 (deftransform expt
((x y
) ((single-float 0f0
) single-float
) *)
464 `(coerce (%pow
(coerce x
'double-float
) (coerce y
'double-float
))
466 (deftransform expt
((x y
) ((double-float 0d0
) double-float
) *)
468 (deftransform expt
((x y
) ((single-float 0f0
) (signed-byte 32)) *)
469 `(coerce (%pow
(coerce x
'double-float
) (coerce y
'double-float
))
471 (deftransform expt
((x y
) ((double-float 0d0
) (signed-byte 32)) *)
472 `(%pow x
(coerce y
'double-float
)))
474 ;;; ANSI says log with base zero returns zero.
475 (deftransform log
((x y
) (float float
) float
)
476 '(if (zerop y
) y
(/ (log x
) (log y
))))
478 ;;; Handle some simple transformations.
480 (deftransform abs
((x) ((complex double-float
)) double-float
)
481 '(%hypot
(realpart x
) (imagpart x
)))
483 (deftransform abs
((x) ((complex single-float
)) single-float
)
484 '(coerce (%hypot
(coerce (realpart x
) 'double-float
)
485 (coerce (imagpart x
) 'double-float
))
488 (deftransform phase
((x) ((complex double-float
)) double-float
)
489 '(%atan2
(imagpart x
) (realpart x
)))
491 (deftransform phase
((x) ((complex single-float
)) single-float
)
492 '(coerce (%atan2
(coerce (imagpart x
) 'double-float
)
493 (coerce (realpart x
) 'double-float
))
496 (deftransform phase
((x) ((float)) float
)
497 '(if (minusp (float-sign x
))
501 ;;; The number is of type REAL.
502 (defun numeric-type-real-p (type)
503 (and (numeric-type-p type
)
504 (eq (numeric-type-complexp type
) :real
)))
506 ;;; Coerce a numeric type bound to the given type while handling
507 ;;; exclusive bounds.
508 (defun coerce-numeric-bound (bound type
)
511 (list (coerce (car bound
) type
))
512 (coerce bound type
))))
514 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
517 ;;;; optimizers for elementary functions
519 ;;;; These optimizers compute the output range of the elementary
520 ;;;; function, based on the domain of the input.
522 ;;; Generate a specifier for a complex type specialized to the same
523 ;;; type as the argument.
524 (defun complex-float-type (arg)
525 (declare (type numeric-type arg
))
526 (let* ((format (case (numeric-type-class arg
)
527 ((integer rational
) 'single-float
)
528 (t (numeric-type-format arg
))))
529 (float-type (or format
'float
)))
530 (specifier-type `(complex ,float-type
))))
532 ;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
533 ;;; should be the right kind of float. Allow bounds for the float
535 (defun float-or-complex-float-type (arg &optional lo hi
)
536 (declare (type numeric-type arg
))
537 (let* ((format (case (numeric-type-class arg
)
538 ((integer rational
) 'single-float
)
539 (t (numeric-type-format arg
))))
540 (float-type (or format
'float
))
541 (lo (coerce-numeric-bound lo float-type
))
542 (hi (coerce-numeric-bound hi float-type
)))
543 (specifier-type `(or (,float-type
,(or lo
'*) ,(or hi
'*))
544 (complex ,float-type
)))))
548 (eval-when (:compile-toplevel
:execute
)
549 ;; So the problem with this hack is that it's actually broken. If
550 ;; the host does not have long floats, then setting *R-D-F-F* to
551 ;; LONG-FLOAT doesn't actually buy us anything. FIXME.
552 (setf *read-default-float-format
*
553 #!+long-float
'long-float
#!-long-float
'double-float
))
554 ;;; Test whether the numeric-type ARG is within in domain specified by
555 ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
557 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
558 (defun domain-subtypep (arg domain-low domain-high
)
559 (declare (type numeric-type arg
)
560 (type (or real null
) domain-low domain-high
))
561 (let* ((arg-lo (numeric-type-low arg
))
562 (arg-lo-val (type-bound-number arg-lo
))
563 (arg-hi (numeric-type-high arg
))
564 (arg-hi-val (type-bound-number arg-hi
)))
565 ;; Check that the ARG bounds are correctly canonicalized.
566 (when (and arg-lo
(floatp arg-lo-val
) (zerop arg-lo-val
) (consp arg-lo
)
567 (minusp (float-sign arg-lo-val
)))
568 (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo
)
569 (setq arg-lo
0e0 arg-lo-val arg-lo
))
570 (when (and arg-hi
(zerop arg-hi-val
) (floatp arg-hi-val
) (consp arg-hi
)
571 (plusp (float-sign arg-hi-val
)))
572 (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi
)
573 (setq arg-hi
(ecase *read-default-float-format
*
574 (double-float (load-time-value (make-unportable-float :double-float-negative-zero
)))
576 (long-float (load-time-value (make-unportable-float :long-float-negative-zero
))))
578 (flet ((fp-neg-zero-p (f) ; Is F -0.0?
579 (and (floatp f
) (zerop f
) (minusp (float-sign f
))))
580 (fp-pos-zero-p (f) ; Is F +0.0?
581 (and (floatp f
) (zerop f
) (plusp (float-sign f
)))))
582 (and (or (null domain-low
)
583 (and arg-lo
(>= arg-lo-val domain-low
)
584 (not (and (fp-pos-zero-p domain-low
)
585 (fp-neg-zero-p arg-lo
)))))
586 (or (null domain-high
)
587 (and arg-hi
(<= arg-hi-val domain-high
)
588 (not (and (fp-neg-zero-p domain-high
)
589 (fp-pos-zero-p arg-hi
)))))))))
590 (eval-when (:compile-toplevel
:execute
)
591 (setf *read-default-float-format
* 'single-float
))
593 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
596 ;;; Handle monotonic functions of a single variable whose domain is
597 ;;; possibly part of the real line. ARG is the variable, FCN is the
598 ;;; function, and DOMAIN is a specifier that gives the (real) domain
599 ;;; of the function. If ARG is a subset of the DOMAIN, we compute the
600 ;;; bounds directly. Otherwise, we compute the bounds for the
601 ;;; intersection between ARG and DOMAIN, and then append a complex
602 ;;; result, which occurs for the parts of ARG not in the DOMAIN.
604 ;;; Negative and positive zero are considered distinct within
605 ;;; DOMAIN-LOW and DOMAIN-HIGH.
607 ;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
608 ;;; can't compute the bounds using FCN.
609 (defun elfun-derive-type-simple (arg fcn domain-low domain-high
610 default-low default-high
611 &optional
(increasingp t
))
612 (declare (type (or null real
) domain-low domain-high
))
615 (cond ((eq (numeric-type-complexp arg
) :complex
)
616 (make-numeric-type :class
(numeric-type-class arg
)
617 :format
(numeric-type-format arg
)
619 ((numeric-type-real-p arg
)
620 ;; The argument is real, so let's find the intersection
621 ;; between the argument and the domain of the function.
622 ;; We compute the bounds on the intersection, and for
623 ;; everything else, we return a complex number of the
625 (multiple-value-bind (intersection difference
)
626 (interval-intersection/difference
(numeric-type->interval arg
)
632 ;; Process the intersection.
633 (let* ((low (interval-low intersection
))
634 (high (interval-high intersection
))
635 (res-lo (or (bound-func fcn
(if increasingp low high
))
637 (res-hi (or (bound-func fcn
(if increasingp high low
))
639 (format (case (numeric-type-class arg
)
640 ((integer rational
) 'single-float
)
641 (t (numeric-type-format arg
))))
642 (bound-type (or format
'float
))
647 :low
(coerce-numeric-bound res-lo bound-type
)
648 :high
(coerce-numeric-bound res-hi bound-type
))))
649 ;; If the ARG is a subset of the domain, we don't
650 ;; have to worry about the difference, because that
652 (if (or (null difference
)
653 ;; Check whether the arg is within the domain.
654 (domain-subtypep arg domain-low domain-high
))
657 (specifier-type `(complex ,bound-type
))))))
659 ;; No intersection so the result must be purely complex.
660 (complex-float-type arg
)))))
662 (float-or-complex-float-type arg default-low default-high
))))))
665 ((frob (name domain-low domain-high def-low-bnd def-high-bnd
666 &key
(increasingp t
))
667 (let ((num (gensym)))
668 `(defoptimizer (,name derive-type
) ((,num
))
672 (elfun-derive-type-simple arg
#',name
673 ,domain-low
,domain-high
674 ,def-low-bnd
,def-high-bnd
677 ;; These functions are easy because they are defined for the whole
679 (frob exp nil nil
0 nil
)
680 (frob sinh nil nil nil nil
)
681 (frob tanh nil nil -
1 1)
682 (frob asinh nil nil nil nil
)
684 ;; These functions are only defined for part of the real line. The
685 ;; condition selects the desired part of the line.
686 (frob asin -
1d0
1d0
(- (/ pi
2)) (/ pi
2))
687 ;; Acos is monotonic decreasing, so we need to swap the function
688 ;; values at the lower and upper bounds of the input domain.
689 (frob acos -
1d0
1d0
0 pi
:increasingp nil
)
690 (frob acosh
1d0 nil nil nil
)
691 (frob atanh -
1d0
1d0 -
1 1)
692 ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
694 (frob sqrt
(load-time-value (make-unportable-float :double-float-negative-zero
)) nil
0 nil
))
696 ;;; Compute bounds for (expt x y). This should be easy since (expt x
697 ;;; y) = (exp (* y (log x))). However, computations done this way
698 ;;; have too much roundoff. Thus we have to do it the hard way.
699 (defun safe-expt (x y
)
701 (when (< (abs y
) 10000)
706 ;;; Handle the case when x >= 1.
707 (defun interval-expt-> (x y
)
708 (case (sb!c
::interval-range-info y
0d0
)
710 ;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
711 ;; obviously non-negative. We just have to be careful for
712 ;; infinite bounds (given by nil).
713 (let ((lo (safe-expt (type-bound-number (sb!c
::interval-low x
))
714 (type-bound-number (sb!c
::interval-low y
))))
715 (hi (safe-expt (type-bound-number (sb!c
::interval-high x
))
716 (type-bound-number (sb!c
::interval-high y
)))))
717 (list (sb!c
::make-interval
:low
(or lo
1) :high hi
))))
719 ;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
720 ;; obviously [0, 1]. However, underflow (nil) means 0 is the
722 (let ((lo (safe-expt (type-bound-number (sb!c
::interval-high x
))
723 (type-bound-number (sb!c
::interval-low y
))))
724 (hi (safe-expt (type-bound-number (sb!c
::interval-low x
))
725 (type-bound-number (sb!c
::interval-high y
)))))
726 (list (sb!c
::make-interval
:low
(or lo
0) :high
(or hi
1)))))
728 ;; Split the interval in half.
729 (destructuring-bind (y- y
+)
730 (sb!c
::interval-split
0 y t
)
731 (list (interval-expt-> x y-
)
732 (interval-expt-> x y
+))))))
734 ;;; Handle the case when x <= 1
735 (defun interval-expt-< (x y
)
736 (case (sb!c
::interval-range-info x
0d0
)
738 ;; The case of 0 <= x <= 1 is easy
739 (case (sb!c
::interval-range-info y
)
741 ;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
742 ;; obviously [0, 1]. We just have to be careful for infinite bounds
744 (let ((lo (safe-expt (type-bound-number (sb!c
::interval-low x
))
745 (type-bound-number (sb!c
::interval-high y
))))
746 (hi (safe-expt (type-bound-number (sb!c
::interval-high x
))
747 (type-bound-number (sb!c
::interval-low y
)))))
748 (list (sb!c
::make-interval
:low
(or lo
0) :high
(or hi
1)))))
750 ;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
751 ;; obviously [1, inf].
752 (let ((hi (safe-expt (type-bound-number (sb!c
::interval-low x
))
753 (type-bound-number (sb!c
::interval-low y
))))
754 (lo (safe-expt (type-bound-number (sb!c
::interval-high x
))
755 (type-bound-number (sb!c
::interval-high y
)))))
756 (list (sb!c
::make-interval
:low
(or lo
1) :high hi
))))
758 ;; Split the interval in half
759 (destructuring-bind (y- y
+)
760 (sb!c
::interval-split
0 y t
)
761 (list (interval-expt-< x y-
)
762 (interval-expt-< x y
+))))))
764 ;; The case where x <= 0. Y MUST be an INTEGER for this to work!
765 ;; The calling function must insure this! For now we'll just
766 ;; return the appropriate unbounded float type.
767 (list (sb!c
::make-interval
:low nil
:high nil
)))
769 (destructuring-bind (neg pos
)
770 (interval-split 0 x t t
)
771 (list (interval-expt-< neg y
)
772 (interval-expt-< pos y
))))))
774 ;;; Compute bounds for (expt x y).
775 (defun interval-expt (x y
)
776 (case (interval-range-info x
1)
779 (interval-expt-> x y
))
782 (interval-expt-< x y
))
784 (destructuring-bind (left right
)
785 (interval-split 1 x t t
)
786 (list (interval-expt left y
)
787 (interval-expt right y
))))))
789 (defun fixup-interval-expt (bnd x-int y-int x-type y-type
)
790 (declare (ignore x-int
))
791 ;; Figure out what the return type should be, given the argument
792 ;; types and bounds and the result type and bounds.
793 (cond ((csubtypep x-type
(specifier-type 'integer
))
794 ;; an integer to some power
795 (case (numeric-type-class y-type
)
797 ;; Positive integer to an integer power is either an
798 ;; integer or a rational.
799 (let ((lo (or (interval-low bnd
) '*))
800 (hi (or (interval-high bnd
) '*)))
801 (if (and (interval-low y-int
)
802 (>= (type-bound-number (interval-low y-int
)) 0))
803 (specifier-type `(integer ,lo
,hi
))
804 (specifier-type `(rational ,lo
,hi
)))))
806 ;; Positive integer to rational power is either a rational
807 ;; or a single-float.
808 (let* ((lo (interval-low bnd
))
809 (hi (interval-high bnd
))
811 (floor (type-bound-number lo
))
814 (ceiling (type-bound-number hi
))
817 (bound-func #'float lo
)
820 (bound-func #'float hi
)
822 (specifier-type `(or (rational ,int-lo
,int-hi
)
823 (single-float ,f-lo
, f-hi
)))))
825 ;; A positive integer to a float power is a float.
826 (modified-numeric-type y-type
827 :low
(interval-low bnd
)
828 :high
(interval-high bnd
)))
830 ;; A positive integer to a number is a number (for now).
831 (specifier-type 'number
))))
832 ((csubtypep x-type
(specifier-type 'rational
))
833 ;; a rational to some power
834 (case (numeric-type-class y-type
)
836 ;; A positive rational to an integer power is always a rational.
837 (specifier-type `(rational ,(or (interval-low bnd
) '*)
838 ,(or (interval-high bnd
) '*))))
840 ;; A positive rational to rational power is either a rational
841 ;; or a single-float.
842 (let* ((lo (interval-low bnd
))
843 (hi (interval-high bnd
))
845 (floor (type-bound-number lo
))
848 (ceiling (type-bound-number hi
))
851 (bound-func #'float lo
)
854 (bound-func #'float hi
)
856 (specifier-type `(or (rational ,int-lo
,int-hi
)
857 (single-float ,f-lo
, f-hi
)))))
859 ;; A positive rational to a float power is a float.
860 (modified-numeric-type y-type
861 :low
(interval-low bnd
)
862 :high
(interval-high bnd
)))
864 ;; A positive rational to a number is a number (for now).
865 (specifier-type 'number
))))
866 ((csubtypep x-type
(specifier-type 'float
))
867 ;; a float to some power
868 (case (numeric-type-class y-type
)
869 ((or integer rational
)
870 ;; A positive float to an integer or rational power is
874 :format
(numeric-type-format x-type
)
875 :low
(interval-low bnd
)
876 :high
(interval-high bnd
)))
878 ;; A positive float to a float power is a float of the
882 :format
(float-format-max (numeric-type-format x-type
)
883 (numeric-type-format y-type
))
884 :low
(interval-low bnd
)
885 :high
(interval-high bnd
)))
887 ;; A positive float to a number is a number (for now)
888 (specifier-type 'number
))))
890 ;; A number to some power is a number.
891 (specifier-type 'number
))))
893 (defun merged-interval-expt (x y
)
894 (let* ((x-int (numeric-type->interval x
))
895 (y-int (numeric-type->interval y
)))
896 (mapcar (lambda (type)
897 (fixup-interval-expt type x-int y-int x y
))
898 (flatten-list (interval-expt x-int y-int
)))))
900 (defun expt-derive-type-aux (x y same-arg
)
901 (declare (ignore same-arg
))
902 (cond ((or (not (numeric-type-real-p x
))
903 (not (numeric-type-real-p y
)))
904 ;; Use numeric contagion if either is not real.
905 (numeric-contagion x y
))
906 ((csubtypep y
(specifier-type 'integer
))
907 ;; A real raised to an integer power is well-defined.
908 (merged-interval-expt x y
))
909 ;; A real raised to a non-integral power can be a float or a
911 ((or (csubtypep x
(specifier-type '(rational 0)))
912 (csubtypep x
(specifier-type '(float (0d0)))))
913 ;; But a positive real to any power is well-defined.
914 (merged-interval-expt x y
))
915 ((and (csubtypep x
(specifier-type 'rational
))
916 (csubtypep x
(specifier-type 'rational
)))
917 ;; A rational to the power of a rational could be a rational
918 ;; or a possibly-complex single float
919 (specifier-type '(or rational single-float
(complex single-float
))))
921 ;; a real to some power. The result could be a real or a
923 (float-or-complex-float-type (numeric-contagion x y
)))))
925 (defoptimizer (expt derive-type
) ((x y
))
926 (two-arg-derive-type x y
#'expt-derive-type-aux
#'expt
))
928 ;;; Note we must assume that a type including 0.0 may also include
929 ;;; -0.0 and thus the result may be complex -infinity + i*pi.
930 (defun log-derive-type-aux-1 (x)
931 (elfun-derive-type-simple x
#'log
0d0 nil nil nil
))
933 (defun log-derive-type-aux-2 (x y same-arg
)
934 (let ((log-x (log-derive-type-aux-1 x
))
935 (log-y (log-derive-type-aux-1 y
))
936 (accumulated-list nil
))
937 ;; LOG-X or LOG-Y might be union types. We need to run through
938 ;; the union types ourselves because /-DERIVE-TYPE-AUX doesn't.
939 (dolist (x-type (prepare-arg-for-derive-type log-x
))
940 (dolist (y-type (prepare-arg-for-derive-type log-y
))
941 (push (/-derive-type-aux x-type y-type same-arg
) accumulated-list
)))
942 (apply #'type-union
(flatten-list accumulated-list
))))
944 (defoptimizer (log derive-type
) ((x &optional y
))
946 (two-arg-derive-type x y
#'log-derive-type-aux-2
#'log
)
947 (one-arg-derive-type x
#'log-derive-type-aux-1
#'log
)))
949 (defun atan-derive-type-aux-1 (y)
950 (elfun-derive-type-simple y
#'atan nil nil
(- (/ pi
2)) (/ pi
2)))
952 (defun atan-derive-type-aux-2 (y x same-arg
)
953 (declare (ignore same-arg
))
954 ;; The hard case with two args. We just return the max bounds.
955 (let ((result-type (numeric-contagion y x
)))
956 (cond ((and (numeric-type-real-p x
)
957 (numeric-type-real-p y
))
958 (let* (;; FIXME: This expression for FORMAT seems to
959 ;; appear multiple times, and should be factored out.
960 (format (case (numeric-type-class result-type
)
961 ((integer rational
) 'single-float
)
962 (t (numeric-type-format result-type
))))
963 (bound-format (or format
'float
)))
964 (make-numeric-type :class
'float
967 :low
(coerce (- pi
) bound-format
)
968 :high
(coerce pi bound-format
))))
970 ;; The result is a float or a complex number
971 (float-or-complex-float-type result-type
)))))
973 (defoptimizer (atan derive-type
) ((y &optional x
))
975 (two-arg-derive-type y x
#'atan-derive-type-aux-2
#'atan
)
976 (one-arg-derive-type y
#'atan-derive-type-aux-1
#'atan
)))
978 (defun cosh-derive-type-aux (x)
979 ;; We note that cosh x = cosh |x| for all real x.
980 (elfun-derive-type-simple
981 (if (numeric-type-real-p x
)
982 (abs-derive-type-aux x
)
984 #'cosh nil nil
0 nil
))
986 (defoptimizer (cosh derive-type
) ((num))
987 (one-arg-derive-type num
#'cosh-derive-type-aux
#'cosh
))
989 (defun phase-derive-type-aux (arg)
990 (let* ((format (case (numeric-type-class arg
)
991 ((integer rational
) 'single-float
)
992 (t (numeric-type-format arg
))))
993 (bound-type (or format
'float
)))
994 (cond ((numeric-type-real-p arg
)
995 (case (interval-range-info (numeric-type->interval arg
) 0.0)
997 ;; The number is positive, so the phase is 0.
998 (make-numeric-type :class
'float
1001 :low
(coerce 0 bound-type
)
1002 :high
(coerce 0 bound-type
)))
1004 ;; The number is always negative, so the phase is pi.
1005 (make-numeric-type :class
'float
1008 :low
(coerce pi bound-type
)
1009 :high
(coerce pi bound-type
)))
1011 ;; We can't tell. The result is 0 or pi. Use a union
1014 (make-numeric-type :class
'float
1017 :low
(coerce 0 bound-type
)
1018 :high
(coerce 0 bound-type
))
1019 (make-numeric-type :class
'float
1022 :low
(coerce pi bound-type
)
1023 :high
(coerce pi bound-type
))))))
1025 ;; We have a complex number. The answer is the range -pi
1026 ;; to pi. (-pi is included because we have -0.)
1027 (make-numeric-type :class
'float
1030 :low
(coerce (- pi
) bound-type
)
1031 :high
(coerce pi bound-type
))))))
1033 (defoptimizer (phase derive-type
) ((num))
1034 (one-arg-derive-type num
#'phase-derive-type-aux
#'phase
))
1038 (deftransform realpart
((x) ((complex rational
)) *)
1039 '(sb!kernel
:%realpart x
))
1040 (deftransform imagpart
((x) ((complex rational
)) *)
1041 '(sb!kernel
:%imagpart x
))
1043 ;;; Make REALPART and IMAGPART return the appropriate types. This
1044 ;;; should help a lot in optimized code.
1045 (defun realpart-derive-type-aux (type)
1046 (let ((class (numeric-type-class type
))
1047 (format (numeric-type-format type
)))
1048 (cond ((numeric-type-real-p type
)
1049 ;; The realpart of a real has the same type and range as
1051 (make-numeric-type :class class
1054 :low
(numeric-type-low type
)
1055 :high
(numeric-type-high type
)))
1057 ;; We have a complex number. The result has the same type
1058 ;; as the real part, except that it's real, not complex,
1060 (make-numeric-type :class class
1063 :low
(numeric-type-low type
)
1064 :high
(numeric-type-high type
))))))
1065 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1066 (defoptimizer (realpart derive-type
) ((num))
1067 (one-arg-derive-type num
#'realpart-derive-type-aux
#'realpart
))
1068 (defun imagpart-derive-type-aux (type)
1069 (let ((class (numeric-type-class type
))
1070 (format (numeric-type-format type
)))
1071 (cond ((numeric-type-real-p type
)
1072 ;; The imagpart of a real has the same type as the input,
1073 ;; except that it's zero.
1074 (let ((bound-format (or format class
'real
)))
1075 (make-numeric-type :class class
1078 :low
(coerce 0 bound-format
)
1079 :high
(coerce 0 bound-format
))))
1081 ;; We have a complex number. The result has the same type as
1082 ;; the imaginary part, except that it's real, not complex,
1084 (make-numeric-type :class class
1087 :low
(numeric-type-low type
)
1088 :high
(numeric-type-high type
))))))
1089 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1090 (defoptimizer (imagpart derive-type
) ((num))
1091 (one-arg-derive-type num
#'imagpart-derive-type-aux
#'imagpart
))
1093 (defun complex-derive-type-aux-1 (re-type)
1094 (if (numeric-type-p re-type
)
1095 (make-numeric-type :class
(numeric-type-class re-type
)
1096 :format
(numeric-type-format re-type
)
1097 :complexp
(if (csubtypep re-type
1098 (specifier-type 'rational
))
1101 :low
(numeric-type-low re-type
)
1102 :high
(numeric-type-high re-type
))
1103 (specifier-type 'complex
)))
1105 (defun complex-derive-type-aux-2 (re-type im-type same-arg
)
1106 (declare (ignore same-arg
))
1107 (if (and (numeric-type-p re-type
)
1108 (numeric-type-p im-type
))
1109 ;; Need to check to make sure numeric-contagion returns the
1110 ;; right type for what we want here.
1112 ;; Also, what about rational canonicalization, like (complex 5 0)
1113 ;; is 5? So, if the result must be complex, we make it so.
1114 ;; If the result might be complex, which happens only if the
1115 ;; arguments are rational, we make it a union type of (or
1116 ;; rational (complex rational)).
1117 (let* ((element-type (numeric-contagion re-type im-type
))
1118 (rat-result-p (csubtypep element-type
1119 (specifier-type 'rational
))))
1121 (type-union element-type
1123 `(complex ,(numeric-type-class element-type
))))
1124 (make-numeric-type :class
(numeric-type-class element-type
)
1125 :format
(numeric-type-format element-type
)
1126 :complexp
(if rat-result-p
1129 (specifier-type 'complex
)))
1131 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1132 (defoptimizer (complex derive-type
) ((re &optional im
))
1134 (two-arg-derive-type re im
#'complex-derive-type-aux-2
#'complex
)
1135 (one-arg-derive-type re
#'complex-derive-type-aux-1
#'complex
)))
1137 ;;; Define some transforms for complex operations. We do this in lieu
1138 ;;; of complex operation VOPs.
1139 (macrolet ((frob (type)
1142 (deftransform %negate
((z) ((complex ,type
)) *)
1143 '(complex (%negate
(realpart z
)) (%negate
(imagpart z
))))
1144 ;; complex addition and subtraction
1145 (deftransform + ((w z
) ((complex ,type
) (complex ,type
)) *)
1146 '(complex (+ (realpart w
) (realpart z
))
1147 (+ (imagpart w
) (imagpart z
))))
1148 (deftransform -
((w z
) ((complex ,type
) (complex ,type
)) *)
1149 '(complex (- (realpart w
) (realpart z
))
1150 (- (imagpart w
) (imagpart z
))))
1151 ;; Add and subtract a complex and a real.
1152 (deftransform + ((w z
) ((complex ,type
) real
) *)
1153 '(complex (+ (realpart w
) z
) (imagpart w
)))
1154 (deftransform + ((z w
) (real (complex ,type
)) *)
1155 '(complex (+ (realpart w
) z
) (imagpart w
)))
1156 ;; Add and subtract a real and a complex number.
1157 (deftransform -
((w z
) ((complex ,type
) real
) *)
1158 '(complex (- (realpart w
) z
) (imagpart w
)))
1159 (deftransform -
((z w
) (real (complex ,type
)) *)
1160 '(complex (- z
(realpart w
)) (- (imagpart w
))))
1161 ;; Multiply and divide two complex numbers.
1162 (deftransform * ((x y
) ((complex ,type
) (complex ,type
)) *)
1163 '(let* ((rx (realpart x
))
1167 (complex (- (* rx ry
) (* ix iy
))
1168 (+ (* rx iy
) (* ix ry
)))))
1169 (deftransform / ((x y
) ((complex ,type
) (complex ,type
)) *)
1170 '(let* ((rx (realpart x
))
1174 (if (> (abs ry
) (abs iy
))
1175 (let* ((r (/ iy ry
))
1176 (dn (* ry
(+ 1 (* r r
)))))
1177 (complex (/ (+ rx
(* ix r
)) dn
)
1178 (/ (- ix
(* rx r
)) dn
)))
1179 (let* ((r (/ ry iy
))
1180 (dn (* iy
(+ 1 (* r r
)))))
1181 (complex (/ (+ (* rx r
) ix
) dn
)
1182 (/ (- (* ix r
) rx
) dn
))))))
1183 ;; Multiply a complex by a real or vice versa.
1184 (deftransform * ((w z
) ((complex ,type
) real
) *)
1185 '(complex (* (realpart w
) z
) (* (imagpart w
) z
)))
1186 (deftransform * ((z w
) (real (complex ,type
)) *)
1187 '(complex (* (realpart w
) z
) (* (imagpart w
) z
)))
1188 ;; Divide a complex by a real.
1189 (deftransform / ((w z
) ((complex ,type
) real
) *)
1190 '(complex (/ (realpart w
) z
) (/ (imagpart w
) z
)))
1191 ;; conjugate of complex number
1192 (deftransform conjugate
((z) ((complex ,type
)) *)
1193 '(complex (realpart z
) (- (imagpart z
))))
1195 (deftransform cis
((z) ((,type
)) *)
1196 '(complex (cos z
) (sin z
)))
1198 (deftransform = ((w z
) ((complex ,type
) (complex ,type
)) *)
1199 '(and (= (realpart w
) (realpart z
))
1200 (= (imagpart w
) (imagpart z
))))
1201 (deftransform = ((w z
) ((complex ,type
) real
) *)
1202 '(and (= (realpart w
) z
) (zerop (imagpart w
))))
1203 (deftransform = ((w z
) (real (complex ,type
)) *)
1204 '(and (= (realpart z
) w
) (zerop (imagpart z
)))))))
1207 (frob double-float
))
1209 ;;; Here are simple optimizers for SIN, COS, and TAN. They do not
1210 ;;; produce a minimal range for the result; the result is the widest
1211 ;;; possible answer. This gets around the problem of doing range
1212 ;;; reduction correctly but still provides useful results when the
1213 ;;; inputs are union types.
1214 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1216 (defun trig-derive-type-aux (arg domain fcn
1217 &optional def-lo def-hi
(increasingp t
))
1220 (cond ((eq (numeric-type-complexp arg
) :complex
)
1221 (make-numeric-type :class
(numeric-type-class arg
)
1222 :format
(numeric-type-format arg
)
1223 :complexp
:complex
))
1224 ((numeric-type-real-p arg
)
1225 (let* ((format (case (numeric-type-class arg
)
1226 ((integer rational
) 'single-float
)
1227 (t (numeric-type-format arg
))))
1228 (bound-type (or format
'float
)))
1229 ;; If the argument is a subset of the "principal" domain
1230 ;; of the function, we can compute the bounds because
1231 ;; the function is monotonic. We can't do this in
1232 ;; general for these periodic functions because we can't
1233 ;; (and don't want to) do the argument reduction in
1234 ;; exactly the same way as the functions themselves do
1236 (if (csubtypep arg domain
)
1237 (let ((res-lo (bound-func fcn
(numeric-type-low arg
)))
1238 (res-hi (bound-func fcn
(numeric-type-high arg
))))
1240 (rotatef res-lo res-hi
))
1244 :low
(coerce-numeric-bound res-lo bound-type
)
1245 :high
(coerce-numeric-bound res-hi bound-type
)))
1249 :low
(and def-lo
(coerce def-lo bound-type
))
1250 :high
(and def-hi
(coerce def-hi bound-type
))))))
1252 (float-or-complex-float-type arg def-lo def-hi
))))))
1254 (defoptimizer (sin derive-type
) ((num))
1255 (one-arg-derive-type
1258 ;; Derive the bounds if the arg is in [-pi/2, pi/2].
1259 (trig-derive-type-aux
1261 (specifier-type `(float ,(- (/ pi
2)) ,(/ pi
2)))
1266 (defoptimizer (cos derive-type
) ((num))
1267 (one-arg-derive-type
1270 ;; Derive the bounds if the arg is in [0, pi].
1271 (trig-derive-type-aux arg
1272 (specifier-type `(float 0d0
,pi
))
1278 (defoptimizer (tan derive-type
) ((num))
1279 (one-arg-derive-type
1282 ;; Derive the bounds if the arg is in [-pi/2, pi/2].
1283 (trig-derive-type-aux arg
1284 (specifier-type `(float ,(- (/ pi
2)) ,(/ pi
2)))
1289 ;;; CONJUGATE always returns the same type as the input type.
1291 ;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX.
1292 ;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))?
1293 (defoptimizer (conjugate derive-type
) ((num))
1296 (defoptimizer (cis derive-type
) ((num))
1297 (one-arg-derive-type num
1299 (sb!c
::specifier-type
1300 `(complex ,(or (numeric-type-format arg
) 'float
))))
1305 ;;;; TRUNCATE, FLOOR, CEILING, and ROUND
1307 (macrolet ((define-frobs (fun ufun
)
1309 (defknown ,ufun
(real) integer
(movable foldable flushable
))
1310 (deftransform ,fun
((x &optional by
)
1312 (constant-arg (member 1))))
1313 '(let ((res (,ufun x
)))
1314 (values res
(- x res
)))))))
1315 (define-frobs truncate %unary-truncate
)
1316 (define-frobs round %unary-round
))
1318 ;;; Convert (TRUNCATE x y) to the obvious implementation. We only want
1319 ;;; this when under certain conditions and let the generic TRUNCATE
1320 ;;; handle the rest. (Note: if Y = 1, the divide and multiply by Y
1321 ;;; should be removed by other DEFTRANSFORMs.)
1322 (deftransform truncate
((x &optional y
)
1323 (float &optional
(or float integer
)))
1324 (let ((defaulted-y (if y
'y
1)))
1325 `(let ((res (%unary-truncate
(/ x
,defaulted-y
))))
1326 (values res
(- x
(* ,defaulted-y res
))))))
1328 (deftransform floor
((number &optional divisor
)
1329 (float &optional
(or integer float
)))
1330 (let ((defaulted-divisor (if divisor
'divisor
1)))
1331 `(multiple-value-bind (tru rem
) (truncate number
,defaulted-divisor
)
1332 (if (and (not (zerop rem
))
1333 (if (minusp ,defaulted-divisor
)
1336 (values (1- tru
) (+ rem
,defaulted-divisor
))
1337 (values tru rem
)))))
1339 (deftransform ceiling
((number &optional divisor
)
1340 (float &optional
(or integer float
)))
1341 (let ((defaulted-divisor (if divisor
'divisor
1)))
1342 `(multiple-value-bind (tru rem
) (truncate number
,defaulted-divisor
)
1343 (if (and (not (zerop rem
))
1344 (if (minusp ,defaulted-divisor
)
1347 (values (1+ tru
) (- rem
,defaulted-divisor
))
1348 (values tru rem
)))))