(deftransform %double-float ((n) (double-float) * :when :both)
'n)
-;;; not strictly float functions, but primarily useful on floats:
-(macrolet ((frob (fun ufun)
- `(progn
- (defknown ,ufun (real) integer (movable foldable flushable))
- (deftransform ,fun ((x &optional by)
- (* &optional
- (constant-argument (member 1))))
- '(let ((res (,ufun x)))
- (values res (- x res)))))))
- (frob truncate %unary-truncate)
- (frob round %unary-round))
-
;;; RANDOM
(macrolet ((frob (fun type)
`(deftransform random ((num &optional state)
;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM
;; to let me scan for places that I made this mistake and didn't
;; catch myself.
- "use inline (unsigned-byte 32) operations"
+ "use inline (UNSIGNED-BYTE 32) operations"
(let ((num-high (numeric-type-high (continuation-type num))))
(when (null num-high)
(give-up-ir1-transform))
'(%scalbn f ex)
'(scale-double-float f ex)))
-;;; toy@rtp.ericsson.se:
+;;; What is the CROSS-FLOAT-INFINITY-KLUDGE?
+;;;
+;;; SBCL's own implementation of floating point supports floating
+;;; point infinities. Some of the old CMU CL :PROPAGATE-FLOAT-TYPE and
+;;; :PROPAGATE-FUN-TYPE code, like the DEFOPTIMIZERs below, uses this
+;;; floating point support. Thus, we have to avoid running it on the
+;;; cross-compilation host, since we're not guaranteed that the
+;;; cross-compilation host will support floating point infinities.
;;;
+;;; If we wanted to live dangerously, we could conditionalize the code
+;;; with #+(OR SBCL SB-XC) instead. That way, if the cross-compilation
+;;; host happened to be SBCL, we'd be able to run the infinity-using
+;;; code. Pro:
+;;; * SBCL itself gets built with more complete optimization.
+;;; Con:
+;;; * You get a different SBCL depending on what your cross-compilation
+;;; host is.
+;;; So far the pros and cons seem seem to be mostly academic, since
+;;; AFAIK (WHN 2001-08-28) the propagate-foo-type optimizations aren't
+;;; actually important in compiling SBCL itself. If this changes, then
+;;; we have to decide:
+;;; * Go for simplicity, leaving things as they are.
+;;; * Go for performance at the expense of conceptual clarity,
+;;; using #+(OR SBCL SB-XC) and otherwise leaving the build
+;;; process as is.
+;;; * Go for performance at the expense of build time, using
+;;; #+(OR SBCL SB-XC) and also making SBCL do not just
+;;; make-host-1.sh and make-host-2.sh, but a third step
+;;; make-host-3.sh where it builds itself under itself. (Such a
+;;; 3-step build process could also help with other things, e.g.
+;;; using specialized arrays to represent debug information.)
+;;; * Rewrite the code so that it doesn't depend on unportable
+;;; floating point infinities.
+
;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds
;;; are computed for the result, if possible.
-
-#!+propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun scale-float-derive-type-aux (f ex same-arg)
;; zeros.
(set-bound
(handler-case
- (scale-float (bound-value x) n)
+ (scale-float (type-bound-number x) n)
(floating-point-overflow ()
nil))
(consp x))))
;;; FLOAT function return the correct ranges if the input has some
;;; defined range. Quite useful if we want to convert some type of
;;; bounded integer into a float.
-
(macrolet
((frob (fun type)
(let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX")))
;;; Derive the result to be float for argument types in the
;;; appropriate domain.
-#!-propagate-fun-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(dolist (stuff '((asin (real -1.0 1.0))
(acos (real -1.0 1.0))
(acosh (real 1.0))
type)
(specifier-type 'float)))))))
-#!-propagate-fun-type
+#+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (log derive-type) ((x &optional y))
(when (and (csubtypep (continuation-type x)
(specifier-type '(real 0.0)))
(cos %cos %cos-quick)
(tan %tan %tan-quick)))
(destructuring-bind (name prim prim-quick) stuff
+ (declare (ignorable prim-quick))
(deftransform name ((x) '(single-float) '* :eval-name t)
#!+x86 (cond ((csubtypep (continuation-type x)
(specifier-type '(single-float
(float pi x)
(float 0 x)))
-#!+(or propagate-float-type propagate-fun-type)
-(progn
-
;;; The number is of type REAL.
-#!-sb-fluid (declaim (inline numeric-type-real-p))
(defun numeric-type-real-p (type)
(and (numeric-type-p type)
(eq (numeric-type-complexp type) :real)))
(list (coerce (car bound) type))
(coerce bound type))))
-) ; PROGN
-
-#!+propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
;;;; optimizers for elementary functions
(float-type (or format 'float)))
(specifier-type `(complex ,float-type))))
-;;; Compute a specifier like '(or float (complex float)), except float
+;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
;;; should be the right kind of float. Allow bounds for the float
;;; part too.
(defun float-or-complex-float-type (arg &optional lo hi)
;;; Test whether the numeric-type ARG is within in domain specified by
;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
-;;; be distinct as for the :negative-zero-is-not-zero feature. With
-;;; the :negative-zero-is-not-zero feature this could be handled by
+;;; be distinct as for the :NEGATIVE-ZERO-IS-NOT-ZERO feature. With
+;;; the :NEGATIVE-ZERO-IS-NOT-ZERO feature this could be handled by
;;; the numeric subtype code in type.lisp.
(defun domain-subtypep (arg domain-low domain-high)
(declare (type numeric-type arg)
(type (or real null) domain-low domain-high))
(let* ((arg-lo (numeric-type-low arg))
- (arg-lo-val (bound-value arg-lo))
+ (arg-lo-val (type-bound-number arg-lo))
(arg-hi (numeric-type-high arg))
- (arg-hi-val (bound-value arg-hi)))
+ (arg-hi-val (type-bound-number arg-hi)))
;; Check that the ARG bounds are correctly canonicalized.
(when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
(minusp (float-sign arg-lo-val)))
default-low))
(res-hi (or (bound-func fcn (if increasingp high low))
default-high))
- ;; Result specifier type.
(format (case (numeric-type-class arg)
((integer rational) 'single-float)
(t (numeric-type-format arg))))
;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
;; obviously non-negative. We just have to be careful for
;; infinite bounds (given by nil).
- (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-low y))))
- (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-high y)))))
+ (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-low y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 1) :high hi))))
('-
;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
;; obviously [0, 1]. However, underflow (nil) means 0 is the
;; result.
- (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-low y))))
- (hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-high y)))))
+ (let ((lo (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-low y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
(t
;; Split the interval in half.
;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
;; obviously [0, 1]. We just have to be careful for infinite bounds
;; (given by nil).
- (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-high y))))
- (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-low y)))))
+ (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-high y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-low y)))))
(list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
('-
;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
;; obviously [1, inf].
- (let ((hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-low y))))
- (lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-high y)))))
+ (let ((hi (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-low y))))
+ (lo (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 1) :high hi))))
(t
;; Split the interval in half
;; Figure out what the return type should be, given the argument
;; types and bounds and the result type and bounds.
(cond ((csubtypep x-type (specifier-type 'integer))
- ;; An integer to some power. Cases to consider:
+ ;; an integer to some power
(case (numeric-type-class y-type)
(integer
;; Positive integer to an integer power is either an
(let ((lo (or (interval-low bnd) '*))
(hi (or (interval-high bnd) '*)))
(if (and (interval-low y-int)
- (>= (bound-value (interval-low y-int)) 0))
+ (>= (type-bound-number (interval-low y-int)) 0))
(specifier-type `(integer ,lo ,hi))
(specifier-type `(rational ,lo ,hi)))))
(rational
(let* ((lo (interval-low bnd))
(hi (interval-high bnd))
(int-lo (if lo
- (floor (bound-value lo))
+ (floor (type-bound-number lo))
'*))
(int-hi (if hi
- (ceiling (bound-value hi))
+ (ceiling (type-bound-number hi))
'*))
(f-lo (if lo
(bound-func #'float lo)
(specifier-type `(or (rational ,int-lo ,int-hi)
(single-float ,f-lo, f-hi)))))
(float
- ;; Positive integer to a float power is a float.
- (let ((res (copy-numeric-type y-type)))
- (setf (numeric-type-low res) (interval-low bnd))
- (setf (numeric-type-high res) (interval-high bnd))
- res))
+ ;; A positive integer to a float power is a float.
+ (modified-numeric-type y-type
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
(t
- ;; Positive integer to a number is a number (for now).
- (specifier-type 'number)))
- )
+ ;; A positive integer to a number is a number (for now).
+ (specifier-type 'number))))
((csubtypep x-type (specifier-type 'rational))
;; a rational to some power
(case (numeric-type-class y-type)
(integer
- ;; Positive rational to an integer power is always a rational.
+ ;; A positive rational to an integer power is always a rational.
(specifier-type `(rational ,(or (interval-low bnd) '*)
,(or (interval-high bnd) '*))))
(rational
- ;; Positive rational to rational power is either a rational
+ ;; A positive rational to rational power is either a rational
;; or a single-float.
(let* ((lo (interval-low bnd))
(hi (interval-high bnd))
(int-lo (if lo
- (floor (bound-value lo))
+ (floor (type-bound-number lo))
'*))
(int-hi (if hi
- (ceiling (bound-value hi))
+ (ceiling (type-bound-number hi))
'*))
(f-lo (if lo
(bound-func #'float lo)
(specifier-type `(or (rational ,int-lo ,int-hi)
(single-float ,f-lo, f-hi)))))
(float
- ;; Positive rational to a float power is a float.
- (let ((res (copy-numeric-type y-type)))
- (setf (numeric-type-low res) (interval-low bnd))
- (setf (numeric-type-high res) (interval-high bnd))
- res))
+ ;; A positive rational to a float power is a float.
+ (modified-numeric-type y-type
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
(t
- ;; Positive rational to a number is a number (for now).
- (specifier-type 'number)))
- )
+ ;; A positive rational to a number is a number (for now).
+ (specifier-type 'number))))
((csubtypep x-type (specifier-type 'float))
;; a float to some power
(case (numeric-type-class y-type)
((or integer rational)
- ;; Positive float to an integer or rational power is
+ ;; A positive float to an integer or rational power is
;; always a float.
(make-numeric-type
:class 'float
:low (interval-low bnd)
:high (interval-high bnd)))
(float
- ;; Positive float to a float power is a float of the higher type.
+ ;; A positive float to a float power is a float of the
+ ;; higher type.
(make-numeric-type
:class 'float
:format (float-format-max (numeric-type-format x-type)
:low (interval-low bnd)
:high (interval-high bnd)))
(t
- ;; Positive float to a number is a number (for now)
+ ;; A positive float to a number is a number (for now)
(specifier-type 'number))))
(t
;; A number to some power is a number.
(let ((result-type (numeric-contagion y x)))
(cond ((and (numeric-type-real-p x)
(numeric-type-real-p y))
- (let* ((format (case (numeric-type-class result-type)
+ (let* (;; FIXME: This expression for FORMAT seems to
+ ;; appear multiple times, and should be factored out.
+ (format (case (numeric-type-class result-type)
((integer rational) 'single-float)
(t (numeric-type-format result-type))))
(bound-format (or format 'float)))
:complexp :real
:low (numeric-type-low type)
:high (numeric-type-high type))))))
-#!+(or propagate-fun-type propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (realpart derive-type) ((num))
(one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
(defun imagpart-derive-type-aux (type)
:complexp :real
:low (numeric-type-low type)
:high (numeric-type-high type))))))
-#!+(or propagate-fun-type propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (imagpart derive-type) ((num))
(one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
:complex))))
(specifier-type 'complex)))
-#!+(or propagate-fun-type propagate-float-type)
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defoptimizer (complex derive-type) ((re &optional im))
(if im
(two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex)
;;; possible answer. This gets around the problem of doing range
;;; reduction correctly but still provides useful results when the
;;; inputs are union types.
-#!+propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun trig-derive-type-aux (arg domain fcn
&optional def-lo def-hi (increasingp t))
#'cis))
) ; PROGN
+\f
+;;;; TRUNCATE, FLOOR, CEILING, and ROUND
+
+(macrolet ((define-frobs (fun ufun)
+ `(progn
+ (defknown ,ufun (real) integer (movable foldable flushable))
+ (deftransform ,fun ((x &optional by)
+ (* &optional
+ (constant-argument (member 1))))
+ '(let ((res (,ufun x)))
+ (values res (- x res)))))))
+ (define-frobs truncate %unary-truncate)
+ (define-frobs round %unary-round))
+
+;;; Convert (TRUNCATE x y) to the obvious implementation. We only want
+;;; this when under certain conditions and let the generic TRUNCATE
+;;; handle the rest. (Note: if Y = 1, the divide and multiply by Y
+;;; should be removed by other DEFTRANSFORMs.)
+(deftransform truncate ((x &optional y)
+ (float &optional (or float integer)))
+ (let ((defaulted-y (if y 'y 1)))
+ `(let ((res (%unary-truncate (/ x ,defaulted-y))))
+ (values res (- x (* ,defaulted-y res))))))
+
+(deftransform floor ((number &optional divisor)
+ (float &optional (or integer float)))
+ (let ((defaulted-divisor (if divisor 'divisor 1)))
+ `(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
+ (if (and (not (zerop rem))
+ (if (minusp ,defaulted-divisor)
+ (plusp number)
+ (minusp number)))
+ (values (1- tru) (+ rem ,defaulted-divisor))
+ (values tru rem)))))
+
+(deftransform ceiling ((number &optional divisor)
+ (float &optional (or integer float)))
+ (let ((defaulted-divisor (if divisor 'divisor 1)))
+ `(multiple-value-bind (tru rem) (truncate number ,defaulted-divisor)
+ (if (and (not (zerop rem))
+ (if (minusp ,defaulted-divisor)
+ (minusp number)
+ (plusp number)))
+ (values (1+ tru) (- rem ,defaulted-divisor))
+ (values tru rem)))))