(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)
(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)))
+;;; 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)
;;; 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.
-#!-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))
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)))
(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 sb-propagate-float-type sb-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
: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))
#'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