From 2de1b72f4bec82ad5289f33a84b34fe9cb62bd0a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 5 Dec 2007 15:16:02 +0000 Subject: [PATCH] 1.0.12.16: sequence optimizations: FILL * Use DEFUN instead of DEFINE-SEQUENCE-TRAVERSER for FILL: the dispatched to functions do all the necessary checking, and do it better since they know more about the types. * New function: STRING-FILL*. * Rewrite VECTOR-FILL* and LIST-FILL* for efficiency. * Macros VECTOR-FILL and LIST-FILL were expanded only in VECTOR-FILL* and LIST-FILL* -- get rid of them. * Compile-time dispatch to STRING-FILL*, VECTOR-FILL*, LIST-FILL*, and SB-SEQUENCE:FILL. * Comment above %CHECK-VECTOR-SEQUENC-BOUNDS no longer applies, delete it. --- NEWS | 6 +-- package-data-list.lisp-expr | 7 ++- src/code/seq.lisp | 109 ++++++++++++++++++++++++++++++------------- src/code/string.lisp | 7 --- src/compiler/seqtran.lisp | 59 ++++++++++++++--------- version.lisp-expr | 2 +- 6 files changed, 124 insertions(+), 66 deletions(-) diff --git a/NEWS b/NEWS index 60791b4..ea84bba 100644 --- a/NEWS +++ b/NEWS @@ -4,9 +4,9 @@ changes in sbcl-1.0.13 relative to sbcl-1.0.12: unparsing of directory pathnames as files. Analogously, SB-EXT:PARSE-NATIVE-NAMESTRING takes an AS-DIRECTORY, forcing a filename to parse into a directory pathname. - * optimization: SUBSEQ and COPY-SEQ are 30-80% faster for strings - and vectors whose element-type or simplicity is not fully known at - compile-time. + * optimizations: COPY-SEQ, FILL, and SUBSEQ are 30-80% faster for + strings and vectors whose element-type or simplicity is not fully + known at compile-time. * bug fix: COPY-SEQ on lists did not signal a type-error on improper lists in safe code. * bug fix: some sequence functions elided bounds checking when diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index de7182e..ace5f0b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1151,7 +1151,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%ASSOC-TEST-NOT" "%ASIN" "%ASINH" "%ATAN" "%ATAN2" "%ATANH" "%CALLER-FRAME-AND-PC" - "%CHECK-BOUND" "%CHECK-VECTOR-SEQUENCE-BOUNDS" + "%CHECK-BOUND" + "%CHECK-GENERIC-SEQUENCE-BOUNDS" + "%CHECK-VECTOR-SEQUENCE-BOUNDS" "%CLOSURE-FUN" "%CLOSURE-INDEX-REF" "%COMPARE-AND-SWAP-CAR" "%COMPARE-AND-SWAP-CDR" @@ -1326,6 +1328,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." #!+(or x86-64 x86) "%LEA" "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" "LIST-COPY-SEQ*" + "LIST-FILL*" "LIST-SUBSEQ*" "ANSI-STREAM" "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE" @@ -1503,6 +1506,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE" "SPECIALIZABLE" "SPECIALIZABLE-VECTOR" "SPECIFIER-TYPE" "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR" + "STRING-FILL*" "STRING-SUBSEQ*" "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" "SUB-GC" "SYMBOLS-DESIGNATOR" @@ -1535,6 +1539,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "VALUES-TYPE-TYPES" "VALUES-TYPES" "VALUES-TYPES-EQUAL-OR-INTERSECT" "VECTOR-T-P" "VECTOR-NIL-P" + "VECTOR-FILL*" "VECTOR-SUBSEQ*" "VECTOR-TO-VECTOR*" "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" "WITH-ARRAY-DATA" diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 390e31f..8fe9d9f 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -20,6 +20,12 @@ ;;;; utilities +(defun %check-generic-sequence-bounds (seq start end) + (let ((length (sb!sequence:length seq))) + (if (<= 0 start (or end length) length) + (or end length) + (sequence-bounding-indices-bad-error seq start end)))) + (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *sequence-keyword-info* @@ -463,43 +469,82 @@ ;;;; FILL -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-fill (sequence item start end) - `(do ((index ,start (1+ index))) - ((= index (the fixnum ,end)) ,sequence) - (declare (fixnum index)) - (setf (aref ,sequence index) ,item))) - -(sb!xc:defmacro list-fill (sequence item start end) - `(do ((current (nthcdr ,start ,sequence) (cdr current)) - (index ,start (1+ index))) - ((or (atom current) (and end (= index (the fixnum ,end)))) - sequence) - (declare (fixnum index)) - (rplaca current ,item))) - -) ; EVAL-WHEN - -;;; The support routines for FILL are used by compiler transforms, so we -;;; worry about dealing with END being supplied or defaulting to NIL -;;; at this level. - (defun list-fill* (sequence item start end) - (declare (list sequence)) - (list-fill sequence item start end)) + (declare (type list sequence) + (type unsigned-byte start) + (type (or null unsigned-byte) end)) + (flet ((oops () + (sequence-bounding-indices-bad-error sequence start end))) + (let ((pointer sequence)) + (unless (zerop start) + ;; If START > 0 the list cannot be empty. So CDR down to it + ;; START-1 times, check that we still have something, then CDR + ;; the final time. + ;; + ;; If START was zero, the list may be empty if END is NIL or + ;; also zero. + (unless (= start 1) + (setf pointer (nthcdr (1- start) pointer))) + (if pointer + (pop pointer) + (oops)) + (if end + (let ((n (- end start))) + (declare (integer n)) + (when (minusp n) + (oops)) + (when (plusp n) + (loop repeat n + do (rplaca pointer item)))) + (loop while pointer + do (setf pointer (cdr (rplaca pointer item))))))))) (defun vector-fill* (sequence item start end) - (declare (vector sequence)) - (when (null end) (setq end (length sequence))) - (vector-fill sequence item start end)) + (with-array-data ((data sequence) + (start start) + (end end) + :force-inline t + :check-fill-pointer t) + (let ((setter (!find-data-vector-setter data))) + (declare (optimize (speed 3) (safety 0))) + (do ((index start (1+ index))) + ((= index end) sequence) + (declare (index index)) + (funcall setter data index item))))) -(define-sequence-traverser fill (sequence item &rest args &key start end) - #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM." +(defun string-fill* (sequence item start end) + (declare (string sequence)) + (with-array-data ((data sequence) + (start start) + (end end) + :force-inline t + :check-fill-pointer t) + (macrolet ((frob () + `(locally (declare (optimize (safety 0) (speed 3))) + (do ((i start (1+ i))) + ((= i end) sequence) + (declare (index i)) + (setf (aref data i) item))))) + (etypecase data + #!+sb-unicode + ((simple-array character (*)) + (let ((item (locally (declare (optimize (safety 3))) + (the character item)))) + (frob))) + ((simple-array base-char (*)) + (let ((item (locally (declare (optimize (safety 3))) + (the base-char item)))) + (frob))))))) + +(defun fill (sequence item &key (start 0) end) + #!+sb-doc + "Replace the specified elements of SEQUENCE with ITEM." (seq-dispatch sequence - (list-fill* sequence item start end) - (vector-fill* sequence item start end) - (apply #'sb!sequence:fill sequence item args))) + (list-fill* sequence item start end) + (vector-fill* sequence item start end) + (sb!sequence:fill sequence item + :start start + :end (%check-generic-sequence-bounds sequence start end)))) ;;;; REPLACE diff --git a/src/code/string.lisp b/src/code/string.lisp index f90b296..36bc060 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -29,13 +29,6 @@ ;;; %CHECK-VECTOR-SEQUENCE-BOUNDS is used to verify that the START and ;;; END arguments are valid bounding indices. -;;; -;;; FIXME: This causes a certain amount of double checking that could -;;; be avoided, as if the string passes this (more stringent) test it -;;; will automatically pass the tests in WITH-ARRAY-DATA. Fixing this -;;; would necessitate rearranging the transforms (maybe converting to -;;; strings in the unasterisked versions and using this in the -;;; transforms conditional on SAFETY>SPEED,SPACE). (defun %check-vector-sequence-bounds (vector start end) (%check-vector-sequence-bounds vector start end)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index cf09aa0..78cb9dc 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -408,29 +408,44 @@ (rplacd splice (cdr x)))) (t (setq splice x))))) -(deftransform fill ((seq item &key (start 0) (end (length seq))) - (vector t &key (:start t) (:end index)) +(deftransform fill ((seq item &key (start 0) (end nil)) + (list t &key (:start t) (:end t))) + '(list-fill* seq item start end)) + +(deftransform fill ((seq item &key (start 0) (end nil)) + (vector t &key (:start t) (:end t)) * - :policy (> speed space)) - "open code" - (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) - (values - `(with-array-data ((data seq) - (start start) - (end end) - :check-fill-pointer t) - (declare (type (simple-array ,element-type 1) data)) - (declare (type fixnum start end)) - (do ((i start (1+ i))) - ((= i end) seq) - (declare (type index i)) - ;; WITH-ARRAY-DATA did our range checks once and for all, so - ;; it'd be wasteful to check again on every AREF... - (declare (optimize (safety 0))) - (setf (aref data i) item))) - ;; ... though we still need to check that the new element can fit - ;; into the vector in safe code. -- CSR, 2002-07-05 - `((declare (type ,element-type item)))))) + :node node) + (let ((type (lvar-type seq)) + (element-type (type-specifier (extract-upgraded-element-type seq)))) + (cond ((and (neq '* element-type) (policy node (> speed space))) + (values + `(with-array-data ((data seq) + (start start) + (end end) + :check-fill-pointer t) + (declare (type (simple-array ,element-type 1) data)) + (declare (type index start end)) + ;; WITH-ARRAY-DATA did our range checks once and for all, so + ;; it'd be wasteful to check again on every AREF... + (declare (optimize (safety 0) (speed 3))) + (do ((i start (1+ i))) + ((= i end) seq) + (declare (type index i)) + (setf (aref data i) item))) + ;; ... though we still need to check that the new element can fit + ;; into the vector in safe code. -- CSR, 2002-07-05 + `((declare (type ,element-type item))))) + ((csubtypep type (specifier-type 'string)) + '(string-fill* seq item start end)) + (t + '(vector-fill* seq item start end))))) + +(deftransform fill ((seq item &key (start 0) (end nil)) + ((and sequence (not vector) (not list)) t &key (:start t) (:end t))) + `(sb!sequence:fill seq item + :start start + :end (%check-generic-sequence-bounds seq start end))) ;;;; utilities diff --git a/version.lisp-expr b/version.lisp-expr index 83e3ff0..7464d29 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.12.15" +"1.0.12.16" -- 1.7.10.4