From 748ade16173ad170bb6bafe0c1bd2a52bc33c275 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Sat, 29 Oct 2005 02:33:41 +0000 Subject: [PATCH] 0.9.6.8: More optimizations to OUTPUT-BYTES/FOO. * Rearrange the guts of the function to allow establishing the OUTPUT-NOTHING catch tag outside the inner loop. * Bounds check STRING once at the start of the function instead of once every iteration. * Declare some types. --- NEWS | 3 ++- src/code/fd-stream.lisp | 63 ++++++++++++++++++++++++++++------------------- version.lisp-expr | 2 +- 3 files changed, 41 insertions(+), 27 deletions(-) diff --git a/NEWS b/NEWS index 027bc54..a591e7b 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,7 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-0.9.7 relative to sbcl-0.9.6: - * optimization: performance improvements to READ-LINE + * optimization: performance improvements to IO on file streams of + :ELEMENT-TYPE CHARACTER changes in sbcl-0.9.6 relative to sbcl-0.9.5: * bug fix: add a workaround to SBCL looping infinitely at startup on diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 3d6cb0f..8b54799 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -999,27 +999,34 @@ (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) + (unless (<= 0 start end (length string)) + (signal-bounding-indices-bad-error string start end)) (do () ((= end start)) (setf (fd-stream-obuf-tail stream) (flet ((do-it (string) - (do* ((len (fd-stream-obuf-length stream)) + (let ((len (fd-stream-obuf-length stream)) (sap (fd-stream-obuf-sap stream)) (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) - ,(if output-restart - `(catch 'output-nothing + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) (let* ((byte (aref string start)) (bits (char-code byte))) ,out-expr - (incf tail ,size))) - `(let* ((byte (aref string start)) - (bits (char-code byte))) - ,out-expr - (incf tail ,size))) - (incf start)))) + (incf tail ,size) + (incf start))) + ;; Exited from the loop normally + (return-from do-it tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) (declare (inline do-it)) ;; Specialized versions for the common cases of ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) @@ -1119,29 +1126,35 @@ (> (fd-stream-ibuf-tail stream) (fd-stream-ibuf-head stream))) (file-position stream (file-position stream))) - (when (< end start) - (error ":END before :START!")) + (unless (<= 0 start end (length string)) + (signal-bounding-indices-bad-error string start end)) (do () ((= end start)) (setf (fd-stream-obuf-tail stream) (flet ((do-it (string) - (do* ((len (fd-stream-obuf-length stream)) + (let ((len (fd-stream-obuf-length stream)) (sap (fd-stream-obuf-sap stream)) (tail (fd-stream-obuf-tail stream))) - ((or (= start end) (< (- len tail) 4)) tail) - ,(if output-restart - `(catch 'output-nothing + (declare (type index tail) + ;; STRING bounds have already been checked. + (optimize (safety 0))) + (loop + (,@(if output-restart + `(catch 'output-nothing) + `(progn)) + (do* () + ((or (= start end) (< (- len tail) 4))) (let* ((byte (aref string start)) (bits (char-code byte)) (size ,out-size-expr)) ,out-expr - (incf tail size))) - `(let* ((byte (aref string start)) - (bits (char-code byte)) - (size ,out-size-expr)) - ,out-expr - (incf tail size))) - (incf start)))) + (incf tail size) + (incf start))) + ;; Exited from the loop normally + (return-from do-it tail)) + ;; Exited via CATCH. Skip the current character + ;; and try the inner loop again. + (incf start))))) (declare (inline do-it)) ;; Specialized versions for the common cases of ;; SIMPLE-BASE-STRING and (SIMPLE-ARRAY CHARACTER) diff --git a/version.lisp-expr b/version.lisp-expr index 6ee9836..e5fb9fc 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".) -"0.9.6.7" +"0.9.6.8" -- 1.7.10.4