From 19efdada13c0ca54d5b0249aeeece458f888896e Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 1 Dec 2007 18:57:57 +0000 Subject: [PATCH] 1.0.12.14: sequence optimizations: COPY-SEQ * Compile-time dispatch to STRING-SUBSEQ*, VECTOR-SUBSEQ*, LIST-COPY-SEQ*, and SB-SEQUENCE:COPY-SEQ. * Share code between COPY-LIST and LIST-COPY-SEQ* via light macrology. * COPY-SEQ on lists should check for improper lists. --- NEWS | 6 ++++-- package-data-list.lisp-expr | 1 + src/code/list.lisp | 32 ++++++++++++++++++-------------- src/code/seq.lisp | 33 ++------------------------------- src/compiler/seqtran.lisp | 28 +++++++++++++++++++--------- tests/seq.pure.lisp | 7 +++++++ version.lisp-expr | 2 +- 7 files changed, 52 insertions(+), 57 deletions(-) diff --git a/NEWS b/NEWS index 1f3ead3..60791b4 100644 --- a/NEWS +++ b/NEWS @@ -4,9 +4,11 @@ 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 is 30-80% faster for strings and vectors - whose element-type or simplicity is not fully known at + * 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. + * 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 SPEED > SAFETY. * bug fix: too liberal weakening of union-type checks when SPEED > diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 246ce9b..de7182e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1325,6 +1325,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "LAYOUT-SLOT-TABLE" #!+(or x86-64 x86) "%LEA" "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" + "LIST-COPY-SEQ*" "LIST-SUBSEQ*" "ANSI-STREAM" "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE" diff --git a/src/code/list.lisp b/src/code/list.lisp index 5f96806..4a72e1a 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -312,22 +312,26 @@ ;;;; list copying functions +(eval-when (:compile-toplevel :load-toplevel :execute) + (sb!xc:defmacro !copy-list-macro (list &key check-proper-list) + ;; Unless CHECK-PROPER-LIST is true, the list is copied correctly + ;; even if the list is not terminated by NIL. The new list is built + ;; by CDR'ing SPLICE which is always at the tail of the new list. + `(when ,list + (let ((copy (list (car ,list)))) + (do ((orig (cdr ,list) (cdr orig)) + (splice copy (cdr (rplacd splice (cons (car orig) nil))))) + (,@(if check-proper-list + '((endp orig)) + '((atom orig) + (unless (null orig) + (rplacd splice orig)))) + copy)))))) + (defun copy-list (list) #!+sb-doc - "Return a new list which is EQUAL to LIST." - ;; The list is copied correctly even if the list is not terminated - ;; by NIL. The new list is built by CDR'ing SPLICE which is always - ;; at the tail of the new list. - (if (atom list) - list - (let ((result (list (car list)))) - (do ((x (cdr list) (cdr x)) - (splice result - (cdr (rplacd splice (cons (car x) '()))))) - ((atom x) - (unless (null x) - (rplacd splice x)))) - result))) + "Return a new list which is EQUAL to LIST. LIST may be improper." + (!copy-list-macro list)) (defun copy-alist (alist) #!+sb-doc diff --git a/src/code/seq.lisp b/src/code/seq.lisp index cefc59b..390e31f 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -451,44 +451,15 @@ ;;;; COPY-SEQ -(eval-when (:compile-toplevel :execute) - -(sb!xc:defmacro vector-copy-seq (sequence) - `(let ((length (length (the vector ,sequence)))) - (declare (fixnum length)) - (do ((index 0 (1+ index)) - (copy (%make-sequence-like ,sequence length))) - ((= index length) copy) - (declare (fixnum index)) - (setf (aref copy index) (aref ,sequence index))))) - -(sb!xc:defmacro list-copy-seq (list) - `(if (atom ,list) '() - (let ((result (cons (car ,list) '()) )) - (do ((x (cdr ,list) (cdr x)) - (splice result - (cdr (rplacd splice (cons (car x) '() ))) )) - ((atom x) (unless (null x) - (rplacd splice x)) - result))))) - -) ; EVAL-WHEN - (defun copy-seq (sequence) #!+sb-doc "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." (seq-dispatch sequence (list-copy-seq* sequence) - (vector-copy-seq* sequence) + (vector-subseq* sequence 0 nil) (sb!sequence:copy-seq sequence))) -;;; internal frobs - (defun list-copy-seq* (sequence) - (list-copy-seq sequence)) - -(defun vector-copy-seq* (sequence) - (declare (type vector sequence)) - (vector-copy-seq sequence)) + (!copy-list-macro sequence :check-proper-list t)) ;;;; FILL diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index e265747..cf09aa0 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -818,15 +818,25 @@ ((and sequence (not vector) (not list)) t &optional t)) '(sb!sequence:subseq seq start end)) -(deftransform copy-seq ((seq) ((or (simple-unboxed-array (*)) simple-vector)) *) - (let ((array-type (lvar-type seq))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let ((element-type (type-specifier (array-type-specialized-element-type array-type)))) - `(let* ((length (length seq)) - (result (make-array length :element-type ',element-type))) - ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) - result)))) +(deftransform copy-seq ((seq) (vector)) + (let ((type (lvar-type seq))) + (cond ((and (array-type-p type) + (csubtypep type (specifier-type '(or (simple-unboxed-array (*)) simple-vector)))) + (let ((element-type (type-specifier (array-type-specialized-element-type type)))) + `(let* ((length (length seq)) + (result (make-array length :element-type ',element-type))) + ,(maybe-expand-copy-loop-inline 'seq 0 'result 0 'length element-type) + result))) + ((csubtypep type (specifier-type 'string)) + '(string-subseq* seq 0 nil)) + (t + '(vector-subseq* seq 0 nil))))) + +(deftransform copy-seq ((seq) (list)) + '(list-copy-seq* seq)) + +(deftransform copy-seq ((seq) ((and sequence (not vector) (not list)))) + '(sb!sequence:copy-seq seq)) ;;; FIXME: it really should be possible to take advantage of the ;;; macros used in code/seq.lisp here to avoid duplication of code, diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index 7eac068..91b1971 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -187,3 +187,10 @@ (assert (string= c "abcde")) (assert (string= d "beacd")) (assert (string= e "abced"))) + +;;; COPY-SEQ "should be prepared to signal an error if sequence is not +;;; a proper sequence". +(locally (declare (optimize safety)) + (multiple-value-bind (seq err) (ignore-errors (copy-seq '(1 2 3 . 4))) + (assert (not seq)) + (assert (typep err 'type-error)))) diff --git a/version.lisp-expr b/version.lisp-expr index 7e93b12..7201ff4 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.13" +"1.0.12.14" -- 1.7.10.4