X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fsrctran.lisp;h=e666b87d70b4c1414ca06d7a85f9c5625d88c24c;hb=372d68ae1432a96a527c662de3af3bb334808856;hp=90ebeede4ba8a3f4daf6f9c983cb6c2d766978d8;hpb=3254e1b6fb33e4ff5be5f37ba4bbcc34ca151cf7;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 90ebeed..e666b87 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -350,15 +350,20 @@ (defun bound-func (f x) (declare (type function f)) (and x - (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - ;; With these traps masked, we might get things like infinity - ;; or negative infinity returned. Check for this and return - ;; NIL to indicate unbounded. - (let ((y (funcall f (type-bound-number x)))) - (if (and (floatp y) - (float-infinity-p y)) - nil - (set-bound y (consp x))))))) + (handler-case + (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) + ;; With these traps masked, we might get things like infinity + ;; or negative infinity returned. Check for this and return + ;; NIL to indicate unbounded. + (let ((y (funcall f (type-bound-number x)))) + (if (and (floatp y) + (float-infinity-p y)) + nil + (set-bound y (consp x))))) + ;; Some numerical operations will signal SIMPLE-TYPE-ERROR, e.g. + ;; in the course of converting a bignum to a float. Default to + ;; NIL in that case. + (simple-type-error ())))) (defun safe-double-coercion-p (x) (or (typep x 'double-float) @@ -366,30 +371,37 @@ (defun safe-single-coercion-p (x) (or (typep x 'single-float) - ;; Fix for bug 420, and related issues: during type derivation we often - ;; end up deriving types for both - ;; - ;; (some-op ) - ;; and - ;; (some-op (coerce 'single-float) ) - ;; - ;; or other equivalent transformed forms. The problem with this is that - ;; on some platforms like x86 (+ ) is on the machine level - ;; equivalent of - ;; - ;; (coerce (+ (coerce 'double-float) - ;; (coerce 'double-float)) - ;; 'single-float) - ;; - ;; so if the result of (coerce 'single-float) is not exact, the - ;; derived types for the transformed forms will have an empty - ;; intersection -- which in turn means that the compiler will conclude - ;; that the call never returns, and all hell breaks lose when it *does* - ;; return at runtime. (This affects not just +, but other operators are - ;; well.) - (and (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum)) - (integer (,most-positive-exactly-single-float-fixnum) *)))) - (<= most-negative-single-float x most-positive-single-float)))) + (and + ;; Fix for bug 420, and related issues: during type derivation we often + ;; end up deriving types for both + ;; + ;; (some-op ) + ;; and + ;; (some-op (coerce 'single-float) ) + ;; + ;; or other equivalent transformed forms. The problem with this + ;; is that on x86 (+ ) is on the machine level + ;; equivalent of + ;; + ;; (coerce (+ (coerce 'double-float) + ;; (coerce 'double-float)) + ;; 'single-float) + ;; + ;; so if the result of (coerce 'single-float) is not exact, the + ;; derived types for the transformed forms will have an empty + ;; intersection -- which in turn means that the compiler will conclude + ;; that the call never returns, and all hell breaks lose when it *does* + ;; return at runtime. (This affects not just +, but other operators are + ;; well.) + ;; + ;; See also: SAFE-CTYPE-FOR-SINGLE-COERCION-P + ;; + ;; FIXME: If we ever add SSE-support for x86, this conditional needs to + ;; change. + #!+x86 + (not (typep x `(or (integer * (,most-negative-exactly-single-float-fixnum)) + (integer (,most-positive-exactly-single-float-fixnum) *)))) + (<= most-negative-single-float x most-positive-single-float)))) ;;; Apply a binary operator OP to two bounds X and Y. The result is ;;; NIL if either is NIL. Otherwise bound is computed and the result @@ -517,7 +529,7 @@ :high (copy-interval-limit (interval-high x)))) ;;; Given a point P contained in the interval X, split X into two -;;; interval at the point P. If CLOSE-LOWER is T, then the left +;;; intervals at the point P. If CLOSE-LOWER is T, then the left ;;; interval contains P. If CLOSE-UPPER is T, the right interval ;;; contains P. You can specify both to be T or NIL. (defun interval-split (p x &optional close-lower close-upper) @@ -848,9 +860,6 @@ ((zerop (type-bound-number y)) ;; Divide by zero means result is infinity nil) - ((and (numberp x) (zerop x)) - ;; Zero divided by anything is zero. - x) (t (bound-binop / x y))))) (let ((top-range (interval-range-info top)) @@ -967,7 +976,7 @@ ;;; a utility for defining derive-type methods of integer operations. If ;;; the types of both X and Y are integer types, then we compute a new -;;; integer type with bounds determined Fun when applied to X and Y. +;;; integer type with bounds determined by FUN when applied to X and Y. ;;; Otherwise, we use NUMERIC-CONTAGION. (defun derive-integer-type-aux (x y fun) (declare (type function fun)) @@ -2317,7 +2326,7 @@ (if (and divisor-low divisor-high) ;; We know the range of the divisor, and the remainder must be ;; smaller than the divisor. We can tell the sign of the - ;; remainer if we know the sign of the number. + ;; remainder if we know the sign of the number. (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high))))) `(integer ,(if (or (null number-low) (minusp number-low)) @@ -2328,7 +2337,7 @@ divisor-max 0))) ;; The divisor is potentially either very positive or very - ;; negative. Therefore, the remainer is unbounded, but we might + ;; negative. Therefore, the remainder is unbounded, but we might ;; be able to tell something about the sign from the number. `(integer ,(if (and number-low (not (minusp number-low))) ;; The number we are dividing is positive. @@ -3034,6 +3043,19 @@ (reoptimize-component (node-component node) :maybe)) (cut-node (node &aux did-something) (when (and (not (block-delete-p (node-block node))) + (ref-p node) + (constant-p (ref-leaf node))) + (let* ((constant-value (constant-value (ref-leaf node))) + (new-value (if signedp + (mask-signed-field width constant-value) + (ldb (byte width 0) constant-value)))) + (unless (= constant-value new-value) + (change-ref-leaf node (make-constant new-value)) + (setf (lvar-%derived-type (node-lvar node)) (make-values-type :required (list (ctype-of new-value)))) + (setf (block-reoptimize (node-block node)) t) + (reoptimize-component (node-component node) :maybe) + (return-from cut-node t)))) + (when (and (not (block-delete-p (node-block node))) (combination-p node) (eq (basic-combination-kind node) :known)) (let* ((fun-ref (lvar-use (combination-fun node))) @@ -3108,9 +3130,23 @@ (best-modular-version width nil) (when w ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH SIGNEDP). - (cut-to-width x kind width signedp) - (cut-to-width y kind width signedp) - nil ; After fixing above, replace with T. + ;; + ;; FIXME: I think the FIXME (which is from APD) above + ;; implies that CUT-TO-WIDTH should do /everything/ + ;; that's required, including reoptimizing things + ;; itself that it knows are necessary. At the moment, + ;; CUT-TO-WIDTH sets up some new calls with + ;; combination-type :FULL, which later get noticed as + ;; known functions and properly converted. + ;; + ;; We cut to W not WIDTH if SIGNEDP is true, because + ;; signed constant replacement needs to know which bit + ;; in the field is the signed bit. + (let ((xact (cut-to-width x kind (if signedp w width) signedp)) + (yact (cut-to-width y kind (if signedp w width) signedp))) + (declare (ignore xact yact)) + nil) ; After fixing above, replace with T, meaning + ; "don't reoptimize this (LOGAND) node any more". )))))))) (defoptimizer (mask-signed-field optimizer) ((width x) node) @@ -3123,8 +3159,9 @@ (multiple-value-bind (w kind) (best-modular-version width t) (when w - ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND WIDTH T). - (cut-to-width x kind width t) + ;; FIXME: This should be (CUT-TO-WIDTH NODE KIND W T). + ;; [ see comment above in LOGAND optimizer ] + (cut-to-width x kind w t) nil ; After fixing above, replace with T. )))))))) @@ -3835,7 +3872,7 @@ (define-source-transform > (&rest args) (multi-compare '> args nil 'real)) ;;; We cannot do the inversion for >= and <= here, since both ;;; (< NaN X) and (> NaN X) -;;; are false, and we don't have type-inforation available yet. The +;;; are false, and we don't have type-information available yet. The ;;; deftransforms for two-argument versions of >= and <= takes care of ;;; the inversion to > and < when possible. (define-source-transform <= (&rest args) (multi-compare '<= args nil 'real))