Author: hhubner Date: Thu May 1 12:26:47 2008 New Revision: 9
Modified: branches/hans/input.lisp branches/hans/output.lisp branches/hans/strings.lisp Log: Checkpoint fast STRING-TO-OCTETS implpementation
Modified: branches/hans/input.lisp ============================================================================== --- branches/hans/input.lisp (original) +++ branches/hans/input.lisp Thu May 1 12:26:47 2008 @@ -309,6 +309,16 @@ save-position (eol-style (external-format-eol-style (flexi-stream-external-format ,stream-var))) (string (make-array (- end start) :element-type 'character :fill-pointer 0))) + ;; High-speed version of OCTETS-TO-STRING: We need to + ;; implement this as a macro as we want to stay with the + ;; old "inner" API for bodies of character readers. In + ;; particular, they shall be able to call (READ-BYTE* + ;; STREAM) as before. To achive this, we create a local + ;; function READ-BYTE* that gets the next byte from the + ;; input vector. Additionally, we create local functions + ;; for reading characters in a loop and for unreading a + ;; character that is used by the newline processing + ;; function CODE-CHAR-WITH-NEWLINE-PROCESSING. (labels ((read-byte* (stream) (declare (ignore stream)) (if (< position end)
Modified: branches/hans/output.lisp ============================================================================== --- branches/hans/output.lisp (original) +++ branches/hans/output.lisp Thu May 1 12:26:47 2008 @@ -78,17 +78,35 @@ (declare (optimize speed)) (char-to-octets stream char stream))
-(defmethod char-to-octets ((stream flexi-latin-1-output-stream) char sink) - (declare (optimize speed)) +(defmacro define-char-writer (((stream-var stream-class) char-var sink-var) &body body) + (let ((body body)) + (with-unique-names (string-var start-var end-var dummy-sink-var byte-var i-var) + `(progn + (defmethod char-to-octets ((,stream-var ,stream-class) ,char-var ,sink-var) + (declare (optimize speed)) + ,@body) + (defmethod string-to-octets% ((,stream-var ,stream-class) ,string-var ,start-var ,end-var) + (declare (optimize speed)) + (let ((,sink-var (make-array (truncate (* (float (- ,end-var ,start-var)) + (flexi-stream-output-size-factor ,stream-var))) + :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8)))) + (loop + for ,i-var of-type fixnum from ,start-var below ,end-var + for ,char-var of-type character = (aref ,string-var ,i-var) + do (flet ((write-byte* (,byte-var ,dummy-sink-var) + (declare (ignore ,dummy-sink-var)) + (vector-push-extend ,byte-var ,sink-var))) + ,@body)) + ,sink-var)))))) + +(define-char-writer ((stream flexi-latin-1-output-stream) char sink) (let ((octet (char-code char))) (when (> octet 255) (signal-encoding-error stream "~S is not a LATIN-1 character." char)) (write-byte* octet sink)) char)
-(defmethod char-to-octets ((stream flexi-ascii-output-stream) char sink) - (declare (optimize speed)) - (declare (type character char)) +(define-char-writer ((stream flexi-ascii-output-stream) char sink) (let ((octet (char-code char))) (declare (type fixnum char-code)) (when (> octet 127) @@ -96,8 +114,7 @@ (write-byte* octet sink)) char)
-(defmethod char-to-octets ((stream flexi-8-bit-output-stream) char sink) - (declare (optimize speed)) +(define-char-writer ((stream flexi-8-bit-output-stream) char sink) (with-accessors ((encoding-hash flexi-stream-encoding-hash)) stream (let ((octet (gethash (char-code char) encoding-hash))) @@ -106,8 +123,7 @@ (write-byte* octet sink)) char))
-(defmethod char-to-octets ((stream flexi-utf-8-output-stream) char sink) - (declare (optimize speed)) +(define-char-writer ((stream flexi-utf-8-output-stream) char sink) (let ((char-code (char-code char))) (tagbody (cond ((< char-code #x80) @@ -138,8 +154,7 @@ zero)) char)
-(defmethod char-to-octets ((stream flexi-utf-16-le-output-stream) char sink) - (declare (optimize speed)) +(define-char-writer ((stream flexi-utf-16-le-output-stream) char sink) (flet ((write-word (word) (write-byte* (ldb (byte 8 0) word) sink) (write-byte* (ldb (byte 8 8) word) sink))) @@ -152,8 +167,7 @@ (write-word (logior #xdc00 (ldb (byte 10 0) char-code))))))) char)
-(defmethod char-to-octets ((stream flexi-utf-16-be-output-stream) char sink) - (declare (optimize speed)) +(define-char-writer ((stream flexi-utf-16-be-output-stream) char sink) (flet ((write-word (word) (write-byte* (ldb (byte 8 8) word) sink) (write-byte* (ldb (byte 8 0) word) sink))) @@ -166,25 +180,22 @@ (write-word (logior #xdc00 (ldb (byte 10 0) char-code))))))) char)
-(defmethod char-to-octets ((stream flexi-utf-32-le-output-stream) char sink) - (declare (optimize speed)) +(define-char-writer ((stream flexi-utf-32-le-output-stream) char sink) (loop with char-code = (char-code char) for position in '(0 8 16 24) do (write-byte* (ldb (byte 8 position) char-code) sink)) char)
-(defmethod char-to-octets ((stream flexi-utf-32-be-output-stream) char sink) - (declare (optimize speed)) +(define-char-writer ((stream flexi-utf-32-be-output-stream) char sink) (loop with char-code = (char-code char) for position in '(24 16 8 0) do (write-byte* (ldb (byte 8 position) char-code) sink)) char)
-(defmethod char-to-octets ((stream flexi-cr-mixin) char sink) +(define-char-writer ((stream flexi-cr-mixin) char sink) "The `base' method for all streams which need end-of-line conversion. Uses CALL-NEXT-METHOD to do the actual work of sending one or more characters to SINK." - (declare (optimize speed)) (with-accessors ((external-format flexi-stream-external-format)) stream (case char
Modified: branches/hans/strings.lisp ============================================================================== --- branches/hans/strings.lisp (original) +++ branches/hans/strings.lisp Thu May 1 12:26:47 2008 @@ -39,13 +39,8 @@ (declare (optimize speed)) (declare (type (array character (*)) string)) (declare (fixnum start end)) - (let* ((dummy-stream (make-flexi-stream (make-broadcast-stream) :external-format external-format)) - (octets (make-array (truncate (* (float (- end start)) (flexi-stream-output-size-factor dummy-stream))) - :adjustable t :fill-pointer 0 :element-type '(unsigned-byte 8)))) - (loop - for i of-type fixnum from start below end - do (char-to-octets dummy-stream (aref string i) octets)) - octets)) + (string-to-octets% (make-flexi-stream (make-broadcast-stream) :external-format external-format) + string start end))
(defun string-to-octets* (string &key (external-format (make-external-format :latin1)) (start 0) end)