(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)
(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 <int> <single>)
- ;; and
- ;; (some-op (coerce <int> 'single-float) <single>)
- ;;
- ;; or other equivalent transformed forms. The problem with this is that
- ;; on some platforms like x86 (+ <int> <single>) is on the machine level
- ;; equivalent of
- ;;
- ;; (coerce (+ (coerce <int> 'double-float)
- ;; (coerce <single> 'double-float))
- ;; 'single-float)
- ;;
- ;; so if the result of (coerce <int> '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 <int> <single>)
+ ;; and
+ ;; (some-op (coerce <int> 'single-float) <single>)
+ ;;
+ ;; or other equivalent transformed forms. The problem with this
+ ;; is that on x86 (+ <int> <single>) is on the machine level
+ ;; equivalent of
+ ;;
+ ;; (coerce (+ (coerce <int> 'double-float)
+ ;; (coerce <single> 'double-float))
+ ;; 'single-float)
+ ;;
+ ;; so if the result of (coerce <int> '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
((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))
;;; Integers using Multiplication", 1994 by Torbj\"{o}rn Granlund and
;;; Peter L. Montgomery, Figures 4.2 and 6.2, modified to exclude the
;;; case of division by powers of two.
+;;; The algorithm includes an adaptive precision argument. Use it, since
+;;; we often have sub-word value ranges. Careful, in this case, we need
+;;; p s.t 2^p > n, not the ceiling of the binary log.
+;;; Also, for some reason, the paper prefers shifting to masking. Mask
+;;; instead. Masking is equivalent to shifting right, then left again;
+;;; all the intermediate values are still words, so we just have to shift
+;;; right a bit more to compensate, at the end.
+;;;
;;; The following two examples show an average case and the worst case
;;; with respect to the complexity of the generated expression, under
;;; a word size of 64 bits:
;;;
-;;; (UNSIGNED-DIV-TRANSFORMER 10) ->
-;;; (ASH (%MULTIPLY (ASH X 0) 14757395258967641293) -3)
+;;; (UNSIGNED-DIV-TRANSFORMER 10 MOST-POSITIVE-WORD) ->
+;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
;;;
-;;; (UNSIGNED-DIV-TRANSFORMER 7) ->
+;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
;;; (LET* ((NUM X)
;;; (T1 (%MULTIPLY NUM 2635249153387078803)))
;;; (ASH (LDB (BYTE 64 0)
;;; -1)))
;;; -2))
;;;
-(defun gen-unsigned-div-by-constant-expr (y)
- (declare (type (integer 3 #.most-positive-word) y))
+(defun gen-unsigned-div-by-constant-expr (y max-x)
+ (declare (type (integer 3 #.most-positive-word) y)
+ (type word max-x))
(aver (not (zerop (logand y (1- y)))))
(labels ((ld (x)
;; the floor of the binary logarithm of (positive) X
(> shift 0)))
(values m-high shift)))))
(let ((n (expt 2 sb!vm:n-word-bits))
+ (precision (integer-length max-x))
(shift1 0))
(multiple-value-bind (m shift2)
- (choose-multiplier y sb!vm:n-word-bits)
+ (choose-multiplier y precision)
(when (and (>= m n) (evenp y))
(setq shift1 (ld (logand y (- y))))
(multiple-value-setq (m shift2)
(choose-multiplier (/ y (ash 1 shift1))
- (- sb!vm:n-word-bits shift1))))
- (if (>= m n)
- (flet ((word-mod (x)
- `(ldb (byte #.sb!vm:n-word-bits 0) ,x)))
- `(let* ((num x)
- (t1 (%multiply num ,(- m n))))
- (ash ,(word-mod `(+ t1 (ash ,(word-mod `(- num t1))
- -1)))
- ,(- 1 shift2))))
- `(ash (%multiply (ash x ,(- shift1)) ,m)
- ,(- shift2)))))))
+ (- precision shift1))))
+ (cond ((>= m n)
+ (flet ((word (x)
+ `(truly-the word ,x)))
+ `(let* ((num x)
+ (t1 (%multiply-high num ,(- m n))))
+ (ash ,(word `(+ t1 (ash ,(word `(- num t1))
+ -1)))
+ ,(- 1 shift2)))))
+ ((and (zerop shift1) (zerop shift2))
+ (let ((max (truncate max-x y)))
+ ;; Explicit TRULY-THE needed to get the FIXNUM=>FIXNUM
+ ;; VOP.
+ `(truly-the (integer 0 ,max)
+ (%multiply-high x ,m))))
+ (t
+ `(ash (%multiply-high (logandc2 x ,(1- (ash 1 shift1))) ,m)
+ ,(- (+ shift1 shift2)))))))))
;;; If the divisor is constant and both args are positive and fit in a
;;; machine word, replace the division by a multiplication and possibly
;;; the same value, emit much simpler code to handle that. (This case
;;; may be rare but it's easy to detect and the compiler doesn't find
;;; this optimization on its own.)
-(deftransform truncate ((x y) ((unsigned-byte #.sb!vm:n-word-bits)
- (constant-arg
- (unsigned-byte #.sb!vm:n-word-bits)))
+(deftransform truncate ((x y) (word (constant-arg word))
*
:policy (and (> speed compilation-speed)
(> speed space)))
"convert integer division to multiplication"
- (let ((y (lvar-value y)))
+ (let* ((y (lvar-value y))
+ (x-type (lvar-type x))
+ (max-x (or (and (numeric-type-p x-type)
+ (numeric-type-high x-type))
+ most-positive-word)))
;; Division by zero, one or powers of two is handled elsewhere.
(when (zerop (logand y (1- y)))
(give-up-ir1-transform))
- ;; The compiler can't derive the result types to maximal tightness
- ;; from the transformed expression, so we calculate them here and
- ;; add the corresponding specifiers explicitly through TRULY-THE.
- ;; This duplicates parts of the TRUNCATE DERIVE-TYPE optimizer but
- ;; using that here would be too cumbersome.
- (let* ((x-type (lvar-type x))
- (x-low (or (and (numeric-type-p x-type)
- (numeric-type-low x-type))
- 0))
- (x-high (or (and (numeric-type-p x-type)
- (numeric-type-high x-type))
- (1- (expt 2 #.sb!vm:n-word-bits))))
- (quot-low (truncate x-low y))
- (quot-high (truncate x-high y)))
- (if (= quot-low quot-high)
- `(values ,quot-low
- (- x ,(* quot-low y)))
- `(let* ((quot ,(gen-unsigned-div-by-constant-expr y))
- (rem (ldb (byte #.sb!vm:n-word-bits 0)
- (- x (* quot ,y)))))
- (values (truly-the (integer ,quot-low ,quot-high) quot)
- (truly-the (integer 0 ,(1- y)) rem)))))))
+ `(let* ((quot ,(gen-unsigned-div-by-constant-expr y max-x))
+ (rem (ldb (byte #.sb!vm:n-word-bits 0)
+ (- x (* quot ,y)))))
+ (values quot rem))))
\f
;;;; arithmetic and logical identity operation elimination