Index: Source/Modules/perl5.cxx =================================================================== --- Source/Modules/perl5.cxx (revision 10313) +++ Source/Modules/perl5.cxx (working copy) @@ -98,6 +98,308 @@ static Hash *operators = 0; static int have_operators = 0; +/* ------------------------------------------------------------ + * emit_functionpointer_wrappers() helper functions and data + * ------------------------------------------------------------ */ +static Hash *FPtr_tbl; +static String *FPtr_newCallStub; +static String *FPtr_callStubTgts; +/* ------------------------------------------------------------ + * FPtr_Swig2ffi() - names the ffi symbol representing a given + * SwigType + * ------------------------------------------------------------ */ +static const char *FPtr_Swig2ffi(SwigType *t) { + /* this table is almost certainly inaccurate, + * more testing is needed. + * we must map the SwigType to the amount of stack allocation used by + * the type so that ffi can build a proper call frame. + */ + switch(SwigType_type(t)) { + /* tested: */ + case T_INT: return "ffi_type_sint"; + case T_UINT: return "ffi_type_uint"; + case T_ULONG: return "ffi_type_ulong"; + case T_CHAR: return "ffi_type_schar"; + case T_VOID: return "ffi_type_void"; + case T_STRING: + case T_USER: + case T_POINTER: return "ffi_type_pointer"; + /* gueswork: */ + case T_SCHAR: return "ffi_type_schar"; + case T_UCHAR: return "ffi_type_uchar"; + case T_SHORT: return "ffi_type_sshort"; + case T_USHORT: return "ffi_type_ushort"; + case T_LONG: return "ffi_type_slong"; + case T_FLOAT: return "ffi_type_float"; + case T_DOUBLE: return "ffi_type_double"; + case T_LONGDOUBLE: return "ffi_type_longdouble"; + case T_BOOL: return "ffi_type_sint"; + /* afraid to guess about: */ + case T_REFERENCE: + case T_ARRAY: + case T_FUNCTION: + case T_MPOINTER: + case T_VARARGS: + case T_SYMBOL: + case T_ENUM: + case T_LONGLONG: + case T_ULONGLONG: + case T_FLTCPLX: + case T_DBLCPLX: + case T_NUMERIC: + case T_WCHAR: + case T_ERROR: + default: + Printf(stderr, "unrecognized type %s (%d)\n", t, SwigType_type(t)); + assert(0); + } +} +/* ------------------------------------------------------------ + * FPtr_stubgen() - builds a fragment for newCallStub() and + * the ffi target function for a specific + * callback type. + * ------------------------------------------------------------ */ +static void FPtr_stubgen(Node *func) { + int nargs; + String *name = Getattr(func, "name"); + SwigType *type = Getattr(func, "type"); + ParmList *parms = Getattr(func, "parms"); + { /* build newCallStub fragment */ + Parm *p; + String *args; + + nargs = 0; + args = NewStringf("&%s, ", FPtr_Swig2ffi(type)); + for(p = Getattr(func, "parms"); p; p = nextSibling(p)) { + Printf(args, "&%s, ", FPtr_Swig2ffi(Getattr(p, "type"))); + nargs++; + } + Printf(FPtr_newCallStub, + "if(func == SWIGTYPE%s) {\n" + " static ffi_type *args[] = { %sNULL };\n" + " stub->args = args;\n" + " stub->nargs = %d;\n" + " stub->handler = _swigfp_%s;\n" + " } else ", + name, args, nargs, name); + } + { /* build _swigfp_ function */ + Wrapper *w = NewWrapper(); + Printf(w->def,"static void _swigfp_%s(ffi_cif *cif, void *resp, void **args, void *userdata) {\n", name); + Wrapper_add_local(w, "cif", NULL); + Wrapper_add_local(w, "resp", NULL); + Wrapper_add_local(w, "args", NULL); + Wrapper_add_local(w, "userdata", NULL); + Wrapper_add_local(w, "stub", "SWIG_Perl_CallStub *stub = (SWIG_Perl_CallStub *)userdata"); + Wrapper_add_local(w, "SP", "dSP"); + Wrapper_add_local(w, "count", "int count"); + Wrapper_add_local(w, "argvi", "int argvi = 0"); + Wrapper_add_local(w, "argsv", "SV *argsv"); + Printf(w->code, + " ENTER;\n" + " SAVETMPS;\n" + " PUSHMARK(SP);\n"); + if(parms) { + Parm *p; + String *tm; + for(p = parms; p; p = nextSibling(p)) { + char dest[256]; + { /* seems like we should be able to use SwigType_lcaststr() here, + * but that didn't work out, so this is a (poor) workaround. */ + SwigType *pt; + char *cast; + pt = Getattr(p, "type"); + switch(SwigType_type(pt)) { + /* tested: */ + case T_INT: cast = "int"; break; + case T_STRING: cast = "char *"; break; + case T_POINTER: + case T_USER: cast = "void *"; break; + case T_ULONG: cast = "unsigned long"; break; + case T_CHAR: cast = "char"; break; + case T_UINT: cast = "unsigned int"; break; + /* guesswork: */ + case T_SCHAR: cast = "char"; break; + case T_UCHAR: cast = "unsigned char"; break; + case T_SHORT: cast = "short"; break; + case T_USHORT: cast = "unsigned short"; break; + case T_LONG: cast = "long"; break; + case T_FLOAT: cast = "float"; break; + case T_DOUBLE: cast = "double"; break; + case T_LONGDOUBLE: cast = "long double"; break; + /* afraid to guess about: */ + case T_VOID: + case T_REFERENCE: + case T_ARRAY: + case T_FUNCTION: + case T_MPOINTER: + case T_VARARGS: + case T_SYMBOL: + case T_BOOL: + case T_ENUM: + case T_LONGLONG: + case T_ULONGLONG: + case T_FLTCPLX: + case T_DBLCPLX: + case T_NUMERIC: + case T_WCHAR: + case T_ERROR: + default: + Printf(stderr, "dunno type %s (%d)\n", pt, SwigType_type(pt)); + assert(0); + } + sprintf(dest, "*(%s *)args[argvi]", cast); + } + tm = Swig_typemap_lookup_new("out", p, dest, w); + if(!tm) continue; + Replaceall(tm, "$result", "argsv"); + Replaceall(tm, "$owner", "0"); + Replaceall(tm, "$shadow", "0"); + Printf(w->code, + " %s\n" + " XPUSHs(argsv);\n", tm); + } + } + Printf(w->code, + " PUTBACK;\n" + " count = call_sv(stub->sv, %s);\n", + SwigType_type(type) == T_VOID ? "G_VOID" : "G_SCALAR"); + if(SwigType_type(type) != T_VOID) { + String *tm; + String *dest = NewStringf("*(%s *)resp", SwigType_lstr(type, NULL)); + if ((tm = Swig_typemap_lookup_new("in", func, dest, w))) { + Replaceall(tm, "$input", "ST(0)"); + Replaceall(tm, "$symname", ""); + Replaceall(tm, "$argnum", ""); + Replaceall(tm, "$disown", "0"); + Wrapper_add_local(w, "ax", "I32 ax"); + Printf(w->code, + " SPAGAIN;\n" + " SP -= count;\n" + " ax = (SP - PL_stack_base) + 1;\n" + " %s\n" + "fail:\n" + " PUTBACK;\n", + tm); + } else { + Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number, + "Unable to use return type %s in function %s.\n", + SwigType_str(type, 0), name); + } + Delete(dest); + } + Printf(w->code, + " FREETMPS;\n" + " LEAVE;\n" + "}\n"); + Wrapper_print(w, FPtr_callStubTgts); + DelWrapper(w); + } +} +static void FPtr_check(SwigType *type) { + /* Originally I was using SwigType_typedef_resolve_all() which + * produced dandy call frames, but would often select typemaps that + * were too primitive when processing arguments. The minimally + * resolved type to appear as a function pointer is more correct. */ + if(!type) return; /* no type */ + if(Getattr(FPtr_tbl, type)) return; /* this type has been inspected before */ + Setattr(FPtr_tbl, type, "1"); + if(SwigType_isfunctionpointer(type)) { + /* this is somewhat ugly. + * the goal is to pretend like FPtr_stubgen is part of the API + * similar to Language::functionWrapper(Node *), so we're going + * to mock up a Node carrying something that looks like a + * function declaration and hope things mostly fly + * except where they don't. + */ + Node *fake; + String *name; + SwigType *rval; + SwigType *func; + ParmList *parm; + + name = SwigType_manglestr(type); + rval = Copy(type); + func = SwigType_functionpointer_decompose(rval); + parm = SwigType_function_parms(func); + + fake = NewHash(); + set_nodeType(fake, "cdecl"); + Setattr(fake, "name", name); + Setattr(fake, "decl", func); + Setattr(fake, "type", rval); + Setattr(fake, "parms", parm); + + FPtr_stubgen(fake); + + Delete(fake); + Delete(rval); + } else { /* keep looking */ + SwigType *ch = SwigType_typedef_resolve(type); + FPtr_check(ch); + Delete(ch); + } +} +/* ------------------------------------------------------------ + * FPtr_scan() - recursively searches the parse tree looking + * for function pointers. on discovery of new + * signatures, it prepares a mock Node for + * FPtr_stubgen() + * ------------------------------------------------------------ */ +static void FPtr_scan(Node *n) { + if(!n) return; + FPtr_check(Getattr(n, "type")); + FPtr_scan(Getattr(n, "parms")); + FPtr_scan(firstChild(n)); + FPtr_scan(nextSibling(n)); +} +/* ------------------------------------------------------------ + * emit_functionpointer_wrappers() - writes newCallStub() + * which can present a Perl + * coderef as a C function + * pointer. + * ------------------------------------------------------------ */ +static String *emit_functionpointer_wrappers(Node *top) { + /* GC_malloc() is used here because most APIs are not going to + * expect to need to deallocate function pointer resources, so this + * serves as a safeguard. If they give us deallocation primitives + * we're fine (use GC_free()), but if they don't, we'll live. + * + * a GC_finalization_proc is registered to let go of the sv once the + * wrapper gets torn down. There is a hope that libgc will trigger + * destruction before Perl runs out of room for more SVs, but there is + * no enforement, so this is not perfect. + */ + FPtr_tbl = NewHash(); + FPtr_callStubTgts = NewString(""); + FPtr_newCallStub = NewString( + "static void SWIG_Perl_freeCallStub(void *obj, void *cd) {\n" + " SvREFCNT_dec(((SWIG_Perl_CallStub *)obj)->sv);\n" + "}\n" + "static SWIG_Perl_CallStub *SWIG_Perl_newCallStub(swig_type_info *func, SV *sv) {\n" + " SWIG_Perl_CallStub *stub = GC_malloc(sizeof(struct SWIG_Perl_CallStub));\n" + " " + ); + FPtr_scan(top); + Append(FPtr_newCallStub, + "{\n" + " GC_free(stub);\n" + " return NULL;\n" + " }\n" + " if(ffi_prep_cif(&stub->cif, FFI_DEFAULT_ABI, stub->nargs, stub->args[0], &stub->args[1]) != FFI_OK) assert(0);\n" + " if(ffi_prep_closure(&stub->closure, &stub->cif, stub->handler, stub) != FFI_OK) assert(0);\n" + " SvREFCNT_inc(sv);\n" + " stub->sv = sv;\n" + " GC_register_finalizer(stub, SWIG_Perl_freeCallStub, NULL, NULL, NULL);\n" + " return stub;\n" + "}\n"); + Append(FPtr_callStubTgts, FPtr_newCallStub); + Delete(FPtr_tbl); + Delete(FPtr_newCallStub); + return FPtr_callStubTgts; +} +// END FPtr hacks + class PERL5:public Language { public: @@ -355,6 +657,10 @@ Printf(f_wrappers, "%s", type_table); Delete(type_table); + String *fpwrap = emit_functionpointer_wrappers(n); + Printf(f_wrappers, "%s", fpwrap); + Delete(fpwrap); + Printf(constant_tab, "{0,0,0,0,0,0}\n};\n"); Printv(f_wrappers, constant_tab, NIL); Index: Lib/perl5/perlrun.swg =================================================================== --- Lib/perl5/perlrun.swg (revision 10313) +++ Lib/perl5/perlrun.swg (working copy) @@ -29,8 +29,8 @@ #define SWIG_NewInstanceObj(ptr, type, flags) SWIG_NewPointerObj(ptr, type, flags) /* for C or C++ function pointers */ -#define SWIG_ConvertFunctionPtr(obj, pptr, type) SWIG_ConvertPtr(obj, pptr, type, 0) -#define SWIG_NewFunctionPtrObj(ptr, type) SWIG_NewPointerObj(ptr, type, 0) +#define SWIG_ConvertFunctionPtr(obj, pptr, type) SWIG_Perl_ConvertFunctionPtr(obj, pptr, type) +#define SWIG_NewFunctionPtrObj(ptr, type) SWIG_Perl_NewFunctionPointerObj(ptr, type) /* for C++ member pointers, ie, member methods */ #define SWIG_ConvertMember(obj, ptr, sz, ty) SWIG_ConvertPacked(obj, ptr, sz, ty) @@ -372,6 +372,43 @@ } +/* function pointer hacks */ +#include +#include +typedef struct SWIG_Perl_CallStub { + ffi_closure closure; + ffi_cif cif; + ffi_type **args; + int nargs; + void (*handler)(ffi_cif*,void*,void**,void*); + SV *sv; +} SWIG_Perl_CallStub; + +static SWIG_Perl_CallStub *SWIG_Perl_newCallStub(swig_type_info *, SV *); + +SWIGRUNTIME int +SWIG_Perl_ConvertFunctionPtr(SWIG_MAYBE_PERL_OBJECT SV *obj, void *pptr, swig_type_info *type) { + if(!SvOK(obj)) { + *(void **)pptr = NULL; + return SWIG_OK; + } + if(!SvROK(obj) || SvTYPE(SvRV(obj)) != SVt_PVCV) { + warn("coderef required"); + return SWIG_ERROR; + } + SWIG_Perl_CallStub *stub = SWIG_Perl_newCallStub(type, obj); + if(!stub) { + warn("newCallStub failure"); + return SWIG_ERROR; + } + *(ffi_closure **)pptr = &stub->closure; + return SWIG_OK; +} +SWIGRUNTIME SV * +SWIG_Perl_NewFunctionPointerObj(SWIG_MAYBE_PERL_OBJECT void *ptr, swig_type_info *t) { + croak("SWIG_Perl_NewFunctionPointerObj(%p, %p)", ptr, t); +} + /* Macros for low-level exception handling */ #define SWIG_croak(x) { SWIG_Error(SWIG_RuntimeError, x); SWIG_fail; }