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
))
19 (defknown %double-float
(real) double-float
(movable foldable
))
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 sb
!vm
::n-word-bits
)) &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 ((type (lvar-type num
))
60 (limit (expt 2 sb
!vm
::n-word-bits
))
61 (random-chunk (ecase sb
!vm
::n-word-bits
63 (64 'sb
!kernel
::big-random-chunk
))))
64 (if (numeric-type-p type
)
65 (let ((num-high (numeric-type-high (lvar-type num
))))
67 (cond ((constant-lvar-p num
)
68 ;; Check the worst case sum absolute error for the
69 ;; random number expectations.
70 (let ((rem (rem limit num-high
)))
71 (unless (< (/ (* 2 rem
(- num-high rem
))
73 (expt 2 (- sb
!kernel
::random-integer-extra-bits
)))
74 (give-up-ir1-transform
75 "The random number expectations are inaccurate."))
76 (if (= num-high limit
)
77 `(,random-chunk
(or state
*random-state
*))
79 `(rem (,random-chunk
(or state
*random-state
*)) num
)
81 ;; Use multiplication, which is faster.
82 `(values (sb!bignum
::%multiply
83 (,random-chunk
(or state
*random-state
*))
85 ((> num-high random-fixnum-max
)
86 (give-up-ir1-transform
87 "The range is too large to ensure an accurate result."))
90 `(values (sb!bignum
::%multiply
91 (,random-chunk
(or state
*random-state
*))
94 `(rem (,random-chunk
(or state
*random-state
*)) num
))))
95 ;; KLUDGE: a relatively conservative treatment, but better
96 ;; than a bug (reported by PFD sbcl-devel towards the end of
98 '(rem (random-chunk (or state
*random-state
*)) num
))))
102 (defknown make-single-float
((signed-byte 32)) single-float
103 (movable foldable flushable
))
105 (defknown make-double-float
((signed-byte 32) (unsigned-byte 32)) double-float
106 (movable foldable flushable
))
108 (defknown single-float-bits
(single-float) (signed-byte 32)
109 (movable foldable flushable
))
111 (defknown double-float-high-bits
(double-float) (signed-byte 32)
112 (movable foldable flushable
))
114 (defknown double-float-low-bits
(double-float) (unsigned-byte 32)
115 (movable foldable flushable
))
117 (deftransform float-sign
((float &optional float2
)
118 (single-float &optional single-float
) *)
120 (let ((temp (gensym)))
121 `(let ((,temp
(abs float2
)))
122 (if (minusp (single-float-bits float
)) (- ,temp
) ,temp
)))
123 '(if (minusp (single-float-bits float
)) -
1f0
1f0
)))
125 (deftransform float-sign
((float &optional float2
)
126 (double-float &optional double-float
) *)
128 (let ((temp (gensym)))
129 `(let ((,temp
(abs float2
)))
130 (if (minusp (double-float-high-bits float
)) (- ,temp
) ,temp
)))
131 '(if (minusp (double-float-high-bits float
)) -
1d0
1d0
)))
133 ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, and SCALE-FLOAT
135 (defknown decode-single-float
(single-float)
136 (values single-float single-float-exponent
(single-float -
1f0
1f0
))
137 (movable foldable flushable
))
139 (defknown decode-double-float
(double-float)
140 (values double-float double-float-exponent
(double-float -
1d0
1d0
))
141 (movable foldable flushable
))
143 (defknown integer-decode-single-float
(single-float)
144 (values single-float-significand single-float-int-exponent
(integer -
1 1))
145 (movable foldable flushable
))
147 (defknown integer-decode-double-float
(double-float)
148 (values double-float-significand double-float-int-exponent
(integer -
1 1))
149 (movable foldable flushable
))
151 (defknown scale-single-float
(single-float integer
) single-float
152 (movable foldable flushable
))
154 (defknown scale-double-float
(double-float integer
) double-float
155 (movable foldable flushable
))
157 (deftransform decode-float
((x) (single-float) *)
158 '(decode-single-float x
))
160 (deftransform decode-float
((x) (double-float) *)
161 '(decode-double-float x
))
163 (deftransform integer-decode-float
((x) (single-float) *)
164 '(integer-decode-single-float x
))
166 (deftransform integer-decode-float
((x) (double-float) *)
167 '(integer-decode-double-float x
))
169 (deftransform scale-float
((f ex
) (single-float *) *)
170 (if (and #!+x86 t
#!-x86 nil
171 (csubtypep (lvar-type ex
)
172 (specifier-type '(signed-byte 32))))
173 '(coerce (%scalbn
(coerce f
'double-float
) ex
) 'single-float
)
174 '(scale-single-float f ex
)))
176 (deftransform scale-float
((f ex
) (double-float *) *)
177 (if (and #!+x86 t
#!-x86 nil
178 (csubtypep (lvar-type ex
)
179 (specifier-type '(signed-byte 32))))
181 '(scale-double-float f ex
)))
183 ;;; What is the CROSS-FLOAT-INFINITY-KLUDGE?
185 ;;; SBCL's own implementation of floating point supports floating
186 ;;; point infinities. Some of the old CMU CL :PROPAGATE-FLOAT-TYPE and
187 ;;; :PROPAGATE-FUN-TYPE code, like the DEFOPTIMIZERs below, uses this
188 ;;; floating point support. Thus, we have to avoid running it on the
189 ;;; cross-compilation host, since we're not guaranteed that the
190 ;;; cross-compilation host will support floating point infinities.
192 ;;; If we wanted to live dangerously, we could conditionalize the code
193 ;;; with #+(OR SBCL SB-XC) instead. That way, if the cross-compilation
194 ;;; host happened to be SBCL, we'd be able to run the infinity-using
196 ;;; * SBCL itself gets built with more complete optimization.
198 ;;; * You get a different SBCL depending on what your cross-compilation
200 ;;; So far the pros and cons seem seem to be mostly academic, since
201 ;;; AFAIK (WHN 2001-08-28) the propagate-foo-type optimizations aren't
202 ;;; actually important in compiling SBCL itself. If this changes, then
203 ;;; we have to decide:
204 ;;; * Go for simplicity, leaving things as they are.
205 ;;; * Go for performance at the expense of conceptual clarity,
206 ;;; using #+(OR SBCL SB-XC) and otherwise leaving the build
208 ;;; * Go for performance at the expense of build time, using
209 ;;; #+(OR SBCL SB-XC) and also making SBCL do not just
210 ;;; make-host-1.sh and make-host-2.sh, but a third step
211 ;;; make-host-3.sh where it builds itself under itself. (Such a
212 ;;; 3-step build process could also help with other things, e.g.
213 ;;; using specialized arrays to represent debug information.)
214 ;;; * Rewrite the code so that it doesn't depend on unportable
215 ;;; floating point infinities.
217 ;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds
218 ;;; are computed for the result, if possible.
219 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
222 (defun scale-float-derive-type-aux (f ex same-arg
)
223 (declare (ignore same-arg
))
224 (flet ((scale-bound (x n
)
225 ;; We need to be a bit careful here and catch any overflows
226 ;; that might occur. We can ignore underflows which become
230 (scale-float (type-bound-number x
) n
)
231 (floating-point-overflow ()
234 (when (and (numeric-type-p f
) (numeric-type-p ex
))
235 (let ((f-lo (numeric-type-low f
))
236 (f-hi (numeric-type-high f
))
237 (ex-lo (numeric-type-low ex
))
238 (ex-hi (numeric-type-high ex
))
242 (if (< (float-sign (type-bound-number f-hi
)) 0.0)
244 (setf new-hi
(scale-bound f-hi ex-lo
)))
246 (setf new-hi
(scale-bound f-hi ex-hi
)))))
248 (if (< (float-sign (type-bound-number f-lo
)) 0.0)
250 (setf new-lo
(scale-bound f-lo ex-hi
)))
252 (setf new-lo
(scale-bound f-lo ex-lo
)))))
253 (make-numeric-type :class
(numeric-type-class f
)
254 :format
(numeric-type-format f
)
258 (defoptimizer (scale-single-float derive-type
) ((f ex
))
259 (two-arg-derive-type f ex
#'scale-float-derive-type-aux
260 #'scale-single-float t
))
261 (defoptimizer (scale-double-float derive-type
) ((f ex
))
262 (two-arg-derive-type f ex
#'scale-float-derive-type-aux
263 #'scale-double-float t
))
265 ;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the
266 ;;; FLOAT function return the correct ranges if the input has some
267 ;;; defined range. Quite useful if we want to convert some type of
268 ;;; bounded integer into a float.
270 ((frob (fun type most-negative most-positive
)
271 (let ((aux-name (symbolicate fun
"-DERIVE-TYPE-AUX")))
273 (defun ,aux-name
(num)
274 ;; When converting a number to a float, the limits are
276 (let* ((lo (bound-func (lambda (x)
277 (if (< x
,most-negative
)
280 (numeric-type-low num
)))
281 (hi (bound-func (lambda (x)
282 (if (< ,most-positive x
)
285 (numeric-type-high num
))))
286 (specifier-type `(,',type
,(or lo
'*) ,(or hi
'*)))))
288 (defoptimizer (,fun derive-type
) ((num))
290 (one-arg-derive-type num
#',aux-name
#',fun
)
293 (frob %single-float single-float
294 most-negative-single-float most-positive-single-float
)
295 (frob %double-float double-float
296 most-negative-double-float most-positive-double-float
))
301 (defun safe-ctype-for-single-coercion-p (x)
302 ;; See comment in SAFE-SINGLE-COERCION-P -- this deals with the same
303 ;; problem, but in the context of evaluated and compiled (+ <int> <single>)
304 ;; giving different result if we fail to check for this.
305 (or (not (csubtypep x
(specifier-type 'integer
)))
306 (csubtypep x
(specifier-type `(integer ,most-negative-exactly-single-float-fixnum
307 ,most-positive-exactly-single-float-fixnum
)))))
309 ;;; Do some stuff to recognize when the loser is doing mixed float and
310 ;;; rational arithmetic, or different float types, and fix it up. If
311 ;;; we don't, he won't even get so much as an efficiency note.
312 (deftransform float-contagion-arg1
((x y
) * * :defun-only t
:node node
)
313 (if (or (not (types-equal-or-intersect (lvar-type y
) (specifier-type 'single-float
)))
314 (safe-ctype-for-single-coercion-p (lvar-type x
)))
315 `(,(lvar-fun-name (basic-combination-fun node
))
317 (give-up-ir1-transform)))
318 (deftransform float-contagion-arg2
((x y
) * * :defun-only t
:node node
)
319 (if (or (not (types-equal-or-intersect (lvar-type x
) (specifier-type 'single-float
)))
320 (safe-ctype-for-single-coercion-p (lvar-type y
)))
321 `(,(lvar-fun-name (basic-combination-fun node
))
323 (give-up-ir1-transform)))
325 (dolist (x '(+ * / -
))
326 (%deftransform x
'(function (rational float
) *) #'float-contagion-arg1
)
327 (%deftransform x
'(function (float rational
) *) #'float-contagion-arg2
))
329 (dolist (x '(= < > + * / -
))
330 (%deftransform x
'(function (single-float double-float
) *)
331 #'float-contagion-arg1
)
332 (%deftransform x
'(function (double-float single-float
) *)
333 #'float-contagion-arg2
))
335 ;;; Prevent ZEROP, PLUSP, and MINUSP from losing horribly. We can't in
336 ;;; general float rational args to comparison, since Common Lisp
337 ;;; semantics says we are supposed to compare as rationals, but we can
338 ;;; do it for any rational that has a precise representation as a
339 ;;; float (such as 0).
340 (macrolet ((frob (op)
341 `(deftransform ,op
((x y
) (float rational
) *)
342 "open-code FLOAT to RATIONAL comparison"
343 (unless (constant-lvar-p y
)
344 (give-up-ir1-transform
345 "The RATIONAL value isn't known at compile time."))
346 (let ((val (lvar-value y
)))
347 (unless (eql (rational (float val
)) val
)
348 (give-up-ir1-transform
349 "~S doesn't have a precise float representation."
351 `(,',op x
(float y x
)))))
356 ;;;; irrational derive-type methods
358 ;;; Derive the result to be float for argument types in the
359 ;;; appropriate domain.
360 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
361 (dolist (stuff '((asin (real -
1.0 1.0))
362 (acos (real -
1.0 1.0))
364 (atanh (real -
1.0 1.0))
366 (destructuring-bind (name type
) stuff
367 (let ((type (specifier-type type
)))
368 (setf (fun-info-derive-type (fun-info-or-lose name
))
370 (declare (type combination call
))
371 (when (csubtypep (lvar-type
372 (first (combination-args call
)))
374 (specifier-type 'float
)))))))
376 #+sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
377 (defoptimizer (log derive-type
) ((x &optional y
))
378 (when (and (csubtypep (lvar-type x
)
379 (specifier-type '(real 0.0)))
381 (csubtypep (lvar-type y
)
382 (specifier-type '(real 0.0)))))
383 (specifier-type 'float
)))
385 ;;;; irrational transforms
387 (defknown (%tan %sinh %asinh %atanh %log %logb %log10 %tan-quick
)
388 (double-float) double-float
389 (movable foldable flushable
))
391 (defknown (%sin %cos %tanh %sin-quick %cos-quick
)
392 (double-float) (double-float -
1.0d0
1.0d0
)
393 (movable foldable flushable
))
395 (defknown (%asin %atan
)
397 (double-float #.
(coerce (- (/ pi
2)) 'double-float
)
398 #.
(coerce (/ pi
2) 'double-float
))
399 (movable foldable flushable
))
402 (double-float) (double-float 0.0d0
#.
(coerce pi
'double-float
))
403 (movable foldable flushable
))
406 (double-float) (double-float 1.0d0
)
407 (movable foldable flushable
))
409 (defknown (%acosh %exp %sqrt
)
410 (double-float) (double-float 0.0d0
)
411 (movable foldable flushable
))
414 (double-float) (double-float -
1d0
)
415 (movable foldable flushable
))
418 (double-float double-float
) (double-float 0d0
)
419 (movable foldable flushable
))
422 (double-float double-float
) double-float
423 (movable foldable flushable
))
426 (double-float double-float
)
427 (double-float #.
(coerce (- pi
) 'double-float
)
428 #.
(coerce pi
'double-float
))
429 (movable foldable flushable
))
432 (double-float double-float
) double-float
433 (movable foldable flushable
))
436 (double-float (signed-byte 32)) double-float
437 (movable foldable flushable
))
440 (double-float) double-float
441 (movable foldable flushable
))
443 (macrolet ((def (name prim rtype
)
445 (deftransform ,name
((x) (single-float) ,rtype
)
446 `(coerce (,',prim
(coerce x
'double-float
)) 'single-float
))
447 (deftransform ,name
((x) (double-float) ,rtype
)
451 (def sqrt %sqrt float
)
452 (def asin %asin float
)
453 (def acos %acos float
)
459 (def acosh %acosh float
)
460 (def atanh %atanh float
))
462 ;;; The argument range is limited on the x86 FP trig. functions. A
463 ;;; post-test can detect a failure (and load a suitable result), but
464 ;;; this test is avoided if possible.
465 (macrolet ((def (name prim prim-quick
)
466 (declare (ignorable prim-quick
))
468 (deftransform ,name
((x) (single-float) *)
469 #!+x86
(cond ((csubtypep (lvar-type x
)
470 (specifier-type '(single-float
471 (#.
(- (expt 2f0
64)))
473 `(coerce (,',prim-quick
(coerce x
'double-float
))
477 "unable to avoid inline argument range check~@
478 because the argument range (~S) was not within 2^64"
479 (type-specifier (lvar-type x
)))
480 `(coerce (,',prim
(coerce x
'double-float
)) 'single-float
)))
481 #!-x86
`(coerce (,',prim
(coerce x
'double-float
)) 'single-float
))
482 (deftransform ,name
((x) (double-float) *)
483 #!+x86
(cond ((csubtypep (lvar-type x
)
484 (specifier-type '(double-float
485 (#.
(- (expt 2d0
64)))
490 "unable to avoid inline argument range check~@
491 because the argument range (~S) was not within 2^64"
492 (type-specifier (lvar-type x
)))
494 #!-x86
`(,',prim x
)))))
495 (def sin %sin %sin-quick
)
496 (def cos %cos %cos-quick
)
497 (def tan %tan %tan-quick
))
499 (deftransform atan
((x y
) (single-float single-float
) *)
500 `(coerce (%atan2
(coerce x
'double-float
) (coerce y
'double-float
))
502 (deftransform atan
((x y
) (double-float double-float
) *)
505 (deftransform expt
((x y
) ((single-float 0f0
) single-float
) *)
506 `(coerce (%pow
(coerce x
'double-float
) (coerce y
'double-float
))
508 (deftransform expt
((x y
) ((double-float 0d0
) double-float
) *)
510 (deftransform expt
((x y
) ((single-float 0f0
) (signed-byte 32)) *)
511 `(coerce (%pow
(coerce x
'double-float
) (coerce y
'double-float
))
513 (deftransform expt
((x y
) ((double-float 0d0
) (signed-byte 32)) *)
514 `(%pow x
(coerce y
'double-float
)))
516 ;;; ANSI says log with base zero returns zero.
517 (deftransform log
((x y
) (float float
) float
)
518 '(if (zerop y
) y
(/ (log x
) (log y
))))
520 ;;; Handle some simple transformations.
522 (deftransform abs
((x) ((complex double-float
)) double-float
)
523 '(%hypot
(realpart x
) (imagpart x
)))
525 (deftransform abs
((x) ((complex single-float
)) single-float
)
526 '(coerce (%hypot
(coerce (realpart x
) 'double-float
)
527 (coerce (imagpart x
) 'double-float
))
530 (deftransform phase
((x) ((complex double-float
)) double-float
)
531 '(%atan2
(imagpart x
) (realpart x
)))
533 (deftransform phase
((x) ((complex single-float
)) single-float
)
534 '(coerce (%atan2
(coerce (imagpart x
) 'double-float
)
535 (coerce (realpart x
) 'double-float
))
538 (deftransform phase
((x) ((float)) float
)
539 '(if (minusp (float-sign x
))
543 ;;; The number is of type REAL.
544 (defun numeric-type-real-p (type)
545 (and (numeric-type-p type
)
546 (eq (numeric-type-complexp type
) :real
)))
548 ;;; Coerce a numeric type bound to the given type while handling
549 ;;; exclusive bounds.
550 (defun coerce-numeric-bound (bound type
)
553 (list (coerce (car bound
) type
))
554 (coerce bound type
))))
556 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
559 ;;;; optimizers for elementary functions
561 ;;;; These optimizers compute the output range of the elementary
562 ;;;; function, based on the domain of the input.
564 ;;; Generate a specifier for a complex type specialized to the same
565 ;;; type as the argument.
566 (defun complex-float-type (arg)
567 (declare (type numeric-type arg
))
568 (let* ((format (case (numeric-type-class arg
)
569 ((integer rational
) 'single-float
)
570 (t (numeric-type-format arg
))))
571 (float-type (or format
'float
)))
572 (specifier-type `(complex ,float-type
))))
574 ;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
575 ;;; should be the right kind of float. Allow bounds for the float
577 (defun float-or-complex-float-type (arg &optional lo hi
)
578 (declare (type numeric-type arg
))
579 (let* ((format (case (numeric-type-class arg
)
580 ((integer rational
) 'single-float
)
581 (t (numeric-type-format arg
))))
582 (float-type (or format
'float
))
583 (lo (coerce-numeric-bound lo float-type
))
584 (hi (coerce-numeric-bound hi float-type
)))
585 (specifier-type `(or (,float-type
,(or lo
'*) ,(or hi
'*))
586 (complex ,float-type
)))))
590 (eval-when (:compile-toplevel
:execute
)
591 ;; So the problem with this hack is that it's actually broken. If
592 ;; the host does not have long floats, then setting *R-D-F-F* to
593 ;; LONG-FLOAT doesn't actually buy us anything. FIXME.
594 (setf *read-default-float-format
*
595 #!+long-float
'long-float
#!-long-float
'double-float
))
596 ;;; Test whether the numeric-type ARG is within in domain specified by
597 ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
599 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
600 (defun domain-subtypep (arg domain-low domain-high
)
601 (declare (type numeric-type arg
)
602 (type (or real null
) domain-low domain-high
))
603 (let* ((arg-lo (numeric-type-low arg
))
604 (arg-lo-val (type-bound-number arg-lo
))
605 (arg-hi (numeric-type-high arg
))
606 (arg-hi-val (type-bound-number arg-hi
)))
607 ;; Check that the ARG bounds are correctly canonicalized.
608 (when (and arg-lo
(floatp arg-lo-val
) (zerop arg-lo-val
) (consp arg-lo
)
609 (minusp (float-sign arg-lo-val
)))
610 (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-lo
)
611 (setq arg-lo
0e0 arg-lo-val arg-lo
))
612 (when (and arg-hi
(zerop arg-hi-val
) (floatp arg-hi-val
) (consp arg-hi
)
613 (plusp (float-sign arg-hi-val
)))
614 (compiler-notify "float zero bound ~S not correctly canonicalized?" arg-hi
)
615 (setq arg-hi
(ecase *read-default-float-format
*
616 (double-float (load-time-value (make-unportable-float :double-float-negative-zero
)))
618 (long-float (load-time-value (make-unportable-float :long-float-negative-zero
))))
620 (flet ((fp-neg-zero-p (f) ; Is F -0.0?
621 (and (floatp f
) (zerop f
) (minusp (float-sign f
))))
622 (fp-pos-zero-p (f) ; Is F +0.0?
623 (and (floatp f
) (zerop f
) (plusp (float-sign f
)))))
624 (and (or (null domain-low
)
625 (and arg-lo
(>= arg-lo-val domain-low
)
626 (not (and (fp-pos-zero-p domain-low
)
627 (fp-neg-zero-p arg-lo
)))))
628 (or (null domain-high
)
629 (and arg-hi
(<= arg-hi-val domain-high
)
630 (not (and (fp-neg-zero-p domain-high
)
631 (fp-pos-zero-p arg-hi
)))))))))
632 (eval-when (:compile-toplevel
:execute
)
633 (setf *read-default-float-format
* 'single-float
))
635 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
638 ;;; Handle monotonic functions of a single variable whose domain is
639 ;;; possibly part of the real line. ARG is the variable, FUN is the
640 ;;; function, and DOMAIN is a specifier that gives the (real) domain
641 ;;; of the function. If ARG is a subset of the DOMAIN, we compute the
642 ;;; bounds directly. Otherwise, we compute the bounds for the
643 ;;; intersection between ARG and DOMAIN, and then append a complex
644 ;;; result, which occurs for the parts of ARG not in the DOMAIN.
646 ;;; Negative and positive zero are considered distinct within
647 ;;; DOMAIN-LOW and DOMAIN-HIGH.
649 ;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
650 ;;; can't compute the bounds using FUN.
651 (defun elfun-derive-type-simple (arg fun domain-low domain-high
652 default-low default-high
653 &optional
(increasingp t
))
654 (declare (type (or null real
) domain-low domain-high
))
657 (cond ((eq (numeric-type-complexp arg
) :complex
)
658 (complex-float-type arg
))
659 ((numeric-type-real-p arg
)
660 ;; The argument is real, so let's find the intersection
661 ;; between the argument and the domain of the function.
662 ;; We compute the bounds on the intersection, and for
663 ;; everything else, we return a complex number of the
665 (multiple-value-bind (intersection difference
)
666 (interval-intersection/difference
(numeric-type->interval arg
)
672 ;; Process the intersection.
673 (let* ((low (interval-low intersection
))
674 (high (interval-high intersection
))
675 (res-lo (or (bound-func fun
(if increasingp low high
))
677 (res-hi (or (bound-func fun
(if increasingp high low
))
679 (format (case (numeric-type-class arg
)
680 ((integer rational
) 'single-float
)
681 (t (numeric-type-format arg
))))
682 (bound-type (or format
'float
))
687 :low
(coerce-numeric-bound res-lo bound-type
)
688 :high
(coerce-numeric-bound res-hi bound-type
))))
689 ;; If the ARG is a subset of the domain, we don't
690 ;; have to worry about the difference, because that
692 (if (or (null difference
)
693 ;; Check whether the arg is within the domain.
694 (domain-subtypep arg domain-low domain-high
))
697 (specifier-type `(complex ,bound-type
))))))
699 ;; No intersection so the result must be purely complex.
700 (complex-float-type arg
)))))
702 (float-or-complex-float-type arg default-low default-high
))))))
705 ((frob (name domain-low domain-high def-low-bnd def-high-bnd
706 &key
(increasingp t
))
707 (let ((num (gensym)))
708 `(defoptimizer (,name derive-type
) ((,num
))
712 (elfun-derive-type-simple arg
#',name
713 ,domain-low
,domain-high
714 ,def-low-bnd
,def-high-bnd
717 ;; These functions are easy because they are defined for the whole
719 (frob exp nil nil
0 nil
)
720 (frob sinh nil nil nil nil
)
721 (frob tanh nil nil -
1 1)
722 (frob asinh nil nil nil nil
)
724 ;; These functions are only defined for part of the real line. The
725 ;; condition selects the desired part of the line.
726 (frob asin -
1d0
1d0
(- (/ pi
2)) (/ pi
2))
727 ;; Acos is monotonic decreasing, so we need to swap the function
728 ;; values at the lower and upper bounds of the input domain.
729 (frob acos -
1d0
1d0
0 pi
:increasingp nil
)
730 (frob acosh
1d0 nil nil nil
)
731 (frob atanh -
1d0
1d0 -
1 1)
732 ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
734 (frob sqrt
(load-time-value (make-unportable-float :double-float-negative-zero
)) nil
0 nil
))
736 ;;; Compute bounds for (expt x y). This should be easy since (expt x
737 ;;; y) = (exp (* y (log x))). However, computations done this way
738 ;;; have too much roundoff. Thus we have to do it the hard way.
739 (defun safe-expt (x y
)
741 (when (< (abs y
) 10000)
746 ;;; Handle the case when x >= 1.
747 (defun interval-expt-> (x y
)
748 (case (sb!c
::interval-range-info y
0d0
)
750 ;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
751 ;; obviously non-negative. We just have to be careful for
752 ;; infinite bounds (given by nil).
753 (let ((lo (safe-expt (type-bound-number (sb!c
::interval-low x
))
754 (type-bound-number (sb!c
::interval-low y
))))
755 (hi (safe-expt (type-bound-number (sb!c
::interval-high x
))
756 (type-bound-number (sb!c
::interval-high y
)))))
757 (list (sb!c
::make-interval
:low
(or lo
1) :high hi
))))
759 ;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
760 ;; obviously [0, 1]. However, underflow (nil) means 0 is the
762 (let ((lo (safe-expt (type-bound-number (sb!c
::interval-high x
))
763 (type-bound-number (sb!c
::interval-low y
))))
764 (hi (safe-expt (type-bound-number (sb!c
::interval-low x
))
765 (type-bound-number (sb!c
::interval-high y
)))))
766 (list (sb!c
::make-interval
:low
(or lo
0) :high
(or hi
1)))))
768 ;; Split the interval in half.
769 (destructuring-bind (y- y
+)
770 (sb!c
::interval-split
0 y t
)
771 (list (interval-expt-> x y-
)
772 (interval-expt-> x y
+))))))
774 ;;; Handle the case when x <= 1
775 (defun interval-expt-< (x y
)
776 (case (sb!c
::interval-range-info x
0d0
)
778 ;; The case of 0 <= x <= 1 is easy
779 (case (sb!c
::interval-range-info y
)
781 ;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
782 ;; obviously [0, 1]. We just have to be careful for infinite bounds
784 (let ((lo (safe-expt (type-bound-number (sb!c
::interval-low x
))
785 (type-bound-number (sb!c
::interval-high y
))))
786 (hi (safe-expt (type-bound-number (sb!c
::interval-high x
))
787 (type-bound-number (sb!c
::interval-low y
)))))
788 (list (sb!c
::make-interval
:low
(or lo
0) :high
(or hi
1)))))
790 ;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
791 ;; obviously [1, inf].
792 (let ((hi (safe-expt (type-bound-number (sb!c
::interval-low x
))
793 (type-bound-number (sb!c
::interval-low y
))))
794 (lo (safe-expt (type-bound-number (sb!c
::interval-high x
))
795 (type-bound-number (sb!c
::interval-high y
)))))
796 (list (sb!c
::make-interval
:low
(or lo
1) :high hi
))))
798 ;; Split the interval in half
799 (destructuring-bind (y- y
+)
800 (sb!c
::interval-split
0 y t
)
801 (list (interval-expt-< x y-
)
802 (interval-expt-< x y
+))))))
804 ;; The case where x <= 0. Y MUST be an INTEGER for this to work!
805 ;; The calling function must insure this! For now we'll just
806 ;; return the appropriate unbounded float type.
807 (list (sb!c
::make-interval
:low nil
:high nil
)))
809 (destructuring-bind (neg pos
)
810 (interval-split 0 x t t
)
811 (list (interval-expt-< neg y
)
812 (interval-expt-< pos y
))))))
814 ;;; Compute bounds for (expt x y).
815 (defun interval-expt (x y
)
816 (case (interval-range-info x
1)
819 (interval-expt-> x y
))
822 (interval-expt-< x y
))
824 (destructuring-bind (left right
)
825 (interval-split 1 x t t
)
826 (list (interval-expt left y
)
827 (interval-expt right y
))))))
829 (defun fixup-interval-expt (bnd x-int y-int x-type y-type
)
830 (declare (ignore x-int
))
831 ;; Figure out what the return type should be, given the argument
832 ;; types and bounds and the result type and bounds.
833 (cond ((csubtypep x-type
(specifier-type 'integer
))
834 ;; an integer to some power
835 (case (numeric-type-class y-type
)
837 ;; Positive integer to an integer power is either an
838 ;; integer or a rational.
839 (let ((lo (or (interval-low bnd
) '*))
840 (hi (or (interval-high bnd
) '*)))
841 (if (and (interval-low y-int
)
842 (>= (type-bound-number (interval-low y-int
)) 0))
843 (specifier-type `(integer ,lo
,hi
))
844 (specifier-type `(rational ,lo
,hi
)))))
846 ;; Positive integer to rational power is either a rational
847 ;; or a single-float.
848 (let* ((lo (interval-low bnd
))
849 (hi (interval-high bnd
))
851 (floor (type-bound-number lo
))
854 (ceiling (type-bound-number hi
))
857 (bound-func #'float lo
)
860 (bound-func #'float hi
)
862 (specifier-type `(or (rational ,int-lo
,int-hi
)
863 (single-float ,f-lo
, f-hi
)))))
865 ;; A positive integer to a float power is a float.
866 (modified-numeric-type y-type
867 :low
(interval-low bnd
)
868 :high
(interval-high bnd
)))
870 ;; A positive integer to a number is a number (for now).
871 (specifier-type 'number
))))
872 ((csubtypep x-type
(specifier-type 'rational
))
873 ;; a rational to some power
874 (case (numeric-type-class y-type
)
876 ;; A positive rational to an integer power is always a rational.
877 (specifier-type `(rational ,(or (interval-low bnd
) '*)
878 ,(or (interval-high bnd
) '*))))
880 ;; A positive rational to rational power is either a rational
881 ;; or a single-float.
882 (let* ((lo (interval-low bnd
))
883 (hi (interval-high bnd
))
885 (floor (type-bound-number lo
))
888 (ceiling (type-bound-number hi
))
891 (bound-func #'float lo
)
894 (bound-func #'float hi
)
896 (specifier-type `(or (rational ,int-lo
,int-hi
)
897 (single-float ,f-lo
, f-hi
)))))
899 ;; A positive rational to a float power is a float.
900 (modified-numeric-type y-type
901 :low
(interval-low bnd
)
902 :high
(interval-high bnd
)))
904 ;; A positive rational to a number is a number (for now).
905 (specifier-type 'number
))))
906 ((csubtypep x-type
(specifier-type 'float
))
907 ;; a float to some power
908 (case (numeric-type-class y-type
)
909 ((or integer rational
)
910 ;; A positive float to an integer or rational power is
914 :format
(numeric-type-format x-type
)
915 :low
(interval-low bnd
)
916 :high
(interval-high bnd
)))
918 ;; A positive float to a float power is a float of the
922 :format
(float-format-max (numeric-type-format x-type
)
923 (numeric-type-format y-type
))
924 :low
(interval-low bnd
)
925 :high
(interval-high bnd
)))
927 ;; A positive float to a number is a number (for now)
928 (specifier-type 'number
))))
930 ;; A number to some power is a number.
931 (specifier-type 'number
))))
933 (defun merged-interval-expt (x y
)
934 (let* ((x-int (numeric-type->interval x
))
935 (y-int (numeric-type->interval y
)))
936 (mapcar (lambda (type)
937 (fixup-interval-expt type x-int y-int x y
))
938 (flatten-list (interval-expt x-int y-int
)))))
940 (defun expt-derive-type-aux (x y same-arg
)
941 (declare (ignore same-arg
))
942 (cond ((or (not (numeric-type-real-p x
))
943 (not (numeric-type-real-p y
)))
944 ;; Use numeric contagion if either is not real.
945 (numeric-contagion x y
))
946 ((csubtypep y
(specifier-type 'integer
))
947 ;; A real raised to an integer power is well-defined.
948 (merged-interval-expt x y
))
949 ;; A real raised to a non-integral power can be a float or a
951 ((or (csubtypep x
(specifier-type '(rational 0)))
952 (csubtypep x
(specifier-type '(float (0d0)))))
953 ;; But a positive real to any power is well-defined.
954 (merged-interval-expt x y
))
955 ((and (csubtypep x
(specifier-type 'rational
))
956 (csubtypep x
(specifier-type 'rational
)))
957 ;; A rational to the power of a rational could be a rational
958 ;; or a possibly-complex single float
959 (specifier-type '(or rational single-float
(complex single-float
))))
961 ;; a real to some power. The result could be a real or a
963 (float-or-complex-float-type (numeric-contagion x y
)))))
965 (defoptimizer (expt derive-type
) ((x y
))
966 (two-arg-derive-type x y
#'expt-derive-type-aux
#'expt
))
968 ;;; Note we must assume that a type including 0.0 may also include
969 ;;; -0.0 and thus the result may be complex -infinity + i*pi.
970 (defun log-derive-type-aux-1 (x)
971 (elfun-derive-type-simple x
#'log
0d0 nil nil nil
))
973 (defun log-derive-type-aux-2 (x y same-arg
)
974 (let ((log-x (log-derive-type-aux-1 x
))
975 (log-y (log-derive-type-aux-1 y
))
976 (accumulated-list nil
))
977 ;; LOG-X or LOG-Y might be union types. We need to run through
978 ;; the union types ourselves because /-DERIVE-TYPE-AUX doesn't.
979 (dolist (x-type (prepare-arg-for-derive-type log-x
))
980 (dolist (y-type (prepare-arg-for-derive-type log-y
))
981 (push (/-derive-type-aux x-type y-type same-arg
) accumulated-list
)))
982 (apply #'type-union
(flatten-list accumulated-list
))))
984 (defoptimizer (log derive-type
) ((x &optional y
))
986 (two-arg-derive-type x y
#'log-derive-type-aux-2
#'log
)
987 (one-arg-derive-type x
#'log-derive-type-aux-1
#'log
)))
989 (defun atan-derive-type-aux-1 (y)
990 (elfun-derive-type-simple y
#'atan nil nil
(- (/ pi
2)) (/ pi
2)))
992 (defun atan-derive-type-aux-2 (y x same-arg
)
993 (declare (ignore same-arg
))
994 ;; The hard case with two args. We just return the max bounds.
995 (let ((result-type (numeric-contagion y x
)))
996 (cond ((and (numeric-type-real-p x
)
997 (numeric-type-real-p y
))
998 (let* (;; FIXME: This expression for FORMAT seems to
999 ;; appear multiple times, and should be factored out.
1000 (format (case (numeric-type-class result-type
)
1001 ((integer rational
) 'single-float
)
1002 (t (numeric-type-format result-type
))))
1003 (bound-format (or format
'float
)))
1004 (make-numeric-type :class
'float
1007 :low
(coerce (- pi
) bound-format
)
1008 :high
(coerce pi bound-format
))))
1010 ;; The result is a float or a complex number
1011 (float-or-complex-float-type result-type
)))))
1013 (defoptimizer (atan derive-type
) ((y &optional x
))
1015 (two-arg-derive-type y x
#'atan-derive-type-aux-2
#'atan
)
1016 (one-arg-derive-type y
#'atan-derive-type-aux-1
#'atan
)))
1018 (defun cosh-derive-type-aux (x)
1019 ;; We note that cosh x = cosh |x| for all real x.
1020 (elfun-derive-type-simple
1021 (if (numeric-type-real-p x
)
1022 (abs-derive-type-aux x
)
1024 #'cosh nil nil
0 nil
))
1026 (defoptimizer (cosh derive-type
) ((num))
1027 (one-arg-derive-type num
#'cosh-derive-type-aux
#'cosh
))
1029 (defun phase-derive-type-aux (arg)
1030 (let* ((format (case (numeric-type-class arg
)
1031 ((integer rational
) 'single-float
)
1032 (t (numeric-type-format arg
))))
1033 (bound-type (or format
'float
)))
1034 (cond ((numeric-type-real-p arg
)
1035 (case (interval-range-info (numeric-type->interval arg
) 0.0)
1037 ;; The number is positive, so the phase is 0.
1038 (make-numeric-type :class
'float
1041 :low
(coerce 0 bound-type
)
1042 :high
(coerce 0 bound-type
)))
1044 ;; The number is always negative, so the phase is pi.
1045 (make-numeric-type :class
'float
1048 :low
(coerce pi bound-type
)
1049 :high
(coerce pi bound-type
)))
1051 ;; We can't tell. The result is 0 or pi. Use a union
1054 (make-numeric-type :class
'float
1057 :low
(coerce 0 bound-type
)
1058 :high
(coerce 0 bound-type
))
1059 (make-numeric-type :class
'float
1062 :low
(coerce pi bound-type
)
1063 :high
(coerce pi bound-type
))))))
1065 ;; We have a complex number. The answer is the range -pi
1066 ;; to pi. (-pi is included because we have -0.)
1067 (make-numeric-type :class
'float
1070 :low
(coerce (- pi
) bound-type
)
1071 :high
(coerce pi bound-type
))))))
1073 (defoptimizer (phase derive-type
) ((num))
1074 (one-arg-derive-type num
#'phase-derive-type-aux
#'phase
))
1078 (deftransform realpart
((x) ((complex rational
)) *)
1079 '(sb!kernel
:%realpart x
))
1080 (deftransform imagpart
((x) ((complex rational
)) *)
1081 '(sb!kernel
:%imagpart x
))
1083 ;;; Make REALPART and IMAGPART return the appropriate types. This
1084 ;;; should help a lot in optimized code.
1085 (defun realpart-derive-type-aux (type)
1086 (let ((class (numeric-type-class type
))
1087 (format (numeric-type-format type
)))
1088 (cond ((numeric-type-real-p type
)
1089 ;; The realpart of a real has the same type and range as
1091 (make-numeric-type :class class
1094 :low
(numeric-type-low type
)
1095 :high
(numeric-type-high type
)))
1097 ;; We have a complex number. The result has the same type
1098 ;; as the real part, except that it's real, not complex,
1100 (make-numeric-type :class class
1103 :low
(numeric-type-low type
)
1104 :high
(numeric-type-high type
))))))
1105 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1106 (defoptimizer (realpart derive-type
) ((num))
1107 (one-arg-derive-type num
#'realpart-derive-type-aux
#'realpart
))
1108 (defun imagpart-derive-type-aux (type)
1109 (let ((class (numeric-type-class type
))
1110 (format (numeric-type-format type
)))
1111 (cond ((numeric-type-real-p type
)
1112 ;; The imagpart of a real has the same type as the input,
1113 ;; except that it's zero.
1114 (let ((bound-format (or format class
'real
)))
1115 (make-numeric-type :class class
1118 :low
(coerce 0 bound-format
)
1119 :high
(coerce 0 bound-format
))))
1121 ;; We have a complex number. The result has the same type as
1122 ;; the imaginary part, except that it's real, not complex,
1124 (make-numeric-type :class class
1127 :low
(numeric-type-low type
)
1128 :high
(numeric-type-high type
))))))
1129 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1130 (defoptimizer (imagpart derive-type
) ((num))
1131 (one-arg-derive-type num
#'imagpart-derive-type-aux
#'imagpart
))
1133 (defun complex-derive-type-aux-1 (re-type)
1134 (if (numeric-type-p re-type
)
1135 (make-numeric-type :class
(numeric-type-class re-type
)
1136 :format
(numeric-type-format re-type
)
1137 :complexp
(if (csubtypep re-type
1138 (specifier-type 'rational
))
1141 :low
(numeric-type-low re-type
)
1142 :high
(numeric-type-high re-type
))
1143 (specifier-type 'complex
)))
1145 (defun complex-derive-type-aux-2 (re-type im-type same-arg
)
1146 (declare (ignore same-arg
))
1147 (if (and (numeric-type-p re-type
)
1148 (numeric-type-p im-type
))
1149 ;; Need to check to make sure numeric-contagion returns the
1150 ;; right type for what we want here.
1152 ;; Also, what about rational canonicalization, like (complex 5 0)
1153 ;; is 5? So, if the result must be complex, we make it so.
1154 ;; If the result might be complex, which happens only if the
1155 ;; arguments are rational, we make it a union type of (or
1156 ;; rational (complex rational)).
1157 (let* ((element-type (numeric-contagion re-type im-type
))
1158 (rat-result-p (csubtypep element-type
1159 (specifier-type 'rational
))))
1161 (type-union element-type
1163 `(complex ,(numeric-type-class element-type
))))
1164 (make-numeric-type :class
(numeric-type-class element-type
)
1165 :format
(numeric-type-format element-type
)
1166 :complexp
(if rat-result-p
1169 (specifier-type 'complex
)))
1171 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1172 (defoptimizer (complex derive-type
) ((re &optional im
))
1174 (two-arg-derive-type re im
#'complex-derive-type-aux-2
#'complex
)
1175 (one-arg-derive-type re
#'complex-derive-type-aux-1
#'complex
)))
1177 ;;; Define some transforms for complex operations. We do this in lieu
1178 ;;; of complex operation VOPs.
1179 (macrolet ((frob (type)
1182 (deftransform %negate
((z) ((complex ,type
)) *)
1183 '(complex (%negate
(realpart z
)) (%negate
(imagpart z
))))
1184 ;; complex addition and subtraction
1185 (deftransform + ((w z
) ((complex ,type
) (complex ,type
)) *)
1186 '(complex (+ (realpart w
) (realpart z
))
1187 (+ (imagpart w
) (imagpart z
))))
1188 (deftransform -
((w z
) ((complex ,type
) (complex ,type
)) *)
1189 '(complex (- (realpart w
) (realpart z
))
1190 (- (imagpart w
) (imagpart z
))))
1191 ;; Add and subtract a complex and a real.
1192 (deftransform + ((w z
) ((complex ,type
) real
) *)
1193 '(complex (+ (realpart w
) z
) (imagpart w
)))
1194 (deftransform + ((z w
) (real (complex ,type
)) *)
1195 '(complex (+ (realpart w
) z
) (imagpart w
)))
1196 ;; Add and subtract a real and a complex number.
1197 (deftransform -
((w z
) ((complex ,type
) real
) *)
1198 '(complex (- (realpart w
) z
) (imagpart w
)))
1199 (deftransform -
((z w
) (real (complex ,type
)) *)
1200 '(complex (- z
(realpart w
)) (- (imagpart w
))))
1201 ;; Multiply and divide two complex numbers.
1202 (deftransform * ((x y
) ((complex ,type
) (complex ,type
)) *)
1203 '(let* ((rx (realpart x
))
1207 (complex (- (* rx ry
) (* ix iy
))
1208 (+ (* rx iy
) (* ix ry
)))))
1209 (deftransform / ((x y
) ((complex ,type
) (complex ,type
)) *)
1210 '(let* ((rx (realpart x
))
1214 (if (> (abs ry
) (abs iy
))
1215 (let* ((r (/ iy ry
))
1216 (dn (* ry
(+ 1 (* r r
)))))
1217 (complex (/ (+ rx
(* ix r
)) dn
)
1218 (/ (- ix
(* rx r
)) dn
)))
1219 (let* ((r (/ ry iy
))
1220 (dn (* iy
(+ 1 (* r r
)))))
1221 (complex (/ (+ (* rx r
) ix
) dn
)
1222 (/ (- (* ix r
) rx
) dn
))))))
1223 ;; Multiply a complex by a real or vice versa.
1224 (deftransform * ((w z
) ((complex ,type
) real
) *)
1225 '(complex (* (realpart w
) z
) (* (imagpart w
) z
)))
1226 (deftransform * ((z w
) (real (complex ,type
)) *)
1227 '(complex (* (realpart w
) z
) (* (imagpart w
) z
)))
1228 ;; Divide a complex by a real.
1229 (deftransform / ((w z
) ((complex ,type
) real
) *)
1230 '(complex (/ (realpart w
) z
) (/ (imagpart w
) z
)))
1231 ;; conjugate of complex number
1232 (deftransform conjugate
((z) ((complex ,type
)) *)
1233 '(complex (realpart z
) (- (imagpart z
))))
1235 (deftransform cis
((z) ((,type
)) *)
1236 '(complex (cos z
) (sin z
)))
1238 (deftransform = ((w z
) ((complex ,type
) (complex ,type
)) *)
1239 '(and (= (realpart w
) (realpart z
))
1240 (= (imagpart w
) (imagpart z
))))
1241 (deftransform = ((w z
) ((complex ,type
) real
) *)
1242 '(and (= (realpart w
) z
) (zerop (imagpart w
))))
1243 (deftransform = ((w z
) (real (complex ,type
)) *)
1244 '(and (= (realpart z
) w
) (zerop (imagpart z
)))))))
1247 (frob double-float
))
1249 ;;; Here are simple optimizers for SIN, COS, and TAN. They do not
1250 ;;; produce a minimal range for the result; the result is the widest
1251 ;;; possible answer. This gets around the problem of doing range
1252 ;;; reduction correctly but still provides useful results when the
1253 ;;; inputs are union types.
1254 #-sb-xc-host
; (See CROSS-FLOAT-INFINITY-KLUDGE.)
1256 (defun trig-derive-type-aux (arg domain fun
1257 &optional def-lo def-hi
(increasingp t
))
1260 (cond ((eq (numeric-type-complexp arg
) :complex
)
1261 (make-numeric-type :class
(numeric-type-class arg
)
1262 :format
(numeric-type-format arg
)
1263 :complexp
:complex
))
1264 ((numeric-type-real-p arg
)
1265 (let* ((format (case (numeric-type-class arg
)
1266 ((integer rational
) 'single-float
)
1267 (t (numeric-type-format arg
))))
1268 (bound-type (or format
'float
)))
1269 ;; If the argument is a subset of the "principal" domain
1270 ;; of the function, we can compute the bounds because
1271 ;; the function is monotonic. We can't do this in
1272 ;; general for these periodic functions because we can't
1273 ;; (and don't want to) do the argument reduction in
1274 ;; exactly the same way as the functions themselves do
1276 (if (csubtypep arg domain
)
1277 (let ((res-lo (bound-func fun
(numeric-type-low arg
)))
1278 (res-hi (bound-func fun
(numeric-type-high arg
))))
1280 (rotatef res-lo res-hi
))
1284 :low
(coerce-numeric-bound res-lo bound-type
)
1285 :high
(coerce-numeric-bound res-hi bound-type
)))
1289 :low
(and def-lo
(coerce def-lo bound-type
))
1290 :high
(and def-hi
(coerce def-hi bound-type
))))))
1292 (float-or-complex-float-type arg def-lo def-hi
))))))
1294 (defoptimizer (sin derive-type
) ((num))
1295 (one-arg-derive-type
1298 ;; Derive the bounds if the arg is in [-pi/2, pi/2].
1299 (trig-derive-type-aux
1301 (specifier-type `(float ,(- (/ pi
2)) ,(/ pi
2)))
1306 (defoptimizer (cos derive-type
) ((num))
1307 (one-arg-derive-type
1310 ;; Derive the bounds if the arg is in [0, pi].
1311 (trig-derive-type-aux arg
1312 (specifier-type `(float 0d0
,pi
))
1318 (defoptimizer (tan derive-type
) ((num))
1319 (one-arg-derive-type
1322 ;; Derive the bounds if the arg is in [-pi/2, pi/2].
1323 (trig-derive-type-aux arg
1324 (specifier-type `(float ,(- (/ pi
2)) ,(/ pi
2)))
1329 (defoptimizer (conjugate derive-type
) ((num))
1330 (one-arg-derive-type num
1332 (flet ((most-negative-bound (l h
)
1334 (if (< (type-bound-number l
) (- (type-bound-number h
)))
1336 (set-bound (- (type-bound-number h
)) (consp h
)))))
1337 (most-positive-bound (l h
)
1339 (if (> (type-bound-number h
) (- (type-bound-number l
)))
1341 (set-bound (- (type-bound-number l
)) (consp l
))))))
1342 (if (numeric-type-real-p arg
)
1344 (let ((low (numeric-type-low arg
))
1345 (high (numeric-type-high arg
)))
1346 (let ((new-low (most-negative-bound low high
))
1347 (new-high (most-positive-bound low high
)))
1348 (modified-numeric-type arg
:low new-low
:high new-high
))))))
1351 (defoptimizer (cis derive-type
) ((num))
1352 (one-arg-derive-type num
1354 (sb!c
::specifier-type
1355 `(complex ,(or (numeric-type-format arg
) 'float
))))
1360 ;;;; TRUNCATE, FLOOR, CEILING, and ROUND
1362 (macrolet ((define-frobs (fun ufun
)
1364 (defknown ,ufun
(real) integer
(movable foldable flushable
))
1365 (deftransform ,fun
((x &optional by
)
1367 (constant-arg (member 1))))
1368 '(let ((res (,ufun x
)))
1369 (values res
(- x res
)))))))
1370 (define-frobs truncate %unary-truncate
)
1371 (define-frobs round %unary-round
))
1373 ;;; Convert (TRUNCATE x y) to the obvious implementation. We only want
1374 ;;; this when under certain conditions and let the generic TRUNCATE
1375 ;;; handle the rest. (Note: if Y = 1, the divide and multiply by Y
1376 ;;; should be removed by other DEFTRANSFORMs.)
1377 (deftransform truncate
((x &optional y
)
1378 (float &optional
(or float integer
)))
1379 (let ((defaulted-y (if y
'y
1)))
1380 `(let ((res (%unary-truncate
(/ x
,defaulted-y
))))
1381 (values res
(- x
(* ,defaulted-y res
))))))
1383 (deftransform floor
((number &optional divisor
)
1384 (float &optional
(or integer float
)))
1385 (let ((defaulted-divisor (if divisor
'divisor
1)))
1386 `(multiple-value-bind (tru rem
) (truncate number
,defaulted-divisor
)
1387 (if (and (not (zerop rem
))
1388 (if (minusp ,defaulted-divisor
)
1391 (values (1- tru
) (+ rem
,defaulted-divisor
))
1392 (values tru rem
)))))
1394 (deftransform ceiling
((number &optional divisor
)
1395 (float &optional
(or integer float
)))
1396 (let ((defaulted-divisor (if divisor
'divisor
1)))
1397 `(multiple-value-bind (tru rem
) (truncate number
,defaulted-divisor
)
1398 (if (and (not (zerop rem
))
1399 (if (minusp ,defaulted-divisor
)
1402 (values (1+ tru
) (- rem
,defaulted-divisor
))
1403 (values tru rem
)))))
1405 (defknown %unary-ftruncate
(real) float
(movable foldable flushable
))
1406 (defknown %unary-ftruncate
/single
(single-float) single-float
1407 (movable foldable flushable
))
1408 (defknown %unary-ftruncate
/double
(double-float) double-float
1409 (movable foldable flushable
))
1411 (defun %unary-ftruncate
/single
(x)
1412 (declare (type single-float x
))
1413 (declare (optimize speed
(safety 0)))
1414 (let* ((bits (single-float-bits x
))
1415 (exp (ldb sb
!vm
:single-float-exponent-byte bits
))
1416 (biased (the single-float-exponent
1417 (- exp sb
!vm
:single-float-bias
))))
1418 (declare (type (signed-byte 32) bits
))
1420 ((= exp sb
!vm
:single-float-normal-exponent-max
) x
)
1421 ((<= biased
0) (* x
0f0
))
1422 ((>= biased
(float-digits x
)) x
)
1424 (let ((frac-bits (- (float-digits x
) biased
)))
1425 (setf bits
(logandc2 bits
(- (ash 1 frac-bits
) 1)))
1426 (make-single-float bits
))))))
1428 (defun %unary-ftruncate
/double
(x)
1429 (declare (type double-float x
))
1430 (declare (optimize speed
(safety 0)))
1431 (let* ((high (double-float-high-bits x
))
1432 (low (double-float-low-bits x
))
1433 (exp (ldb sb
!vm
:double-float-exponent-byte high
))
1434 (biased (the double-float-exponent
1435 (- exp sb
!vm
:double-float-bias
))))
1436 (declare (type (signed-byte 32) high
)
1437 (type (unsigned-byte 32) low
))
1439 ((= exp sb
!vm
:double-float-normal-exponent-max
) x
)
1440 ((<= biased
0) (* x
0d0
))
1441 ((>= biased
(float-digits x
)) x
)
1443 (let ((frac-bits (- (float-digits x
) biased
)))
1444 (cond ((< frac-bits
32)
1445 (setf low
(logandc2 low
(- (ash 1 frac-bits
) 1))))
1448 (setf high
(logandc2 high
(- (ash 1 (- frac-bits
32)) 1)))))
1449 (make-double-float high low
))))))
1452 ((def (float-type fun
)
1453 `(deftransform %unary-ftruncate
((x) (,float-type
))
1455 (def single-float %unary-ftruncate
/single
)
1456 (def double-float %unary-ftruncate
/double
))