X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=58477076fdee70d38d077da97513ca044c8d113f;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=fe0ff5ccdd8f199adfa68f7c8188fdb7cabc979a;hpb=3ceaa081c90a970f6779e02bed659835a202772c;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index fe0ff5c..5847707 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))
@@ -299,17 +348,27 @@
   (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))
-             `(defun ,op (&rest args)
-                #!+sb-doc ,doc
-                (if (null args) ,init
-                    (do ((args (cdr args) (cdr args))
-                         (result (car args) (,op result (car args))))
-                        ((null args) result)
-                      ;; to signal TYPE-ERROR when exactly 1 arg of wrong type:
-                      (declare (type number result)))))))
+             `(defun ,op (&rest numbers)
+                #!+sb-doc
+                ,doc
+                (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
@@ -320,11 +379,9 @@
   "Subtract the second and all subsequent arguments from the first;
   or with one argument, negate the first argument."
   (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-           (result number))
-          ((atom nlist) result)
-         (declare (list nlist))
-         (setq result (- result (car nlist))))
+      (let ((result number))
+        (dotimes (i (length more-numbers) result)
+          (setf result (- result (nth i more-numbers)))))
       (- number)))
 
 (defun / (number &rest more-numbers)
@@ -332,11 +389,9 @@
   "Divide the first argument by each of the following arguments, in turn.
   With one argument, return reciprocal."
   (if more-numbers
-      (do ((nlist more-numbers (cdr nlist))
-           (result number))
-          ((atom nlist) result)
-         (declare (list nlist))
-         (setq result (/ result (car nlist))))
+      (let ((result number))
+        (dotimes (i (length more-numbers) result)
+          (setf result (/ result (nth i more-numbers)))))
       (/ number)))
 
 (defun 1+ (number)
@@ -362,9 +417,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 +644,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 +675,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 +693,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,99 +813,63 @@
 (defun = (number &rest more-numbers)
   #!+sb-doc
   "Return T if all of its arguments are numerically equal, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
-  (the number number)
-  (do ((nlist more-numbers (cdr nlist)))
-      ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (= (car nlist) number)) (return nil))))
+  (declare (number number))
+  (dotimes (i (length more-numbers) t)
+    (unless (= number (nth i more-numbers))
+      (return nil))))
 
 (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))
-  (do* ((head (the number number) (car nlist))
-        (nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (unless (do* ((nl nlist (cdr nl)))
-                  ((atom nl) t)
-               (declare (list nl))
-               (if (= head (car nl)) (return nil)))
-       (return nil))))
-
-(defun < (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if its arguments are in strictly increasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
-  (do* ((n (the number number) (car nlist))
-        (nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (< n (car nlist))) (return nil))))
-
-(defun > (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if its arguments are in strictly decreasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
-  (do* ((n (the number number) (car nlist))
-        (nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (> n (car nlist))) (return nil))))
-
-(defun <= (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if arguments are in strictly non-decreasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
-  (do* ((n (the number number) (car nlist))
-        (nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (<= n (car nlist))) (return nil))))
-
-(defun >= (number &rest more-numbers)
-  #!+sb-doc
-  "Return T if arguments are in strictly non-increasing order, NIL otherwise."
-  (declare (dynamic-extent more-numbers))
-  (do* ((n (the number number) (car nlist))
-        (nlist more-numbers (cdr nlist)))
-       ((atom nlist) t)
-     (declare (list nlist))
-     (if (not (>= n (car nlist))) (return nil))))
+  (declare (number number))
+  (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))
+             `(defun ,op (number &rest more-numbers)
+                #!+sb-doc ,doc
+                (let ((n number))
+                  (declare (number n))
+                  (dotimes (i (length more-numbers) t)
+                    (let ((arg (nth i more-numbers)))
+                      (if (,op n arg)
+                        (setf n arg)
+                        (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."))
 
 (defun max (number &rest more-numbers)
   #!+sb-doc
   "Return the greatest of its arguments; among EQUALP greatest, return
 the first."
-  (declare (dynamic-extent more-numbers))
-  (do ((nlist more-numbers (cdr nlist))
-       (result number))
-      ((null nlist) (return result))
-     (declare (list nlist))
-     (declare (type real number result))
-     (if (> (car nlist) result) (setq result (car nlist)))))
+  (let ((n number))
+    (declare (number n))
+    (dotimes (i (length more-numbers) n)
+      (let ((arg (nth i more-numbers)))
+        (when (> arg n)
+          (setf n arg))))))
 
 (defun min (number &rest more-numbers)
   #!+sb-doc
   "Return the least of its arguments; among EQUALP least, return
 the first."
-  (declare (dynamic-extent more-numbers))
-  (do ((nlist more-numbers (cdr nlist))
-       (result number))
-      ((null nlist) (return result))
-     (declare (list nlist))
-     (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))
+  (let ((n number))
+    (declare (number n))
+    (dotimes (i (length more-numbers) n)
+      (let ((arg (nth i more-numbers)))
+        (when (< arg n)
+          (setf n arg))))))
 
 (eval-when (:compile-toplevel :execute)
 
@@ -863,10 +898,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 +915,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)
@@ -972,45 +1007,21 @@ the first."
 
 ;;;; logicals
 
-(defun logior (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise or of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logior result (pop integers))))
-          ((null integers) result)
-        (declare (integer result)))
-      0))
-
-(defun logxor (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise exclusive or of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logxor result (pop integers))))
-          ((null integers) result)
-        (declare (integer result)))
-      0))
-
-(defun logand (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise and of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logand result (pop integers))))
-          ((null integers) result)
-        (declare (integer result)))
-      -1))
-
-(defun logeqv (&rest integers)
-  #!+sb-doc
-  "Return the bit-wise equivalence of its arguments. Args must be integers."
-  (declare (list integers))
-  (if integers
-      (do ((result (pop integers) (logeqv result (pop integers))))
-          ((null integers) result)
-        (declare (integer result)))
-      -1))
+(macrolet ((def (op init doc)
+             #!-sb-doc (declare (ignore doc))
+             `(defun ,op (&rest integers)
+                #!+sb-doc ,doc
+                (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.")
+  (def logand -1 "Return the bit-wise and of its arguments. Args must be integers.")
+  (def logeqv -1 "Return the bit-wise equivalence of its arguments. Args must be integers."))
 
 (defun lognot (number)
   #!+sb-doc
@@ -1077,9 +1088,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))))
 
@@ -1165,18 +1176,22 @@ the first."
   (deposit-field newbyte bytespec integer))
 
 (defun %ldb (size posn integer)
+  (declare (type bit-index size posn))
   (logand (ash integer (- posn))
           (1- (ash 1 size))))
 
 (defun %mask-field (size posn integer)
+  (declare (type bit-index size posn))
   (logand integer (ash (1- (ash 1 size)) posn)))
 
 (defun %dpb (newbyte size posn integer)
+  (declare (type bit-index size posn))
   (let ((mask (1- (ash 1 size))))
     (logior (logand integer (lognot (ash mask posn)))
             (ash (logand newbyte mask) posn))))
 
 (defun %deposit-field (newbyte size posn integer)
+  (declare (type bit-index size posn))
   (let ((mask (ash (ldb (byte size 0) -1) posn)))
     (logior (logand newbyte mask)
             (logand integer (lognot mask)))))
@@ -1304,32 +1319,35 @@ the first."
 
 ;;;; GCD and LCM
 
-(defun gcd (&rest numbers)
+(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."
-  (cond ((null numbers) 0)
-        ((null (cdr numbers)) (abs (the integer (car numbers))))
-        (t
-         (do ((gcd (the integer (car numbers))
-                   (gcd gcd (the integer (car rest))))
-              (rest (cdr numbers) (cdr rest)))
-             ((null rest) gcd)
-           (declare (integer gcd)
-                    (list rest))))))
-
-(defun lcm (&rest numbers)
+  (case (length integers)
+    (0 0)
+    (1 (abs (the integer (nth 0 integers))))
+    (otherwise
+     (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."
-  (cond ((null numbers) 1)
-        ((null (cdr numbers)) (abs (the integer (car numbers))))
-        (t
-         (do ((lcm (the integer (car numbers))
-                   (lcm lcm (the integer (car rest))))
-              (rest (cdr numbers) (cdr rest)))
-             ((null rest) lcm)
-           (declare (integer lcm) (list rest))))))
+  (case (length integers)
+    (0 1)
+    (1 (abs (the integer (nth 0 integers))))
+    (otherwise
+     (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))
@@ -1340,6 +1358,10 @@ the first."
       ;; complicated way of writing the algorithm in the CLHS page for
       ;; LCM, and I don't know why.  To be investigated.  -- CSR,
       ;; 2003-09-11
+      ;;
+      ;;    It seems to me that this is written this way to avoid
+      ;;    unnecessary bignumification of intermediate results.
+      ;;        -- TCR, 2008-03-05
       (let ((m (abs m))
             (n (abs n)))
         (multiple-value-bind (max min)
@@ -1360,7 +1382,7 @@ the first."
          (number-dispatch ((u integer) (v integer))
            ((fixnum fixnum)
             (locally
-              (declare (optimize (speed 3) (safety 0)))
+                (declare (optimize (speed 3) (safety 0)))
               (do ((k 0 (1+ k))
                    (u (abs u) (ash u -1))
                    (v (abs v) (ash v -1)))
@@ -1376,11 +1398,11 @@ the first."
                        (setq temp (- u v))
                        (when (zerop temp)
                          (let ((res (ash u k)))
-                           (declare (type (signed-byte 31) res)
+                           (declare (type sb!vm:signed-word res)
                                     (optimize (inhibit-warnings 3)))
                            (return res))))))
-                (declare (type (mod 30) k)
-                         (type (signed-byte 31) u v)))))
+                (declare (type (mod #.sb!vm:n-word-bits) k)
+                         (type sb!vm:signed-word u v)))))
            ((bignum bignum)
             (bignum-gcd u v))
            ((bignum fixnum)
@@ -1388,29 +1410,66 @@ the first."
            ((fixnum bignum)
             (bignum-gcd (make-small-bignum u) v))))))
 
-;;; From discussion on comp.lang.lisp and Akira Kurihara.
+;;; 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 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))))))
+  "Return the greatest integer less than or equal to the square root of N."
+  (declare (type unsigned-byte n))
+  (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
 
@@ -1425,30 +1484,18 @@ the first."
 ;;;; modular functions
 #.
 (collect ((forms))
-  (flet ((definition (name lambda-list width pattern)
-           `(defun ,name ,lambda-list
-              (flet ((prepare-argument (x)
-                       (declare (integer x))
-                       (etypecase x
-                         ((unsigned-byte ,width) x)
-                         (fixnum (logand x ,pattern))
-                         (bignum (logand x ,pattern)))))
-                (,name ,@(loop for arg in lambda-list
-                               collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
-          ;; FIXME: We need to process only "toplevel" functions
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (sb!c::modular-fun-info-name info)
-                   and width = (sb!c::modular-fun-info-width info)
-                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
-                   for pattern = (1- (ash 1 width))
-                   do (forms (definition name lambda-list width pattern)))))
-  `(progn ,@(forms)))
-
-#.
-(collect ((forms))
-  (flet ((definition (name lambda-list width)
+  (flet ((unsigned-definition (name lambda-list width)
+           (let ((pattern (1- (ash 1 width))))
+             `(defun ,name ,lambda-list
+               (flet ((prepare-argument (x)
+                        (declare (integer x))
+                        (etypecase x
+                          ((unsigned-byte ,width) x)
+                          (fixnum (logand x ,pattern))
+                          (bignum (logand x ,pattern)))))
+                 (,name ,@(loop for arg in lambda-list
+                                collect `(prepare-argument ,arg)))))))
+         (signed-definition (name lambda-list width)
            `(defun ,name ,lambda-list
               (flet ((prepare-argument (x)
                        (declare (integer x))
@@ -1458,15 +1505,23 @@ the first."
                          (bignum (sb!c::mask-signed-field ,width x)))))
                 (,name ,@(loop for arg in lambda-list
                                collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
-          ;; FIXME: We need to process only "toplevel" functions
-          when (listp infos)
-          do (loop for info in infos
-                   for name = (sb!c::modular-fun-info-name info)
-                   and width = (sb!c::modular-fun-info-width info)
-                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
-                   do (forms (definition name lambda-list width)))))
-  `(progn ,@(forms)))
+    (flet ((do-mfuns (class)
+             (loop for infos being each hash-value of (sb!c::modular-class-funs class)
+                   ;; FIXME: We need to process only "toplevel" functions
+                   when (listp infos)
+                   do (loop for info in infos
+                            for name = (sb!c::modular-fun-info-name info)
+                            and width = (sb!c::modular-fun-info-width info)
+                            and signedp = (sb!c::modular-fun-info-signedp info)
+                            and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                            if signedp
+                            do (forms (signed-definition name lambda-list width))
+                            else
+                            do (forms (unsigned-definition name lambda-list width))))))
+      (do-mfuns sb!c::*untagged-unsigned-modular-class*)
+      (do-mfuns sb!c::*untagged-signed-modular-class*)
+      (do-mfuns sb!c::*tagged-modular-class*)))
+  `(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 +1541,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))))))