(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))
(deftransform scale-float ((f ex) (single-float *) * :when :both)
(if (and #!+x86 t #!-x86 nil
(csubtypep (continuation-type ex)
- (specifier-type '(signed-byte 32)))
- (not (byte-compiling)))
+ (specifier-type '(signed-byte 32))))
'(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
'(scale-single-float f ex)))
'(%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")))
;;; Do some stuff to recognize when the loser is doing mixed float and
;;; rational arithmetic, or different float types, and fix it up. If
-;;; we don't, he won't even get so much as an efficency note.
+;;; we don't, he won't even get so much as an efficiency note.
(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
- `(,(continuation-function-name (basic-combination-fun node))
+ `(,(continuation-fun-name (basic-combination-fun node))
(float x y) y))
(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
- `(,(continuation-function-name (basic-combination-fun node))
+ `(,(continuation-fun-name (basic-combination-fun node))
x (float y x)))
(dolist (x '(+ * / -))
;;; 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)))
(double-float) double-float
(movable foldable flushable))
-(dolist (stuff '((exp %exp *)
- (log %log float)
- (sqrt %sqrt float)
- (asin %asin float)
- (acos %acos float)
- (atan %atan *)
- (sinh %sinh *)
- (cosh %cosh *)
- (tanh %tanh *)
- (asinh %asinh *)
- (acosh %acosh float)
- (atanh %atanh float)))
- (destructuring-bind (name prim rtype) stuff
- (deftransform name ((x) '(single-float) rtype :eval-name t)
- `(coerce (,prim (coerce x 'double-float)) 'single-float))
- (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
- `(,prim x))))
+(macrolet ((def-frob (name prim rtype)
+ `(progn
+ (deftransform ,name ((x) (single-float) ,rtype)
+ `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+ (deftransform ,name ((x) (double-float) ,rtype :when :both)
+ `(,',prim x)))))
+ (def-frob exp %exp *)
+ (def-frob log %log float)
+ (def-frob sqrt %sqrt float)
+ (def-frob asin %asin float)
+ (def-frob acos %acos float)
+ (def-frob atan %atan *)
+ (def-frob sinh %sinh *)
+ (def-frob cosh %cosh *)
+ (def-frob tanh %tanh *)
+ (def-frob asinh %asinh *)
+ (def-frob acosh %acosh float)
+ (def-frob atanh %atanh float))
;;; The argument range is limited on the x86 FP trig. functions. A
;;; post-test can detect a failure (and load a suitable result), but
;;; this test is avoided if possible.
-(dolist (stuff '((sin %sin %sin-quick)
- (cos %cos %cos-quick)
- (tan %tan %tan-quick)))
- (destructuring-bind (name prim prim-quick) stuff
- (deftransform name ((x) '(single-float) '* :eval-name t)
- #!+x86 (cond ((csubtypep (continuation-type x)
- (specifier-type '(single-float
- (#.(- (expt 2f0 64)))
- (#.(expt 2f0 64)))))
- `(coerce (,prim-quick (coerce x 'double-float))
- 'single-float))
- (t
- (compiler-note
- "unable to avoid inline argument range check~@
- because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
- `(coerce (,prim (coerce x 'double-float)) 'single-float)))
- #!-x86 `(coerce (,prim (coerce x 'double-float)) 'single-float))
- (deftransform name ((x) '(double-float) '* :eval-name t :when :both)
- #!+x86 (cond ((csubtypep (continuation-type x)
- (specifier-type '(double-float
- (#.(- (expt 2d0 64)))
- (#.(expt 2d0 64)))))
- `(,prim-quick x))
- (t
- (compiler-note
- "unable to avoid inline argument range check~@
- because the argument range (~S) was not within 2^64"
- (type-specifier (continuation-type x)))
- `(,prim x)))
- #!-x86 `(,prim x))))
+(macrolet ((def-frob (name prim prim-quick)
+ (declare (ignorable prim-quick))
+ `(progn
+ (deftransform ,name ((x) (single-float) *)
+ #!+x86 (cond ((csubtypep (continuation-type x)
+ (specifier-type '(single-float
+ (#.(- (expt 2f0 64)))
+ (#.(expt 2f0 64)))))
+ `(coerce (,',prim-quick (coerce x 'double-float))
+ 'single-float))
+ (t
+ (compiler-note
+ "unable to avoid inline argument range check~@
+ because the argument range (~S) was not within 2^64"
+ (type-specifier (continuation-type x)))
+ `(coerce (,',prim (coerce x 'double-float)) 'single-float)))
+ #!-x86 `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+ (deftransform ,name ((x) (double-float) * :when :both)
+ #!+x86 (cond ((csubtypep (continuation-type x)
+ (specifier-type '(double-float
+ (#.(- (expt 2d0 64)))
+ (#.(expt 2d0 64)))))
+ `(,',prim-quick x))
+ (t
+ (compiler-note
+ "unable to avoid inline argument range check~@
+ because the argument range (~S) was not within 2^64"
+ (type-specifier (continuation-type x)))
+ `(,',prim x)))
+ #!-x86 `(,',prim x)))))
+ (def-frob sin %sin %sin-quick)
+ (def-frob cos %cos %cos-quick)
+ (def-frob tan %tan %tan-quick))
(deftransform atan ((x y) (single-float single-float) *)
`(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-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)))))
projects / sbcl.git / blobdiff