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

cs: support ptr-ref and ptr-set! on string types

Browse Source
This commit is contained in:
Matthew Flatt 2018-10-26 16:31:46 -06:00
parent 3f6a7b3e06
commit c128c5aad6
1 changed files with 122 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
racket/src/cs/rumble/foreign.ss
View File

@ -204,7 +204,8 @@
(define (stripped-cpointer? v)
(or (eqv? v 0)
(bytes? v)
(vector? v)))
(#%vector? v)
(exact-nonnegative-integer? v)))
;; ----------------------------------------
@ -411,7 +412,49 @@
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (add1 i))))])))
(loop (fx+ i 1))))])))
(define (subbytes-at-2-byte-nul x)
(let ([len (fxand (bytes-length x) (fxnot 1))])
(let loop ([i 0])
(cond
[(fx= i len) x]
[(and (fx= 0 (bytes-ref x i))
(fx= 0 (bytes-ref x (fx+ i 1))))
(subbytes x 0 i)]
[else (loop (fx+ i 2))]))))
(define (uptr->bytes/2-byte-nul x)
(let loop ([i 0])
(if (and (fx= 0 (foreign-ref 'unsigned-8 x i))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 1))))
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (fx+ i 2)))))
(define (subbytes-at-4-byte-nul x)
(let ([len (fxand (bytes-length x) (fxnot 3))])
(let loop ([i 0])
(cond
[(fx= i len) x]
[(and (fx= 0 (bytes-ref x i))
(fx= 0 (bytes-ref x (fx+ i 1)))
(fx= 0 (bytes-ref x (fx+ i 2)))
(fx= 0 (bytes-ref x (fx+ i 3))))
(subbytes x 0 i)]
[else (loop (fx+ i 4))]))))
(define (uptr->bytes/4-byte-nul x)
(let loop ([i 0])
(if (and (fx= 0 (foreign-ref 'unsigned-8 x i))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 1)))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 2)))
(fx= 0 (foreign-ref 'unsigned-8 x (fx+ i 3))))
(let ([bstr (make-bytes i)])
(memcpy* bstr 0 x 0 i #f)
bstr)
(loop (fx+ i 4)))))
(define-ctype _short_bytes 'void* 'bytes
(lambda (x) x)
@ -782,26 +825,68 @@
[host-rep (ctype-host-rep type)])
(cond
[(cpointer-nonatomic? p)
(let ([offset (+ offset (ptr-offset* p))])
(let* ([offset (+ offset (ptr-offset* p))]
[extract-pointer
(lambda ()
(let* ([i (fxsrl offset log-ptr-size-in-bytes)]
[v (#%vector-ref (cpointer-memory p) i)])
(cond
[(eq? 'scheme-object host-rep) v]
[(stripped-cpointer? v) v]
[else
(raise-arguments-error 'ptr-ref
"cannot convert value to a cpointer"
"extracted value" v
"source" orig-p)])))])
(cond
[(and (word-aligned? offset)
(or (eq? 'void* host-rep)
(eq? 'scheme-object host-rep)))
(let* ([i (fxsrl offset log-ptr-size-in-bytes)]
[v (vector-ref (cpointer-memory p) i)])
(cond
[(eq? 'scheme-object host-rep) v]
[(stripped-cpointer? v) v]
[else
(raise-arguments-error 'ptr-ref
"cannot convert value to a cpointer"
"extracted value" v
"source" orig-p)]))]
(extract-pointer)]
[(and (word-aligned? offset)
(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep))
(let ([v (extract-pointer)]
[endian (if (eq? 'utf-16le host-rep)
'little
'big)])
(cond
[(bytevector? v)
(utf16->string (subbytes-at-2-byte-nul v) endian #t)]
[(integer? v)
(utf16->string (uptr->bytes/2-byte-nul v) endian #t)]
[else #f])))
=> (lambda (v) v)]
[(and (word-aligned? offset)
(or (eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep))
(let ([v (extract-pointer)]
[endian (if (eq? 'utf-32le host-rep)
'little
'big)])
(cond
[(bytevector? v)
(utf32->string (subbytes-at-4-byte-nul v) endian #t)]
[(integer? v)
(utf32->string (uptr->bytes/4-byte-nul v) endian #t)]
[else #f])))
=> (lambda (v) v)]
[else
(raise-arguments-error 'ptr-ref "unsupported access into non-atomic memory"
"offset" offset
"representation" host-rep
"source" orig-p)]))]
[(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep)
(eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep))
(let ([v (with-interrupts-disabled
(foreign-ref 'uptr (cpointer-address p) 0))])
(case host-rep
[(utf-16le) (utf16->string (uptr->bytes/2-byte-nul v) 'little #t)]
[(utf-16be) (utf16->string (uptr->bytes/2-byte-nul v) 'big #t)]
[(utf-32le) (utf16->string (uptr->bytes/4-byte-nul v) 'little #t)]
[(utf-32be) (utf16->string (uptr->bytes/4-byte-nul v) 'big #t)]))]
[else
;; Disable interrupts to avoid a GC:
(with-interrupts-disabled
@ -874,16 +959,28 @@
(eq? 'scheme-object host-rep)))
(let ([i (fxsrl offset log-ptr-size-in-bytes)])
(if (eq? host-rep 'scheme-object)
(vector-set! (cpointer-memory p) i v)
(#%vector-set! (cpointer-memory p) i v)
(let ([v (cpointer-strip v)])
(if (eq? v none)
(raise-arguments-error 'ptr-set!
"cannot install value into non-atomic memory"
"value" orig-v
"destination" orig-p)
(vector-set! (cpointer-memory p) i v)))))]
(#%vector-set! (cpointer-memory p) i v)))))]
[(and (word-aligned? offset)
(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep)))
(let ([i (fxsrl offset log-ptr-size-in-bytes)]
[endian (if (eq? 'utf-16le host-rep) 'little 'big)])
(#%vector-set! (cpointer-memory p) i (bytes-append (string->utf16 v endian) #vu8(0 0))))]
[(and (word-aligned? offset)
(or (eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep)))
(let ([i (fxsrl offset log-ptr-size-in-bytes)]
[endian (if (eq? 'utf-32le host-rep) 'little 'big)])
(#%vector-set! (cpointer-memory p) i (bytes-append (string->utf32 v endian) #vu8(0 0 0 0))))]
[else
(raise-arguments-error 'ptr-set! "unsupported access into non-atomic memory"
(raise-arguments-error 'ptr-set! "unsupported assignment into non-atomic memory"
"offset" offset
"representation" host-rep
"value" orig-v
@ -893,7 +990,15 @@
(raise-arguments-error 'ptr-set!
"cannot install non-atomic pointer into atomic memory"
"non-atomic pointer" orig-v
"destination" orig-p)]
"atomic destination" orig-p)]
[(or (eq? 'utf-16le host-rep)
(eq? 'utf-16be host-rep)
(eq? 'utf-32le host-rep)
(eq? 'utf-32be host-rep))
(raise-arguments-error 'ptr-set!
"cannot install GC-allocated bytes for string conversion into atomic memory"
"string" orig-v
"atomic destination" orig-p)]
[else
;; Disable interrupts to avoid a GC:
(with-interrupts-disabled