X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=e235f4b2b938979b5fc5ffaca66b1d447f4d7cfd;hb=5d04a95274c9ddaebbcd6ddffc5d646e2c25598c;hp=d3096e852c4b3bb1931337f73745f4bf367a542e;hpb=970dd272dc84f7420252eadb4829cc193f795716;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index d3096e8..e235f4b 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -908,7 +908,8 @@ ;; this for now. [noted by anonymous long ago] -- WHN 19991130 `(or (char= ,char #\\) (char= ,char #\")))) - (with-array-data ((data string) (start) (end (length string))) + (with-array-data ((data string) (start) (end) + :check-fill-pointer t) (do ((index start (1+ index))) ((>= index end)) (let ((char (schar data index))) @@ -982,17 +983,17 @@ (2 #\b) (8 #\o) (16 #\x) - (t (%output-fixnum-in-base base 10 stream) + (t (%output-reasonable-integer-in-base base 10 stream) #\r)) stream)) -(defun %output-fixnum-in-base (n base stream) +(defun %output-reasonable-integer-in-base (n base stream) (multiple-value-bind (q r) (truncate n base) ;; Recurse until you have all the digits pushed on ;; the stack. (unless (zerop q) - (%output-fixnum-in-base q base stream)) + (%output-reasonable-integer-in-base q base stream)) ;; Then as each recursive call unwinds, turn the ;; digit (in remainder) into a character and output ;; the character. @@ -1000,21 +1001,89 @@ (schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r) stream))) +;;; *POWER-CACHE* is an alist mapping bases to power-vectors. It is +;;; filled and probed by POWERS-FOR-BASE. SCRUB-POWER-CACHE is called +;;; always prior a GC to drop overly large bignums from the cache. +;;; +;;; It doesn't need a lock, but if you work on SCRUB-POWER-CACHE or +;;; POWERS-FOR-BASE, see that you don't break the assumptions! +(defvar *power-cache* nil) + +(defconstant +power-cache-integer-length-limit+ 2048) + +(defun scrub-power-cache () + (let ((cache *power-cache*)) + (dolist (cell cache) + (let ((powers (cdr cell))) + (declare (simple-vector powers)) + (let ((too-big (position-if + (lambda (x) + (>= (integer-length x) + +power-cache-integer-length-limit+)) + powers))) + (when too-big + (setf (cdr cell) (subseq powers 0 too-big)))))) + ;; Since base 10 is overwhelmingly common, make sure it's at head. + ;; Try to keep other bases in a hopefully sensible order as well. + (if (eql 10 (caar cache)) + (setf *power-cache* cache) + ;; If we modify the list destructively we need to copy it, otherwise + ;; an alist lookup in progress might be screwed. + (setf *power-cache* (sort (copy-list cache) + (lambda (a b) + (declare (fixnum a b)) + (cond ((= 10 a) t) + ((= 10 b) nil) + ((= 16 a) t) + ((= 16 b) nil) + ((= 2 a) t) + ((= 2 b) nil) + (t (< a b)))) + :key #'car))))) + +;;; Compute (and cache) a power vector for a BASE and LIMIT: +;;; the vector holds integers for which +;;; (aref powers k) == (expt base (expt 2 k)) +;;; holds. +(defun powers-for-base (base limit) + (flet ((compute-powers (from) + (let (powers) + (do ((p from (* p p))) + ((> p limit) + ;; We don't actually need this, but we also + ;; prefer not to cons it up a second time... + (push p powers)) + (push p powers)) + (nreverse powers)))) + ;; Grab a local reference so that we won't stuff consed at the + ;; head by other threads -- or sorting by SCRUB-POWER-CACHE. + (let ((cache *power-cache*)) + (let ((cell (assoc base cache))) + (if cell + (let* ((powers (cdr cell)) + (len (length powers)) + (max (svref powers (1- len)))) + (if (> max limit) + powers + (let ((new + (concatenate 'vector powers + (compute-powers (* max max))))) + (setf (cdr cell) new) + new))) + (let ((powers (coerce (compute-powers base) 'vector))) + ;; Add new base to head: SCRUB-POWER-CACHE will later + ;; put it to a better place. + (setf *power-cache* (acons base powers cache)) + powers)))))) + ;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05 -(defun %output-bignum-in-base (n base stream) +(defun %output-huge-integer-in-base (n base stream) (declare (type bignum n) (type fixnum base)) - (let ((power (make-array 10 :adjustable t :fill-pointer 0))) - ;; Here there be the bottleneck for big bignums, in the (* p p). - ;; A special purpose SQUARE-BIGNUM might help a bit. See eg: Dan - ;; Zuras, "On Squaring and Multiplying Large Integers", ARITH-11: - ;; IEEE Symposium on Computer Arithmetic, 1993, pp. 260 to 271. - ;; Reprinted as "More on Multiplying and Squaring Large Integers", - ;; IEEE Transactions on Computers, volume 43, number 8, August - ;; 1994, pp. 899-908. - (do ((p base (* p p))) - ((> p n)) - (vector-push-extend p power)) - ;; (aref power k) == (expt base (expt 2 k)) + ;; POWER is a vector for which the following holds: + ;; (aref power k) == (expt base (expt 2 k)) + (let* ((power (powers-for-base base n)) + (k-start (or (position-if (lambda (x) (> x n)) power) + (bug "power-vector too short")))) (labels ((bisect (n k exactp) (declare (fixnum k)) ;; N is the number to bisect @@ -1036,15 +1105,19 @@ ;; doesn't get any leading zeros. (bisect q k exactp) (bisect r k (or exactp (plusp q)))))))) - (bisect n (fill-pointer power) nil)))) + (bisect n k-start nil)))) (defun %output-integer-in-base (integer base stream) (when (minusp integer) (write-char #\- stream) (setf integer (- integer))) - (if (fixnump integer) - (%output-fixnum-in-base integer base stream) - (%output-bignum-in-base integer base stream))) + ;; The ideal cutoff point between these two algorithms is almost + ;; certainly quite platform dependent: this gives 87 for 32 bit + ;; SBCL, which is about right at least for x86/Darwin. + (if (or (fixnump integer) + (< (integer-length integer) (* 3 sb!vm:n-positive-fixnum-bits))) + (%output-reasonable-integer-in-base integer base stream) + (%output-huge-integer-in-base integer base stream))) (defun output-integer (integer stream) (let ((base *print-base*)) @@ -1230,91 +1303,90 @@ (let (;; FIXME: these even tests assume normal IEEE rounding ;; mode. I wonder if we should cater for non-normal? (high-ok (evenp f)) - (low-ok (evenp f)) - (result (make-array 50 :element-type 'base-char - :fill-pointer 0 :adjustable t))) - (labels ((scale (r s m+ m-) - (do ((k 0 (1+ k)) - (s s (* s print-base))) - ((not (or (> (+ r m+) s) - (and high-ok (= (+ r m+) s)))) - (do ((k k (1- k)) - (r r (* r print-base)) - (m+ m+ (* m+ print-base)) - (m- m- (* m- print-base))) - ((not (or (< (* (+ r m+) print-base) s) - (and (not high-ok) - (= (* (+ r m+) print-base) s)))) - (values k (generate r s m+ m-))))))) - (generate (r s m+ m-) - (let (d tc1 tc2) - (tagbody - loop - (setf (values d r) (truncate (* r print-base) s)) - (setf m+ (* m+ print-base)) - (setf m- (* m- print-base)) - (setf tc1 (or (< r m-) (and low-ok (= r m-)))) - (setf tc2 (or (> (+ r m+) s) - (and high-ok (= (+ r m+) s)))) - (when (or tc1 tc2) - (go end)) - (vector-push-extend (char digit-characters d) result) - (go loop) - end - (let ((d (cond - ((and (not tc1) tc2) (1+ d)) - ((and tc1 (not tc2)) d) - (t ; (and tc1 tc2) - (if (< (* r 2) s) d (1+ d)))))) - (vector-push-extend (char digit-characters d) result) - (return-from generate result))))) - (initialize () - (let (r s m+ m-) - (if (>= e 0) - (let* ((be (expt float-radix e)) - (be1 (* be float-radix))) - (if (/= f (expt float-radix (1- float-digits))) - (setf r (* f be 2) - s 2 - m+ be - m- be) - (setf r (* f be1 2) - s (* float-radix 2) - m+ be1 - m- be))) - (if (or (= e min-e) - (/= f (expt float-radix (1- float-digits)))) - (setf r (* f 2) - s (* (expt float-radix (- e)) 2) - m+ 1 - m- 1) - (setf r (* f float-radix 2) - s (* (expt float-radix (- 1 e)) 2) - m+ float-radix - m- 1))) - (when position - (when relativep - (aver (> position 0)) - (do ((k 0 (1+ k)) - ;; running out of letters here - (l 1 (* l print-base))) - ((>= (* s l) (+ r m+)) - ;; k is now \hat{k} - (if (< (+ r (* s (/ (expt print-base (- k position)) 2))) - (* s (expt print-base k))) - (setf position (- k position)) - (setf position (- k position 1)))))) - (let ((low (max m- (/ (* s (expt print-base position)) 2))) - (high (max m+ (/ (* s (expt print-base position)) 2)))) - (when (<= m- low) - (setf m- low) - (setf low-ok t)) - (when (<= m+ high) - (setf m+ high) - (setf high-ok t)))) - (values r s m+ m-)))) - (multiple-value-bind (r s m+ m-) (initialize) - (scale r s m+ m-))))))) + (low-ok (evenp f))) + (with-push-char (:element-type base-char) + (labels ((scale (r s m+ m-) + (do ((k 0 (1+ k)) + (s s (* s print-base))) + ((not (or (> (+ r m+) s) + (and high-ok (= (+ r m+) s)))) + (do ((k k (1- k)) + (r r (* r print-base)) + (m+ m+ (* m+ print-base)) + (m- m- (* m- print-base))) + ((not (or (< (* (+ r m+) print-base) s) + (and (not high-ok) + (= (* (+ r m+) print-base) s)))) + (values k (generate r s m+ m-))))))) + (generate (r s m+ m-) + (let (d tc1 tc2) + (tagbody + loop + (setf (values d r) (truncate (* r print-base) s)) + (setf m+ (* m+ print-base)) + (setf m- (* m- print-base)) + (setf tc1 (or (< r m-) (and low-ok (= r m-)))) + (setf tc2 (or (> (+ r m+) s) + (and high-ok (= (+ r m+) s)))) + (when (or tc1 tc2) + (go end)) + (push-char (char digit-characters d)) + (go loop) + end + (let ((d (cond + ((and (not tc1) tc2) (1+ d)) + ((and tc1 (not tc2)) d) + (t ; (and tc1 tc2) + (if (< (* r 2) s) d (1+ d)))))) + (push-char (char digit-characters d)) + (return-from generate (get-pushed-string)))))) + (initialize () + (let (r s m+ m-) + (if (>= e 0) + (let* ((be (expt float-radix e)) + (be1 (* be float-radix))) + (if (/= f (expt float-radix (1- float-digits))) + (setf r (* f be 2) + s 2 + m+ be + m- be) + (setf r (* f be1 2) + s (* float-radix 2) + m+ be1 + m- be))) + (if (or (= e min-e) + (/= f (expt float-radix (1- float-digits)))) + (setf r (* f 2) + s (* (expt float-radix (- e)) 2) + m+ 1 + m- 1) + (setf r (* f float-radix 2) + s (* (expt float-radix (- 1 e)) 2) + m+ float-radix + m- 1))) + (when position + (when relativep + (aver (> position 0)) + (do ((k 0 (1+ k)) + ;; running out of letters here + (l 1 (* l print-base))) + ((>= (* s l) (+ r m+)) + ;; k is now \hat{k} + (if (< (+ r (* s (/ (expt print-base (- k position)) 2))) + (* s (expt print-base k))) + (setf position (- k position)) + (setf position (- k position 1)))))) + (let ((low (max m- (/ (* s (expt print-base position)) 2))) + (high (max m+ (/ (* s (expt print-base position)) 2)))) + (when (<= m- low) + (setf m- low) + (setf low-ok t)) + (when (<= m+ high) + (setf m+ high) + (setf high-ok t)))) + (values r s m+ m-)))) + (multiple-value-bind (r s m+ m-) (initialize) + (scale r s m+ m-)))))))) ;;; Given a non-negative floating point number, SCALE-EXPONENT returns ;;; a new floating point number Z in the range (0.1, 1.0] and an