From a7a221e1364a37e257deb5ea284f604de8c7ecec Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Fri, 28 May 2010 23:46:00 +0200 Subject: [PATCH] Optimized COPY-SUBARRAY and used it for improving REPLACE --- src/CHANGELOG | 2 +- src/c/array.d | 39 +++++++++++++++++------ src/c/symbols_list.h | 2 +- src/c/symbols_list2.h | 2 +- src/cmp/cmputil.lsp | 1 + src/h/external.h | 1 + src/lsp/seqlib.lsp | 73 +++++++++++++++++++++---------------------- 7 files changed, 71 insertions(+), 49 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index addc0b06e..a4b29ca3f 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -62,7 +62,7 @@ ECL 10.5.1: SAFETY are below 2. - Important performance improvements in sequence functions, such as FIND, - POSITION, COUNT, REMOVE, DELETE, SUBSTITUTE, NSUBSTITUTE, + REPLACE, POSITION, COUNT, REMOVE, DELETE, SUBSTITUTE, NSUBSTITUTE, DELETE-DUPLICATES, REMOVE-DUPLICATES and their possible 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 diff --git a/src/c/array.d b/src/c/array.d index 874bd8ace..4fab5f6ec 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -1107,17 +1107,28 @@ ecl_copy_subarray(cl_object dest, cl_index i0, cl_object orig, if (i1 + l > orig->array.dim) { l = orig->array.dim - i1; } - if (t != ecl_array_elttype(orig) || t == aet_bit) { - while (l--) { - ecl_aset_unsafe(dest, i0++, ecl_aref_unsafe(orig, i1++)); - } - } else if (t >= 0 && t <= aet_last_type) { + if (dest == orig && i0 > i1) { + if (t != ecl_array_elttype(orig) || t == aet_bit) { + for (i0 += l, i1 += l; l--; ) { + ecl_aset_unsafe(dest, --i0, + ecl_aref_unsafe(orig, --i1)); + } + } else { + cl_index elt_size = ecl_aet_size[t]; + memmove(dest->array.self.bc + i0 * elt_size, + orig->array.self.bc + i1 * elt_size, + l * elt_size); + } + } else if (t != ecl_array_elttype(orig) || t == aet_bit) { + while (l--) { + ecl_aset_unsafe(dest, i0++, + ecl_aref_unsafe(orig, i1++)); + } + } else { cl_index elt_size = ecl_aet_size[t]; memcpy(dest->array.self.bc + i0 * elt_size, - orig->array.self.bc + i1 * elt_size, - l * elt_size); - } else { - FEbad_aet(); + orig->array.self.bc + i1 * elt_size, + l * elt_size); } } @@ -1235,6 +1246,16 @@ ecl_reverse_subarray(cl_object x, cl_index i0, cl_index i1) } } +cl_object +si_copy_subarray(cl_object dest, cl_object start0, + cl_object orig, cl_object start1, cl_object length) +{ + ecl_copy_subarray(dest, fixnnint(start0), + orig, fixnnint(start1), + fixnnint(length)); + @(return dest) +} + cl_object si_fill_array_with_elt(cl_object x, cl_object elt, cl_object start, cl_object end) { diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e1b3edf90..39cc26f52 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1914,7 +1914,7 @@ 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}, +{SYS_ "COPY-SUBARRAY", SI_ORDINARY, si_copy_subarray, 5, OBJNULL}, {SYS_ "CONS-CAR", SI_ORDINARY, cl_car, 1, OBJNULL}, {SYS_ "CONS-CDR", SI_ORDINARY, cl_cdr, 1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index b7e00fb07..c8d9de7ff 100755 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1914,7 +1914,7 @@ cl_symbols[] = { {SYS_ "SEQUENCE-START-END","si_sequence_start_end"}, {SYS_ "SEQUENCE-COUNT",NULL}, {SYS_ "SHRINK-VECTOR",NULL}, -{SYS_ "COPY-SUBARRAY",NULL}, +{SYS_ "COPY-SUBARRAY","si_copy_subarray"}, {SYS_ "CONS-CAR","cl_car"}, {SYS_ "CONS-CDR","cl_cdr"}, diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index e695ae806..bbbb9f7f5 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -211,6 +211,7 @@ `(unless ,condition (cmperr ,string ,@args))) (defun cmperr (string &rest args) + (break) (let ((c (make-condition 'compiler-error :format-control string :format-arguments args))) diff --git a/src/h/external.h b/src/h/external.h index 3d51b6be9..e5be79190 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -340,6 +340,7 @@ extern ECL_API cl_object si_replace_array(cl_object old_obj, cl_object new_obj); extern ECL_API cl_object cl_aref _ARGS((cl_narg narg, cl_object x, ...)); extern ECL_API cl_object si_aset _ARGS((cl_narg narg, cl_object x, ...)); extern ECL_API cl_object si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff); +extern ECL_API cl_object si_copy_subarray(cl_object dest, cl_object start0, cl_object orig, cl_object start1, cl_object length); extern ECL_API cl_object si_fill_array_with_elt(cl_object array, cl_object elt, cl_object start, cl_object end); extern ECL_API void FEwrong_dimensions(cl_object a, cl_index rank) ecl_attr_noreturn; diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index dffa0e670..361e19045 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -18,6 +18,14 @@ (eval-when (:execute) (load (merge-pathnames "seqmacros.lsp" *load-truename*))) +#-ecl-min +(eval-when (:compile-toplevel) +(define-compiler-macro copy-subarray (&rest args) + `(ffi:c-inline ,args (:object :fixnum :object :fixnum :fixnum) :void + "ecl_copy_subarray(#0,#1,#2,#3,#4)" + :one-liner t)) +) + (defun seqtype (sequence) (declare (si::c-local)) (cond ((listp sequence) 'list) @@ -118,29 +126,29 @@ (defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2) (with-start-end (start1 end1 sequence1) (with-start-end (start2 end2 sequence2) - (if (and (eq sequence1 sequence2) - (> start1 start2)) - (do* ((i 0 (1+ i)) - (l (if (< (the fixnum (- end1 start1)) - (the fixnum (- end2 start2))) - (- end1 start1) - (- end2 start2))) - (s1 (+ start1 (the fixnum (1- l))) (the fixnum (1- s1))) - (s2 (+ start2 (the fixnum (1- l))) (the fixnum (1- s2)))) - ((>= i l) sequence1) - (declare (fixnum i l s1 s2)) - (setf (elt sequence1 s1) (elt sequence2 s2))) - (do ((i 0 (1+ i)) - (l (if (< (the fixnum (- end1 start1)) - (the fixnum (- end2 start2))) - (- end1 start1) - (- end2 start2))) - (s1 start1 (1+ s1)) - (s2 start2 (1+ s2))) - ((>= i l) sequence1) - (declare (fixnum i l s1 s2)) - (setf (elt sequence1 s1) (elt sequence2 s2))))))) - + (declare (optimize (speed 3) (safety 0) (debug 0))) + (let ((length (min (- end2 start2) (- end1 start1)))) + (declare (fixnum length)) + ;; If the two sequences are arrays, we can use COPY-SUBARRAY. + ;; Otherwise we have our own loop, which relies on sequence + ;; iterators. It becomes inefficient when sequences overlap + ;; because it has to save the data. + (if (and (vectorp sequence1) + (vectorp sequence2)) + (copy-subarray sequence1 start1 sequence2 start2 length) + (do* ((data (if (and (eq sequence1 sequence2) + (> start1 start2)) + (subseq sequence2 start2 end2) + sequence2)) + (it2 (make-seq-iterator data start2) + (seq-iterator-next data it2)) + (it1 (make-seq-iterator sequence1 start1) + (seq-iterator-next sequence1 it1))) + ((or (<= length 0) (null it1) (null it2))) + (seq-iterator-set sequence1 it1 + (seq-iterator-ref sequence2 it2)) + (decf length)))))) + sequence1) (defun filter-vector (which out in start end from-end count test test-not key) @@ -198,17 +206,8 @@ (setf (aref (the vector out) start) elt start (1+ start)))) ;; ... and copy the elements outside the limits - (values out (copy-subarray out start in end l))))))) - -(defun copy-subarray (out start-out in start-in end-in) - (declare (optimize (speed 3) (safety 0) (debug 0))) - (do* ((n end-in) - (i start-in (1+ i)) - (j start-out (1+ j))) - ((>= i n) - j) - (declare (fixnum i j n)) - (row-major-aset out j (row-major-aref in i)))) + (copy-subarray out start in end l) + (values out (+ start (- l end)))))))) (defun remove-list (which sequence start end count test test-not key) (with-tests (test test-not key) @@ -580,9 +579,9 @@ Returns a copy of SEQUENCE without duplicated elements." (declare (fixnum index jndex)) (loop (when (= index end) - (return (if out - (copy-subarray out jndex in end length) - (+ jndex (- length end))))) + (return (progn + (when out (copy-subarray out jndex in end length)) + (+ jndex (- length end))))) (unless (already-in-vector-p in start index end from-end) (when out (setf (aref (the vector out) jndex)