X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=25c604625fa8145ed8a18983c2ef50092ed898cc;hb=512c78f5f0c8e4c11bad219313dd83890f625006;hp=19e6be9e874281e8c5c0963c4cd16805ded55b0c;hpb=91e1d65670542ceb7c177423f25b53d250c9d9cb;p=sbcl.git diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp index 19e6be9..25c6046 100644 --- a/src/code/numbers.lisp +++ b/src/code/numbers.lisp @@ -62,10 +62,51 @@ ;;; Return an ETYPECASE form that does the type dispatch, ordering the ;;; cases for efficiency. +;;; Check for some simple to detect problematic cases where the caller +;;; used types that are not disjoint and where this may lead to +;;; unexpected behaviour of the generated form, for example making +;;; a clause unreachable, and throw an error if such a case is found. +;;; An example: +;;; (number-dispatch ((var1 integer) (var2 float)) +;;; ((fixnum single-float) a) +;;; ((integer float) b)) +;;; Even though the types are not reordered here, the generated form, +;;; basically +;;; (etypecase var1 +;;; (fixnum (etypecase var2 +;;; (single-float a))) +;;; (integer (etypecase var2 +;;; (float b)))) +;;; would fail at runtime if given var1 fixnum and var2 double-float, +;;; even though the second clause matches this signature. To catch +;;; this earlier than runtime we throw an error already here. (defun generate-number-dispatch (vars error-tags cases) (if vars (let ((var (first vars)) (cases (sort cases #'type-test-order :key #'car))) + (flet ((error-if-sub-or-supertype (type1 type2) + (when (or (subtypep type1 type2) + (subtypep type2 type1)) + (error "Types not disjoint: ~S ~S." type1 type2))) + (error-if-supertype (type1 type2) + (when (subtypep type2 type1) + (error "Type ~S ordered before subtype ~S." + type1 type2))) + (test-type-pairs (fun) + ;; Apply FUN to all (ordered) pairs of types from the + ;; cases. + (mapl (lambda (cases) + (when (cdr cases) + (let ((type1 (caar cases))) + (dolist (case (cdr cases)) + (funcall fun type1 (car case)))))) + cases))) + ;; For the last variable throw an error if a type is followed + ;; by a subtype, for all other variables additionally if a + ;; type is followed by a supertype. + (test-type-pairs (if (cdr vars) + #'error-if-sub-or-supertype + #'error-if-supertype))) `((typecase ,var ,@(mapcar (lambda (case) `(,(first case) @@ -92,6 +133,13 @@ ;;; symbol. In this case, we apply the CAR of the form to the CDR and ;;; treat the result of the call as a list of cases. This process is ;;; not applied recursively. +;;; +;;; Be careful when using non-disjoint types in different cases for the +;;; same variable. Some uses will behave as intended, others not, as the +;;; variables are dispatched off sequentially and clauses are reordered +;;; for efficiency. Some, but not all, problematic cases are detected +;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above +;;; for an example. (defmacro number-dispatch (var-specs &body cases) (let ((res (list nil)) (vars (mapcar #'car var-specs)) @@ -238,7 +286,7 @@ (defun realpart (number) #!+sb-doc "Extract the real part of a number." - (typecase number + (etypecase number #!+long-float ((complex long-float) (truly-the long-float (realpart number))) @@ -248,13 +296,13 @@ (truly-the single-float (realpart number))) ((complex rational) (sb!kernel:%realpart number)) - (t + (number number))) (defun imagpart (number) #!+sb-doc "Extract the imaginary part of a number." - (typecase number + (etypecase number #!+long-float ((complex long-float) (truly-the long-float (imagpart number))) @@ -266,13 +314,14 @@ (sb!kernel:%imagpart number)) (float (* 0 number)) - (t + (number 0))) (defun conjugate (number) #!+sb-doc "Return the complex conjugate of NUMBER. For non-complex numbers, this is an identity." + (declare (type number number)) (if (complexp number) (complex (realpart number) (- (imagpart number))) number)) @@ -362,9 +411,9 @@ (,op (imagpart x) (imagpart y)))) (((foreach bignum fixnum ratio single-float double-float #!+long-float long-float) complex) - (complex (,op x (realpart y)) (,op (imagpart y)))) + (complex (,op x (realpart y)) (,op 0 (imagpart y)))) ((complex (or rational float)) - (complex (,op (realpart x) y) (imagpart x))) + (complex (,op (realpart x) y) (,op (imagpart x) 0))) (((foreach fixnum bignum) ratio) (let* ((dy (denominator y)) @@ -589,19 +638,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. @@ -613,10 +669,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. @@ -628,6 +687,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. @@ -742,7 +807,7 @@ (defun = (number &rest more-numbers) #!+sb-doc "Return T if all of its arguments are numerically equal, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (the number number) (do ((nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -752,7 +817,7 @@ (defun /= (number &rest more-numbers) #!+sb-doc "Return T if no two of its arguments are numerically equal, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((head (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -766,7 +831,7 @@ (defun < (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly increasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -776,7 +841,7 @@ (defun > (number &rest more-numbers) #!+sb-doc "Return T if its arguments are in strictly decreasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -786,7 +851,7 @@ (defun <= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-decreasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -796,7 +861,7 @@ (defun >= (number &rest more-numbers) #!+sb-doc "Return T if arguments are in strictly non-increasing order, NIL otherwise." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do* ((n (the number number) (car nlist)) (nlist more-numbers (cdr nlist))) ((atom nlist) t) @@ -807,7 +872,7 @@ #!+sb-doc "Return the greatest of its arguments; among EQUALP greatest, return the first." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) @@ -819,7 +884,7 @@ the first." #!+sb-doc "Return the least of its arguments; among EQUALP least, return the first." - (declare (dynamic-extent more-numbers)) + (declare (truly-dynamic-extent more-numbers)) (do ((nlist more-numbers (cdr nlist)) (result number)) ((null nlist) (return result)) @@ -827,15 +892,6 @@ the first." (declare (type real number result)) (if (< (car nlist) result) (setq result (car nlist))))) -(defconstant most-positive-exactly-single-float-fixnum - (min #xffffff most-positive-fixnum)) -(defconstant most-negative-exactly-single-float-fixnum - (max #x-ffffff most-negative-fixnum)) -(defconstant most-positive-exactly-double-float-fixnum - (min #x1fffffffffffff most-positive-fixnum)) -(defconstant most-negative-exactly-double-float-fixnum - (max #x-1fffffffffffff most-negative-fixnum)) - (eval-when (:compile-toplevel :execute) ;;; The INFINITE-X-FINITE-Y and INFINITE-Y-FINITE-X args tell us how @@ -863,10 +919,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) @@ -880,10 +936,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) @@ -1077,9 +1133,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)))) @@ -1392,29 +1448,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 @@ -1466,7 +1524,7 @@ the first." (do-mfuns sb!c::*untagged-unsigned-modular-class*) (do-mfuns sb!c::*untagged-signed-modular-class*) (do-mfuns sb!c::*tagged-modular-class*))) - `(progn ,@(forms))) + `(progn ,@(sort (forms) #'string< :key #'cadr))) ;;; KLUDGE: these out-of-line definitions can't use the modular ;;; arithmetic, as that is only (currently) defined for constant @@ -1486,14 +1544,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))))))