;;; toy@rtp.ericsson.se:
;;;
-;;; Optimizers for scale-float. If the float has bounds, new bounds
+;;; 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
(progn
(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.
(one-arg-derive-type num #',aux-name #',fun))))))
(frob %single-float single-float)
(frob %double-float double-float))
-)) ; PROGN PROGN
+) ; PROGN
\f
;;;; float contagion
;;; 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
(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)))))))
+ (lambda (call)
+ (declare (type combination call))
+ (when (csubtypep (continuation-type
+ (first (combination-args call)))
+ type)
+ (specifier-type 'float)))))))
#!-propagate-fun-type
(defoptimizer (log derive-type) ((x &optional y))
(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))
+ (double-float) double-float
+ (movable foldable flushable))
(dolist (stuff '((exp %exp *)
(log %log float)
(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
(interval-expt-< pos y))))))
;;; Compute bounds for (expt x y).
-
(defun interval-expt (x y)
(case (interval-range-info x 1)
('+
(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
;;; 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)
(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)
(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
(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
(progn
(defun trig-derive-type-aux (arg domain fcn
(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))
projects / sbcl.git / blobdiff