From d7eeed8e500932c38cd2c7d22ea1ff9630d2f7c8 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 18 Dec 2008 11:56:47 +0000
Subject: [PATCH] 1.0.23.52: FORMAT performance tweaking

 * Handle plain ~D using explicitly bindings and OUTPUT-OBJECT to
   avoid paying for WRITE keyword argument parsing.

 * Compile format control strings when SPEED = SPACE.

 * Always transform FORMAT calls when the second argument is a
   function -- trying to save space there doesn't make much sense.
---
 NEWS                        | 3 +++
 src/code/late-format.lisp   | 6 ++++--
 src/code/target-format.lisp | 5 ++++-
 src/compiler/srctran.lisp   | 8 +++-----
 tests/print.impure.lisp     | 3 ++-
 version.lisp-expr           | 2 +-
 6 files changed, 17 insertions(+), 10 deletions(-)

diff --git a/NEWS b/NEWS
index e826d51e0..9683e6536 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,9 @@
   * new feature: the system now signals a continuable error if standard
     readtable modification is attempted.
   * optimization: faster generic arithmetic dispatch on x86 and x86-64.
+  * optimization: unmodified FORMAT ~D is now approximately 5% faster.
+  * tradeoff: constant FORMAT control strings are now compiled unless
+    SPACE > SPEED (previously only when SPEED > SPACE.)
   * bug fix: Red Hat Enterprise 3 mmap randomization workaround. (thanks
     to Thomas Burdick)
   * bug fix: DEFCLASS and ENSURE-CLASS-USING-CLASS are now expected to
diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index 7ed479bec..8c5c0c5c4 100644
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -483,8 +483,10 @@
         `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
                                ,base ,mincol ,padchar ,commachar
                                ,commainterval))
-      `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
-              :escape nil)))
+      `(let ((*print-base* ,base)
+             (*print-radix* nil)
+             (*print-escape* nil))
+         (output-object ,(expand-next-arg) stream))))
 
 (def-format-directive #\D (colonp atsignp params)
   (expand-format-integer 10 colonp atsignp params))
diff --git a/src/code/target-format.lisp b/src/code/target-format.lisp
index 890b943ca..67fc81342 100644
--- a/src/code/target-format.lisp
+++ b/src/code/target-format.lisp
@@ -290,7 +290,10 @@
            params
          (format-print-integer stream (next-arg) colonp atsignp ,base mincol
                                padchar commachar commainterval))
-       (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
+       (let ((*print-base* ,base)
+             (*print-radix* nil)
+             (*print-escape* nil))
+         (output-object (next-arg) stream))))
 
 (def-format-interpreter #\D (colonp atsignp params)
   (interpret-format-integer 10))
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index b17b40422..f94f1d0a5 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3816,7 +3816,7 @@
 ;;; error messages, and those don't need to be particularly fast.
 #+sb-xc
 (deftransform format ((dest control &rest args) (t simple-string &rest t) *
-                      :policy (> speed space))
+                      :policy (>= speed space))
   (unless (constant-lvar-p control)
     (give-up-ir1-transform "The control string is not a constant."))
   (let ((arg-names (make-gensym-list (length args))))
@@ -3824,15 +3824,13 @@
        (declare (ignore control))
        (format dest (formatter ,(lvar-value control)) ,@arg-names))))
 
-(deftransform format ((stream control &rest args) (stream function &rest t) *
-                      :policy (> speed space))
+(deftransform format ((stream control &rest args) (stream function &rest t))
   (let ((arg-names (make-gensym-list (length args))))
     `(lambda (stream control ,@arg-names)
        (funcall control stream ,@arg-names)
        nil)))
 
-(deftransform format ((tee control &rest args) ((member t) function &rest t) *
-                      :policy (> speed space))
+(deftransform format ((tee control &rest args) ((member t) function &rest t))
   (let ((arg-names (make-gensym-list (length args))))
     `(lambda (tee control ,@arg-names)
        (declare (ignore tee))
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index d1ccc0169..81cb0f33c 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -414,7 +414,8 @@
 (assert (string= (format nil (formatter "~:C") #\a) "a"))
 
 ;;; This used to trigger an AVER instead.
-(assert (raises-error? (format t "~>") sb-format:format-error))
+(assert (raises-error? (eval '(formatter "~>")) sb-format:format-error))
+(assert (raises-error? (eval '(format t "~>")) sb-format:format-error))
 
 ;;; readably printing hash-tables, check for circularity
 (let ((x (cons 1 2))
diff --git a/version.lisp-expr b/version.lisp-expr
index f6ebf01bc..c374dbc99 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.23.51"
+"1.0.23.52"
-- 
2.11.4.GIT