;;;; files for more information.
(in-package "SB!C")
-
-(file-comment
- "$Header$")
\f
;;;; coercions
(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.
;;;
-;;; Optimizers for scale-float. If the float has bounds, new bounds
+;;; 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-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr)
-(progn
-#!+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))))
(two-arg-derive-type f ex #'scale-float-derive-type-aux
#'scale-double-float t))
-;;; toy@rtp.ericsson.se:
-;;;
-;;; Defoptimizers for %single-float and %double-float. This makes the
+;;; DEFOPTIMIZERs for %SINGLE-FLOAT and %DOUBLE-FLOAT. This makes the
;;; 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")))
(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 '*)))))
(one-arg-derive-type num #',aux-name #',fun))))))
(frob %single-float single-float)
(frob %double-float double-float))
-)) ; PROGN PROGN
+) ; PROGN
\f
;;;; float contagion
;;; 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 '(+ * / -))
;;; float (such as 0).
(macrolet ((frob (op)
`(deftransform ,op ((x y) (float rational) * :when :both)
+ "open-code FLOAT to RATIONAL comparison"
(unless (constant-continuation-p y)
(give-up-ir1-transform
- "can't open-code float to rational comparison"))
+ "The RATIONAL value isn't known at compile time."))
(let ((val (continuation-value y)))
(unless (eql (rational (float val)) val)
(give-up-ir1-transform
;;; 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))
(sqrt (real 0.0))))
(destructuring-bind (name type) stuff
(let ((type (specifier-type type)))
- (setf (function-info-derive-type (function-info-or-lose name))
- #'(lambda (call)
- (declare (type combination call))
- (when (csubtypep (continuation-type
- (first (combination-args call)))
- type)
- (specifier-type 'float)))))))
-
-#!-propagate-fun-type
+ (setf (fun-info-derive-type (fun-info-or-lose name))
+ (lambda (call)
+ (declare (type combination call))
+ (when (csubtypep (continuation-type
+ (first (combination-args call)))
+ type)
+ (specifier-type 'float)))))))
+
+#+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 (%sin %cos %tanh %sin-quick %cos-quick)
- (double-float) (double-float -1.0d0 1.0d0)
- (movable foldable flushable))
+ (double-float) (double-float -1.0d0 1.0d0)
+ (movable foldable flushable))
(defknown (%asin %atan)
- (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
- (movable foldable flushable))
+ (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+ (movable foldable flushable))
(defknown (%acos)
- (double-float) (double-float 0.0d0 #.pi)
- (movable foldable flushable))
+ (double-float) (double-float 0.0d0 #.pi)
+ (movable foldable flushable))
(defknown (%cosh)
- (double-float) (double-float 1.0d0)
- (movable foldable flushable))
+ (double-float) (double-float 1.0d0)
+ (movable foldable flushable))
(defknown (%acosh %exp %sqrt)
- (double-float) (double-float 0.0d0)
- (movable foldable flushable))
+ (double-float) (double-float 0.0d0)
+ (movable foldable flushable))
(defknown %expm1
- (double-float) (double-float -1d0)
- (movable foldable flushable))
+ (double-float) (double-float -1d0)
+ (movable foldable flushable))
(defknown (%hypot)
- (double-float double-float) (double-float 0d0)
+ (double-float double-float) (double-float 0d0)
(movable foldable flushable))
(defknown (%pow)
- (double-float double-float) double-float
+ (double-float double-float) double-float
(movable foldable flushable))
(defknown (%atan2)
- (double-float double-float) (double-float #.(- pi) #.pi)
+ (double-float double-float) (double-float #.(- pi) #.pi)
(movable foldable flushable))
(defknown (%scalb)
- (double-float double-float) double-float
+ (double-float double-float) double-float
(movable foldable flushable))
(defknown (%scalbn)
- (double-float (signed-byte 32)) double-float
- (movable foldable flushable))
+ (double-float (signed-byte 32)) double-float
+ (movable foldable flushable))
(defknown (%log1p)
- (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))))
+ (double-float) double-float
+ (movable foldable flushable))
+
+(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)))
(minusp (float-sign arg-hi-val))
(plusp (float-sign arg-hi-val))))))))))
-;;; Elfun-Derive-Type-Simple
-;;;
;;; Handle monotonic functions of a single variable whose domain is
;;; possibly part of the real line. ARG is the variable, FCN is the
;;; function, and DOMAIN is a specifier that gives the (real) domain
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))))
`(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.
;; 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
(interval-expt-< pos y))))))
;;; Compute bounds for (expt x y).
-
(defun interval-expt (x y)
(case (interval-range-info x 1)
('+
;; 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.
(defun merged-interval-expt (x y)
(let* ((x-int (numeric-type->interval x))
(y-int (numeric-type->interval y)))
- (mapcar #'(lambda (type)
- (fixup-interval-expt type x-int y-int x y))
+ (mapcar (lambda (type)
+ (fixup-interval-expt type x-int y-int x y))
(flatten-list (interval-expt x-int y-int)))))
(defun expt-derive-type-aux (x y same-arg)
;; But a positive real to any power is well-defined.
(merged-interval-expt x y))
(t
- ;; A real to some power. The result could be a real
+ ;; a real to some power. The result could be a real
;; or a complex.
(float-or-complex-float-type (numeric-contagion x y)))))))
(defun log-derive-type-aux-2 (x y same-arg)
(let ((log-x (log-derive-type-aux-1 x))
(log-y (log-derive-type-aux-1 y))
- (result '()))
- ;; log-x or log-y might be union types. We need to run through
- ;; the union types ourselves because /-derive-type-aux doesn't.
+ (accumulated-list nil))
+ ;; LOG-X or LOG-Y might be union types. We need to run through
+ ;; the union types ourselves because /-DERIVE-TYPE-AUX doesn't.
(dolist (x-type (prepare-arg-for-derive-type log-x))
(dolist (y-type (prepare-arg-for-derive-type log-y))
- (push (/-derive-type-aux x-type y-type same-arg) result)))
- (setf result (flatten-list result))
- (if (rest result)
- (make-union-type result)
- (first result))))
+ (push (/-derive-type-aux x-type y-type same-arg) accumulated-list)))
+ (apply #'type-union (flatten-list accumulated-list))))
(defoptimizer (log derive-type) ((x &optional y))
(if y
(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)))
;;; Make REALPART and IMAGPART return the appropriate types. This
;;; should help a lot in optimized code.
-
(defun realpart-derive-type-aux (type)
(let ((class (numeric-type-class type))
(format (numeric-type-format 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 (realpart derive-type) ((num))
(one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
-
(defun imagpart-derive-type-aux (type)
(let ((class (numeric-type-class type))
(format (numeric-type-format 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))
(rat-result-p (csubtypep element-type
(specifier-type 'rational))))
(if rat-result-p
- (make-union-type
- (list element-type
- (specifier-type
- `(complex ,(numeric-type-class element-type)))))
+ (type-union element-type
+ (specifier-type
+ `(complex ,(numeric-type-class element-type))))
(make-numeric-type :class (numeric-type-class element-type)
:format (numeric-type-format element-type)
:complexp (if rat-result-p
: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)
(frob single-float)
(frob double-float))
-;;; Here are simple optimizers for sin, cos, and tan. They do not
+;;; Here are simple optimizers for SIN, COS, and TAN. They do not
;;; produce a minimal range for the result; the result is the widest
;;; 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))
(defoptimizer (sin derive-type) ((num))
(one-arg-derive-type
num
- #'(lambda (arg)
- ;; Derive the bounds if the arg is in [-pi/2, pi/2].
- (trig-derive-type-aux
- arg
- (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
- #'sin
- -1 1))
+ (lambda (arg)
+ ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+ (trig-derive-type-aux
+ arg
+ (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+ #'sin
+ -1 1))
#'sin))
(defoptimizer (cos derive-type) ((num))
(one-arg-derive-type
num
- #'(lambda (arg)
- ;; Derive the bounds if the arg is in [0, pi].
- (trig-derive-type-aux arg
- (specifier-type `(float 0d0 ,pi))
- #'cos
- -1 1
- nil))
+ (lambda (arg)
+ ;; Derive the bounds if the arg is in [0, pi].
+ (trig-derive-type-aux arg
+ (specifier-type `(float 0d0 ,pi))
+ #'cos
+ -1 1
+ nil))
#'cos))
(defoptimizer (tan derive-type) ((num))
(one-arg-derive-type
num
- #'(lambda (arg)
- ;; Derive the bounds if the arg is in [-pi/2, pi/2].
- (trig-derive-type-aux arg
- (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
- #'tan
- nil nil))
+ (lambda (arg)
+ ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+ (trig-derive-type-aux arg
+ (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+ #'tan
+ nil nil))
#'tan))
;;; CONJUGATE always returns the same type as the input type.
+;;;
+;;; FIXME: ANSI allows any subtype of REAL for the components of COMPLEX.
+;;; So what if the input type is (COMPLEX (SINGLE-FLOAT 0 1))?
(defoptimizer (conjugate derive-type) ((num))
(continuation-type num))
(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
+\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