suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add unsafe-bytes-copy!

Browse Source 
Also, improve checking and performance of safe `bytes-copy!` in Racket
CS.
This commit is contained in:
Matthew Flatt 2019-12-28 10:55:57 -06:00
parent 085dd494d7
commit e087059f21
12 changed files with 129 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -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]))

15
pkgs/racket-doc/scribblings/reference/unsafe.scrbl
View File

@ -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
@racket[bytes-set!]. A bytes's size can never be larger than a
Unsafe versions of @racket[bytes-length], @racket[bytes-ref],
@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[(

15
pkgs/racket-test-core/tests/racket/basic.rktl
View File

@ -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")

6
pkgs/racket-test-core/tests/racket/unsafe.rktl
View File

@ -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)])

2
racket/src/cs/primitive/kernel.ss
View File

@ -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)]

47
racket/src/cs/primitive/unsafe.ss
View File

@ -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-set! (known-procedure 8)]
[unsafe-bytes-ref (known-procedure/succeeds 4)]
[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-set! (known-procedure 8)]
[unsafe-f64vector-ref (known-procedure 4)]
[unsafe-f64vector-set! (known-procedure 8)]
[unsafe-f80vector-ref (known-procedure 4)]
[unsafe-f80vector-set! (known-procedure 8)]
[unsafe-extflvector-ref (known-procedure/succeeds 4)]
[unsafe-extflvector-set! (known-procedure/succeeds 8)]
[unsafe-f64vector-ref (known-procedure/succeeds 4)]
[unsafe-f64vector-set! (known-procedure/succeeds 8)]
[unsafe-f80vector-ref (known-procedure/succeeds 4)]
[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-set! (known-procedure 8)]
[unsafe-flvector-ref (known-procedure/succeeds 4)]
[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-set! (known-procedure/pure 8)]
[unsafe-string-ref (known-procedure/succeeds 4)]
[unsafe-string-set! (known-procedure/succeeds 8)]
[unsafe-struct*-cas! (known-procedure 16)]
[unsafe-struct*-ref (known-procedure/pure 4)]
[unsafe-struct*-set! (known-procedure/pure 8)]
[unsafe-struct-ref (known-procedure/pure 4)]
[unsafe-struct-set! (known-procedure/pure 8)]
[unsafe-struct*-ref (known-procedure/succeeds 4)]
[unsafe-struct*-set! (known-procedure/succeeds 8)]
[unsafe-struct-ref (known-procedure/succeeds 4)]
[unsafe-struct-set! (known-procedure/succeeds 8)]
[unsafe-thread-at-root (known-procedure 2)]
[unsafe-u16vector-ref (known-procedure 4)]
[unsafe-u16vector-set! (known-procedure 8)]
[unsafe-u16vector-ref (known-procedure/succeeds 4)]
[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*-set! (known-procedure 8)]
[unsafe-vector*-ref (known-procedure/succeeds 4)]
[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)]

1
racket/src/cs/rumble.sls
View File

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

18
racket/src/cs/rumble/bytes.ss
View File

@ -51,10 +51,22 @@
(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)
;; start with fast, inlined checks for valid calls, then use
;; slower tests with consistent reporting if fast tests fail
(cond
[(and (mutable-bytevector? dest)
(bytevector? src)
(fixnum? d-start)
(fixnum? s-start)
(fixnum? s-end)
(fx<= 0 d-start (fx+ d-start (fx- s-end s-start)) (bytevector-length dest))
(fx<= 0 s-start s-end (bytevector-length src)))
(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)
@ -65,7 +77,7 @@
(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)))]))
(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)

9
racket/src/cs/rumble/unsafe.ss
View File

@ -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!))

2
racket/src/racket/src/schminc.h
View File

@ -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

2
racket/src/racket/src/schvers.h
View File

@ -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

34
racket/src/racket/src/vector.c
View File

@ -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;
}