X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=9e302d9180b0a3e42885401c5e7e07867b6f006b;hb=2b0851c405b494143009f68e2bc7e91017a809d4;hp=d3096e852c4b3bb1931337f73745f4bf367a542e;hpb=970dd272dc84f7420252eadb4829cc193f795716;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index d3096e8..9e302d9 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -129,6 +129,27 @@
 
 ;;;; routines to print objects
 
+
+;;; keyword variables shared by WRITE and WRITE-TO-STRING, and
+;;; the bindings they map to.
+(eval-when (:compile-toplevel :load-toplevel)
+  (defvar *printer-keyword-variables*
+    '(:escape *print-escape*
+      :radix *print-radix*
+      :base *print-base*
+      :circle *print-circle*
+      :pretty *print-pretty*
+      :level *print-level*
+      :length *print-length*
+      :case *print-case*
+      :array *print-array*
+      :gensym *print-gensym*
+      :readably *print-readably*
+      :right-margin *print-right-margin*
+      :miser-width *print-miser-width*
+      :lines *print-lines*
+      :pprint-dispatch *print-pprint-dispatch*)))
+
 (defun write (object &key
                      ((:stream stream) *standard-output*)
                      ((:escape *print-escape*) *print-escape*)
@@ -154,6 +175,32 @@
   (output-object object (out-synonym-of stream))
   object)
 
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write (&whole form object &rest keys)
+  (let (bind ignore)
+    (do ()
+        ((not (cdr keys))
+         ;; Odd number of keys, punt
+         (when keys
+           (return-from write form)))
+      (let* ((key (pop keys))
+             (value (pop keys))
+             (variable (or (getf *printer-keyword-variables* key)
+                           (when (eq :stream key)
+                             'stream)
+                           (return-from write form))))
+        (when (assoc variable bind)
+          ;; First key has precedence, but we still need to execute the
+          ;; argument, and in the right order.
+          (setf variable (gensym "IGNORE"))
+          (push variable ignore))
+        (push (list variable value) bind)))
+    (unless (assoc 'stream bind)
+      (push (list 'stream '*standard-output*) bind))
+    `(let ,(nreverse bind)
+       ,@(when ignore `((declare (ignore ,@ignore))))
+       (output-object ,object stream))))
+
 (defun prin1 (object &optional stream)
   #!+sb-doc
   "Output a mostly READable printed representation of OBJECT on the specified
@@ -192,27 +239,51 @@
   (values))
 
 (defun write-to-string
-       (object &key
-               ((:escape *print-escape*) *print-escape*)
-               ((:radix *print-radix*) *print-radix*)
-               ((:base *print-base*) *print-base*)
-               ((:circle *print-circle*) *print-circle*)
-               ((:pretty *print-pretty*) *print-pretty*)
-               ((:level *print-level*) *print-level*)
-               ((:length *print-length*) *print-length*)
-               ((:case *print-case*) *print-case*)
-               ((:array *print-array*) *print-array*)
-               ((:gensym *print-gensym*) *print-gensym*)
-               ((:readably *print-readably*) *print-readably*)
-               ((:right-margin *print-right-margin*) *print-right-margin*)
-               ((:miser-width *print-miser-width*) *print-miser-width*)
-               ((:lines *print-lines*) *print-lines*)
-               ((:pprint-dispatch *print-pprint-dispatch*)
-                *print-pprint-dispatch*))
+    (object &key
+            ((:escape *print-escape*) *print-escape*)
+            ((:radix *print-radix*) *print-radix*)
+            ((:base *print-base*) *print-base*)
+            ((:circle *print-circle*) *print-circle*)
+            ((:pretty *print-pretty*) *print-pretty*)
+            ((:level *print-level*) *print-level*)
+            ((:length *print-length*) *print-length*)
+            ((:case *print-case*) *print-case*)
+            ((:array *print-array*) *print-array*)
+            ((:gensym *print-gensym*) *print-gensym*)
+            ((:readably *print-readably*) *print-readably*)
+            ((:right-margin *print-right-margin*) *print-right-margin*)
+            ((:miser-width *print-miser-width*) *print-miser-width*)
+            ((:lines *print-lines*) *print-lines*)
+            ((:pprint-dispatch *print-pprint-dispatch*)
+             *print-pprint-dispatch*))
   #!+sb-doc
   "Return the printed representation of OBJECT as a string."
   (stringify-object object))
 
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write-to-string (&whole form object &rest keys)
+  (let (bind ignore)
+    (do ()
+        ((not (cdr keys))
+         ;; Odd number of keys, punt
+         (when keys
+           (return-from write-to-string form)))
+      (let* ((key (pop keys))
+             (value (pop keys))
+             (variable (or (getf *printer-keyword-variables* key)
+                           (return-from write-to-string form))))
+        (when (assoc variable bind)
+          ;; First key has precedence, but we still need to execute the
+          ;; argument, and in the right order.
+          (setf variable (gensym "IGNORE"))
+          (push variable ignore))
+        (push (list variable value) bind)))
+    (if bind
+        `(let ,(nreverse bind)
+           ,@(when ignore `((declare (ignore ,@ignore))))
+           (stringify-object ,object))
+        `(stringify-object ,object))))
+
 (defun prin1-to-string (object)
   #!+sb-doc
   "Return the printed representation of OBJECT as a string with
@@ -376,8 +447,6 @@
         (output-float object stream))
        (ratio
         (output-ratio object stream))
-       (ratio
-        (output-ratio object stream))
        (complex
         (output-complex object stream))))
     (character
@@ -908,7 +977,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 +1052,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 +1070,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 +1174,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*))
@@ -1207,9 +1349,9 @@
 ;;; possible extension for the enthusiastic: printing floats in bases
 ;;; other than base 10.
 (defconstant single-float-min-e
-  (nth-value 1 (decode-float least-positive-single-float)))
+  (- 2 sb!vm:single-float-bias sb!vm:single-float-digits))
 (defconstant double-float-min-e
-  (nth-value 1 (decode-float least-positive-double-float)))
+  (- 2 sb!vm:double-float-bias sb!vm:double-float-digits))
 #!+long-float
 (defconstant long-float-min-e
   (nth-value 1 (decode-float least-positive-long-float)))
@@ -1230,91 +1372,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
@@ -1340,7 +1481,20 @@
           (values (float 0.0e0 original-x) 1)
           (let* ((ex (locally (declare (optimize (safety 0)))
                        (the fixnum
-                         (round (* exponent (log 2e0 10))))))
+                         (round (* exponent
+                                   ;; this is the closest double float
+                                   ;; to (log 2 10), but expressed so
+                                   ;; that we're not vulnerable to the
+                                   ;; host lisp's interpretation of
+                                   ;; arithmetic.  (FIXME: it turns
+                                   ;; out that sbcl itself is off by 1
+                                   ;; ulp in this value, which is a
+                                   ;; little unfortunate.)
+                                   (load-time-value
+                                    #!-long-float
+                                    (sb!kernel:make-double-float 1070810131 1352628735)
+                                    #!+long-float
+                                    (error "(log 2 10) not computed")))))))
                  (x (if (minusp ex)
                         (if (float-denormalized-p x)
                             #!-long-float