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

ffi/unsafe: fix cast from _bytes to _pointer

Browse Source 
The `cast` function is supposed to auto-promote its second argument to
a GCable type if the value to convert is a GCable pointer. This
promotion did not happen for `_bytes` and other string-like types.

Also, in CS, `malloc` did not alocate GCable memory by default when
given the `_bytes` type, which would sometimes interfere with getting
a GCable pointer result.

This bug explains why the "draw-test/tests/racket/draw/dc.rkt" test
would occassionally have an `unscaled-alpha-set` failure on DrDr (for
many years).
This commit is contained in:
Matthew Flatt 2021-04-02 10:32:40 -06:00
parent 181b9c80ac
commit 601f4a76e7
3 changed files with 55 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -729,6 +729,23 @@
(test (cast p _thing-pointer _intptr)
cast q _stuff-pointer _intptr))
;; `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))
(test #t cpointer-gcable? (cast #"x" _pointer _gcpointer))
(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 #"x" _bytes _pointer))
(test #t cpointer-gcable? (cast #"x" _bytes _gcpointer))
(test #t cpointer-gcable? (cast #"x" _bytes _bytes))
(test #t
'many-casts
(for/and ([i (in-range 1000)])
(cpointer-gcable? (cast (bytes 1 2 3 4)
_bytes
_pointer))))
;; test 'interior allocation mode
(when (eq? 'racket (system-type 'vm))
;; Example by Ron Garcia

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

@ -1465,36 +1465,47 @@
(cond
[(and (cpointer? p)
(cpointer-gcable? p))
(define from-t (ctype-coretype from-type))
(define to-t (ctype-coretype to-type))
(let loop ([p p])
(cond
[(and (not (zero? (ptr-offset p)))
(or (or (eq? to-t 'pointer)
(eq? to-t '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]
[else
(if (and (or (eq? from-t 'pointer)
(eq? to-t 'pointer))
(or (eq? from-t 'pointer)
(eq? from-t 'gcpointer))
(or (eq? to-t 'pointer)
(eq? to-t 'gcpointer)))
(convert p (_gcable from-type) (_gcable to-type))
(convert p from-type to-type))]))]
[(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))]
[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* (_or-null ctype)
(let ([coretype (ctype-coretype ctype)])
(unless (memq coretype '(pointer gcpointer fpointer))

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

@ -688,7 +688,9 @@
(define (ctype-malloc-mode c)
(let ([t (ctype-our-rep c)])
(if (or (eq? t 'gcpointer)
(eq? t 'bytes)
(eq? t 'scheme)
(eq? t 'string)
(eq? t 'string/ucs-4)
(eq? t 'string/utf-16))
'nonatomic