;;; 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)
;;; 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))
(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)))
(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)))
(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))
(,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))
(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.
(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)
(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)
(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)
(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)
(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)
(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)
#!+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))
#!+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))
(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
;; 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
(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
(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))))))
projects / sbcl.git / blobdiff