(bignum-cross-fixnum ,op ,big-op)
(float-contagion ,op x y)
- ((complex complex) +
+ ((complex complex)
(canonical-complex (,op (realpart x) (realpart y))
(,op (imagpart x) (imagpart y))))
(((foreach bignum fixnum ratio single-float double-float
(foreach single-float double-float #!+long-float long-float))
(truncate-float (dispatch-type divisor))))))
+;; Only inline when no VOP exists
+#!-multiply-high-vops (declaim (inline %multiply-high))
+(defun %multiply-high (x y)
+ (declare (type word x y))
+ #!-multiply-high-vops
+ (values (sb!bignum:%multiply x y))
+ #!+multiply-high-vops
+ (%multiply-high x y))
+
;;; Declare these guys inline to let them get optimized a little.
;;; ROUND and FROUND are not declared inline since they seem too
;;; obscure and too big to inline-expand by default. Also, this gives
-;;; the compiler a chance to pick off the unary float case. Similarly,
-;;; CEILING and FLOOR are only maybe-inline for now, so that the
-;;; power-of-2 CEILING and FLOOR transforms get a chance.
-#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
-(declaim (maybe-inline ceiling floor))
-
-(defun floor (number &optional (divisor 1))
- #!+sb-doc
- "Return the greatest integer not greater than number, or number/divisor.
- The second returned value is (mod number divisor)."
+;;; the compiler a chance to pick off the unary float case.
+;;;
+;;; CEILING and FLOOR are implemented in terms of %CEILING and %FLOOR
+;;; if no better transform can be found: they aren't inline directly,
+;;; since we want to try a transform specific to them before letting
+;;; the transform for TRUNCATE pick up the slack.
+#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate %floor %ceiling))
+(defun %floor (number divisor)
;; If the numbers do not divide exactly and the result of
;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
;; and augment the remainder by the divisor.
(values (1- tru) (+ rem divisor))
(values tru rem))))
-(defun ceiling (number &optional (divisor 1))
+(defun floor (number &optional (divisor 1))
#!+sb-doc
- "Return the smallest integer not less than number, or number/divisor.
- The second returned value is the remainder."
+ "Return the greatest integer not greater than number, or number/divisor.
+ The second returned value is (mod number divisor)."
+ (%floor number divisor))
+
+(defun %ceiling (number divisor)
;; If the numbers do not divide exactly and the result of
;; (/ NUMBER DIVISOR) would be positive then increment the quotient
;; and decrement the remainder by the divisor.
(values (+ tru 1) (- rem divisor))
(values tru rem))))
+(defun ceiling (number &optional (divisor 1))
+ #!+sb-doc
+ "Return the smallest integer not less than number, or number/divisor.
+ The second returned value is the remainder."
+ (%ceiling number divisor))
+
(defun round (number &optional (divisor 1))
#!+sb-doc
"Rounds number (or number/divisor) to nearest integer.
;; conversion.
(multiple-value-bind (lo hi)
(case '(dispatch-type y)
- ('single-float
+ (single-float
(values most-negative-exactly-single-float-fixnum
most-positive-exactly-single-float-fixnum))
- ('double-float
+ (double-float
(values most-negative-exactly-double-float-fixnum
most-positive-exactly-double-float-fixnum)))
(if (<= lo y hi)
;; Likewise
(multiple-value-bind (lo hi)
(case '(dispatch-type x)
- ('single-float
+ (single-float
(values most-negative-exactly-single-float-fixnum
most-positive-exactly-single-float-fixnum))
- ('double-float
+ (double-float
(values most-negative-exactly-double-float-fixnum
most-positive-exactly-double-float-fixnum)))
(if (<= lo y hi)
#!+sb-doc
"Predicate returns T if bit index of integer is a 1."
(number-dispatch ((index integer) (integer integer))
- ((fixnum fixnum) (if (> index #.(- sb!vm:n-word-bits sb!vm:n-lowtag-bits))
- (minusp integer)
- (not (zerop (logand integer (ash 1 index))))))
+ ((fixnum fixnum) (if (< index sb!vm:n-positive-fixnum-bits)
+ (not (zerop (logand integer (ash 1 index))))
+ (minusp integer)))
((fixnum bignum) (bignum-logbitp index integer))
((bignum (foreach fixnum bignum)) (minusp integer))))
((fixnum bignum)
(bignum-gcd (make-small-bignum u) v))))))
\f
-;;; From discussion on comp.lang.lisp and Akira Kurihara.
+;;;; from Robert Smith
(defun isqrt (n)
#!+sb-doc
"Return the root of the nearest integer less than n which is a perfect
square."
- (declare (type unsigned-byte n) (values unsigned-byte))
- ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
- (if (and (fixnump n) (<= n 24))
- (cond ((> n 15) 4)
- ((> n 8) 3)
- ((> n 3) 2)
- ((> n 0) 1)
- (t 0))
- (let* ((n-len-quarter (ash (integer-length n) -2))
- (n-half (ash n (- (ash n-len-quarter 1))))
- (n-half-isqrt (isqrt n-half))
- (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
- (loop
- (let ((iterated-value
- (ash (+ init-value (truncate n init-value)) -1)))
- (unless (< iterated-value init-value)
- (return init-value))
- (setq init-value iterated-value))))))
+ (declare (type unsigned-byte n))
+ (cond
+ ((> n 24)
+ (let* ((n-fourth-size (ash (1- (integer-length n)) -2))
+ (n-significant-half (ash n (- (ash n-fourth-size 1))))
+ (n-significant-half-isqrt (isqrt n-significant-half))
+ (zeroth-iteration (ash n-significant-half-isqrt n-fourth-size))
+ (qr (multiple-value-list (floor n zeroth-iteration)))
+ (first-iteration (ash (+ zeroth-iteration (first qr)) -1)))
+ (cond ((oddp (first qr))
+ first-iteration)
+ ((> (expt (- first-iteration zeroth-iteration) 2) (second qr))
+ (1- first-iteration))
+ (t
+ first-iteration))))
+ ((> n 15) 4)
+ ((> n 8) 3)
+ ((> n 3) 2)
+ ((> n 0) 1)
+ ((= n 0) 0)))
\f
;;;; miscellaneous number predicates
(bignum (ldb (byte 64 0)
(ash (logand integer #xffffffffffffffff) amount)))))
-#!+x86
-(defun sb!vm::ash-left-smod30 (integer amount)
- (etypecase integer
- ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
- (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))
-
-#!+x86-64
-(defun sb!vm::ash-left-smod61 (integer amount)
- (etypecase integer
- ((signed-byte 61) (sb!c::mask-signed-field 61 (ash integer amount)))
- (integer (sb!c::mask-signed-field 61 (ash (sb!c::mask-signed-field 61 integer) amount)))))
+#!+(or x86 x86-64)
+(defun sb!vm::ash-left-modfx (integer amount)
+ (let ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)))
+ (etypecase integer
+ (fixnum (sb!c::mask-signed-field fixnum-width (ash integer amount)))
+ (integer (sb!c::mask-signed-field fixnum-width (ash (sb!c::mask-signed-field fixnum-width integer) amount))))))