From 0de420caaed973d00a802343b197971a2c573f97 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Wed, 9 Jun 2004 15:01:20 +0000 Subject: [PATCH] Implement a much faster and much less consy bignum printer and a faster bignum reader. Contributed by Mark Wooding on cmucl-imp, May 24, 2004. --- code/print.lisp | 135 ++++++++++++++++++++++++++++++----------------- code/reader.lisp | 100 ++++++++++++++++++++++++++++++++++- 2 files changed, 187 insertions(+), 48 deletions(-) diff --git a/code/print.lisp b/code/print.lisp index c86fbb340..1e92a1772 100644 --- a/code/print.lisp +++ b/code/print.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.93 2004/04/23 12:33:39 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.94 2004/06/09 15:01:20 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1234,59 +1234,100 @@ ;;;; Bignum printing -;;; Written by Steven Handerson -;;; (based on Skef's idea) -;;; -;;; Rewritten to remove assumptions about the length of fixnums for the -;;; MIPS port by William Lott. -;;; - -;;; *BASE-POWER* holds the number that we keep dividing into the bignum for -;;; each *print-base*. We want this number as close to *most-positive-fixnum* -;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)). -;;; -(defparameter *base-power* (make-array 37 :initial-element nil)) +;;; Contributed by Mark Wooding, based on the algorithm in Emacs calc +;;; by David I. Bell and Landon Curt Noll. Slightly modified to be +;;; less scheme-like by rtoy. Caching by rtoy. -;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that -;;; fit in the corresponding *base-power*. -;;; -(defparameter *fixnum-power--1* (make-array 37 :initial-element nil)) +;;; A cache of the power lists we need for the algorithm. A power +;;; list is an alist of (2^k . r^(2^k)), where r is the desired +;;; *print-base*. The last entry in the alist should be (1 . r). +(defparameter *power-lists* + (make-array 37 :initial-contents (let ((r '())) + (dotimes (k 37) + (push (list (cons 1 k)) r)) + (nreverse r)))) ;;; PRINT-BIGNUM -- internal. ;;; -;;; Print the bignum to the stream. We first generate the correct value for -;;; *base-power* and *fixnum-power--1* if we have not already. Then we call -;;; bignum-print-aux to do the printing. -;;; (defun print-bignum (big stream) - (unless (aref *base-power* *print-base*) - (do ((power-1 -1 (1+ power-1)) - (new-divisor *print-base* (* new-divisor *print-base*)) - (divisor 1 new-divisor)) - ((not (fixnump new-divisor)) - (setf (aref *base-power* *print-base*) divisor) - (setf (aref *fixnum-power--1* *print-base*) power-1)))) - (bignum-print-aux (cond ((minusp big) - (write-char #\- stream) - (- big)) - (t big)) - (aref *base-power* *print-base*) - (aref *fixnum-power--1* *print-base*) - stream) + (print-bignum-fast big stream) big) -;;; BIGNUM-PRINT-AUX -- internal. -;;; -(defun bignum-print-aux (big divisor power-1 stream) - (multiple-value-bind (newbig fix) (truncate big divisor) - (if (fixnump newbig) - (sub-output-integer newbig stream) - (bignum-print-aux newbig divisor power-1 stream)) - (do ((zeros power-1 (1- zeros)) - (base-power *print-base* (* base-power *print-base*))) - ((> base-power fix) - (dotimes (i zeros) (write-char #\0 stream)) - (sub-output-integer fix stream))))) +(defun power-list (n r) + "Compute a list of pairs (2^i . r^{2^i}), stopping with the largest r^{2^i} +greater than n." + (declare (integer n) (fixnum r)) + (do ((l nil (acons i r l)) + (i 1 (* 2 i)) + (r r (* r r))) + ((> r n) l))) + +(declaim (inline digit-to-char)) +(defun digit-to-char (d) + "Convert digit into a character representation. We use 0..9, a..z for +10..35, and A..Z for 36..52." + (declare (fixnum d)) + (labels ((offset (d b) (code-char (+ d (char-code b))))) + (cond ((< d 10) (offset d #\0)) + ((< d 36) (offset (- d 10) #\A)) + (t (error "overflow in digit-to-char"))))) + +(defun print-fixnum-sub (n r z s) + "Print a fixnum N to stream S, maybe with leading zeros. This isn't +ever-so efficient, but we probably don't need to care." + (declare (fixnum n r z) + (stream s)) + (labels ((gen-digits (n l z) + (declare (fixnum n z) + (list l)) + (cond ((zerop n) + (dotimes (i z) + (write-char #\0 s)) + (dolist (d l) + (write-char d s))) + (t + (multiple-value-bind (n d) + (truncate n r) + (gen-digits n (cons (digit-to-char d) l) (1- z))))))) + (gen-digits n nil z))) + +(defun print-bignum-fast-sub (n r z s pl) + "Use the power list (see power-list) PL to split N roughly in half; then +print the left and right halves using (cdr PL). Make sure we count the +leading zeroes correctly." + (declare (integer n) + (type (integer 2 36) r) + (stream s) + (list pl) + (fixnum z)) + (if (fixnump n) + (print-fixnum-sub n r z s) + (do ((nz (caar pl) (caar rest)) + (split (cdar pl) (cdar rest)) + (rest pl (rest rest))) + ((<= split n) + (multiple-value-bind (u v) + (truncate n split) + (print-bignum-fast-sub u r (if (> z nz) (- z nz) 0) s rest) + (print-bignum-fast-sub v r nz s rest)))))) + +(defun maybe-update-power-list (n base) + ;; Look up entry and see if we need to add entries to it + (let ((pl (aref *power-lists* base))) + (do ((index (caar pl) (caar pl)) + (max (cdar pl) (cdar pl))) + ((>= max n)) + (setf pl (acons (* index 2) (* max max) pl))) + (setf (aref *power-lists* base) pl) + pl)) + +(defun print-bignum-fast (n s) + "Primary fast bignum-printing interface. Prints integer N to stream S in +radix-R. If you have a power-list then pass it in as PL." + (when (minusp n) + (write-char #\- s) + (setf n (- n))) + (print-bignum-fast-sub n *print-base* 0 s (maybe-update-power-list n *print-base*))) (defun output-ratio (ratio stream) diff --git a/code/reader.lisp b/code/reader.lisp index 332b6f4c1..488871eab 100644 --- a/code/reader.lisp +++ b/code/reader.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.47 2004/04/23 12:32:32 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.48 2004/06/09 15:01:20 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1314,6 +1314,7 @@ ;;;; Number reading functions. +#+nil (defmacro digit* nil `(do ((ch char (inch-read-buffer))) ((or (eofp ch) (not (digit-char-p ch))) (setq char ch)) @@ -1355,6 +1356,7 @@ (expt base digits))))) |# +#+nil (defun make-integer () "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, then multiplying by a power of the base and adding." @@ -1386,6 +1388,102 @@ (the index (* num base)))))))) (setq number (+ num (* number base-power))))))) +(defun make-integer () + "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, + then multiplying by a power of the base and adding." + (read-unwind-read-buffer) + ;; Use the fast reader if the number has enough digits. It seems + ;; that the fast reader is slower for small numbers but much faster + ;; for large numbers. The value of 500 is an approximate break-even + ;; point. + (if (>= (the fixnum *ouch-ptr*) 500) + (fast-read-integer *read-base*) + (let* ((base *read-base*) + (digits-per (aref *integer-reader-safe-digits* base)) + (base-power (aref *integer-reader-base-power* base)) + (negativep nil) + (number 0)) + (declare (type index digits-per base-power)) + (let ((char (inch-read-buffer))) + (cond ((char= char #\-) + (setq negativep t)) + ((char= char #\+)) + (t (unread-buffer)))) + (loop + (let ((num 0)) + (declare (type index num)) + (dotimes (digit digits-per) + (let* ((ch (inch-read-buffer))) + (cond ((or (eofp ch) (char= ch #\.)) + (return-from make-integer + (let ((res + (if (zerop number) num + (+ num (* number + (expt base digit)))))) + (if negativep (- res) res)))) + (t (setq num (+ (digit-char-p ch base) + (the index (* num base)))))))) + (setq number (+ num (* number base-power)))))))) + +(defun fast-read-integer (r) + "Fast bignum-reading interface. Reads from stream S an integer in radix +R. If we find some kind of error (bad characters, EOF), then NIL is +returned; otherwise the number. Reads at least one digit, but may not get to +the end of the stream." + (let ((v (make-array 32 :element-type 'integer + :adjustable t :fill-pointer 0))) + ;; V maps integers i to r^(2^i). + (vector-push-extend r v) + (labels ((scan (ch l) + ;; Character CH has been read. L contains a list of entries + ;; of the form (n . i), where i is the base-2 log of the + ;; length of n in digits. We read digits and push entries + ;; onto the front of the list as (d . 1), and then fix the + ;; list to maintain the invariant that entries on the list + ;; have strictly increasing length. + (declare (type (or character list) ch) (list l)) + (if (or (eofp ch) (char= ch #\.)) + (finish l) + (let ((d (digit-char-p ch r))) + (declare (type (or null fixnum) d)) + (labels ((fix (x i l) + (declare (integer x) (fixnum i) (list l)) + (if (>= i (fill-pointer v)) + (vector-push-extend + (let ((x (aref v (1- i)))) + (* x x)) + v)) + (if (null l) + (scan (inch-read-buffer) (cons (cons x i) nil)) + (let ((y (caar l)) (j (cdar l)) (rest (cdr l))) + (declare (integer y) (fixnum j) (list l)) + (if (= i j) + (fix (+ (* y (aref v i)) x) (1+ i) rest) + (scan (inch-read-buffer) (cons (cons x i) l))))))) + (fix d 0 l))))) + (finish (l) + ;; Convert the list into a final answer. The main loop below + ;; counts Z as the length of what we've built so far in + ;; digits. Remember that, since this is a stack, we're + ;; effectively working right-to-left here. + (declare (list l)) + (labels ((create-integer (a z l) + (declare (integer a z) (list l)) + (if (null l) + a + (create-integer (+ (* z (the integer (caar l))) a) + (* z (aref v (cdar l))) + (cdr l))))) + (create-integer 0 1 l)))) + (let ((ch (inch-read-buffer))) + (cond ((char= ch #\-) + (let ((n (scan (inch-read-buffer) nil))) + (- n))) + ((char= ch #\+) + (scan (inch-read-buffer) nil)) + (t + (scan ch nil))))))) + (defun make-float () ;; Assume that the contents of *read-buffer* are a legal float, with nothing -- GitLab