extend vector-copy and add vector-append

Make `vector-copy` like `substring` when start and end positions are
supplied. Internally, allocate the vector without initializing memory,
since the content is immediately replaced by copying, and avoid using
write barriers, since the vector copy is freshly allocated.

Along similar lines `vector-append` can append vectors without
redundant initialization and write barriers.

boot/pb/equates.h

@@ -1,4 +1,4 @@
-/* equates.h for Chez Scheme Version 9.9.9-pre-release.22 */
+/* equates.h for Chez Scheme Version 9.9.9-pre-release.23 */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -1010,7 +1010,7 @@ typedef uint64_t U64;
 #define rtd_sealed 0x4
 #define sbwp (ptr)0x4E
 #define scaled_shot_1_shot_flag -0x8
-#define scheme_version 0x9090916
+#define scheme_version 0x9090917
 #define seginfo_generation_disp 0x1
 #define seginfo_list_bits_disp 0x8
 #define seginfo_space_disp 0x0

boot/pb/scheme.h

@@ -1,4 +1,4 @@
-/* scheme.h for Chez Scheme Version 9.9.9-pre-release.22 (pb) */
+/* scheme.h for Chez Scheme Version 9.9.9-pre-release.23 (pb) */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -40,7 +40,7 @@
 #endif
 
 /* Chez Scheme Version and machine type */
-#define VERSION "9.9.9-pre-release.22"
+#define VERSION "9.9.9-pre-release.23"
 #define MACHINE_TYPE "pb"
 
 /* Integer typedefs */

csug/objects.stex

@@ -760,22 +760,51 @@ Any attempt to modify an immutable vector causes an exception to be raised.
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{vector-copy}{\categoryprocedure}{(vector-copy \var{vector})}
-\returns a copy of \var{vector}
+\formdef{vector-copy}{\categoryprocedure}{(vector-copy \var{vector} \var{start} \var{end})}
+\returns a new vector
 \listlibraries
 \endentryheader
 
 \noindent
-\scheme{vector-copy} creates a new vector of the same length and contents
-as \var{vector}.
-The elements themselves are not copied.
+\var{vector} must be a vector.
+\var{start} and \var{end} must be exact nonnegative integers, both
+in the range \scheme{0} to the length of \var{vector}, inclusive,
+and \var{start} must be less or equal to \var{end}. When \var{start}
+and \var{end} are not supplied, \scheme{0} and
+\scheme{(vector-length \var{vector})} are used.
+
+\noindent
+\scheme{vector-copy} creates a new vector of length
+\var{end}-\var{start} and contents as elements \var{start} through
+\var{end}-1 of \var{vector}. When \var{start} and \var{end} are not
+supplied, the result is a copy of \var{vector}. The vector elements
+themselves are not copied.
 
 \schemedisplay
 (vector-copy '#(a b c)) ;=> #(a b c)
+(vector-copy '#(a b c d) 1 3) ;=> #(b c)
 
 (let ([v '#(a b c)])
   (eq? v (vector-copy v))) ;=> #f
 \endschemedisplay
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{vector-append}{\categoryprocedure}{(vector-append \var{vector} \dots)}
+\returns a new vector
+\listlibraries
+\endentryheader
+
+\noindent
+\scheme{vector-append} creates a new vector whose content is the
+concatenation of the given \var{vector}s in order.
+
+\schemedisplay
+(vector-append '#(a b c)) ;=> #(a b c)
+(vector-append '#(a b c) #'(d e) #'(f)) ;=> #(a b c d e f)
+(vector-append) ;=> #()
+\endschemedisplay
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{vector-set-fixnum!}{\categoryprocedure}{(vector-set-fixnum! \var{vector} \var{n} \var{fixnum})}

mats/5_6.ms

@@ -114,6 +114,10 @@
 (mat vector-copy
     (equal? (vector-copy '#()) '#())
     (equal? (vector-copy '#(a b c)) '#(a b c))
+    (equal? (vector-copy '#(a b c) 0 1) '#(a))
+    (equal? (vector-copy '#(a b c) 2 3) '#(c))
+    (equal? (vector-copy '#(a b c d) 1 3) '#(b c))
+    (eq? (vector-copy '#(a b c d) 1 1) '#())
     (let* ((x1 (vector 1 2 3)) (x2 (vector-copy x1)))
         (and (equal? x2 x1) (not (eq? x2 x1))))
     (andmap
@@ -122,6 +126,26 @@
           (equal? (vector-copy v) v)))
       (map random (make-list 500 2500)))
     (error? (vector-copy '(a b c)))
+    (error? (vector-copy '#(a b c) 'x 2))
+    (error? (vector-copy '#(a b c) 1 'x))
+    (error? (vector-copy '#(a b c) -1 2))
+    (error? (vector-copy '#(a b c) 1 4))
+    (error? (vector-copy '#(a b c) 2 1))
+    )
+
+(mat vector-append
+    (eq? (vector-append) '#())
+    (eq? (vector-append '#()) '#())
+    (eq? (vector-append '#() '#()) '#())
+    (eq? (vector-append '#() '#() '#()) '#())
+    (eq? (vector-append '#() '#() '#() '#()) '#())
+    (equal? (vector-append '#(a b c)) '#(a b c))
+    (equal? (vector-append '#(a b c) '#(d e)) '#(a b c d e))
+    (equal? (vector-append '#(a b c) '#(d e) '#(f) '#(g h i)) '#(a b c d e f g h i))
+    (error? (vector-append 1))
+    (error? (vector-append '#(a b c) 'x))
+    (error? (vector-append '#(a b c) '#(d) 'x))
+    (error? (vector-append '#(a b c) '#(d) '#(e)'x))
  )
 
 (mat vector-fill!

mats/root-experr-compile-0-f-f-f

@@ -4276,6 +4276,15 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
 5_6.mo:Expected error in mat vector-set-fixnum!: "vector-set-fixnum!: #\d is not a fixnum".
 5_6.mo:Expected error in mat vector-set-fixnum!: "vector-set-fixnum!: (a b c) is not a fixnum".
 5_6.mo:Expected error in mat vector-copy: "vector-copy: (a b c) is not a vector".
+5_6.mo:Expected error in mat vector-copy: "vector-copy: x and 2 are not valid start/end indices for #(a b c)".
+5_6.mo:Expected error in mat vector-copy: "vector-copy: 1 and x are not valid start/end indices for #(a b c)".
+5_6.mo:Expected error in mat vector-copy: "vector-copy: -1 and 2 are not valid start/end indices for #(a b c)".
+5_6.mo:Expected error in mat vector-copy: "vector-copy: 1 and 4 are not valid start/end indices for #(a b c)".
+5_6.mo:Expected error in mat vector-copy: "vector-copy: 2 and 1 are not valid start/end indices for #(a b c)".
+5_6.mo:Expected error in mat vector-append: "vector-append: 1 is not a vector".
+5_6.mo:Expected error in mat vector-append: "vector-append: x is not a vector".
+5_6.mo:Expected error in mat vector-append: "vector-append: x is not a vector".
+5_6.mo:Expected error in mat vector-append: "vector-append: x is not a vector".
 5_6.mo:Expected error in mat vector-fill!: "vector-fill!: #vfx() is not a mutable vector".
 5_6.mo:Expected error in mat list->vector: "list->vector: #(a b c) is not a proper list".
 5_6.mo:Expected error in mat list->vector: "list->vector: (#\a #\b . #\c) is not a proper list".

release_notes/release_notes.stex

@@ -461,6 +461,16 @@ stencil-vector-mask-width
 \endschemedisplay
 
 
+\subsection{New vector functions (9.9.9)}
+
+The \scheme{vector-copy} function now accepts optional start and end
+positions to create a vector that contains a subsequence of the
+original vector's elements. The new \scheme{vector-append} function
+combines vectors. Although these functions could be implemented with
+\scheme{make-vector} and \scheme{vector-set!}, the new versions avoid
+redundant initialization and write barriers.
+
+
 \subsection{New symbol functions (9.9.9)}
 
 While gensyms support most symbol-generation needs, uninterned symbols

s/5_6.ss

@@ -35,26 +35,64 @@
             (loop (cdr ls) (fx+ i 2))))))
     v))
 
-(define ($vector-copy! v1 v2 n)
+(define ($vector-copy! v1 v2 n delta)
   (let loop ([i (fx- n 1)])
     (cond
       [(fx> i 0)
-       (vector-set! v2 i (vector-ref v1 i))
-       (let ([i (fx- i 1)]) (vector-set! v2 i (vector-ref v1 i)))
+       (vector-set! v2 (fx+ i delta) (vector-ref v1 i))
+       (let ([i (fx- i 1)]) (vector-set! v2 (fx+ i delta) (vector-ref v1 i)))
        (loop (fx- i 2))]
-      [(fx= i 0) (vector-set! v2 i (vector-ref v1 i))])))
+      [(fx= i 0) (vector-set! v2 (fx+ i delta) (vector-ref v1 i))])))
 
-;; assumes that `v2` is newer than values to copy
-(define ($vector-fill-copy! v1 v2 n)
-  (if (fx<= n 10)
-      ($vector-copy! v1 v2 n)
-      ($ptr-copy! v1 (constant vector-data-disp) v2
-        (constant vector-data-disp) n)))
-
-(define ($vector-copy v1 n)
-  (let ([v2 (make-vector n)])
-    ($vector-fill-copy! v1 v2 n)
-    v2))
+(set-who! vector-copy
+  (case-lambda
+   [(v)
+    (unless (vector? v)
+      ($oops who "~s is not a vector" v))
+    (#3%vector-copy v 0 (vector-length v))]
+   [(v start end)
+    (unless (vector? v)
+      ($oops who "~s is not a vector" v))
+    (unless (and (fixnum? start) (fixnum? end) (fx<= 0 start end (vector-length v)))
+      ($oops 'vector-copy
+             "~s and ~s are not valid start/end indices for ~s"
+             start end v))
+    (#3%vector-copy v start end)]))
+
+(set-who! vector-append
+  (let ([not-a-vector
+         (lambda (v)
+           ($oops who "~s is not a vector" v))])
+    (case-lambda
+      [(v)
+       (unless (vector? v) (not-a-vector v))
+       (vector-copy v)]
+      [(v1 v2)
+       (unless (vector? v1) (not-a-vector v1))
+       (unless (vector? v2) (not-a-vector v2))
+       (#3%vector-append v1 v2)]
+      [(v1 v2 v3)
+       (unless (vector? v1) (not-a-vector v1))
+       (unless (vector? v2) (not-a-vector v2))
+       (unless (vector? v3) (not-a-vector v3))
+       (#3%vector-append v1 v2 v3)]
+      [vs
+       (let ([len (let loop ([vs vs])
+                    (cond
+                      [(null? vs) 0]
+                      [else
+                       (let ([v (car vs)])
+                         (unless (vector? v) (not-a-vector v))
+                         (fx+ (vector-length v) (loop (cdr vs))))]))])
+         (let ([dest (make-vector len)])
+           (let loop ([vs vs] [i 0])
+             (cond
+               [(null? vs) dest]
+               [else
+                (let* ([v (car vs)]
+                       [len (vector-length v)])
+                  ($vector-copy! v dest len i)
+                  (loop (cdr vs) (fx+ i len)))]))))])))
 
 (set! vector->list
   (lambda (v)
@@ -66,12 +104,6 @@
   (lambda (ls)
     ($list->vector ls ($list-length ls 'list->vector))))
 
-(set! vector-copy
-  (lambda (v)
-    (unless (vector? v)
-      ($oops 'vector-copy "~s is not a vector" v))
-    ($vector-copy v (vector-length v))))
-
 (set-who! vector->immutable-vector
   (lambda (v)
     (cond
@@ -395,7 +427,7 @@
       (unless (procedure? elt<) ($oops who "~s is not a procedure" elt<))
       (unless (vector? v) ($oops who "~s is not a vector" v))
       (let ([n (vector-length v)])
-        (if (fx<= n 1) v (dovsort! elt< ($vector-copy v n) n)))))
+        (if (fx<= n 1) v (dovsort! elt< (vector-copy v 0 n) n)))))
 
   (set-who! vector-sort!
     (lambda (elt< v)
@@ -405,7 +437,7 @@
         (unless (fx<= n 1)
           (let ([outvec (dovsort! elt< v n)])
             (unless (eq? outvec v)
-              ($vector-copy! outvec v n)))))))
+              ($vector-copy! outvec v n 0)))))))
 
   (set-who! list-sort
     (lambda (elt< ls)

s/cmacros.ss

@@ -357,7 +357,7 @@
 ;; ---------------------------------------------------------------------
 ;; Version and machine types:
 
-(define-constant scheme-version #x09090916)
+(define-constant scheme-version #x09090917)
 
 (define-syntax define-machine-types
   (lambda (x)

s/cpprim.ss

@@ -7352,8 +7352,8 @@
       (let ()
         (define do-make-vector
           (lambda (e-length e-fill)
-            ; NB: caller must bind e-fill
-            (safe-assert (no-need-to-bind? #f e-fill))
+            ; NB: caller must bind e-fill, if not #f
+            (safe-assert (or (not e-fill) (no-need-to-bind? #f e-fill)))
             (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length)
                 (let ([n (constant-value e-length)])
                   (if (fx= n 0)
@@ -7365,7 +7365,9 @@
                              (set! ,(%mref ,t ,(constant vector-type-disp))
                                (immediate ,(+ (fx* n (constant vector-length-factor))
                                               (constant type-vector))))
-                             ,(build-vector-fill t `(immediate ,bytes) e-fill))))))
+                             ,(if e-fill
+                                  (build-vector-fill t `(immediate ,bytes) e-fill)
+                                  t))))))
                 (bind #t (e-length) ; fixnum length doubles as byte count
                   (let ([t-vec (make-tmp 'tvec)])
                     `(if ,(%inline eq? ,e-length (immediate 0))
@@ -7382,11 +7384,63 @@
                                   (constant type-vector)
                                   (constant fixnum-offset)
                                   (constant vector-length-offset)))
-                             ,(build-vector-fill t-vec e-length e-fill)))))))))
+                             ,(if e-fill
+                                  (build-vector-fill t-vec e-length e-fill)
+                                  t-vec)))))))))
         (define default-fill `(immediate ,(fix 0)))
         (define-inline 3 make-vector
           [(e-length) (do-make-vector e-length default-fill)]
           [(e-length e-fill) (bind #t (e-fill) (do-make-vector e-length e-fill))])
+        (let ()
+          (define (extract-vector-length vec)
+            (extract-length (%mref ,vec ,(constant vector-type-disp)) (constant vector-length-offset)))
+          (define build-vector-copy
+            (lambda (e-vec e-start e-end)
+              (let ([Ltop (make-local-label 'Ltop)]
+                    [vec (make-assigned-tmp 'vec 'ptr)]
+                    [t (make-assigned-tmp 't 'uptr)])
+                (bind #t (e-vec e-start e-end)
+                  `(let ([,t ,e-start]
+                         [,vec ,(do-make-vector (%inline - ,e-end ,e-start) #f)])
+                     (label ,Ltop
+                       (if ,(%inline eq? ,t ,e-end)
+                           ,vec
+                           ,(%seq
+                             (set! ,(%mref ,vec ,(%inline - ,t ,e-start) ,(constant vector-data-disp))
+                                   ,(%mref ,e-vec ,t ,(constant vector-data-disp)))
+                             (set! ,t ,(%inline + ,t (immediate ,(constant ptr-bytes))))
+                             (goto ,Ltop)))))))))
+          (define build-vector-append
+            (lambda (e-vecs)
+              (let loop ([e-vecs e-vecs] [len `(immediate 0)])
+                (cond
+                  [(null? e-vecs)
+                   (do-make-vector len #f)]
+                  [else
+                   (let ([Ltop (make-local-label 'Ltop)]
+                         [d-vec (make-assigned-tmp 'd-vec 'ptr)]
+                         [e-vec (car e-vecs)]
+                         [t (make-assigned-tmp 't 'uptr)]
+                         [e-len (make-assigned-tmp 'e-len 'uptr)])
+                     (bind #t (e-vec)
+                       `(let ([,t ,len]
+                              [,e-len ,(extract-vector-length e-vec)])
+                          (let ([,d-vec ,(loop (cdr e-vecs) (%inline + ,t ,e-len))])
+                            (label ,Ltop
+                                   (if ,(%inline eq? ,e-len (immediate 0))
+                                       ,d-vec
+                                       ,(%seq
+                                         (set! ,e-len ,(%inline - ,e-len (immediate ,(constant ptr-bytes))))
+                                         (set! ,(%mref ,d-vec ,(%inline + ,t ,e-len) ,(constant vector-data-disp))
+                                               ,(%mref ,e-vec ,e-len ,(constant vector-data-disp)))
+                                         (goto ,Ltop))))))))]))))
+          (define-inline 3 vector-copy
+            [(vec) (bind #t (vec)
+                     (build-vector-copy vec `(immediate ,(fix 0)) (extract-vector-length vec)))]
+            [(vec start end) (build-vector-copy vec start end)])
+          (define-inline 3 vector-append
+            [() `(quote ,(vector))]
+            [(vec . vecs) (build-vector-append (cons vec vecs))]))
         (let ()
           (define (valid-length? e-length)
             (constant?

s/primdata.ss

@@ -1831,8 +1831,9 @@
   (utf-16-codec [sig [() -> (codec)] [(sub-symbol) -> (codec)]] [flags pure true]) ; has optional eness argument
   (utf-16le-codec [sig [() -> (codec)]] [flags pure unrestricted true])
   (utf-16be-codec [sig [() -> (codec)]] [flags pure unrestricted true])
+  (vector-append [sig [(vector ...) -> (vector)]] [flags alloc])
   (vector-cas! [sig [(nonempty-vector sub-index ptr ptr) -> (boolean)]] [flags cptypes2])
-  (vector-copy [sig [(vector) -> (vector)]] [flags alloc safeongoodargs])
+  (vector-copy [sig [(vector) -> (vector)] [(vector sub-index sub-index) -> (vector)]] [flags alloc])
   (vector->immutable-vector [sig [(vector) -> (immutable-vector)]] [flags alloc cp02 safeongoodargs])
   (vector->pseudo-random-generator [sig [(nonempty-vector) -> (pseudo-random-generator)]] [flags])
   (vector->pseudo-random-generator! [sig [(pseudo-random-generator nonempty-vector) -> (void)]] [flags])

s/prims.ss

@@ -1455,7 +1455,7 @@
 ; not safe; assumes `val` is older than `v`
 (define $stencil-vector-fill-set!
   (lambda (v i val)
-    ($stencil-vector-set! v i val)))
+    ($stencil-vector-fill-set! v i val)))
 
 ; not safe
 (define $record-ref

s/reboot.ss

@@ -529,7 +529,7 @@
 
 (define-primitive ($make-source-oops who . args)
   (($top-level-value 'datum->syntax) (or who ($make-interaction-syntax 'unknown))
-                                     '(error "oops")))
+                                     `(error 'source "oops ~s" '(,who . ,args))))
 
 (define-primitive ($source-warning . args)
   (printf "~s\n" args))