(defknown %single-float (real) single-float (movable foldable flushable))
(defknown %double-float (real) double-float (movable foldable flushable))
-(deftransform float ((n &optional f) (* &optional single-float) * :when :both)
+(deftransform float ((n &optional f) (* &optional single-float) *)
'(%single-float n))
-(deftransform float ((n f) (* double-float) * :when :both)
+(deftransform float ((n f) (* double-float) *)
'(%double-float n))
-(deftransform %single-float ((n) (single-float) * :when :both)
+(deftransform %single-float ((n) (single-float) *)
'n)
-(deftransform %double-float ((n) (double-float) * :when :both)
+(deftransform %double-float ((n) (double-float) *)
'n)
;;; RANDOM
(macrolet ((frob (fun type)
`(deftransform random ((num &optional state)
- (,type &optional *) *
- :when :both)
+ (,type &optional *) *)
"Use inline float operations."
'(,fun num (or state *random-state*)))))
(frob %random-single-float single-float)
(defknown scale-double-float (double-float fixnum) double-float
(movable foldable flushable))
-(deftransform decode-float ((x) (single-float) * :when :both)
+(deftransform decode-float ((x) (single-float) *)
'(decode-single-float x))
-(deftransform decode-float ((x) (double-float) * :when :both)
+(deftransform decode-float ((x) (double-float) *)
'(decode-double-float x))
-(deftransform integer-decode-float ((x) (single-float) * :when :both)
+(deftransform integer-decode-float ((x) (single-float) *)
'(integer-decode-single-float x))
-(deftransform integer-decode-float ((x) (double-float) * :when :both)
+(deftransform integer-decode-float ((x) (double-float) *)
'(integer-decode-double-float x))
-(deftransform scale-float ((f ex) (single-float *) * :when :both)
+(deftransform scale-float ((f ex) (single-float *) *)
(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)))
-(deftransform scale-float ((f ex) (double-float *) * :when :both)
+(deftransform scale-float ((f ex) (double-float *) *)
(if (and #!+x86 t #!-x86 nil
(csubtypep (continuation-type ex)
(specifier-type '(signed-byte 32))))
'(%scalbn f ex)
'(scale-double-float f ex)))
+;;; 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.
-#!+sb-propagate-float-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
(defun scale-float-derive-type-aux (f ex same-arg)
(defun ,aux-name (num)
;; When converting a number to a float, the limits are
;; the same.
- (let* ((lo (bound-func #'(lambda (x)
- (coerce x ',type))
+ (let* ((lo (bound-func (lambda (x)
+ (coerce x ',type))
(numeric-type-low num)))
- (hi (bound-func #'(lambda (x)
- (coerce x ',type))
+ (hi (bound-func (lambda (x)
+ (coerce x ',type))
(numeric-type-high num))))
(specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
;;; 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 '(+ * / -))
;;; do it for any rational that has a precise representation as a
;;; float (such as 0).
(macrolet ((frob (op)
- `(deftransform ,op ((x y) (float rational) * :when :both)
+ `(deftransform ,op ((x y) (float rational) *)
"open-code FLOAT to RATIONAL comparison"
(unless (constant-continuation-p y)
(give-up-ir1-transform
;;; Derive the result to be float for argument types in the
;;; appropriate domain.
-#!-sb-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))
(sqrt (real 0.0))))
(destructuring-bind (name type) stuff
(let ((type (specifier-type type)))
- (setf (function-info-derive-type (function-info-or-lose name))
+ (setf (fun-info-derive-type (fun-info-or-lose name))
(lambda (call)
(declare (type combination call))
(when (csubtypep (continuation-type
type)
(specifier-type 'float)))))))
-#!-sb-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)))
(movable foldable flushable))
(defknown (%asin %atan)
- (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+ (double-float)
+ (double-float #.(coerce (- (/ pi 2)) 'double-float)
+ #.(coerce (/ pi 2) 'double-float))
(movable foldable flushable))
(defknown (%acos)
- (double-float) (double-float 0.0d0 #.pi)
+ (double-float) (double-float 0.0d0 #.(coerce pi 'double-float))
(movable foldable flushable))
(defknown (%cosh)
(movable foldable flushable))
(defknown (%atan2)
- (double-float double-float) (double-float #.(- pi) #.pi)
+ (double-float double-float)
+ (double-float #.(coerce (- pi) 'double-float)
+ #.(coerce pi 'double-float))
(movable foldable flushable))
(defknown (%scalb)
(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 (name prim rtype)
+ `(progn
+ (deftransform ,name ((x) (single-float) ,rtype)
+ `(coerce (,',prim (coerce x 'double-float)) 'single-float))
+ (deftransform ,name ((x) (double-float) ,rtype)
+ `(,',prim x)))))
+ (def exp %exp *)
+ (def log %log float)
+ (def sqrt %sqrt float)
+ (def asin %asin float)
+ (def acos %acos float)
+ (def atan %atan *)
+ (def sinh %sinh *)
+ (def cosh %cosh *)
+ (def tanh %tanh *)
+ (def asinh %asinh *)
+ (def acosh %acosh float)
+ (def 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
- (declare (ignorable prim-quick))
- (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 (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) *)
+ #!+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 sin %sin %sin-quick)
+ (def cos %cos %cos-quick)
+ (def tan %tan %tan-quick))
(deftransform atan ((x y) (single-float single-float) *)
`(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float))
'single-float))
-(deftransform atan ((x y) (double-float double-float) * :when :both)
+(deftransform atan ((x y) (double-float double-float) *)
`(%atan2 x y))
(deftransform expt ((x y) ((single-float 0f0) single-float) *)
`(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
'single-float))
-(deftransform expt ((x y) ((double-float 0d0) double-float) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) double-float) *)
`(%pow x y))
(deftransform expt ((x y) ((single-float 0f0) (signed-byte 32)) *)
`(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
'single-float))
-(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) * :when :both)
+(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) *)
`(%pow x (coerce y 'double-float)))
;;; ANSI says log with base zero returns zero.
\f
;;; Handle some simple transformations.
-(deftransform abs ((x) ((complex double-float)) double-float :when :both)
+(deftransform abs ((x) ((complex double-float)) double-float)
'(%hypot (realpart x) (imagpart x)))
(deftransform abs ((x) ((complex single-float)) single-float)
(coerce (imagpart x) 'double-float))
'single-float))
-(deftransform phase ((x) ((complex double-float)) double-float :when :both)
+(deftransform phase ((x) ((complex double-float)) double-float)
'(%atan2 (imagpart x) (realpart x)))
(deftransform phase ((x) ((complex single-float)) single-float)
(coerce (realpart x) 'double-float))
'single-float))
-(deftransform phase ((x) ((float)) float :when :both)
+(deftransform phase ((x) ((float)) float)
'(if (minusp (float-sign x))
(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
-
-#!+sb-propagate-fun-type
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(progn
;;;; optimizers for elementary functions
(specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
(complex ,float-type)))))
+) ; PROGN
+
+(eval-when (:compile-toplevel :execute)
+ ;; So the problem with this hack is that it's actually broken. If
+ ;; the host does not have long floats, then setting *R-D-F-F* to
+ ;; LONG-FLOAT doesn't actually buy us anything. FIXME.
+ (setf *read-default-float-format*
+ #!+long-float 'long-float #!-long-float 'double-float))
;;; 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
-;;; the numeric subtype code in type.lisp.
+;;; be distinct.
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(defun domain-subtypep (arg domain-low domain-high)
(declare (type numeric-type arg)
(type (or real null) domain-low domain-high))
(when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
(minusp (float-sign arg-lo-val)))
(compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo)
- (setq arg-lo '(0l0) arg-lo-val 0l0))
+ (setq arg-lo '(0e0) arg-lo-val 0e0))
(when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
(plusp (float-sign arg-hi-val)))
(compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi)
- (setq arg-hi '(-0l0) arg-hi-val -0l0))
+ (setq arg-hi `(,(ecase *read-default-float-format*
+ (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+ #!+long-float
+ (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))
+ arg-hi-val (ecase *read-default-float-format*
+ (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+ #!+long-float
+ (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))))
(and (or (null domain-low)
(and arg-lo (>= arg-lo-val domain-low)
(not (and (zerop domain-low) (floatp domain-low)
(if (consp arg-hi)
(minusp (float-sign arg-hi-val))
(plusp (float-sign arg-hi-val))))))))))
+(eval-when (:compile-toplevel :execute)
+ (setf *read-default-float-format* 'single-float))
+
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+(progn
;;; Handle monotonic functions of a single variable whose domain is
;;; possibly part of the real line. ARG is the variable, FCN is the
;;; result, which occurs for the parts of ARG not in the DOMAIN.
;;;
;;; Negative and positive zero are considered distinct within
-;;; DOMAIN-LOW and DOMAIN-HIGH, as for the :negative-zero-is-not-zero
-;;; feature.
+;;; DOMAIN-LOW and DOMAIN-HIGH.
;;;
;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
;;; can't compute the bounds using FCN.
`(defoptimizer (,name derive-type) ((,num))
(one-arg-derive-type
,num
- #'(lambda (arg)
- (elfun-derive-type-simple arg #',name
- ,domain-low ,domain-high
- ,def-low-bnd ,def-high-bnd
- ,increasingp))
+ (lambda (arg)
+ (elfun-derive-type-simple arg #',name
+ ,domain-low ,domain-high
+ ,def-low-bnd ,def-high-bnd
+ ,increasingp))
#',name)))))
;; These functions are easy because they are defined for the whole
;; real line.
(frob atanh -1d0 1d0 -1 1)
;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
;; includes -0.0.
- (frob sqrt -0d0 nil 0 nil))
+ (frob sqrt (load-time-value (make-unportable-float :double-float-negative-zero)) nil 0 nil))
;;; Compute bounds for (expt x y). This should be easy since (expt x
;;; y) = (exp (* y (log x))). However, computations done this way
:complexp :real
:low (numeric-type-low type)
:high (numeric-type-high type))))))
-#!+(or sb-propagate-fun-type sb-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 sb-propagate-fun-type sb-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 sb-propagate-fun-type sb-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.
-#!+sb-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))
(defoptimizer (cis derive-type) ((num))
(one-arg-derive-type num
- #'(lambda (arg)
- (sb!c::specifier-type
- `(complex ,(or (numeric-type-format arg) 'float))))
+ (lambda (arg)
+ (sb!c::specifier-type
+ `(complex ,(or (numeric-type-format arg) 'float))))
#'cis))
) ; PROGN
(defknown ,ufun (real) integer (movable foldable flushable))
(deftransform ,fun ((x &optional by)
(* &optional
- (constant-argument (member 1))))
+ (constant-arg (member 1))))
'(let ((res (,ufun x)))
(values res (- x res)))))))
(define-frobs truncate %unary-truncate)