From 7a2c04ec5b42fa2faf4ce0969772b10042d74c70 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 18 Dec 2008 20:41:57 +0000 Subject: [PATCH] 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. --- src/code/print.lisp | 105 ++++++++++++++++++++++++++++++++++++++++++--------- version.lisp-expr | 2 +- 2 files changed, 89 insertions(+), 18 deletions(-) diff --git a/src/code/print.lisp b/src/code/print.lisp index e235f4b..7240bf8 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 diff --git a/version.lisp-expr b/version.lisp-expr index 74113a3..be05f36 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.53" +"1.0.23.54" -- 1.7.10.4