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

ffi/unsafe: repair cast from GCable pointer with offset

Browse Source 
The repair in 601f4a76e7 did not correctly handle pointers with a
non-zero offset.

Thanks to Bruce O'Neel for the report.
This commit is contained in:
Matthew Flatt 2021-04-04 09:34:18 -06:00
parent d3f3be5dc5
commit 589f0e55e4
2 changed files with 88 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
pkgs/racket-test-core/tests/racket/foreign-test.rktl
View File

@ -731,6 +731,15 @@
(test (cast p _thing-pointer _intptr)
cast q _stuff-pointer _intptr))
;; For casts where the BC output might share with the input, so
;; an offset pointer needs to be 'atomic-interior
(define (share-protect bstr)
(if (eq? 'racket (system-type 'vm))
(let ([new-bstr (malloc 'atomic-interior (add1 (bytes-length bstr)))])
(memcpy new-bstr bstr (add1 (bytes-length bstr)))
(make-sized-byte-string new-bstr (bytes-length bstr)))
bstr))
;; `cast` should auto-upgrade target pointer types using `_gcable` for a GCable argument
(test #t cpointer-gcable? (cast #"x" _pointer _pointer))
(test #t cpointer-gcable? (cast #"x" _gcpointer _pointer))
@ -738,9 +747,22 @@
(test #t cpointer-gcable? (cast (malloc 8) _pointer _pointer))
(test #t cpointer-gcable? (cast (malloc 8) _gcpointer _pointer))
(test #t cpointer-gcable? (cast (malloc 8) _pointer _gcpointer))
(test #t cpointer-gcable? (cast (ptr-add (malloc 8) 5) _pointer _pointer))
(test #t cpointer-gcable? (cast #"x" _bytes _pointer))
(test #t cpointer-gcable? (cast #"x" _bytes _gcpointer))
(test #t cpointer-gcable? (cast #"x" _bytes _bytes))
(test "lo" cast #"lo\0" _pointer _string/utf-8)
(test "lo" cast (if (system-big-endian?) #"l\0o\0\0\0" #"l\0o\0\0\0") _pointer _string/utf-16)
(test "lo" cast (if (system-big-endian?) #"\0\0\0l\0\0\0o\0\0\0\0\0\0\0\0" #"l\0\0\0o\0\0\0\0\0\0\0")
_pointer _string/ucs-4)
(test #t cpointer-gcable? (cast (ptr-add #"xy" 1) _pointer _bytes))
(test #t cpointer-gcable? (cast (ptr-add #"xy" 1) _pointer _pointer))
(test (char->integer #\y) ptr-ref (cast (ptr-add #"xy" 1) _pointer _pointer) _byte)
(test #"lo" cast (ptr-add (share-protect #"hello\0") 3) _pointer _bytes)
(test "lo" cast (ptr-add #"hello\0" 3) _pointer _string/utf-8)
(test "lo" cast (ptr-add (if (system-big-endian?) #"e\0l\0l\0o\0\0\0" #"\0l\0l\0o\0\0\0") 3) _pointer _string/utf-16)
(test "lo" cast (ptr-add (share-protect (if (system-big-endian?) #"\0\0\0l\0\0\0l\0\0\0o\0\0\0\0\0\0\0\0" #"\0\0\0\0l\0\0\0o\0\0\0\0\0\0\0")) 4)
_pointer _string/ucs-4)
(test #t
'many-casts
(for/and ([i (in-range 1000)])

99
racket/collects/ffi/unsafe.rkt
View File

@ -1476,46 +1476,79 @@
(cond
[(and (cpointer? p)
(cpointer-gcable? p))
(define to-ct (ctype-coretype to-type))
(define (pointer->gcpointer t)
(define ct (ctype-coretype t))
(if (eq? ct 'pointer)
(_gcable t)
t))
(let loop ([p p])
(cond
[(and (not (zero? (ptr-offset p)))
(let ([ct (ctype-coretype to-type)])
(or (eq? ct 'pointer)
(eq? ct 'gcpointer))))
(define o (ptr-offset p))
(define from-t (cpointer-tag p))
(define z (ptr-add p (- o)))
(when from-t
(set-cpointer-tag! z from-t))
(define q (loop z))
(define to-t (cpointer-tag q))
(define r (ptr-add q o))
(when to-t
(set-cpointer-tag! r to-t))
r]
[(ctype-pointer? to-type)
(define (pointer->cpointer t)
(define ct (ctype-coretype t))
(if (eq? ct 'pointer)
(_gcable t)
t))
(convert p (pointer->cpointer from-type) (pointer->cpointer to-type))]
[(coretype-pointer? to-ct)
(cond
[(not (zero? (ptr-offset p)))
(cond
[(coretype-plain-pointer? to-ct)
(define o (ptr-offset p))
(define from-t (cpointer-tag p))
(define z (ptr-add p (- o)))
(when from-t
(set-cpointer-tag! z from-t))
(define q (loop z))
(define to-t (cpointer-tag q))
(define r (ptr-add q o))
(when to-t
(set-cpointer-tag! r to-t))
r]
[(coretype-noncopying? to-ct)
;; we assume that an interior pointer is ok/wanted
(convert p (pointer->gcpointer from-type) to-type)]
[else
;; converting to a string or similar;
;; we can't store an offset pointer into
;; GCable memory, so copy to fresh GCable
;; memory, first
(define nul-count (case to-ct
[(string/ucs-4) 4]
[(string/utf-16) 2]
[else 1]))
(define len (let loop ([i 0] [count nul-count])
(if (zero? (ptr-ref p _byte i))
(if (= count 1)
(+ i nul-count)
(loop (add1 i) (sub1 count)))
(loop (add1 i) nul-count))))
(define p2 (malloc len 'atomic))
(memcpy p2 p len)
(loop p2)])]
[else
(convert p (pointer->gcpointer from-type) (pointer->gcpointer to-type))])]
[else
(convert p from-type to-type)]))]
[else
(convert p from-type to-type)]))
(define (ctype-pointer? ctype)
(define coretype (ctype-coretype ctype))
(memq coretype '(pointer
gcpointer
fpointer
bytes
scheme
string
string/ucs-4
string/utf-16
symbol)))
(define (coretype-pointer? ct)
(memq ct '(pointer
gcpointer
fpointer
bytes
scheme
string
string/ucs-4
string/utf-16
symbol)))
(define (coretype-plain-pointer? ct)
(or (eq? ct 'pointer)
(eq? ct 'gcpointer)
(eq? ct 'fpointer)))
(define (coretype-noncopying? ct)
(or (and (eq? 'racket (system-type 'vm))
(or (eq? ct 'bytes)
(eq? ct 'string/ucs-4)))
(eq? ct 'scheme)))
(define* (_or-null ctype)
(let ([coretype (ctype-coretype ctype)])