1.0.23.54: compiler-macros for WRITE and WRITE-TO-STRING

 * The common use-cases have only constant keywords, but due to the
   way they are defined inlining doesn't really help -- so do it with
   compiler-macros, which bind only those specials specified in the
   call.

diff --git a/src/code/print.lisp b/src/code/print.lisp
index e235f4b..7240bf8 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -129,6 +129,27 @@
 \f
 ;;;; routines to print objects
 
+\f
+;;; 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

diff --git a/version.lisp-expr b/version.lisp-expr
index 74113a3..be05f36 100644 (file)
--- 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.53"
+"1.0.23.54"