ffi/unsafe: change `cast' to avoid pitfalls for you

The old `cast' didn't work right for a mismatch between
a pointer GCableness and the source or target types, and
it didn't work right for an GCable pointer with a non-zero
offset. While those pitfalls were documented, the first
of them definitely has been a source of bugs in code that
I wrote.

Also added `cpointer-gcable?'
This commit is contained in:
Matthew Flatt 2012-09-04 14:41:25 -06:00
parent 7d2ce136fa
commit 8bd5dbf7cc
10 changed files with 159 additions and 52 deletions

View File

@ -7,7 +7,7 @@
(provide ctype-sizeof ctype-alignof compiler-sizeof
malloc free end-stubborn-change
cpointer? prop:cpointer
cpointer? cpointer-gcable? prop:cpointer
ptr-equal? ptr-add ptr-ref ptr-set! (protect-out cast)
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
vector->cpointer flvector->cpointer saved-errno lookup-errno
@ -1159,9 +1159,43 @@
"representation sizes of from and to types differ"
"size of from type" (ctype-sizeof from-type)
"size of to size" (ctype-sizeof to-type)))
(let ([p2 (malloc from-type)])
(ptr-set! p2 from-type p)
(ptr-ref p2 to-type)))
(define (convert p from-type to-type)
(let ([p2 (malloc from-type)])
(ptr-set! p2 from-type p)
(ptr-ref p2 to-type)))
(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))]))]
[else
(convert p from-type to-type)]))
(define* (_or-null ctype)
(let ([coretype (ctype-coretype ctype)])
@ -1176,15 +1210,20 @@
(lambda (v) (and v (cast v _pointer ctype))))))
(define* (_gcable ctype)
(unless (memq (ctype-coretype ctype) '(pointer gcpointer))
(raise-argument-error '_or-null "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer))))" ctype))
(let loop ([ctype ctype])
(if (eq? ctype 'pointer)
_gcpointer
(make-ctype
(loop (ctype-basetype ctype))
(ctype-scheme->c ctype)
(ctype-c->scheme ctype)))))
(define t (ctype-coretype ctype))
(cond
[(eq? t 'gcpointer) ctype]
[(eq? t 'pointer)
(let loop ([ctype ctype])
(if (eq? ctype 'pointer)
_gcpointer
(make-ctype
(loop (ctype-basetype ctype))
(ctype-scheme->c ctype)
(ctype-c->scheme ctype))))]
[else
(raise-argument-error '_or-null "(and/c ctype? (lambda (ct) (memq (ctype-coretype ct) '(pointer gcpointer))))"
ctype)]))
(define (ctype-coretype c)
(let loop ([c (ctype-basetype c)])

View File

@ -46,7 +46,7 @@ Converts @racket[v] from a value matching @racket[from-type] to a
value matching @racket[to-type], where @racket[(ctype-sizeof from-type)]
matches @racket[(ctype-sizeof to-type)].
The conversion is equivalent to
The conversion is roughly equivalent to
@racketblock[
(let ([p (malloc from-type)])
@ -54,24 +54,18 @@ The conversion is equivalent to
(ptr-ref p to-type))
]
Beware of potential pitfalls with @racket[cast]:
If @racket[v] is a cpointer, @racket[(cpointer-gcable? v)] is true,
and @racket[from-type] and @racket[to-type] are both based on
@racket[_pointer] or @racket[_gcpointer], then @racket[from-type] is
implicitly converted with @racket[_gcable] to ensure that the result
cpointer is treated as referring to memory that is managed by the
garbage collector.
@itemlist[
@item{If @racket[v] is a pointer that refers to memory that is
managed by the garbage collector, @racket[from-type] and
@racket[to-type] normally should be based on
@racket[_gcpointer], not @racket[_pointer]; see also
@racket[_gcable].}
@item{If @racket[v] is a pointer with an offset component (e.g., from
@racket[ptr-add]), the offset is folded into the pointer base
for the result. Consequently, @racket[cast] generally should
not be used on a source pointer that refers to memory that is
managed by the garbage collector and that has an offset, unless
the memory is specially allocated to allow interior pointers.}
]}
If @racket[v] is a pointer with an offset component (e.g., from
@racket[ptr-add]), @racket[(cpointer-gcable? v)] is true, and the
result is a cpointer, then the result pointer has the same offset
component as @racket[v]. If @racket[(cpointer-gcable? v)] is false,
then any offset is folded into the pointer base for the result.}
@defproc[(cblock->list [cblock any/c] [type ctype?] [length exact-nonnegative-integer?])

View File

@ -52,6 +52,13 @@ and non-cpointers.}
Returns the offset of a pointer that has an offset. The resulting
offset is always in bytes.}
@defproc[(cpointer-gcable? [cptr cpointer?]) boolean?]{
Returns @racket[#t] if @racket[cptr] is treated as a reference to
memory that is managed by the garbage collector, @racket[#f]
otherwise.}
@; ----------------------------------------------------------------------
@section{Pointer Dereferencing}

View File

@ -342,7 +342,12 @@ might eventually become managed by the garbage collector. For example,
if a reference is created by @racket[malloc] with @racket['raw] and
released by @racket[free], then the @racket[free] may allow the memory
formerly occupied by the reference to be used later by the garbage
collector.}
collector.
The @racket[cpointer-gcable?] function returns @racket[#t] for a
cpointer generated via the @racket[_gcpointer] type, while it
generates @racket[#f] for a cpointer generated via the
@racket[_cpointer] type.}
@deftogether[(

View File

@ -449,6 +449,20 @@
(test n array-ref ar 19 9 4))
(for-each t '(1 2 3)))
;; test casting of GCable and offset pointers:
(let ()
(define _thing-pointer (_cpointer 'thing))
(define _stuff-pointer (_cpointer 'stuff))
(define p (cast (ptr-add (malloc 10) 5) _pointer _thing-pointer))
(cpointer-gcable? p)
(define q (cast p _thing-pointer _stuff-pointer))
(test (cast p _pointer _intptr)
cast q _pointer _intptr)
(collect-garbage)
(test (cast p _thing-pointer _intptr)
cast q _stuff-pointer _intptr))
(delete-test-files)
(report-errs)

View File

@ -1,3 +1,6 @@
Version 5.3.0.22
ffi/unsafe: added cpointer-gcable?
Version 5.3.0.20
Added exn:break:hang-up and exn:break:terminate, added
extra argument to break-thread and place-break, and

View File

@ -1585,12 +1585,34 @@ static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *arg
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPTRP(cp))
scheme_wrong_contract(MYNAME, "propert-cpointer?", 0, argc, argv);
scheme_wrong_contract(MYNAME, "proper-cpointer?", 0, argc, argv);
SCHEME_CPTR_TYPE(cp) = argv[1];
return scheme_void;
}
#undef MYNAME
#define MYNAME "cpointer-gcable?"
static Scheme_Object *foreign_cpointer_gcable_p(int argc, Scheme_Object *argv[])
{
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (SCHEME_CPTRP(cp)) {
return ((SCHEME_CPTR_FLAGS(cp) & 0x1)
? scheme_false
: scheme_true);
} else if (SCHEME_FALSEP(cp)
|| SCHEME_FFIOBJP(cp)
|| SCHEME_FFICALLBACKP(cp))
return scheme_false;
else if (SCHEME_BYTE_STRINGP(cp))
return scheme_true;
else {
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
return NULL;
}
}
#undef MYNAME
void *scheme_extract_pointer(Scheme_Object *v) {
return SCHEME_FFIANYPTR_VAL(v);
}
@ -3819,6 +3841,8 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
scheme_add_global("set-cpointer-tag!",
scheme_make_prim_w_arity(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global("cpointer-gcable?",
scheme_make_prim_w_arity(foreign_cpointer_gcable_p, "cpointer-gcable?", 1, 1), menv);
scheme_add_global("ctype-sizeof",
scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv);
scheme_add_global("ctype-alignof",
@ -4142,6 +4166,8 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "cpointer-tag", 1, 1), menv);
scheme_add_global("set-cpointer-tag!",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global("cpointer-gcable?",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "cpointer-gcable?", 1, 1), menv);
scheme_add_global("ctype-sizeof",
scheme_make_prim_w_arity((Scheme_Prim *)unimplemented, "ctype-sizeof", 1, 1), menv);
scheme_add_global("ctype-alignof",

View File

@ -1365,11 +1365,30 @@ int scheme_is_cpointer(Scheme_Object *cp) {
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (!SCHEME_CPTRP(cp))
scheme_wrong_contract(MYNAME, "propert-cpointer?", 0, argc, argv);
scheme_wrong_contract(MYNAME, "proper-cpointer?", 0, argc, argv);
SCHEME_CPTR_TYPE(cp) = argv[1];
return scheme_void;
}
@cdefine[cpointer-gcable? 1]{
Scheme_Object *cp;
cp = unwrap_cpointer_property(argv[0]);
if (SCHEME_CPTRP(cp)) {
return ((SCHEME_CPTR_FLAGS(cp) & 0x1)
? scheme_false
: scheme_true);
} else if (SCHEME_FALSEP(cp)
|| SCHEME_FFIOBJP(cp)
|| SCHEME_FFICALLBACKP(cp))
return scheme_false;
else if (SCHEME_BYTE_STRINGP(cp))
return scheme_true;
else {
scheme_wrong_contract(MYNAME, "cpointer?", 0, argc, argv);
return NULL;
}
}
void *scheme_extract_pointer(Scheme_Object *v) {
return SCHEME_FFIANYPTR_VAL(v);
}

View File

@ -1,5 +1,5 @@
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,49,84,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,50,84,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,
0,21,0,26,0,30,0,33,0,38,0,51,0,58,0,62,0,67,0,74,0,
83,0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,
@ -16,12 +16,12 @@
73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,
1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,
121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,
240,189,86,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,
240,190,86,0,0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,
16,20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,
2,2,8,2,2,2,9,2,2,2,10,2,2,2,11,2,2,2,12,2,2,
97,37,11,8,240,189,86,0,0,93,159,2,16,36,37,16,2,2,13,161,2,
2,37,2,13,2,2,2,13,96,11,11,8,240,189,86,0,0,16,0,96,38,
11,8,240,189,86,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,
97,37,11,8,240,190,86,0,0,93,159,2,16,36,37,16,2,2,13,161,2,
2,37,2,13,2,2,2,13,96,11,11,8,240,190,86,0,0,16,0,96,38,
11,8,240,190,86,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,
14,2,2,11,11,11,8,32,8,31,8,30,8,29,27,248,22,163,4,195,249,
22,156,4,80,158,39,36,251,22,89,2,18,248,22,104,199,12,249,22,79,2,
19,248,22,106,201,27,248,22,163,4,195,249,22,156,4,80,158,39,36,251,22,
@ -30,14 +30,14 @@
22,81,194,248,22,80,193,249,22,156,4,80,158,39,36,251,22,89,2,18,248,
22,80,199,249,22,79,2,5,248,22,81,201,11,18,100,10,13,16,6,36,2,
14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,20,3,
1,8,101,110,118,49,54,57,54,52,16,4,11,11,2,21,3,1,8,101,110,
118,49,54,57,54,53,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,
1,8,101,110,118,49,54,57,54,53,16,4,11,11,2,21,3,1,8,101,110,
118,49,54,57,54,54,27,248,22,81,248,22,163,4,196,28,248,22,87,193,20,
14,159,37,36,37,28,248,22,87,248,22,81,194,248,22,80,193,249,22,156,4,
80,158,39,36,250,22,89,2,22,248,22,89,249,22,89,248,22,89,2,23,248,
22,80,201,251,22,89,2,18,2,23,2,23,249,22,79,2,6,248,22,81,204,
18,100,11,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,
29,16,4,11,11,2,20,3,1,8,101,110,118,49,54,57,54,55,16,4,11,
11,2,21,3,1,8,101,110,118,49,54,57,54,56,248,22,163,4,193,27,248,
29,16,4,11,11,2,20,3,1,8,101,110,118,49,54,57,54,56,16,4,11,
11,2,21,3,1,8,101,110,118,49,54,57,54,57,248,22,163,4,193,27,248,
22,163,4,194,249,22,79,248,22,89,248,22,80,196,248,22,81,195,27,248,22,
81,248,22,163,4,23,197,1,249,22,156,4,80,158,39,36,28,248,22,64,248,
22,157,4,248,22,80,23,198,2,27,249,22,2,32,0,88,163,8,36,37,43,
@ -67,8 +67,8 @@
22,89,2,18,28,249,22,152,9,248,22,157,4,248,22,80,200,64,101,108,115,
101,10,248,22,80,197,250,22,90,2,22,9,248,22,81,200,249,22,79,2,11,
248,22,81,202,99,13,16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,
30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,54,57,57,48,16,
4,11,11,2,21,3,1,8,101,110,118,49,54,57,57,49,18,158,94,10,64,
30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,54,57,57,49,16,
4,11,11,2,21,3,1,8,101,110,118,49,54,57,57,50,18,158,94,10,64,
118,111,105,100,8,48,27,248,22,81,248,22,163,4,196,249,22,156,4,80,158,
39,36,28,248,22,64,248,22,157,4,248,22,80,197,250,22,89,2,28,248,22,
89,248,22,80,199,248,22,104,198,27,248,22,157,4,248,22,80,197,250,22,89,
@ -99,7 +99,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 2029);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,49,84,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,50,84,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,115,0,0,0,1,0,0,8,0,21,
0,26,0,43,0,65,0,94,0,109,0,127,0,139,0,155,0,169,0,191,0,
207,0,224,0,246,0,1,1,7,1,16,1,23,1,30,1,42,1,58,1,82,
@ -529,7 +529,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 8952);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,49,84,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,50,84,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,12,0,0,0,1,0,0,15,0,40,
0,57,0,75,0,97,0,120,0,140,0,162,0,169,0,176,0,183,0,0,0,
179,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,1,23,
@ -556,7 +556,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 502);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,49,84,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,50,84,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,85,0,0,0,1,0,0,7,0,18,
0,45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,
187,0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,63,1,94,1,101,
@ -937,7 +937,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 7928);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,49,84,0,0,0,0,0,0,0,0,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,51,46,48,46,50,50,84,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,
0,29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,98,1,
0,0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,
@ -945,7 +945,7 @@
111,114,107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,
2,74,35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,2,
66,35,37,98,111,111,116,11,29,94,2,2,68,35,37,101,120,112,111,98,115,
11,29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,189,
11,29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,190,
88,0,0,100,159,2,3,36,36,159,2,4,36,36,159,2,5,36,36,159,2,
6,36,36,159,2,7,36,36,159,2,8,36,36,159,2,9,36,36,159,2,9,
36,36,16,0,159,36,20,113,159,36,16,1,11,16,0,20,26,144,9,2,1,

View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.0.21"
#define MZSCHEME_VERSION "5.3.0.22"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 21
#define MZSCHEME_VERSION_W 22
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)