[Guile-commits] 01/01: Add function vector-copy! to core

[Daniel Llorens]

lloda pushed a commit to branch wip-vector-cleanup-2
in repository guile.

commit 5df5555d12f1408a66a5368a918abb981edf5445
Author: Daniel Llorens <lloda@sarc.name>
AuthorDate: Fri Aug 6 16:51:40 2021 +0200

    Add function vector-copy! to core
    
    This is up to 20%-30% faster than the previous versions in (scheme base) or
    (srfi srfi-43) that used vector-move-left!/vector-move-right!.
    
    * libguile/vectors.h:
    * libguile/vectors.c: As stated.
    * doc/ref/api-data.texi (vector-copy!): Document the new function.
      (vector-fill!): Document optional arguments.
      (vector-copy): Document optional arguments.
    * module/scheme/base.scm: Reuse core vector-copy!.
    * module/srfi/srfi-43.scm: Reuse core vector-copy!.
---
 doc/ref/api-data.texi   | 36 +++++++++++++++++++++++++++++++-----
 libguile/vectors.c      | 42 ++++++++++++++++++++++++++++++++++++++++++
 libguile/vectors.h      |  6 +++---
 module/scheme/base.scm  | 17 ++---------------
 module/srfi/srfi-43.scm | 17 ++---------------
 5 files changed, 80 insertions(+), 38 deletions(-)

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index eb3d910..a3e6d6c 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -6381,16 +6381,38 @@ Store @var{obj} in position @var{k} (a @code{size_t}) 
of @var{vec}.
 @end deftypefn
 
 @rnindex vector-fill!
-@deffn {Scheme Procedure} vector-fill! vec fill
+@deffn {Scheme Procedure} vector-fill! vec fill [start [end]]
 @deffnx {C Function} scm_vector_fill_x (vec, fill)
-Store @var{fill} in every position of @var{vec}.  The value
-returned by @code{vector-fill!} is unspecified.
+Store @var{fill} in every position of @var{vec} in the range
+[@var{start} ... @var{end}). @var{start} defaults to 0 and @var{end}
+defaults to the length of @var{vec}.
+
+The value returned by @code{vector-fill!} is unspecified.
 @end deffn
 
 @rnindex vector-copy
-@deffn {Scheme Procedure} vector-copy vec
+@deffn {Scheme Procedure} vector-copy vec [start [end]]
 @deffnx {C Function} scm_vector_copy (vec)
-Return a copy of @var{vec}.
+Returns a freshly allocated vector containing the elements of @var{vec}
+in the range [@var{start} ... @var{end}). @var{start} defaults to 0 and
+@var{end} defaults to the length of @var{vec}.
+@end deffn
+
+@rnindex vector-copy!
+@deffn {Scheme Procedure} vector-copy! dst at src [start [end]]
+Copy the block of elements from vector @var{src} in the range
+[@var{start} ... @var{end}) into vector @var{dst}, starting at position
+@var{at}. @var{at} and @var{start} default to 0 and @var{end} defaults
+to the length of @var{src}.
+
+It is an error for @var{dst} to have a length less than @var{at} +
+(@var{end} - @var{start}).  
+
+The order in which elements are copied is unspecified, except that if the
+source and destination overlap, copying takes place as if the source is
+first copied into a temporary vector and then into the destination.
+
+The value returned by @code{vector-copy!} is unspecified.
 @end deffn
 
 @deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2
@@ -6403,6 +6425,8 @@ to @var{vec2} starting at position @var{start2}.  
@var{start1} and
 Therefore, in the case where @var{vec1} and @var{vec2} refer to the
 same vector, @code{vector-move-left!} is usually appropriate when
 @var{start1} is greater than @var{start2}.
+
+The value returned by @code{vector-move-left!} is unspecified.
 @end deffn
 
 @deffn {Scheme Procedure} vector-move-right! vec1 start1 end1 vec2 start2
@@ -6415,6 +6439,8 @@ to @var{vec2} starting at position @var{start2}.  
@var{start1} and
 Therefore, in the case where @var{vec1} and @var{vec2} refer to the
 same vector, @code{vector-move-right!} is usually appropriate when
 @var{start1} is less than @var{start2}.
+
+The value returned by @code{vector-move-right!} is unspecified.
 @end deffn
 
 @node Vector Accessing from C
diff --git a/libguile/vectors.c b/libguile/vectors.c
index 3a2ff7a..40e80dd 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -329,6 +329,48 @@ scm_vector_copy (SCM vec)
   return scm_vector_copy_partial (vec, SCM_UNDEFINED, SCM_UNDEFINED);
 }
 
+SCM_DEFINE (scm_vector_copy_x, "vector-copy!", 3, 2, 0,
+           (SCM dst, SCM at, SCM src, SCM start, SCM end),
+            "Copy a block of elements from @var{src} to @var{dst}, both of 
which must be\n"
+            "vectors, starting in @var{dst} at @var{at} and starting in 
@var{src} at\n"
+            "@var{start} and ending at @var{end}.\n\n"
+            "It is an error for @var{dst} to have a length less than\n"
+            "@var{at} + (@var{end} - @var{start}). @var{at} and @var{start} 
default\n"
+            "to 0 and @var{end} defaults to the length of @var{src}.\n\n"
+            "The order in which elements are copied is unspecified, except 
that if the\n"
+            "source and destination overlap, copying takes place as if the 
source is\n"
+            "first copied into a temporary vector and then into the 
destination.")
+#define FUNC_NAME s_scm_vector_copy_x
+{
+  SCM_VALIDATE_MUTABLE_VECTOR (1, dst);
+  SCM_VALIDATE_VECTOR (3, src);
+  size_t src_org = 0;
+  size_t dst_org = scm_to_size_t (at);
+  size_t src_end = SCM_I_VECTOR_LENGTH (src);
+  size_t dst_end = SCM_I_VECTOR_LENGTH (dst);
+
+  if (!SCM_UNBNDP (start))
+    {
+      src_org = scm_to_size_t (start);
+      SCM_ASSERT_RANGE (SCM_ARG4, start, src_org<=src_end);
+
+      if (!SCM_UNBNDP (end))
+        {
+          size_t e = scm_to_size_t (end);
+          SCM_ASSERT_RANGE (SCM_ARG5, end, e>=src_org && e<=src_end);
+          src_end = e;
+        }
+    }
+  size_t len = src_end-src_org;
+  SCM_ASSERT_RANGE (SCM_ARG2, at, dst_org<=dst_end && len<=dst_end-dst_org);
+
+  memmove (SCM_I_VECTOR_WELTS (dst) + dst_org, SCM_I_VECTOR_ELTS (src) + 
src_org,
+           len * sizeof(SCM));
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
 
 SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0, 
            (SCM vec),
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 1c04f9a..78abc16 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -41,6 +41,8 @@ SCM_API SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM 
end1,
 SCM_API SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1, 
                                     SCM vec2, SCM start2);
 SCM_API SCM scm_vector_copy (SCM vec);
+SCM_API SCM scm_vector_copy_partial (SCM vec, SCM start, SCM end);
+SCM_API SCM scm_vector_copy_x (SCM dst, SCM at, SCM src, SCM start, SCM end);
 
 SCM_API int scm_is_vector (SCM obj);
 SCM_API int scm_is_simple_vector (SCM obj);
@@ -87,9 +89,7 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec,
 #define SCM_I_VECTOR_WELTS(x)  (SCM_CELL_OBJECT_LOC (x, 1))
 #define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
 
-SCM_INTERNAL SCM  scm_i_vector_equal_p (SCM x, SCM y);
-SCM_INTERNAL SCM scm_vector_copy_partial (SCM vec, SCM start, SCM end);
-
+SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
 SCM_INTERNAL void scm_init_vectors (void);
 
 #endif  /* SCM_VECTORS_H */
diff --git a/module/scheme/base.scm b/module/scheme/base.scm
index c57bdf1..c6a73c0 100644
--- a/module/scheme/base.scm
+++ b/module/scheme/base.scm
@@ -57,7 +57,7 @@
             string->vector vector->string
             (r7:string->utf8 . string->utf8)
             (r7:vector->list . vector->list)
-            vector-copy! vector-append vector-for-each vector-map
+            vector-append vector-for-each vector-map
             (r7:bytevector-copy . bytevector-copy)
             (r7:bytevector-copy! . bytevector-copy!)
             (r7:utf8->string . utf8->string)
@@ -114,7 +114,7 @@
    (char-ready? . u8-ready?)
    unless
    unquote unquote-splicing values
-   vector vector-copy vector-fill!
+   vector vector-copy vector-copy! vector-fill!
    vector-length vector-ref vector-set! vector?
    when with-exception-handler write-char
    zero?))
@@ -431,19 +431,6 @@
 
 ;;; vector
 
-(define* (vector-copy! target tstart source
-                       #:optional (sstart 0) (send (vector-length source)))
-  "Copy a block of elements from SOURCE to TARGET, both of which must be
-vectors, starting in TARGET at TSTART and starting in SOURCE at SSTART,
-ending when SEND - SSTART elements have been copied.  It is an error for
-TARGET to have a length less than TSTART + (SEND - SSTART).  SSTART
-defaults to 0 and SEND defaults to the length of SOURCE."
-  (let ((tlen (vector-length target))
-        (slen (vector-length source)))
-    (if (< tstart sstart)
-        (vector-move-left!  source sstart send target tstart)
-        (vector-move-right! source sstart send target tstart))))
-
 (define r7:vector->list
   (case-lambda*
     ((v) (vector->list v))
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
index f8e38e2..18e97cf 100644
--- a/module/srfi/srfi-43.scm
+++ b/module/srfi/srfi-43.scm
@@ -22,7 +22,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-8)
   #:re-export (make-vector vector vector? vector-ref vector-set!
-                           vector-length vector-fill!)
+                           vector-length vector-fill! vector-copy!)
   #:replace (vector-copy list->vector vector->list)
   #:export (vector-empty? vector= vector-unfold vector-unfold-right
                           vector-reverse-copy
@@ -35,7 +35,7 @@
                           vector-binary-search
                           vector-any vector-every
                           vector-swap! vector-reverse!
-                          vector-copy! vector-reverse-copy!
+                          vector-reverse-copy!
                           reverse-vector->list
                           reverse-list->vector))
 
@@ -933,19 +933,6 @@ START defaults to 0 and END defaults to the length of VEC."
              (error-from 'copy! "would write past end of target"))
            (%copy! target tstart source sstart send)))))))
 
-(define-vector-copier! vector-copy!
-  "(vector-copy! target tstart source [sstart [send]]) -> unspecified
-
-Copy a block of elements from SOURCE to TARGET, both of which must be
-vectors, starting in TARGET at TSTART and starting in SOURCE at
-SSTART, ending when SEND - SSTART elements have been copied.  It is an
-error for TARGET to have a length less than TSTART + (SEND - SSTART).
-SSTART defaults to 0 and SEND defaults to the length of SOURCE."
-  (lambda (target tstart source sstart send)
-    (if (< tstart sstart)
-        (vector-move-left!  source sstart send target tstart)
-        (vector-move-right! source sstart send target tstart))))
-
 (define-vector-copier! vector-reverse-copy!
   "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified