X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=d1d30051f6dad3a28427466c1452aa235415027d;hb=104ee7ee303efa16e415f5e75df635ac54dba733;hp=bc7a1cd6508d3614cae6082552abbbe17170ea6b;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index bc7a1cd..d1d3005 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -30,18 +30,6 @@ (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) @@ -166,8 +154,7 @@ (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))) @@ -178,9 +165,43 @@ '(%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) @@ -229,11 +250,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 '*))))) @@ -247,12 +268,12 @@ ;;; 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 '(+ * / -)) @@ -290,7 +311,7 @@ ;;; 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)) @@ -298,7 +319,7 @@ (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 @@ -306,7 +327,7 @@ 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))) @@ -369,59 +390,61 @@ (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-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 - (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-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)) @@ -467,11 +490,7 @@ (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))) @@ -484,9 +503,7 @@ (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 @@ -632,11 +649,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. @@ -1021,7 +1038,7 @@ :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) @@ -1045,7 +1062,7 @@ :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)) @@ -1087,7 +1104,7 @@ :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) @@ -1170,7 +1187,7 @@ ;;; 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)) @@ -1254,9 +1271,54 @@ (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)))))