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

@@ -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 >

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"

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

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
 

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,

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))))

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"