X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=7bb61f999194ccfbaa2ed0a31e8bf34cd23c750f;hb=ee5629ee974ee8ce7a1cb245a99e94f8943ffd90;hp=6a2dd702163a9f0813e1422c9f2959dd3dcd9ee3;hpb=2230ea0c1765a95fd2aa0a8996b3555b93ba3745;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 6a2dd70..7bb61f9 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -590,19 +590,26 @@ (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. @@ -614,10 +621,13 @@ (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. @@ -629,6 +639,12 @@ (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. @@ -855,10 +871,10 @@ the first." ;; 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) @@ -872,10 +888,10 @@ the first." ;; 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) @@ -1069,9 +1085,9 @@ the first." #!+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)))) @@ -1384,29 +1400,31 @@ the first." ((fixnum bignum) (bignum-gcd (make-small-bignum u) v)))))) -;;; 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))) ;;;; miscellaneous number predicates @@ -1478,14 +1496,9 @@ the first." (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))))))