(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
: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)
((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))
;;; 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))
(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))
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.
(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)))
(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)
(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.
))))))))
\f
`(- (ash x ,len))
`(ash x ,len))))
+;;; These must come before the ones below, so that they are tried
+;;; first. Since %FLOOR and %CEILING are inlined, this allows
+;;; the general case to be handled by TRUNCATE transforms.
+(deftransform floor ((x y))
+ `(%floor x y))
+
+(deftransform ceiling ((x y))
+ `(%ceiling x y))
+
;;; If arg is a constant power of two, turn FLOOR into a shift and
;;; mask. If CEILING, add in (1- (ABS Y)), do FLOOR and correct a
;;; remainder.
`(if (minusp x)
(- (logand (- x) ,mask))
(logand x ,mask)))))
+
+;;; Return an expression to calculate the integer quotient of X and
+;;; constant Y, using multiplication, shift and add/sub instead of
+;;; division. Both arguments must be unsigned, fit in a machine word and
+;;; Y must neither be zero nor a power of two. The quotient is rounded
+;;; towards zero.
+;;; The algorithm is taken from the paper "Division by Invariant
+;;; 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 MOST-POSITIVE-WORD) ->
+;;; (ASH (%MULTIPLY (LOGANDC2 X 0) 14757395258967641293) -3)
+;;;
+;;; (UNSIGNED-DIV-TRANSFORMER 7 MOST-POSITIVE-WORD) ->
+;;; (LET* ((NUM X)
+;;; (T1 (%MULTIPLY NUM 2635249153387078803)))
+;;; (ASH (LDB (BYTE 64 0)
+;;; (+ T1 (ASH (LDB (BYTE 64 0)
+;;; (- NUM T1))
+;;; -1)))
+;;; -2))
+;;;
+(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
+ (integer-length (1- x)))
+ (choose-multiplier (y precision)
+ (do* ((l (ld y))
+ (shift l (1- shift))
+ (expt-2-n+l (expt 2 (+ sb!vm:n-word-bits l)))
+ (m-low (truncate expt-2-n+l y) (ash m-low -1))
+ (m-high (truncate (+ expt-2-n+l
+ (ash expt-2-n+l (- precision)))
+ y)
+ (ash m-high -1)))
+ ((not (and (< (ash m-low -1) (ash m-high -1))
+ (> 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 precision)
+ (when (and (>= m n) (evenp y))
+ (setq shift1 (ld (logand y (- y))))
+ (multiple-value-setq (m shift2)
+ (choose-multiplier (/ y (ash 1 shift1))
+ (- 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
+;;; some shifts and an addition. Calculate the remainder by a second
+;;; multiplication and a subtraction. Dead code elimination will
+;;; suppress the latter part if only the quotient is needed. If the type
+;;; of the dividend allows to derive that the quotient will always have
+;;; 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) (word (constant-arg word))
+ *
+ :policy (and (> speed compilation-speed)
+ (> speed space)))
+ "convert integer division to multiplication"
+ (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))
+ `(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
(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))
(consp (arg-info-default info))
(not (lambda-var-specvar var))
(not (lambda-var-sets var))
- (every #'ref-good-for-more-context-p (lambda-var-refs var)))))
+ (every #'ref-good-for-more-context-p (lambda-var-refs var))
+ (policy node (= 3 rest-conversion)))))
(cond (context-ok
(destructuring-bind (context count &optional used) (arg-info-default info)
(declare (ignore used))
projects / sbcl.git / blobdiff