X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=b0e652a88cfa0363574a6b68c87f1175fa760396;hb=148e3820ad314a9b59d0133c1d60eaac4af9118b;hp=f3d252eac9dae7c2df85ea6f79b89802d5596cf1;hpb=0979026ea99240e9a5cdda0b5580bbdc8f7b00d7;p=sbcl.git diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index f3d252e..b0e652a 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -18,35 +18,22 @@ (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) -;;; 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) - (,type &optional *) * - :when :both) + (,type &optional *) *) "Use inline float operations." '(,fun num (or state *random-state*))))) (frob %random-single-float single-float) @@ -63,7 +50,7 @@ ;; 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)) @@ -151,41 +138,69 @@ (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))) -;;; 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) @@ -196,7 +211,7 @@ ;; zeros. (set-bound (handler-case - (scale-float (bound-value x) n) + (scale-float (type-bound-number x) n) (floating-point-overflow () nil)) (consp x)))) @@ -223,13 +238,10 @@ (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"))) @@ -237,11 +249,11 @@ (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 '*))))) @@ -249,18 +261,18 @@ (one-arg-derive-type num #',aux-name #',fun)))))) (frob %single-float single-float) (frob %double-float double-float)) -)) ; PROGN PROGN +) ; PROGN ;;;; 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 '(+ * / -)) @@ -279,10 +291,11 @@ ;;; 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 - "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 @@ -297,7 +310,7 @@ ;;; 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)) @@ -305,15 +318,15 @@ (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))) @@ -329,121 +342,128 @@ (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 #.(coerce (- (/ pi 2)) 'double-float) + #.(coerce (/ pi 2) 'double-float)) + (movable foldable flushable)) (defknown (%acos) - (double-float) (double-float 0.0d0 #.pi) - (movable foldable flushable)) + (double-float) (double-float 0.0d0 #.(coerce pi 'double-float)) + (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 #.(coerce (- pi) 'double-float) + #.(coerce pi 'double-float)) (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 (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 - (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. @@ -452,7 +472,7 @@ ;;; 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) @@ -460,7 +480,7 @@ (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) @@ -468,16 +488,12 @@ (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))) @@ -490,9 +506,7 @@ (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 @@ -510,7 +524,7 @@ (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) @@ -526,16 +540,16 @@ ;;; 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))) @@ -562,8 +576,6 @@ (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 @@ -608,7 +620,6 @@ 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)))) @@ -641,11 +652,11 @@ `(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. @@ -682,19 +693,19 @@ ;; 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. @@ -713,18 +724,18 @@ ;; 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 @@ -744,7 +755,6 @@ (interval-expt-< pos y)))))) ;;; Compute bounds for (expt x y). - (defun interval-expt (x y) (case (interval-range-info x 1) ('+ @@ -764,7 +774,7 @@ ;; 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 @@ -772,7 +782,7 @@ (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 @@ -781,10 +791,10 @@ (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) @@ -795,32 +805,30 @@ (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) @@ -831,20 +839,18 @@ (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 @@ -852,7 +858,8 @@ :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) @@ -860,7 +867,7 @@ :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. @@ -869,8 +876,8 @@ (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) @@ -890,7 +897,7 @@ ;; 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))))))) @@ -905,16 +912,13 @@ (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-or-something 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 @@ -930,7 +934,9 @@ (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))) @@ -1015,7 +1021,6 @@ ;;; 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))) @@ -1036,11 +1041,9 @@ :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))) @@ -1062,8 +1065,7 @@ :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)) @@ -1095,10 +1097,9 @@ (rat-result-p (csubtypep element-type (specifier-type 'rational)))) (if rat-result-p - (make-union-type-or-something - (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 @@ -1106,7 +1107,7 @@ :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) @@ -1184,13 +1185,12 @@ (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)) @@ -1233,47 +1233,95 @@ (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 + +;;;; 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-arg (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)))))