From bf1e7a5ab0d9892af9264638162da60a8792a9da Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 4 Sep 2008 10:35:41 +0000 Subject: [PATCH] Added optional abi argument to `ffi-call', `ffi-callback', `make-cstruct-type'. svn: r11533 --- src/foreign/foreign.c | 125 ++++++++++++++++++++++++++++------------ src/foreign/foreign.ssc | 83 +++++++++++++++++++------- 2 files changed, 150 insertions(+), 58 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index bf9112cd58..66db104a04 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -956,7 +956,7 @@ static Scheme_Object *foreign_make_ctype(int argc, Scheme_Object *argv[]) type->c_to_scheme = (argv[2]); return (Scheme_Object*)type; } - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } /* see below */ @@ -966,7 +966,43 @@ void free_libffi_type(void *ignored, void *p) free(p); } -/* (make-cstruct-type types) -> ctype */ +/*****************************************************************************/ +/* ABI spec */ + +static Scheme_Object *default_sym; +static Scheme_Object *stdcall_sym; +static Scheme_Object *sysv_sym; + +ffi_abi sym_to_abi(char *who, Scheme_Object *sym) +{ + if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym)) + return FFI_DEFAULT_ABI; + else if (SAME_OBJ(sym, sysv_sym)) { +#ifdef FFI_SYSV + return FFI_SYSV; +#else + scheme_signal_error("%s: ABI unimplemented: %V", who, sym); +#endif + } else if (SAME_OBJ(sym, stdcall_sym)) { +#ifdef FFI_STDCALL + return FFI_STDCALL; +#else + scheme_signal_error("%s: ABI unimplemented: %V", who, sym); +#endif + } else { + scheme_signal_error("%s: unknown ABI: %V", who, sym); + } + return 0; /* hush the compiler */ +} + +/* helper macro */ +#define GET_ABI(name,n) \ + ((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI) + +/*****************************************************************************/ +/* cstruct types */ + +/* (make-cstruct-type types [abi]) -> ctype */ /* This creates a new primitive type that is a struct. This type can be used * with cpointer objects, except that the contents is used rather than the * pointer value. Marshaling to lists or whatever should be done in Scheme. */ @@ -982,9 +1018,10 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[]) ctype_struct *type; ffi_cif cif; int i, nargs; + ffi_abi abi; nargs = scheme_proper_list_length(argv[0]); - if (nargs < 0) - scheme_wrong_type(MYNAME, "proper list", 0, argc, argv); + if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv); + abi = GET_ABI(MYNAME,1); /* allocate the type elements */ elements = malloc((nargs+1) * sizeof(ffi_type*)); elements[nargs] = NULL; @@ -1003,7 +1040,7 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[]) libffi_type->elements = elements; /* use ffi_prep_cif to set the size and alignment information */ dummy = &libffi_type; - if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1, &ffi_type_void, dummy) != FFI_OK) + if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); type = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); type->so.type = ctype_tag; @@ -1170,7 +1207,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, return scheme_make_foreign_cpointer(W_OFFSET(src, delta)); default: scheme_signal_error("corrupt foreign type: %V", type); } - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } #undef REF_CTYPE @@ -1229,7 +1266,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((Tsint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","int8",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_uint8: #ifdef SCHEME_BIG_ENDIAN @@ -1244,7 +1281,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((Tuint8*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","uint8",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_int16: #ifdef SCHEME_BIG_ENDIAN @@ -1259,7 +1296,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((Tsint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","int16",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_uint16: #ifdef SCHEME_BIG_ENDIAN @@ -1274,7 +1311,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((Tuint16*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","uint16",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_int32: if (!(scheme_get_realint_val(val,&(((Tsint32*)W_OFFSET(dst,delta))[0])))) scheme_wrong_type("Scheme->C","int32",0,1,&(val)); @@ -1301,7 +1338,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((Tsint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","fixint",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_ufixint: #ifdef SCHEME_BIG_ENDIAN @@ -1316,7 +1353,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((Tuint32*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","ufixint",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_fixnum: #ifdef SCHEME_BIG_ENDIAN @@ -1331,7 +1368,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","fixnum",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_ufixnum: #ifdef SCHEME_BIG_ENDIAN @@ -1346,7 +1383,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((unsigned long*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","ufixnum",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_float: #ifdef SCHEME_BIG_ENDIAN @@ -1361,7 +1398,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((float*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","float",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_double: #ifdef SCHEME_BIG_ENDIAN @@ -1376,7 +1413,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","double",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_doubleS: #ifdef SCHEME_BIG_ENDIAN @@ -1391,7 +1428,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((double*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","double*",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_bool: #ifdef SCHEME_BIG_ENDIAN @@ -1406,7 +1443,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (((int*)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { scheme_wrong_type("Scheme->C","bool",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_string_ucs_4: #ifdef SCHEME_BIG_ENDIAN @@ -1427,7 +1464,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } } else { scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_string_utf_16: #ifdef SCHEME_BIG_ENDIAN @@ -1448,7 +1485,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } } else { scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_bytes: #ifdef SCHEME_BIG_ENDIAN @@ -1469,7 +1506,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } } else { scheme_wrong_type("Scheme->C","bytes",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_path: #ifdef SCHEME_BIG_ENDIAN @@ -1490,7 +1527,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } } else { scheme_wrong_type("Scheme->C","path",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_symbol: #ifdef SCHEME_BIG_ENDIAN @@ -1511,7 +1548,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } } else { scheme_wrong_type("Scheme->C","symbol",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_pointer: #ifdef SCHEME_BIG_ENDIAN @@ -1534,7 +1571,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } } else { scheme_wrong_type("Scheme->C","pointer",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_scheme: #ifdef SCHEME_BIG_ENDIAN @@ -1555,7 +1592,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } } else { scheme_wrong_type("Scheme->C","scheme",0,1,&(val)); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } case FOREIGN_fpointer: scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type)); @@ -1583,7 +1620,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } default: scheme_signal_error("corrupt foreign type: %V", type); } - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } #undef SET_CTYPE @@ -1599,7 +1636,7 @@ static Scheme_Object *foreign_ctype_sizeof(int argc, Scheme_Object *argv[]) size = ctype_sizeof(argv[0]); if (size >= 0) return scheme_make_integer(size); else scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } /* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */ @@ -1611,7 +1648,7 @@ static Scheme_Object *foreign_ctype_alignof(int argc, Scheme_Object *argv[]) type = get_ctype_base(argv[0]); if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } /* (compiler-sizeof symbols) -> int, where symbols name some C type. @@ -1792,7 +1829,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[]) else if (SAME_OBJ(mode, raw_sym)) mf = malloc; else { scheme_signal_error(MYNAME": bad allocation mode: %V", mode); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size); if (((from != NULL) || (foff != 0)) && (res != NULL)) @@ -2224,9 +2261,13 @@ void do_ptr_finalizer(void *p, void *finalizer) /* object, the finalizer will be invoked when the pointer itself is */ /* unreachable, and it will get a new cpointer object that points to it. */ /* (Only needed in cases where pointer aliases might be created.) */ -/* *** Calling Scheme code while the GC is working leads to subtle bugs, so */ -/* *** this is implemented now in Scheme using will executors. */ /* + + *** Calling Scheme code while the GC is working leads to subtle bugs, so + *** this is implemented now in Scheme using will executors. + +(defsymbols pointer) +(cdefine register-finalizer 2 3) { void *ptr, *old = NULL; int ptrsym = (argc == 3 && argv[2] == pointer_sym); @@ -2373,7 +2414,7 @@ void free_fficall_data(void *ignored, void *p) free(p); } -/* (ffi-call ffi-obj in-types out-type) -> (in-types -> out-value) */ +/* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ #undef MYNAME #define MYNAME "ffi-call" @@ -2383,6 +2424,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *obj, *data, *p, *base; + ffi_abi abi; long ooff; GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; @@ -2402,6 +2444,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) if (NULL == (base = get_ctype_base(otype))) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); + abi = GET_ABI(MYNAME,3); atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; i ffi-callback */ +/* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ #undef MYNAME @@ -2498,6 +2541,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *p, *base; + ffi_abi abi; int nargs, i; /* ffi_closure objects are problematic when used with a moving GC. The * problem is that memory that is GC-visible can move at any time. The @@ -2540,6 +2584,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) if (NULL == (base = get_ctype_base(otype))) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); + abi = GET_ABI(MYNAME,3); /* malloc space for everything needed, so a single free gets rid of this */ cl_cif_args = malloc(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */ @@ -2552,7 +2597,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv); atypes[i] = CTYPE_PRIMTYPE(base); } - if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK) + if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); data = (ffi_callback_struct*)scheme_malloc_tagged(sizeof(ffi_callback_struct)); data->so.type = ffi_callback_tag; @@ -2598,6 +2643,12 @@ void scheme_init_foreign(Scheme_Env *env) #endif MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); + MZ_REGISTER_STATIC(default_sym); + default_sym = scheme_intern_symbol("default"); + MZ_REGISTER_STATIC(stdcall_sym); + stdcall_sym = scheme_intern_symbol("stdcall"); + MZ_REGISTER_STATIC(sysv_sym); + sysv_sym = scheme_intern_symbol("sysv"); MZ_REGISTER_STATIC(nonatomic_sym); nonatomic_sym = scheme_intern_symbol("nonatomic"); MZ_REGISTER_STATIC(atomic_sym); @@ -2693,9 +2744,9 @@ void scheme_init_foreign(Scheme_Env *env) scheme_add_global("make-sized-byte-string", scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv); scheme_add_global("ffi-call", - scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 3), menv); + scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv); scheme_add_global("ffi-callback", - scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 3), menv); + scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (NULL); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index d8993ce6be..391387430e 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -810,7 +810,7 @@ static int ctype_sizeof(Scheme_Object *type) {:(cmake-object "type" ctype "argv[0]" "argv[1]" "argv[2]"):} return (Scheme_Object*)type; } - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } /* see below */ @@ -820,7 +820,41 @@ void free_libffi_type(void *ignored, void *p) free(p); } -/* (make-cstruct-type types) -> ctype */ +/*****************************************************************************/ +/* ABI spec */ + +{:(defsymbols default stdcall sysv):} + +ffi_abi sym_to_abi(char *who, Scheme_Object *sym) +{ + if (SCHEME_FALSEP(sym) || SAME_OBJ(sym, default_sym)) + return FFI_DEFAULT_ABI; + else if (SAME_OBJ(sym, sysv_sym)) { +#ifdef FFI_SYSV + return FFI_SYSV; +#else + scheme_signal_error("%s: ABI unimplemented: %V", who, sym); +#endif + } else if (SAME_OBJ(sym, stdcall_sym)) { +#ifdef FFI_STDCALL + return FFI_STDCALL; +#else + scheme_signal_error("%s: ABI unimplemented: %V", who, sym); +#endif + } else { + scheme_signal_error("%s: unknown ABI: %V", who, sym); + } + return 0; /* hush the compiler */ +} + +/* helper macro */ +#define GET_ABI(name,n) \ + ((argc > (n)) ? sym_to_abi((name),argv[n]) : FFI_DEFAULT_ABI) + +/*****************************************************************************/ +/* cstruct types */ + +/* (make-cstruct-type types [abi]) -> ctype */ /* This creates a new primitive type that is a struct. This type can be used * with cpointer objects, except that the contents is used rather than the * pointer value. Marshaling to lists or whatever should be done in Scheme. */ @@ -834,9 +868,10 @@ void free_libffi_type(void *ignored, void *p) ctype_struct *type; ffi_cif cif; int i, nargs; + ffi_abi abi; nargs = scheme_proper_list_length(argv[0]); - if (nargs < 0) - scheme_wrong_type(MYNAME, "proper list", 0, argc, argv); + if (nargs < 0) scheme_wrong_type(MYNAME, "proper list", 0, argc, argv); + abi = GET_ABI(MYNAME,1); /* allocate the type elements */ elements = malloc((nargs+1) * sizeof(ffi_type*)); elements[nargs] = NULL; @@ -855,7 +890,7 @@ void free_libffi_type(void *ignored, void *p) libffi_type->elements = elements; /* use ffi_prep_cif to set the size and alignment information */ dummy = &libffi_type; - if (ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1, &ffi_type_void, dummy) != FFI_OK) + if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); {:(cmake-object "type" ctype "NULL" "(Scheme_Object*)libffi_type" @@ -963,7 +998,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, return scheme_make_foreign_cpointer(W_OFFSET(src, delta)); default: scheme_signal_error("corrupt foreign type: %V", type); } - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } #undef REF_CTYPE @@ -1050,7 +1085,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (~ " "x" = tmp; return NULL;")) (~ " } else {" \\ " "(wrong-type "val" stype) \\ - " return NULL; /* shush the compiler */" \\ + " return NULL; /* hush the compiler */" \\ " }")) (if ptr? (error 'scheme->c "unhandled pointer type: ~s" ctype) @@ -1081,7 +1116,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } default: scheme_signal_error("corrupt foreign type: %V", type); } - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } #undef SET_CTYPE @@ -1095,7 +1130,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, size = ctype_sizeof(argv[0]); if (size >= 0) return scheme_make_integer(size); else scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } /* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */ @@ -1105,7 +1140,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, type = get_ctype_base(argv[0]); if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); else return scheme_make_integer(CTYPE_PRIMTYPE(type)->alignment); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } /* (compiler-sizeof symbols) -> int, where symbols name some C type. @@ -1275,7 +1310,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, else if (SAME_OBJ(mode, raw_sym)) mf = malloc; else { scheme_signal_error(MYNAME": bad allocation mode: %V", mode); - return NULL; /* shush the compiler */ + return NULL; /* hush the compiler */ } if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size); if (((from != NULL) || (foff != 0)) && (res != NULL)) @@ -1670,11 +1705,13 @@ void do_ptr_finalizer(void *p, void *finalizer) /* object, the finalizer will be invoked when the pointer itself is */ /* unreachable, and it will get a new cpointer object that points to it. */ /* (Only needed in cases where pointer aliases might be created.) */ -/* *** Calling Scheme code while the GC is working leads to subtle bugs, so */ -/* *** this is implemented now in Scheme using will executors. */ /* -{:#;(defsymbols pointer):} -{:#;(cdefine register-finalizer 2 3):} + + *** Calling Scheme code while the GC is working leads to subtle bugs, so + *** this is implemented now in Scheme using will executors. + +{:"(defsymbols pointer)":} +{:"(cdefine register-finalizer 2 3)":} { void *ptr, *old = NULL; int ptrsym = (argc == 3 && argv[2] == pointer_sym); @@ -1821,14 +1858,15 @@ void free_fficall_data(void *ignored, void *p) free(p); } -/* (ffi-call ffi-obj in-types out-type) -> (in-types -> out-value) */ +/* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ -{:(cdefine ffi-call 3 3):} +{:(cdefine ffi-call 3 4):} { static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *obj, *data, *p, *base; + ffi_abi abi; long ooff; GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; @@ -1848,6 +1886,7 @@ void free_fficall_data(void *ignored, void *p) if (NULL == (base = get_ctype_base(otype))) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); + abi = GET_ABI(MYNAME,3); atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; i ffi-callback */ +/* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ -{:(cdefine ffi-callback 3 3):} +{:(cdefine ffi-callback 3 4):} { ffi_callback_struct *data; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; Scheme_Object *p, *base; + ffi_abi abi; int nargs, i; /* ffi_closure objects are problematic when used with a moving GC. The * problem is that memory that is GC-visible can move at any time. The @@ -1984,6 +2024,7 @@ void free_cl_cif_args(void *ignored, void *p) if (NULL == (base = get_ctype_base(otype))) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); + abi = GET_ABI(MYNAME,3); /* malloc space for everything needed, so a single free gets rid of this */ cl_cif_args = malloc(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */ @@ -1996,7 +2037,7 @@ void free_cl_cif_args(void *ignored, void *p) scheme_wrong_type(MYNAME, "list-of-non-void-C-types", 1, argc, argv); atypes[i] = CTYPE_PRIMTYPE(base); } - if (ffi_prep_cif(cif, FFI_DEFAULT_ABI, nargs, rtype, atypes) != FFI_OK) + if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); {:(cmake-object "data" ffi-callback "cl_cif_args" "argv[0]" "argv[1]" "argv[2]"):}