add unsafe-bytes-copy!

Also, improve checking and performance of safe `bytes-copy!` in Racket
CS.

pkgs/base/info.rkt

@@ -12,7 +12,7 @@
 
 (define collection 'multi)
 
-(define version "7.5.0.14")
+(define version "7.5.0.15")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/unsafe.scrbl

@@ -310,12 +310,21 @@ always returns a fixnum).}
 @defproc[(unsafe-bytes-length [bstr bytes?]) fixnum?]
 @defproc[(unsafe-bytes-ref [bstr bytes?] [k fixnum?]) byte?]
 @defproc[(unsafe-bytes-set! [bstr (and/c bytes? (not/c immutable?))] [k fixnum?] [b byte?]) void?]
+@defproc[(unsafe-bytes-copy! [dest (and/c bytes? (not/c immutable?))]
+                             [dest-start fixnum?]
+                             [src bytes?]
+                             [src-start fixnum? 0]
+                             [src-end fixnum? (bytes-length src)])
+         void?]
 )]{
 
-Unsafe versions of @racket[bytes-length], @racket[bytes-ref], and
+Unsafe versions of @racket[bytes-length], @racket[bytes-ref],
-@racket[bytes-set!]. A bytes's size can never be larger than a
+@racket[bytes-set!], and @racket[bytes-copy!].
+A bytes's size can never be larger than a
 @tech{fixnum} (so even @racket[bytes-length] always returns a
-fixnum).}
+fixnum).
+
+@history[#:changed "7.5.0.15" @elem{Added @racket[unsafe-bytes-copy!].}]}
 
 
 @deftogether[(

pkgs/racket-test-core/tests/racket/basic.rktl

@@ -1168,13 +1168,26 @@
 (test (bytes 97 0 98) bytes-copy (bytes 97 0 98))
 (bytes-fill! s (char->integer #\x))
 (test #"xxxxx" 'bytes-fill! s)
+(let ([bstr (make-bytes 10)])
+  (test (void) bytes-copy! bstr 1 #"testing" 2 6)
+  (test #"\0stin\0\0\0\0\0" values bstr)
+  (test (void) bytes-copy! bstr 0 #"testing")
+  (test #"testing\0\0\0" values bstr))
 (arity-test bytes-copy 1 1)
 (arity-test bytes-fill! 2 2)
 (err/rt-test (bytes-copy 'blah))
 (err/rt-test (bytes-fill! 'sym 1))
 (err/rt-test (bytes-fill! #"static" 1))
 (err/rt-test (bytes-fill! (bytes-copy #"oops") #\5))
-
+(err/rt-test (bytes-copy! (bytes-copy #"oops") #\5))
+(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 -1))
+(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" #f))
+(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" -1))
+(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" 1 #f))
+(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" 1 0))
+(err/rt-test (bytes-copy! (bytes-copy #"oops") 0 #"src" 1 17))
+(err/rt-test (bytes-copy! (bytes-copy #"o") 0 #"src"))
+(err/rt-test (bytes-copy! (bytes-copy #"o") 0 #"src" 1))
 (test #t bytes=? #"a" #"a" #"a")
 (test #t bytes=? #"a" #"a")
 (test #t bytes=? #"a")

pkgs/racket-test-core/tests/racket/unsafe.rktl

@@ -594,6 +594,12 @@
               #:post (lambda (x) (list x (bytes-ref v 2)))
               #:literal-ok? #f))
 
+  (let ([bstr (make-bytes 10)])
+    (test (void) unsafe-bytes-copy! bstr 1 #"testing" 2 6)
+    (test #"\0stin\0\0\0\0\0" values bstr)
+    (test (void) unsafe-bytes-copy! bstr 0 #"testing")
+    (test #"testing\0\0\0" values bstr))
+
   (test-bin #\5 'unsafe-string-ref "157" 1)
   (test-un 3 'unsafe-string-length "157")
   (let ([v (string #\0 #\3 #\7)])

racket/src/cs/primitive/kernel.ss

@@ -69,7 +69,7 @@
   [bytes-convert-end (known-procedure/no-prompt 30)]
   [bytes-converter? (known-procedure/pure/folding 2)]
   [bytes-copy (known-procedure/no-prompt 2)]
-  [bytes-copy! (known-procedure/no-prompt 56)]
+  [bytes-copy! (known-procedure/has-unsafe 56 'unsafe-bytes-copy!)]
   [bytes-fill! (known-procedure/no-prompt 4)]
   [bytes-length (known-procedure/has-unsafe 2 'unsafe-bytes-length)]
   [bytes-open-converter (known-procedure/no-prompt 4)]

racket/src/cs/primitive/unsafe.ss

@@ -8,10 +8,11 @@
   [unsafe-add-global-finalizer (known-procedure 4)]
   [unsafe-add-post-custodian-shutdown (known-procedure 2)]
   [unsafe-add-collect-callbacks (known-procedure 4)]
-  [unsafe-box*-cas! (known-procedure 8)]
+  [unsafe-box*-cas! (known-procedure/succeeds 8)]
   [unsafe-bytes-length (known-procedure/pure 2)]
-  [unsafe-bytes-ref (known-procedure 4)]
+  [unsafe-bytes-ref (known-procedure/succeeds 4)]
-  [unsafe-bytes-set! (known-procedure 8)]
+  [unsafe-bytes-set! (known-procedure/succeeds 8)]
+  [unsafe-bytes-copy! (known-procedure/succeeds 56)]
   [unsafe-call-in-os-thread (known-procedure 2)]
   [unsafe-call-with-composable-continuation/no-wind (known-procedure 4)]
   [unsafe-car (known-procedure/pure 2)]
@@ -44,12 +45,12 @@
   [unsafe-extflmin (known-procedure/pure 4)]
   [unsafe-extflsqrt (known-procedure/pure 2)]
   [unsafe-extflvector-length (known-procedure/pure 2)]
-  [unsafe-extflvector-ref (known-procedure 4)]
+  [unsafe-extflvector-ref (known-procedure/succeeds 4)]
-  [unsafe-extflvector-set! (known-procedure 8)]
+  [unsafe-extflvector-set! (known-procedure/succeeds 8)]
-  [unsafe-f64vector-ref (known-procedure 4)]
+  [unsafe-f64vector-ref (known-procedure/succeeds 4)]
-  [unsafe-f64vector-set! (known-procedure 8)]
+  [unsafe-f64vector-set! (known-procedure/succeeds 8)]
-  [unsafe-f80vector-ref (known-procedure 4)]
+  [unsafe-f80vector-ref (known-procedure/succeeds 4)]
-  [unsafe-f80vector-set! (known-procedure 8)]
+  [unsafe-f80vector-set! (known-procedure/succeeds 8)]
   [unsafe-file-descriptor->port (known-procedure 8)]
   [unsafe-file-descriptor->semaphore (known-procedure 4)]
   [unsafe-fl* (known-procedure/pure/folding-unsafe -1 'fl*)]
@@ -70,8 +71,8 @@
   [unsafe-flreal-part (known-procedure/pure/folding-unsafe 2 'flreal-part)]
   [unsafe-flsqrt (known-procedure/pure/folding-unsafe 2 'flsqrt)]
   [unsafe-flvector-length (known-procedure/pure/folding-unsafe 2 'flvector-length)]
-  [unsafe-flvector-ref (known-procedure 4)]
+  [unsafe-flvector-ref (known-procedure/succeeds 4)]
-  [unsafe-flvector-set! (known-procedure 8)]
+  [unsafe-flvector-set! (known-procedure/succeeds 8)]
   [unsafe-fx* (known-procedure/pure/folding-unsafe -1 'fx*)]
   [unsafe-fx+ (known-procedure/pure/folding-unsafe -1 'fx+)]
   [unsafe-fx- (known-procedure/pure/folding-unsafe -2 'fx-)]
@@ -152,23 +153,23 @@
   [unsafe-start-atomic (known-procedure 1)]
   [unsafe-start-breakable-atomic (known-procedure 1)]
   [unsafe-string-length (known-procedure/pure 2)]
-  [unsafe-string-ref (known-procedure/pure 4)]
+  [unsafe-string-ref (known-procedure/succeeds 4)]
-  [unsafe-string-set! (known-procedure/pure 8)]
+  [unsafe-string-set! (known-procedure/succeeds 8)]
   [unsafe-struct*-cas! (known-procedure 16)]
-  [unsafe-struct*-ref (known-procedure/pure 4)]
+  [unsafe-struct*-ref (known-procedure/succeeds 4)]
-  [unsafe-struct*-set! (known-procedure/pure 8)]
+  [unsafe-struct*-set! (known-procedure/succeeds 8)]
-  [unsafe-struct-ref (known-procedure/pure 4)]
+  [unsafe-struct-ref (known-procedure/succeeds 4)]
-  [unsafe-struct-set! (known-procedure/pure 8)]
+  [unsafe-struct-set! (known-procedure/succeeds 8)]
   [unsafe-thread-at-root (known-procedure 2)]
-  [unsafe-u16vector-ref (known-procedure 4)]
+  [unsafe-u16vector-ref (known-procedure/succeeds 4)]
-  [unsafe-u16vector-set! (known-procedure 8)]
+  [unsafe-u16vector-set! (known-procedure/succeeds 8)]
   [unsafe-unbox (known-procedure 2)]
-  [unsafe-unbox* (known-procedure 2)]
+  [unsafe-unbox* (known-procedure/succeeds 2)]
   [unsafe-undefined (known-constant)]
-  [unsafe-vector*-cas! (known-procedure 16)]
+  [unsafe-vector*-cas! (known-procedure/succeeds 16)]
   [unsafe-vector*-length (known-procedure/pure 2)]
-  [unsafe-vector*-ref (known-procedure 4)]
+  [unsafe-vector*-ref (known-procedure/succeeds 4)]
-  [unsafe-vector*-set! (known-procedure 8)]
+  [unsafe-vector*-set! (known-procedure/succeeds 8)]
   [unsafe-vector-length (known-procedure/pure 2)]
   [unsafe-vector-ref (known-procedure 4)]
   [unsafe-vector-set! (known-procedure 8)]

racket/src/cs/rumble.sls

@@ -670,6 +670,7 @@
           unsafe-bytes-length
           unsafe-bytes-ref
           unsafe-bytes-set!
+          unsafe-bytes-copy!
 
           unsafe-undefined
           check-not-unsafe-undefined

racket/src/cs/rumble/bytes.ss

@@ -51,21 +51,33 @@
 (define/who bytes-copy!
   (case-lambda
     [(dest d-start src)
-     (bytes-copy! dest d-start src 0 (bytes-length src))]
+     (bytes-copy! dest d-start src 0 (and (bytevector? src) (bytevector-length src)))]
     [(dest d-start src s-start)
-     (bytes-copy! dest d-start src s-start (bytes-length src))]
+     (bytes-copy! dest d-start src s-start (and (bytevector? src) (bytevector-length src)))]
     [(dest d-start src s-start s-end)
-     (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" dest)
+     ;; start with fast, inlined checks for valid calls, then use
-     (check who exact-nonnegative-integer? d-start)
+     ;; slower tests with consistent reporting if fast tests fail
-     (check who bytes? src)
+     (cond
-     (check who exact-nonnegative-integer? s-start)
+      [(and (mutable-bytevector? dest)
-     (check who exact-nonnegative-integer? s-end)
+            (bytevector? src)
-     (let ([d-len (bytevector-length dest)])
+            (fixnum? d-start)
-       (check-range who "byte string" dest d-start #f d-len)
+            (fixnum? s-start)
-       (check-range who "byte string" src s-start s-end (bytevector-length src))
+            (fixnum? s-end)
-       (let ([s-len (fx- s-end s-start)])
+            (fx<= 0 d-start (fx+ d-start (fx- s-end s-start)) (bytevector-length dest))
-         (check-space who "byte string" d-start d-len s-len)
+            (fx<= 0 s-start s-end (bytevector-length src)))
-         (bytevector-copy! src s-start dest d-start s-len)))]))
+       (bytevector-copy! src s-start dest d-start (fx- s-end s-start))]
+      [else
+       (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" dest)
+       (check who exact-nonnegative-integer? d-start)
+       (check who bytes? src)
+       (check who exact-nonnegative-integer? s-start)
+       (check who exact-nonnegative-integer? s-end)
+       (let ([d-len (bytevector-length dest)])
+         (check-range who "byte string" dest d-start #f d-len)
+         (check-range who "byte string" src s-start s-end (bytevector-length src))
+         (let ([s-len (fx- s-end s-start)])
+           (check-space who "byte string" d-start d-len s-len)
+           (bytevector-copy! src s-start dest d-start s-len)))])]))
 
 (define/who (bytes-fill! bstr b)
   (check who mutable-bytevector? :contract "(and/c bytes? (not/c immutable?))" bstr)

racket/src/cs/rumble/unsafe.ss

@@ -89,6 +89,15 @@
 (define unsafe-bytes-ref (unsafe-primitive bytevector-u8-ref))
 (define unsafe-bytes-set! (unsafe-primitive bytevector-u8-set!))
 
+(define unsafe-bytes-copy!
+  (case-lambda
+    [(dest d-start src)
+     (unsafe-bytes-copy! dest d-start src 0 (bytevector-length src))]
+    [(dest d-start src s-start)
+     (unsafe-bytes-copy! dest d-start src s-start (bytevector-length src))]
+    [(dest d-start src s-start s-end)
+     (bytevector-copy! src s-start dest d-start (fx- s-end s-start))]))
+
 (define unsafe-string-length (unsafe-primitive string-length))
 (define unsafe-string-ref (unsafe-primitive string-ref))
 (define unsafe-string-set! (unsafe-primitive string-set!))

racket/src/racket/src/schminc.h

@@ -14,7 +14,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1463
+#define EXPECTED_PRIM_COUNT 1464
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/racket/src/schvers.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 7
 #define MZSCHEME_VERSION_Y 5
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 14
+#define MZSCHEME_VERSION_W 15
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x

racket/src/racket/src/vector.c

@@ -66,6 +66,7 @@ static Scheme_Object *unsafe_string_set (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_bytes_len (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_bytes_ref (int argc, Scheme_Object *argv[]);
 static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[]);
+static Scheme_Object *unsafe_bytes_copy_bang (int argc, Scheme_Object *argv[]);
 
 void
 scheme_init_vector (Scheme_Startup_Env *env)
@@ -350,6 +351,12 @@ scheme_init_unsafe_vector (Scheme_Startup_Env *env)
   scheme_addto_prim_instance("unsafe-bytes-set!", p, env);
   scheme_unsafe_bytes_set_proc = p;
 
+  scheme_addto_prim_instance("unsafe-bytes-copy!",
+			     scheme_make_prim_w_arity(unsafe_bytes_copy_bang,
+						      "unsafe-bytes-copy!",
+						      3, 5),
+			     env);
+
   scheme_addto_prim_instance("unsafe-impersonate-vector",
 			     scheme_make_prim_w_arity(unsafe_impersonate_vector,
 						      "unsafe-impersonate-vector",
@@ -1331,3 +1338,30 @@ static Scheme_Object *unsafe_bytes_set (int argc, Scheme_Object *argv[])
   SCHEME_BYTE_STR_VAL(argv[0])[SCHEME_INT_VAL(argv[1])] = (char)SCHEME_INT_VAL(argv[2]);
   return scheme_void;
 }
+
+static Scheme_Object *unsafe_bytes_copy_bang (int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *s1, *s2;
+  intptr_t istart, ifinish;
+  intptr_t ostart;
+
+  s1 = argv[0];
+  ostart = SCHEME_INT_VAL(argv[1]);
+  s2 = argv[2];
+  if (argc > 3) {
+    istart = SCHEME_INT_VAL(argv[3]);
+    if (argc > 4)
+      ifinish = SCHEME_INT_VAL(argv[4]);
+    else
+      ifinish = SCHEME_BYTE_STRLEN_VAL(s2);
+  } else {
+    istart = 0;
+    ifinish = SCHEME_BYTE_STRLEN_VAL(s2);
+  }
+
+  memmove(SCHEME_BYTE_STR_VAL(s1) XFORM_OK_PLUS ostart,
+	  SCHEME_BYTE_STR_VAL(s2) XFORM_OK_PLUS istart,
+	  (ifinish - istart));
+
+  return scheme_void;
+}