X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=bf3a03a71ee13f1414b1ae51504206fa5821f24f;hb=a3d4610158f227d53cb5eac287dd2661e975fc70;hp=076775c541caaa0e3bb36fa78903d4cc3ca7e6f8;hpb=2df8da85688355b4f4f31314246483ccea364746;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 076775c..bf3a03a 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -348,45 +348,50 @@ (denominator number)) ;;;; arithmetic operations +;;;; +;;;; IMPORTANT NOTE: Accessing &REST arguments with NTH is actually extremely +;;;; efficient in SBCL, as is taking their LENGTH -- so this code is very +;;;; clever instead of being charmingly naive. Please check that "obvious" +;;;; improvements don't actually ruin performance. +;;;; +;;;; (Granted that the difference between very clever and charmingly naivve +;;;; can sometimes be sliced exceedingly thing...) (macrolet ((define-arith (op init doc) #!-sb-doc (declare (ignore doc)) - `(define-more-fun ,op (&rest numbers) + `(defun ,op (&rest numbers) #!+sb-doc ,doc - (if (more-p) - (let ((result (more-arg 0))) - ;; to signal TYPE-ERROR when exactly 1 arg of wrong type: - (declare (type number result)) - (do-more (arg 1) - (setf result (,op result arg))) - result) + (if numbers + (do ((result (nth 0 numbers) (,op result (nth i numbers))) + (i 1 (1+ i))) + ((>= i (length numbers)) + result) + (declare (number result))) ,init)))) (define-arith + 0 "Return the sum of its arguments. With no args, returns 0.") (define-arith * 1 "Return the product of its arguments. With no args, returns 1.")) -(define-more-fun - (number &rest more-numbers) +(defun - (number &rest more-numbers) #!+sb-doc "Subtract the second and all subsequent arguments from the first; or with one argument, negate the first argument." - (if (more-p) + (if more-numbers (let ((result number)) - (do-more (arg) - (setf result (- result arg))) - result) + (dotimes (i (length more-numbers) result) + (setf result (- result (nth i more-numbers))))) (- number))) -(define-more-fun / (number &rest more-numbers) +(defun / (number &rest more-numbers) #!+sb-doc "Divide the first argument by each of the following arguments, in turn. With one argument, return reciprocal." - (if (more-p) + (if more-numbers (let ((result number)) - (do-more (arg) - (setf result (/ result arg))) - result) + (dotimes (i (length more-numbers) result) + (setf result (/ result (nth i more-numbers))))) (/ number))) (defun 1+ (number) @@ -805,66 +810,66 @@ ;;;; comparisons -(define-more-fun = (number &rest more-numbers) +(defun = (number &rest more-numbers) #!+sb-doc "Return T if all of its arguments are numerically equal, NIL otherwise." (declare (number number)) - (do-more (arg) - (unless (= number arg) - (return-from = nil))) - t) + (dotimes (i (length more-numbers) t) + (unless (= number (nth i more-numbers)) + (return nil)))) -(define-more-fun /= (number &rest more-numbers) +(defun /= (number &rest more-numbers) #!+sb-doc "Return T if no two of its arguments are numerically equal, NIL otherwise." (declare (number number)) - (do-more (arg) - (when (= number arg) - (return-from /= nil))) - (dotimes (start (1- (more-count))) - (let ((head (more-arg start))) - (do-more (arg (1+ start)) - (when (= head arg) - (return-from /= nil))))) - t) + (if more-numbers + (do ((n number (nth i more-numbers)) + (i 0 (1+ i))) + ((>= i (length more-numbers)) + t) + (do ((j i (1+ j))) + ((>= j (length more-numbers))) + (when (= n (nth j more-numbers)) + (return-from /= nil)))) + t)) (macrolet ((def (op doc) #!-sb-doc (declare (ignore doc)) - `(define-more-fun ,op (number &rest more-numbers) + `(defun ,op (number &rest more-numbers) #!+sb-doc ,doc (let ((n number)) (declare (number n)) - (do-more (arg) - (if (,op n arg) + (dotimes (i (length more-numbers) t) + (let ((arg (nth i more-numbers))) + (if (,op n arg) (setf n arg) - (return-from ,op nil))) - t)))) + (return-from ,op nil)))))))) (def < "Return T if its arguments are in strictly increasing order, NIL otherwise.") (def > "Return T if its arguments are in strictly decreasing order, NIL otherwise.") (def <= "Return T if arguments are in strictly non-decreasing order, NIL otherwise.") (def >= "Return T if arguments are in strictly non-increasing order, NIL otherwise.")) -(define-more-fun max (number &rest more-numbers) +(defun max (number &rest more-numbers) #!+sb-doc "Return the greatest of its arguments; among EQUALP greatest, return the first." (let ((n number)) (declare (number n)) - (do-more (arg) - (when (> arg n) - (setf n arg))) - n)) + (dotimes (i (length more-numbers) n) + (let ((arg (nth i more-numbers))) + (when (> arg n) + (setf n arg)))))) -(define-more-fun min (number &rest more-numbers) +(defun min (number &rest more-numbers) #!+sb-doc "Return the least of its arguments; among EQUALP least, return the first." (let ((n number)) (declare (number n)) - (do-more (arg) - (when (< arg n) - (setf n arg))) - n)) + (dotimes (i (length more-numbers) n) + (let ((arg (nth i more-numbers))) + (when (< arg n) + (setf n arg)))))) (eval-when (:compile-toplevel :execute) @@ -1004,14 +1009,14 @@ the first." (macrolet ((def (op init doc) #!-sb-doc (declare (ignore doc)) - `(define-more-fun ,op (&rest integers) + `(defun ,op (&rest integers) #!+sb-doc ,doc - (if (more-p) - (let ((result (more-arg 0))) - (declare (integer result)) - (do-more (arg 1) - (setf result (,op result arg))) - result) + (if integers + (do ((result (nth 0 integers) (,op result (nth i integers))) + (i 1 (1+ i))) + ((>= i (length integers)) + result) + (declare (integer result))) ,init)))) (def logior 0 "Return the bit-wise or of its arguments. Args must be integers.") (def logxor 0 "Return the bit-wise exclusive or of its arguments. Args must be integers.") @@ -1310,33 +1315,35 @@ the first." ;;;; GCD and LCM -(define-more-fun gcd (&rest integers) +(defun gcd (&rest integers) #!+sb-doc "Return the greatest common divisor of the arguments, which must be integers. Gcd with no arguments is defined to be 0." - (case (more-count) + (case (length integers) (0 0) - (1 (abs (the integer (more-arg 0)))) + (1 (abs (the integer (nth 0 integers)))) (otherwise - (let ((gcd (more-arg 0))) - (declare (integer gcd)) - (do-more (arg 1) - (setf gcd (gcd gcd (the integer arg)))) - gcd)))) - -(define-more-fun lcm (&rest integers) + (do ((result (nth 0 integers) + (gcd result (the integer (nth i integers)))) + (i 1 (1+ i))) + ((>= i (length integers)) + result) + (declare (integer result)))))) + +(defun lcm (&rest integers) #!+sb-doc "Return the least common multiple of one or more integers. LCM of no arguments is defined to be 1." - (case (more-count) + (case (length integers) (0 1) - (1 (abs (the integer (more-arg 0)))) + (1 (abs (the integer (nth 0 integers)))) (otherwise - (let ((lcm (more-arg 0))) - (declare (integer lcm)) - (do-more (arg 1) - (setf lcm (lcm lcm (the integer arg)))) - lcm)))) + (do ((result (nth 0 integers) + (lcm result (the integer (nth i integers)))) + (i 1 (1+ i))) + ((>= i (length integers)) + result) + (declare (integer result)))))) (defun two-arg-lcm (n m) (declare (integer n m)) @@ -1399,31 +1406,66 @@ the first." ((fixnum bignum) (bignum-gcd (make-small-bignum u) v)))))) -;;;; from Robert Smith; slightly changed not to cons unnecessarily. +;;; from Robert Smith; changed not to cons unnecessarily, and tuned for +;;; faster operation on fixnum inputs by compiling the central recursive +;;; algorithm twice, once using generic and once fixnum arithmetic, and +;;; dispatching on function entry into the applicable part. For maximum +;;; speed, the fixnum part recurs into itself, thereby avoiding further +;;; type dispatching. This pattern is not supported by NUMBER-DISPATCH +;;; thus some special-purpose macrology is needed. (defun isqrt (n) #!+sb-doc "Return the greatest integer less than or equal to the square root of N." (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))) - (multiple-value-bind (quot rem) - (floor n zeroth-iteration) - (let ((first-iteration (ash (+ zeroth-iteration quot) -1))) - (cond ((oddp quot) - first-iteration) - ((> (expt (- first-iteration zeroth-iteration) 2) rem) - (1- first-iteration)) - (t - first-iteration)))))) - ((> n 15) 4) - ((> n 8) 3) - ((> n 3) 2) - ((> n 0) 1) - ((= n 0) 0))) + (macrolet + ((isqrt-recursion (arg recurse fixnum-p) + ;; Expands into code for the recursive step of the ISQRT + ;; calculation. ARG is the input variable and RECURSE the name + ;; of the function to recur into. If FIXNUM-P is true, some + ;; type declarations are added that, together with ARG being + ;; declared as a fixnum outside of here, make the resulting code + ;; compile into fixnum-specialized code without any calls to + ;; generic arithmetic. Else, the code works for bignums, too. + ;; The input must be at least 16 to ensure that RECURSE is called + ;; with a strictly smaller number and that the result is correct + ;; (provided that RECURSE correctly implements ISQRT, itself). + `(macrolet ((if-fixnum-p-truly-the (type expr) + ,@(if fixnum-p + '(`(truly-the ,type ,expr)) + '((declare (ignore type)) + expr)))) + (let* ((fourth-size (ash (1- (integer-length ,arg)) -2)) + (significant-half (ash ,arg (- (ash fourth-size 1)))) + (significant-half-isqrt + (if-fixnum-p-truly-the + (integer 1 #.(isqrt sb!xc:most-positive-fixnum)) + (,recurse significant-half))) + (zeroth-iteration (ash significant-half-isqrt + fourth-size))) + (multiple-value-bind (quot rem) + (floor ,arg zeroth-iteration) + (let ((first-iteration (ash (+ zeroth-iteration quot) -1))) + (cond ((oddp quot) + first-iteration) + ((> (if-fixnum-p-truly-the + fixnum + (expt (- first-iteration zeroth-iteration) 2)) + rem) + (1- first-iteration)) + (t + first-iteration)))))))) + (typecase n + (fixnum (labels ((fixnum-isqrt (n) + (declare (type fixnum n)) + (cond ((> n 24) + (isqrt-recursion n fixnum-isqrt t)) + ((> n 15) 4) + ((> n 8) 3) + ((> n 3) 2) + ((> n 0) 1) + ((= n 0) 0)))) + (fixnum-isqrt n))) + (bignum (isqrt-recursion n isqrt nil))))) ;;;; miscellaneous number predicates