X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ffloat-tran.lisp;h=681aa48868c8fd2904e340e78ff34f6db506baeb;hb=71d9292d4c2627c4d76b763443be759f95423c2c;hp=1cb39f6654687cee0158bda7ea1680344fa45501;hpb=0a7604d54581d2c846838c26ce6a7993629586fa;p=sbcl.git diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 1cb39f6..681aa48 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -15,8 +15,8 @@ ;;;; coercions -(defknown %single-float (real) single-float (movable foldable flushable)) -(defknown %double-float (real) double-float (movable foldable flushable)) +(defknown %single-float (real) single-float (movable foldable)) +(defknown %double-float (real) double-float (movable foldable)) (deftransform float ((n f) (* single-float) *) '(%single-float n)) @@ -43,6 +43,59 @@ '(,fun num (or state *random-state*))))) (frob %random-single-float single-float) (frob %random-double-float double-float)) + +;;; Mersenne Twister RNG +;;; +;;; FIXME: It's unpleasant to have RANDOM functionality scattered +;;; through the code this way. It would be nice to move this into the +;;; same file as the other RANDOM definitions. +(deftransform random ((num &optional state) + ((integer 1 #.(expt 2 sb!vm::n-word-bits)) &optional *)) + ;; FIXME: I almost conditionalized this as #!+sb-doc. Find some way + ;; 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" + (let ((type (lvar-type num)) + (limit (expt 2 sb!vm::n-word-bits)) + (random-chunk (ecase sb!vm::n-word-bits + (32 'random-chunk) + (64 'sb!kernel::big-random-chunk)))) + (if (numeric-type-p type) + (let ((num-high (numeric-type-high (lvar-type num)))) + (aver num-high) + (cond ((constant-lvar-p num) + ;; Check the worst case sum absolute error for the + ;; random number expectations. + (let ((rem (rem limit num-high))) + (unless (< (/ (* 2 rem (- num-high rem)) + num-high limit) + (expt 2 (- sb!kernel::random-integer-extra-bits))) + (give-up-ir1-transform + "The random number expectations are inaccurate.")) + (if (= num-high limit) + `(,random-chunk (or state *random-state*)) + #!-(or x86 x86-64) + `(rem (,random-chunk (or state *random-state*)) num) + #!+(or x86 x86-64) + ;; Use multiplication, which is faster. + `(values (sb!bignum::%multiply + (,random-chunk (or state *random-state*)) + num))))) + ((> num-high random-fixnum-max) + (give-up-ir1-transform + "The range is too large to ensure an accurate result.")) + #!+(or x86 x86-64) + ((< num-high limit) + `(values (sb!bignum::%multiply + (,random-chunk (or state *random-state*)) + num))) + (t + `(rem (,random-chunk (or state *random-state*)) num)))) + ;; KLUDGE: a relatively conservative treatment, but better + ;; than a bug (reported by PFD sbcl-devel towards the end of + ;; 2004-11. + '(rem (random-chunk (or state *random-state*)) num)))) ;;;; float accessors @@ -233,7 +286,10 @@ (specifier-type `(,',type ,(or lo '*) ,(or hi '*))))) (defoptimizer (,fun derive-type) ((num)) - (one-arg-derive-type num #',aux-name #',fun)))))) + (handler-case + (one-arg-derive-type num #',aux-name #',fun) + (type-error () + nil))))))) (frob %single-float single-float most-negative-single-float most-positive-single-float) (frob %double-float double-float @@ -242,15 +298,29 @@ ;;;; float contagion +(defun safe-ctype-for-single-coercion-p (x) + ;; See comment in SAFE-SINGLE-COERCION-P -- this deals with the same + ;; problem, but in the context of evaluated and compiled (+ ) + ;; giving different result if we fail to check for this. + (or (not (csubtypep x (specifier-type 'integer))) + (csubtypep x (specifier-type `(integer ,most-negative-exactly-single-float-fixnum + ,most-positive-exactly-single-float-fixnum))))) + ;;; 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 efficiency note. (deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node) - `(,(lvar-fun-name (basic-combination-fun node)) - (float x y) y)) + (if (or (not (types-equal-or-intersect (lvar-type y) (specifier-type 'single-float))) + (safe-ctype-for-single-coercion-p (lvar-type x))) + `(,(lvar-fun-name (basic-combination-fun node)) + (float x y) y) + (give-up-ir1-transform))) (deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node) - `(,(lvar-fun-name (basic-combination-fun node)) - x (float y x))) + (if (or (not (types-equal-or-intersect (lvar-type x) (specifier-type 'single-float))) + (safe-ctype-for-single-coercion-p (lvar-type y))) + `(,(lvar-fun-name (basic-combination-fun node)) + x (float y x)) + (give-up-ir1-transform))) (dolist (x '(+ * / -)) (%deftransform x '(function (rational float) *) #'float-contagion-arg1) @@ -566,7 +636,7 @@ (progn ;;; Handle monotonic functions of a single variable whose domain is -;;; possibly part of the real line. ARG is the variable, FCN is the +;;; possibly part of the real line. ARG is the variable, FUN is the ;;; function, and DOMAIN is a specifier that gives the (real) domain ;;; of the function. If ARG is a subset of the DOMAIN, we compute the ;;; bounds directly. Otherwise, we compute the bounds for the @@ -577,8 +647,8 @@ ;;; DOMAIN-LOW and DOMAIN-HIGH. ;;; ;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we -;;; can't compute the bounds using FCN. -(defun elfun-derive-type-simple (arg fcn domain-low domain-high +;;; can't compute the bounds using FUN. +(defun elfun-derive-type-simple (arg fun domain-low domain-high default-low default-high &optional (increasingp t)) (declare (type (or null real) domain-low domain-high)) @@ -602,9 +672,9 @@ ;; Process the intersection. (let* ((low (interval-low intersection)) (high (interval-high intersection)) - (res-lo (or (bound-func fcn (if increasingp low high)) + (res-lo (or (bound-func fun (if increasingp low high)) default-low)) - (res-hi (or (bound-func fcn (if increasingp high low)) + (res-hi (or (bound-func fun (if increasingp high low)) default-high)) (format (case (numeric-type-class arg) ((integer rational) 'single-float) @@ -1183,7 +1253,7 @@ ;;; inputs are union types. #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (progn -(defun trig-derive-type-aux (arg domain fcn +(defun trig-derive-type-aux (arg domain fun &optional def-lo def-hi (increasingp t)) (etypecase arg (numeric-type @@ -1204,8 +1274,8 @@ ;; exactly the same way as the functions themselves do ;; it. (if (csubtypep arg domain) - (let ((res-lo (bound-func fcn (numeric-type-low arg))) - (res-hi (bound-func fcn (numeric-type-high arg)))) + (let ((res-lo (bound-func fun (numeric-type-low arg))) + (res-hi (bound-func fun (numeric-type-high arg)))) (unless increasingp (rotatef res-lo res-hi)) (make-numeric-type