From 61b86312e48371df16eefee1ccca9f6cebb4e338 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Fri, 21 May 2010 21:05:22 +0200 Subject: [PATCH] Reimplemented REMOVE using specialized vector and list operations. --- src/CHANGELOG | 6 +- src/c/symbols_list.h | 2 + src/c/symbols_list2.h | 2 + src/lsp/arraylib.lsp | 41 ++++++------- src/lsp/seqlib.lsp | 137 ++++++++++++++++++++++++++++++++---------- src/lsp/seqmacros.lsp | 10 +-- 6 files changed, 139 insertions(+), 59 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index bdbb73bd8..98c854c51 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -61,8 +61,10 @@ ECL 10.5.1: slot inlining would be activated by a SPEED of 1, but only if DEBUG and SAFETY are below 2. - - Important performance improvements in sequence functions, such as - FIND, POSITION, COUNT, NSUBSTITUTE and their IF/IF-NOT variants. + - Important performance improvements in sequence functions, such as FIND, + POSITION, COUNT, REMOVE, NSUBSTITUTE and their IF/IF-NOT variants. Except + COUNT, for efficiency, some of the previously mentioned functions may run + through the sequences in arbitrary orders one or more times. ;;; Local Variables: *** ;;; mode:text *** diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index cfc6485cf..da776e5bf 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1913,6 +1913,8 @@ cl_symbols[] = { {SYS_ "SEQUENCE-START-END", SI_ORDINARY, si_sequence_start_end, 4, OBJNULL}, {SYS_ "SEQUENCE-COUNT", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "SHRINK-VECTOR", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "COPY-SUBARRAY", SI_ORDINARY, NULL, -1, OBJNULL}, /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 16cbfe7aa..10c975ca0 100755 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1913,6 +1913,8 @@ cl_symbols[] = { {SYS_ "SEQUENCE-START-END","si_sequence_start_end"}, {SYS_ "SEQUENCE-COUNT",NULL}, +{SYS_ "SHRINK-VECTOR",NULL}, +{SYS_ "COPY-SUBARRAY",NULL}, /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/lsp/arraylib.lsp b/src/lsp/arraylib.lsp index e4c30eff7..a53c6fa57 100644 --- a/src/lsp/arraylib.lsp +++ b/src/lsp/arraylib.lsp @@ -390,25 +390,22 @@ adjustable array." )) ;;; Copied from cmuci-compat.lisp of CLSQL by Kevin M. Rosenberg (LLGPL-licensed) -(defmacro shrink-vector (vec len) - "Shrinks a vector. Optimized if vector has a fill pointer. -Needs to be a macro to overwrite value of VEC." - (let ((new-vec (gensym))) - `(cond - ((adjustable-array-p ,vec) - (adjust-array ,vec ,len)) - ((typep ,vec 'simple-array) - (let ((,new-vec (make-array ,len :element-type - (array-element-type ,vec)))) - (check-type ,len fixnum) - (locally (declare (optimize (speed 3) (safety 0) (space 0)) ) - (dotimes (i ,len) - (declare (fixnum i)) - (setf (aref ,new-vec i) (aref ,vec i)))) - (setq ,vec ,new-vec))) - ((typep ,vec 'vector) - (setf (fill-pointer ,vec) ,len) - ,vec) - (t - (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) - ))) +(defun shrink-vector (vec len) + "Shrinks a vector." + (cond ((adjustable-array-p vec) + (adjust-array vec len)) + ((typep vec 'simple-array) + (let ((new-vec (make-array len :element-type + (array-element-type vec)))) + (check-type len fixnum) + (locally (declare (optimize (speed 3) (safety 0) (space 0)) ) + (dotimes (i len) + (declare (fixnum i)) + (setf (aref new-vec i) (aref vec i)))) + new-vec)) + ((typep vec 'vector) + (setf (fill-pointer vec) len) + vec) + (t + (error "Unable to shrink vector ~S which is type-of ~S" vec (type-of vec))) + )) diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index 8c3f0fd20..7d46f20fe 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -33,7 +33,9 @@ ((fixnump count) count) ((integerp count) - most-positive-fixnum) + (if (minusp count) + -1 + most-positive-fixnum)) (t (error 'simple-type-error :datum count @@ -227,38 +229,111 @@ `(',f))))) ; eval-when +(defun filter-vector (which out in start end from-end count + test test-not key) + (with-start-end (start end in) + (with-tests (test test-not key) + (with-count (%count count :output in) + (let* ((l (length in)) + (existing 0)) + (declare (fixnum l jndex removed existing)) + ;; If the OUT is empty that means we REMOVE and we have to + ;; create the destination array. For that we first count how + ;; many elements are deletable and allocate the + ;; corresponding amount of space. + (unless (eq out in) + (setf existing (count which in :start start :end end + :test test :test-not test-not :key key)) + (when (zerop existing) + (return-from filter-vector + (values in l))) + (setf out (make-array (- l (min existing %count)) + :element-type + (array-element-type in)))) + ;; We begin by copying the elements in [0, start) + (unless (eq out in) + (copy-subarray out 0 in 0 start)) + ;; ... filter the segement in [start, end) + (cond (from-end + (unless (plusp existing) + (setf existing (count which in :start start :end end + :test test :test-not test-not + :key key))) + (setf %count (if (< existing %count) + 0 + (- existing %count))) + (do-vector (elt in start end :index index) + (when (or (not (compare which (key elt))) + (not (minusp (decf %count)))) + (setf (aref (the vector out) start) elt + start (1+ start))))) + (t + (do-vector (elt in start end :index index) + (if (compare which (key elt)) + (when (zerop (decf %count)) + (setf end (1+ index)) + (return)) + (setf (aref (the vector out) start) elt + start (1+ start)))))) + ;; ... and copy the rest + (values out (copy-subarray out start in end l))))))) -(defseq remove () t nil t - ;; Ordinary run - `(if (listp sequence) - (let* ((l sequence) (l1 nil)) - (do ((i 0 (1+ i))) - ((>= i start)) - (declare (fixnum i)) - (push (car l) l1) - (pop l)) - (do ((i start (1+ i)) (j 0)) - ((or (>= i end) (>= j count) (endp l)) - (nreconc l1 l)) - (declare (fixnum i j)) - (if (compare item (key (car l))) - (incf j) - (push (car l) l1)) - (pop l))) - (delete item sequence - :from-end from-end - :test test :test-not test-not - :start start :end end - :count count - :key key)) - ;; From end run - `(delete item sequence - :from-end from-end - :test test :test-not test-not - :start start :end end - :count count - :key key)) +(defun copy-subarray (out start-out in start-in end-in) + (reckless + (do* ((n end-in) + (i start-in (1+ i)) + (j start-out (1+ j))) + ((>= i n) + i) + (declare (fixnum i j n)) + (row-major-aset out j (row-major-aref in i))))) +(defun remove-list (which sequence start end count test test-not key) + (with-start-end (start end sequence) + (with-tests (test test-not key) + (with-count (%count count :output sequence) + (let* ((output nil) + (index 0)) + (declare (fixnum index)) + (while (and sequence (< index start)) + (setf output (cons (car (the cons sequence)) output) + sequence (cdr (the cons sequence)) + index (1+ index))) + (when (plusp %count) + (loop + (unless (< index end) (return)) + (let ((elt (car (the cons sequence)))) + (setf sequence (cdr (the cons sequence))) + (if (compare which (key elt)) + (when (zerop (decf %count)) + (return)) + (push elt output)) + (incf index)))) + (nreconc output sequence)))))) + +(defun remove (which sequence &key (start 0) end from-end count + test test-not key) + (if (listp sequence) + (if from-end + (let ((l (length sequence))) + (nreverse (delete which (reverse sequence) + :start (if end (- l end) 0) :end (- l start) + :from-end nil + :test test :test-not test-not :key key + :count count))) + (remove-list which sequence start end count test test-not key)) + (values (filter-vector which nil sequence start end from-end count + test test-not key)))) + +(defun remove-if (predicate sequence &key (start 0) end from-end count key) + (remove (si::coerce-to-function predicate) sequence + :start start :end end :from-end from-end :count count + :test #'unsafe-funcall1 :key key)) + +(defun remove-if-not (predicate sequence &key (start 0) end from-end count key) + (remove (si::coerce-to-function predicate) sequence + :start start :end end :from-end from-end :count count + :test-not #'unsafe-funcall1 :key key)) (defseq delete () t t t ;; Ordinary run diff --git a/src/lsp/seqmacros.lsp b/src/lsp/seqmacros.lsp index ef73b995e..45bbd9861 100644 --- a/src/lsp/seqmacros.lsp +++ b/src/lsp/seqmacros.lsp @@ -14,13 +14,15 @@ (in-package "SYSTEM") -(defmacro with-count ((count &optional (value count) &key output) +(defmacro with-count ((count &optional (value count) &key (output nil output-p)) &body body) `(let ((,count (sequence-count ,value))) (declare (fixnum ,count)) - (if (plusp ,count) - ,@body - ,output))) + ,(if output-p + `(if (plusp ,count) + ,@body + ,output) + `(progn ,@body)))) (defmacro with-predicate ((predicate) &body body) `(let ((,predicate (si::coerce-to-function ,predicate)))