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

fix ffi issue with pointer vs. gcpointer

Browse Source 
- don't put a non-gcpointer into a pointer array during ffi call setup
 - fix GCness of pointers to structs inside of structs
This commit is contained in:
Matthew Flatt 2010-11-14 11:39:04 -07:00
parent 279315b582
commit a8b318da7a
3 changed files with 97 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/scribblings/foreign/types.scrbl
View File

@ -814,7 +814,9 @@ The resulting bindings are as follows:
an argument for each type.} an argument for each type.}
@item{@schemevarfont{id}@schemeidfont{-}@scheme[field-id] : an accessor @item{@schemevarfont{id}@schemeidfont{-}@scheme[field-id] : an accessor
function for each @scheme[field-id].} function for each @scheme[field-id]; if the field has a cstruct type, then
the result of the accessor is a pointer to the field within the
enclosing structure, rather than a copy of the field.}
@item{@schemeidfont{set-}@schemevarfont{id}@schemeidfont{-}@scheme[field-id]@schemeidfont{!} @item{@schemeidfont{set-}@schemevarfont{id}@schemeidfont{-}@scheme[field-id]@schemeidfont{!}
: a mutator function for each @scheme[field-id].} : a mutator function for each @scheme[field-id].}
@ -860,12 +862,11 @@ addition for the new fields. This adjustment of the constructor is,
again, in analogy to using a supertype with @scheme[define-struct]. again, in analogy to using a supertype with @scheme[define-struct].
Note that structs are allocated as atomic blocks, which means that the Note that structs are allocated as atomic blocks, which means that the
garbage collector ignores their content. Currently, there is no safe garbage collector ignores their content. Thus, struct fields can hold
way to store pointers to GC-managed objects in structs (even if you only non-pointer values, pointers to memory outside the GC's control,
keep a reference to avoid collecting the referenced objects, a the 3m and otherwise-reachable pointers to immobile GC-managed values (such
variant's GC will invalidate the pointer's value). Thus, only as those allocated with @racket[malloc] and @racket['internal] or
non-pointer values and pointers to memory that is outside the GC's @racket['internal-atomic]).
control can be placed into struct fields.
As an example, consider the following C code: As an example, consider the following C code:

64
src/foreign/foreign.c
View File

@ -713,7 +713,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
#define FOREIGN_string_ucs_4 (18) #define FOREIGN_string_ucs_4 (18)
/* Type Name: string/ucs-4 (string_ucs_4) /* Type Name: string/ucs-4 (string_ucs_4)
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_gcpointer
* C type: mzchar* * C type: mzchar*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>) * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
* Scheme->C: ucs4_string_or_null_to_ucs4_pointer(<Scheme>) * Scheme->C: ucs4_string_or_null_to_ucs4_pointer(<Scheme>)
@ -723,7 +723,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
#define FOREIGN_string_utf_16 (19) #define FOREIGN_string_utf_16 (19)
/* Type Name: string/utf-16 (string_utf_16) /* Type Name: string/utf-16 (string_utf_16)
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_gcpointer
* C type: unsigned short* * C type: unsigned short*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>) * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
* Scheme->C: ucs4_string_or_null_to_utf16_pointer(<Scheme>) * Scheme->C: ucs4_string_or_null_to_utf16_pointer(<Scheme>)
@ -736,7 +736,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
#define FOREIGN_bytes (20) #define FOREIGN_bytes (20)
/* Type Name: bytes /* Type Name: bytes
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_gcpointer
* C type: char* * C type: char*
* Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_BYTE_STRINGP(<Scheme>) * Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_BYTE_STRINGP(<Scheme>)
* Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_BYTE_STR_VAL(<Scheme>) * Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_BYTE_STR_VAL(<Scheme>)
@ -746,7 +746,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
#define FOREIGN_path (21) #define FOREIGN_path (21)
/* Type Name: path /* Type Name: path
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_gcpointer
* C type: char* * C type: char*
* Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_PATH_STRINGP(<Scheme>) * Predicate: SCHEME_FALSEP(<Scheme>)||SCHEME_PATH_STRINGP(<Scheme>)
* Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_PATH_VAL(TO_PATH(<Scheme>)) * Scheme->C: SCHEME_FALSEP(<Scheme>)?NULL:SCHEME_PATH_VAL(TO_PATH(<Scheme>))
@ -843,6 +843,11 @@ typedef union _ForeignAny {
/* This is a tag that is used to identify user-made struct types. */ /* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (27) #define FOREIGN_struct (27)
static int is_gcable_pointer(Scheme_Object *o) {
return !SCHEME_CPTRP(o)
|| !(SCHEME_CPTR_FLAGS(o) & 0x1);
}
/*****************************************************************************/ /*****************************************************************************/
/* Type objects */ /* Type objects */
@ -1218,6 +1223,9 @@ END_XFORM_SKIP;
#define scheme_make_foreign_external_cpointer(x) \ #define scheme_make_foreign_external_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
#define scheme_make_foreign_offset_external_cpointer(x, delta) \
((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL))
#define MYNAME "cpointer?" #define MYNAME "cpointer?"
static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[]) static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
{ {
@ -1258,23 +1266,23 @@ void *scheme_extract_pointer(Scheme_Object *v) {
* memory location -- deal with it via a C2SCHEME macro wrapper that is used * memory location -- deal with it via a C2SCHEME macro wrapper that is used
* for both the function definition and calls */ * for both the function definition and calls */
#ifdef SCHEME_BIG_ENDIAN #ifdef SCHEME_BIG_ENDIAN
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc) #define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc)
#define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \ #define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \
? ((ctype)(((int*)W_OFFSET(src,delta))[0])) \ ? ((ctype)(((int*)W_OFFSET(src,delta))[0])) \
: (((ctype *)W_OFFSET(src,delta))[0])) : (((ctype *)W_OFFSET(src,delta))[0]))
#else #else
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta) #define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,gcsrc)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0]) #define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif #endif
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc) int delta, int args_loc, int gcsrc)
{ {
Scheme_Object *res; Scheme_Object *res;
if (!SCHEME_CTYPEP(type)) if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
if (CTYPE_USERP(type)) { if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res; return res;
else else
@ -1309,7 +1317,10 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*); case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
case FOREIGN_fpointer: return (REF_CTYPE(void*)); case FOREIGN_fpointer: return (REF_CTYPE(void*));
case FOREIGN_struct: case FOREIGN_struct:
if (gcsrc)
return scheme_make_foreign_offset_cpointer(src, delta); return scheme_make_foreign_offset_cpointer(src, delta);
else
return scheme_make_foreign_offset_external_cpointer(src, delta);
default: scheme_signal_error("corrupt foreign type: %V", type); default: scheme_signal_error("corrupt foreign type: %V", type);
} }
return NULL; /* hush the compiler */ return NULL; /* hush the compiler */
@ -1556,7 +1567,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp; mzchar* tmp;
tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val)); tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
if (basetype_p == NULL || tmp == NULL) { if (basetype_p == NULL || tmp == NULL || 0) {
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; return NULL;
} else { } else {
@ -1577,7 +1588,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
unsigned short* tmp; unsigned short* tmp;
tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val)); tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
if (basetype_p == NULL || tmp == NULL) { if (basetype_p == NULL || tmp == NULL || 0) {
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; return NULL;
} else { } else {
@ -1598,7 +1609,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) { if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) {
char* tmp; char* tmp;
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val)); tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val));
if (basetype_p == NULL || tmp == NULL) { if (basetype_p == NULL || tmp == NULL || 0) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp; (((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; return NULL;
} else { } else {
@ -1619,7 +1630,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) { if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) {
char* tmp; char* tmp;
tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val))); tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val)));
if (basetype_p == NULL || tmp == NULL) { if (basetype_p == NULL || tmp == NULL || 0) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp; (((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; return NULL;
} else { } else {
@ -1640,7 +1651,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (SCHEME_SYMBOLP(val)) { if (SCHEME_SYMBOLP(val)) {
char* tmp; char* tmp;
tmp = (char*)(SCHEME_SYM_VAL(val)); tmp = (char*)(SCHEME_SYM_VAL(val));
if (basetype_p == NULL || tmp == NULL) { if (basetype_p == NULL || tmp == NULL || !is_gcable_pointer(val)) {
(((char**)W_OFFSET(dst,delta))[0]) = tmp; (((char**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; return NULL;
} else { } else {
@ -1663,7 +1674,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val)); tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val); toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff; if (_offset) *_offset = toff;
if (basetype_p == NULL || (tmp == NULL && toff == 0)) { if (basetype_p == NULL || (tmp == NULL && toff == 0) || !is_gcable_pointer(val)) {
(((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff)); (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
return NULL; return NULL;
} else { } else {
@ -1686,7 +1697,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
tmp = (void*)(SCHEME_FFIANYPTR_VAL(val)); tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
toff = SCHEME_FFIANYPTR_OFFSET(val); toff = SCHEME_FFIANYPTR_OFFSET(val);
if (_offset) *_offset = toff; if (_offset) *_offset = toff;
if (basetype_p == NULL || (tmp == NULL && toff == 0)) { if (basetype_p == NULL || (tmp == NULL && toff == 0) || 0) {
(((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff)); (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff));
return NULL; return NULL;
} else { } else {
@ -1707,7 +1718,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
if (1) { if (1) {
Scheme_Object* tmp; Scheme_Object* tmp;
tmp = (Scheme_Object*)(val); tmp = (Scheme_Object*)(val);
if (basetype_p == NULL || tmp == NULL) { if (basetype_p == NULL || tmp == NULL || 0) {
(((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; return NULL;
} else { } else {
@ -2274,12 +2285,14 @@ static Scheme_Object *abs_sym;
static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
{ {
int size=0; void *ptr; Scheme_Object *base; int size=0; void *ptr; Scheme_Object *base;
long delta; long delta; int gcsrc=1;
if (!SCHEME_FFIANYPTRP(argv[0])) if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if (!is_gcable_pointer(argv[0]))
gcsrc = 0;
if ((ptr == NULL) && (delta == 0)) if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1]))) if (NULL == (base = get_ctype_base(argv[1])))
@ -2314,7 +2327,7 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2])); delta += (size * SCHEME_INT_VAL(argv[2]));
} }
return C2SCHEME(argv[1], ptr, delta, 0); return C2SCHEME(argv[1], ptr, delta, 0, gcsrc);
} }
#undef MYNAME #undef MYNAME
@ -2541,6 +2554,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */ /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
ivals[i].x_pointer = avalues[i]; ivals[i].x_pointer = avalues[i];
avalues[i] = &(ivals[i]); avalues[i] = &(ivals[i]);
} else if (offsets[i]) {
/* struct argument has an offset */
avalues[i] = (char *)avalues[i] + offsets[i];
} }
/* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
/* Add offset, if any: */ /* Add offset, if any: */
@ -2569,7 +2585,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
} }
break; break;
} }
return C2SCHEME(otype, p, 0, 1); return C2SCHEME(otype, p, 0, 1, 1);
} }
/* see below */ /* see below */
@ -2696,7 +2712,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
if (data->sync && !SCHEME_RPAIRP(data->sync)) if (data->sync && !SCHEME_RPAIRP(data->sync))
scheme_start_in_scheduler(); scheme_start_in_scheduler();
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) { for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0); v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0, 0);
argv[i] = v; argv[i] = v;
} }
p = _scheme_apply(data->proc, argc, argv); p = _scheme_apply(data->proc, argc, argv);
@ -3345,28 +3361,28 @@ void scheme_init_foreign(Scheme_Env *env)
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16"); s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bytes"); s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes);
scheme_add_global("_bytes", (Scheme_Object*)t, menv); scheme_add_global("_bytes", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("path"); s = scheme_intern_symbol("path");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; t->so.type = ctype_tag;
t->basetype = (s); t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path);
scheme_add_global("_path", (Scheme_Object*)t, menv); scheme_add_global("_path", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("symbol"); s = scheme_intern_symbol("symbol");

45
src/foreign/foreign.rktc
View File

@ -664,14 +664,14 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* meaningless to use NULL. */ * meaningless to use NULL. */
@(defctype 'string/ucs-4 @(defctype 'string/ucs-4
'ftype "pointer" 'ftype "gcpointer"
'ctype "mzchar*" 'ctype "mzchar*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
's->c "ucs4_string_or_null_to_ucs4_pointer" 's->c "ucs4_string_or_null_to_ucs4_pointer"
'c->s "scheme_make_char_string_without_copying") 'c->s "scheme_make_char_string_without_copying")
@(defctype 'string/utf-16 @(defctype 'string/utf-16
'ftype "pointer" 'ftype "gcpointer"
'ctype "unsigned short*" 'ctype "unsigned short*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
's->c "ucs4_string_or_null_to_utf16_pointer" 's->c "ucs4_string_or_null_to_utf16_pointer"
@ -681,7 +681,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* (note: these are not like char* which is just a pointer) */ * (note: these are not like char* which is just a pointer) */
@(defctype 'bytes @(defctype 'bytes
'ftype "pointer" 'ftype "gcpointer"
'ctype "char*" 'ctype "char*"
'pred (lambda (x aux) 'pred (lambda (x aux)
@list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)}) @list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)})
@ -692,7 +692,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
scheme_make_byte_string_without_copying(@x)})) scheme_make_byte_string_without_copying(@x)}))
@(defctype 'path @(defctype 'path
'ftype "pointer" 'ftype "gcpointer"
'ctype "char*" 'ctype "char*"
'pred (lambda (x aux) 'pred (lambda (x aux)
@list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)}) @list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)})
@ -756,6 +756,11 @@ typedef union _ForeignAny {
@; last makes sure this is the last one value that gets used @; last makes sure this is the last one value that gets used
#define FOREIGN_struct (@(type-counter 'last)) #define FOREIGN_struct (@(type-counter 'last))
static int is_gcable_pointer(Scheme_Object *o) {
return !SCHEME_CPTRP(o)
|| !(SCHEME_CPTR_FLAGS(o) & 0x1);
}
/*****************************************************************************/ /*****************************************************************************/
/* Type objects */ /* Type objects */
@ -1014,6 +1019,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
#define scheme_make_foreign_external_cpointer(x) \ #define scheme_make_foreign_external_cpointer(x) \
((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
#define scheme_make_foreign_offset_external_cpointer(x, delta) \
((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL))
@cdefine[cpointer? 1]{ @cdefine[cpointer? 1]{
return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
} }
@ -1045,23 +1053,23 @@ void *scheme_extract_pointer(Scheme_Object *v) {
* memory location -- deal with it via a C2SCHEME macro wrapper that is used * memory location -- deal with it via a C2SCHEME macro wrapper that is used
* for both the function definition and calls */ * for both the function definition and calls */
#ifdef SCHEME_BIG_ENDIAN #ifdef SCHEME_BIG_ENDIAN
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc) #define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc)
#define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \ #define REF_CTYPE(ctype) (((sizeof(ctype)<sizeof(int)) && args_loc) \
? ((ctype)(((int*)W_OFFSET(src,delta))[0])) \ ? ((ctype)(((int*)W_OFFSET(src,delta))[0])) \
: (((ctype *)W_OFFSET(src,delta))[0])) : (((ctype *)W_OFFSET(src,delta))[0]))
#else #else
#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta) #define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,gcsrc)
#define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0]) #define REF_CTYPE(ctype) (((ctype *)W_OFFSET(src,delta))[0])
#endif #endif
static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
int delta, int args_loc) int delta, int args_loc, int gcsrc)
{ {
Scheme_Object *res; Scheme_Object *res;
if (!SCHEME_CTYPEP(type)) if (!SCHEME_CTYPEP(type))
scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type); scheme_wrong_type("C->Scheme", "C-type", 0, 1, &type);
if (CTYPE_USERP(type)) { if (CTYPE_USERP(type)) {
res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc);
if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) if (SCHEME_FALSEP(CTYPE_USER_C2S(type)))
return res; return res;
else else
@ -1076,7 +1084,10 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
(if (procedure? c->s) (c->s x) (list c->s"("x")"))) (if (procedure? c->s) (c->s x) (list c->s"("x")")))
"scheme_void")}) "scheme_void")})
case FOREIGN_struct: case FOREIGN_struct:
if (gcsrc)
return scheme_make_foreign_offset_cpointer(src, delta); return scheme_make_foreign_offset_cpointer(src, delta);
else
return scheme_make_foreign_offset_external_cpointer(src, delta);
default: scheme_signal_error("corrupt foreign type: %V", type); default: scheme_signal_error("corrupt foreign type: %V", type);
} }
@hush @hush
@ -1153,7 +1164,10 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
@list{if (basetype_p == NULL || @; @list{if (basetype_p == NULL || @;
@(if offset @(if offset
@list{(tmp == NULL && toff == 0)} @list{(tmp == NULL && toff == 0)}
@list{tmp == NULL})) { @list{tmp == NULL}) || @;
@(if (equal? ftype "pointer")
@list{!is_gcable_pointer(val)}
@list{0})) {
@x = @(if offset @x = @(if offset
@list{(_offset ? tmp : @; @list{(_offset ? tmp : @;
(@ctype)W_OFFSET(tmp, toff))} (@ctype)W_OFFSET(tmp, toff))}
@ -1651,12 +1665,14 @@ static Scheme_Object *do_memop(const char *who, int mode,
/* WARNING: there are *NO* checks at all, this is raw C level code. */ /* WARNING: there are *NO* checks at all, this is raw C level code. */
@cdefine[ptr-ref 2 4]{ @cdefine[ptr-ref 2 4]{
int size=0; void *ptr; Scheme_Object *base; int size=0; void *ptr; Scheme_Object *base;
long delta; long delta; int gcsrc=1;
if (!SCHEME_FFIANYPTRP(argv[0])) if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]); ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if (!is_gcable_pointer(argv[0]))
gcsrc = 0;
if ((ptr == NULL) && (delta == 0)) if ((ptr == NULL) && (delta == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
if (NULL == (base = get_ctype_base(argv[1]))) if (NULL == (base = get_ctype_base(argv[1])))
@ -1691,7 +1707,7 @@ static Scheme_Object *do_memop(const char *who, int mode,
scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); scheme_signal_error(MYNAME": cannot multiply fpointer type by offset");
delta += (size * SCHEME_INT_VAL(argv[2])); delta += (size * SCHEME_INT_VAL(argv[2]));
} }
return C2SCHEME(argv[1], ptr, delta, 0); return C2SCHEME(argv[1], ptr, delta, 0, gcsrc);
} }
/* (ptr-set! cpointer type [['abs] n] value) -> void */ /* (ptr-set! cpointer type [['abs] n] value) -> void */
@ -1909,6 +1925,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
/* ... set the ivals pointer (pointer type doesn't matter) and avalues */ /* ... set the ivals pointer (pointer type doesn't matter) and avalues */
ivals[i].x_pointer = avalues[i]; ivals[i].x_pointer = avalues[i];
avalues[i] = &(ivals[i]); avalues[i] = &(ivals[i]);
} else if (offsets[i]) {
/* struct argument has an offset */
avalues[i] = (char *)avalues[i] + offsets[i];
} }
/* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Otherwise it was a struct pointer, and avalues[i] is already fine. */
/* Add offset, if any: */ /* Add offset, if any: */
@ -1937,7 +1956,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
} }
break; break;
} }
return C2SCHEME(otype, p, 0, 1); return C2SCHEME(otype, p, 0, 1, 1);
} }
/* see below */ /* see below */
@ -2061,7 +2080,7 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
if (data->sync && !SCHEME_RPAIRP(data->sync)) if (data->sync && !SCHEME_RPAIRP(data->sync))
scheme_start_in_scheduler(); scheme_start_in_scheduler();
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) { for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0); v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0, 0);
argv[i] = v; argv[i] = v;
} }
p = _scheme_apply(data->proc, argc, argv); p = _scheme_apply(data->proc, argc, argv);