void dcVCallF(DCCallVM* vm, DCValue* result, DCpointer funcptr, const DCsigchar* signature, va_list args)
{
const DCsigchar* ptr = signature;
dcArgF_impl(vm, &ptr, args);
switch(*ptr) {
case DC_SIGCHAR_VOID: dcCallVoid (vm,funcptr); break;
case DC_SIGCHAR_BOOL: result->B = dcCallBool (vm,funcptr); break;
case DC_SIGCHAR_CHAR: result->c = dcCallChar (vm,funcptr); break;
case DC_SIGCHAR_UCHAR: result->C = (DCuchar)dcCallChar (vm,funcptr); break;
case DC_SIGCHAR_SHORT: result->s = dcCallShort (vm,funcptr); break;
case DC_SIGCHAR_USHORT: result->S = dcCallShort (vm,funcptr); break;
case DC_SIGCHAR_INT: result->i = dcCallInt (vm,funcptr); break;
case DC_SIGCHAR_UINT: result->I = dcCallInt (vm,funcptr); break;
case DC_SIGCHAR_LONG: result->j = dcCallLong (vm,funcptr); break;
case DC_SIGCHAR_ULONG: result->J = dcCallLong (vm,funcptr); break;
case DC_SIGCHAR_LONGLONG: result->l = dcCallLongLong (vm,funcptr); break;
case DC_SIGCHAR_ULONGLONG: result->L = dcCallLongLong (vm,funcptr); break;
case DC_SIGCHAR_FLOAT: result->f = dcCallFloat (vm,funcptr); break;
case DC_SIGCHAR_DOUBLE: result->d = dcCallDouble (vm,funcptr); break;
case DC_SIGCHAR_POINTER: result->p = dcCallPointer (vm,funcptr); break;
case DC_SIGCHAR_STRING: result->Z = (DCstring)dcCallPointer(vm,funcptr); break;
}
}
jboolean followCall(CallTempStruct* call, ValueType returnType, DCValue* result, void* callback, jboolean bCallingJava, jboolean forceVoidReturn)
{
JNIEnv* env = call->env;
switch (returnType) {
#define CALL_CASE(valueType, capCase, hiCase, uni) \
case valueType: \
result->uni = dcCall ## capCase(call->vm, callback); \
break;
CALL_CASE(eIntValue, Int, INT, i)
CALL_CASE(eLongValue, LongLong, LONGLONG, l)
CALL_CASE(eShortValue, Short, SHORT, s)
CALL_CASE(eFloatValue, Float, FLOAT, f)
CALL_CASE(eDoubleValue, Double, DOUBLE, d)
case eBooleanValue:
CALL_CASE(eByteValue, Char, CHAR, c)
case eCLongValue:
result->L = (jlong)dcCallLong(call->vm, callback);
break;
case eSizeTValue:
result->L = (size_t)dcCallPointer(call->vm, callback);
break;
#define CALL_BOXED_INTEGRAL(type, capitalized) \
if (bCallingJava) { \
time_t tt = Unbox ## capitalized(env, dcCallPointer(call->vm, callback)); \
if (sizeof(type) == 4) \
result->i = (jint)tt; \
else \
result->l = (jlong)tt; \
} else { \
type tt = (sizeof(type) == 4) ? (type)dcCallInt(call->vm, callback) : (type)dcCallLongLong(call->vm, callback); \
result->p = Box ## capitalized(env, tt); \
}
case eCLongObjectValue:
CALL_BOXED_INTEGRAL(long, CLong);
break;
case eSizeTObjectValue:
CALL_BOXED_INTEGRAL(size_t, SizeT);
break;
case eTimeTObjectValue:
CALL_BOXED_INTEGRAL(time_t, TimeT);
break;
case eVoidValue:
dcCallVoid(call->vm, callback);
break;
case eIntFlagSet:
{
int flags = dcCallInt(call->vm, callback);
jobject callIO = call && call->pCallIOs ? *(call->pCallIOs++) : NULL;
jobject obj = createPointerFromIO(env, JLONG_TO_PTR ((jlong)flags), callIO);
result->p = obj;
}
break;
case ePointerValue:
{
void* ptr = dcCallPointer(call->vm, callback);
if (bCallingJava)
result->p = ptr ? getPointerPeer(env, ptr) : NULL;
//result->p = ptr;
else
{
jobject callIO = call && call->pCallIOs ? *(call->pCallIOs++) : NULL;
//printf("RETURNED POINTER = %d\n", ptr);
result->p = createPointerFromIO(env, ptr, callIO);
}
}
break;
case eWCharValue:
switch (sizeof(wchar_t)) {
case 1:
result->c = dcCallChar(call->vm, callback);
break;
case 2:
result->s = dcCallShort(call->vm, callback);
break;
case 4:
result->i = dcCallInt(call->vm, callback);
break;
default:
throwException(env, "Invalid wchar_t size !");
return JNI_FALSE;
}
break;
default:
if (forceVoidReturn)
{
dcCallVoid(call->vm, callback);
break;
}
throwException(env, "Invalid return value type !");
return JNI_FALSE;
}
HACK_REFETCH_ENV();
if (bCallingJava && (*env)->ExceptionCheck(env))
return JNI_FALSE;
return JNI_TRUE;
}
int invoke(char const* signature, void* t)
{
DCCallVM * p = (DCCallVM*) G_callvm;
char const * sig = signature;
char rtype;
char atype;
int pos = 0;
int s = 0;
clear_V();
rtype = *sig++;
dcReset(p);
while ( (atype = *sig++) != '\0') {
pos++;
switch(atype) {
case 'c': dcArgChar (p,K_c[pos]); break;
case 's': dcArgShort (p,K_s[pos]); break;
case 'i': dcArgInt (p,K_i[pos]); break;
case 'j': dcArgLong (p,K_j[pos]); break;
case 'l': dcArgLongLong(p,K_l[pos]); break;
case 'p': dcArgPointer (p,K_p[pos]); break;
case 'f': dcArgFloat (p,K_f[pos]); break;
case 'd': dcArgDouble (p,K_d[pos]); break;
default: printf("unknown atype '%c' (1) ;", atype); return 0;
}
}
switch(rtype)
{
case 'v': dcCallVoid(p,t); s=1; /*TODO:check that no return-arg was touched.*/ break;
case 'c': s = (dcCallChar (p,t) == K_c[pos]) ; break;
case 's': s = (dcCallShort (p,t) == K_s[pos]) ; break;
case 'i': s = (dcCallInt (p,t) == K_i[pos]) ; break;
case 'j': s = (dcCallLong (p,t) == K_j[pos]) ; break;
case 'l': s = (dcCallLongLong(p,t) == K_l[pos]) ; break;
case 'p': s = (dcCallPointer (p,t) == K_p[pos]) ; break;
case 'f': s = (dcCallFloat (p,t) == K_f[pos]) ; break;
case 'd': s = (dcCallDouble (p,t) == K_d[pos]) ; break;
default: printf("unknown rtype '%c'", rtype); return 0;
}
if (!s) { printf("rval wrong;"); return 0; }
/* test: */
sig = signature+1;
pos = 1;
while ( (atype = *sig++) != '\0') {
switch(atype) {
#if 0
#define X(CH,T,QCH) case QCH: s = (V_##CH[pos] == K_##CH[pos]); break;
DEF_TYPES
#undef X
#endif
case 'c': s = ( V_c[pos] == K_c[pos] ); if (!s) printf("'c':%d: %d != %d ; ", pos, V_c[pos], K_c[pos]); break;
case 's': s = ( V_s[pos] == K_s[pos] ); if (!s) printf("'s':%d: %d != %d ; ", pos, V_s[pos], K_s[pos]); break;
case 'i': s = ( V_i[pos] == K_i[pos] ); if (!s) printf("'i':%d: %d != %d ; ", pos, V_i[pos], K_i[pos]); break;
case 'j': s = ( V_j[pos] == K_j[pos] ); if (!s) printf("'j':%d: %ld != %ld ; ", pos, V_j[pos], K_j[pos]); break;
case 'l': s = ( V_l[pos] == K_l[pos] ); if (!s) printf("'l':%d: %lld != %lld ; ", pos, V_l[pos], K_l[pos]); break;
case 'p': s = ( V_p[pos] == K_p[pos] ); if (!s) printf("'p':%d: %lld != %lld ; ", pos, (long long) V_p[pos], (long long) K_p[pos]); break;
case 'f': s = ( V_f[pos] == K_f[pos] ); if (!s) printf("'f':%d: %f != %f ; ", pos, V_f[pos], K_f[pos]); break;
case 'd': s = ( V_d[pos] == K_d[pos] ); if (!s) printf("'d':%d: %f != %f ; ", pos, V_d[pos], K_d[pos]); break;
default: printf("unknown atype '%c' ; ", atype); return 0;
}
if (!s) {
printf("arg mismatch at %d ; ", pos);
return 0;
}
pos++;
}
return 1;
}
MVMObject * MVM_nativecall_invoke(MVMThreadContext *tc, MVMObject *res_type,
MVMObject *site, MVMObject *args) {
MVMObject *result = NULL;
char **free_strs = NULL;
void **free_rws = NULL;
MVMint16 num_strs = 0;
MVMint16 num_rws = 0;
MVMint16 i;
/* Get native call body, so we can locate the call info. Read out all we
* shall need, since later we may allocate a result and and move it. */
MVMNativeCallBody *body = MVM_nativecall_get_nc_body(tc, site);
MVMint16 num_args = body->num_args;
MVMint16 *arg_types = body->arg_types;
MVMint16 ret_type = body->ret_type;
void *entry_point = body->entry_point;
/* Create and set up call VM. */
DCCallVM *vm = dcNewCallVM(8192);
dcMode(vm, body->convention);
/* Process arguments. */
for (i = 0; i < num_args; i++) {
MVMObject *value = MVM_repr_at_pos_o(tc, args, i);
switch (arg_types[i] & MVM_NATIVECALL_ARG_TYPE_MASK) {
case MVM_NATIVECALL_ARG_CHAR:
handle_arg("integer", cont_i, DCchar, i64, dcArgChar, MVM_nativecall_unmarshal_char);
break;
case MVM_NATIVECALL_ARG_SHORT:
handle_arg("integer", cont_i, DCshort, i64, dcArgShort, MVM_nativecall_unmarshal_short);
break;
case MVM_NATIVECALL_ARG_INT:
handle_arg("integer", cont_i, DCint, i64, dcArgInt, MVM_nativecall_unmarshal_int);
break;
case MVM_NATIVECALL_ARG_LONG:
handle_arg("integer", cont_i, DClong, i64, dcArgLong, MVM_nativecall_unmarshal_long);
break;
case MVM_NATIVECALL_ARG_LONGLONG:
handle_arg("integer", cont_i, DClonglong, i64, dcArgLongLong, MVM_nativecall_unmarshal_longlong);
break;
case MVM_NATIVECALL_ARG_FLOAT:
handle_arg("number", cont_n, DCfloat, n64, dcArgFloat, MVM_nativecall_unmarshal_float);
break;
case MVM_NATIVECALL_ARG_DOUBLE:
handle_arg("number", cont_n, DCdouble, n64, dcArgDouble, MVM_nativecall_unmarshal_double);
break;
case MVM_NATIVECALL_ARG_ASCIISTR:
case MVM_NATIVECALL_ARG_UTF8STR:
case MVM_NATIVECALL_ARG_UTF16STR:
{
MVMint16 free = 0;
char *str = MVM_nativecall_unmarshal_string(tc, value, arg_types[i], &free);
if (free) {
if (!free_strs)
free_strs = (char**)MVM_malloc(num_args * sizeof(char *));
free_strs[num_strs] = str;
num_strs++;
}
dcArgPointer(vm, str);
}
break;
case MVM_NATIVECALL_ARG_CSTRUCT:
dcArgPointer(vm, MVM_nativecall_unmarshal_cstruct(tc, value));
break;
case MVM_NATIVECALL_ARG_CPOINTER:
dcArgPointer(vm, MVM_nativecall_unmarshal_cpointer(tc, value));
break;
case MVM_NATIVECALL_ARG_CARRAY:
dcArgPointer(vm, MVM_nativecall_unmarshal_carray(tc, value));
break;
case MVM_NATIVECALL_ARG_CUNION:
dcArgPointer(vm, MVM_nativecall_unmarshal_cunion(tc, value));
break;
case MVM_NATIVECALL_ARG_VMARRAY:
dcArgPointer(vm, MVM_nativecall_unmarshal_vmarray(tc, value));
break;
case MVM_NATIVECALL_ARG_CALLBACK:
dcArgPointer(vm, unmarshal_callback(tc, value, body->arg_info[i]));
break;
case MVM_NATIVECALL_ARG_UCHAR:
handle_arg("integer", cont_i, DCuchar, i64, dcArgChar, MVM_nativecall_unmarshal_uchar);
break;
case MVM_NATIVECALL_ARG_USHORT:
handle_arg("integer", cont_i, DCushort, i64, dcArgShort, MVM_nativecall_unmarshal_ushort);
break;
case MVM_NATIVECALL_ARG_UINT:
handle_arg("integer", cont_i, DCuint, i64, dcArgInt, MVM_nativecall_unmarshal_uint);
break;
case MVM_NATIVECALL_ARG_ULONG:
handle_arg("integer", cont_i, DCulong, i64, dcArgLong, MVM_nativecall_unmarshal_ulong);
break;
case MVM_NATIVECALL_ARG_ULONGLONG:
handle_arg("integer", cont_i, DCulonglong, i64, dcArgLongLong, MVM_nativecall_unmarshal_ulonglong);
break;
default:
MVM_exception_throw_adhoc(tc, "Internal error: unhandled dyncall argument type");
}
}
/* Call and process return values. */
MVMROOT(tc, args, {
MVMROOT(tc, res_type, {
switch (ret_type & MVM_NATIVECALL_ARG_TYPE_MASK) {
case MVM_NATIVECALL_ARG_VOID:
dcCallVoid(vm, entry_point);
result = res_type;
break;
case MVM_NATIVECALL_ARG_CHAR:
result = MVM_nativecall_make_int(tc, res_type, dcCallChar(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_SHORT:
result = MVM_nativecall_make_int(tc, res_type, dcCallShort(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_INT:
result = MVM_nativecall_make_int(tc, res_type, dcCallInt(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_LONG:
result = MVM_nativecall_make_int(tc, res_type, dcCallLong(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_LONGLONG:
result = MVM_nativecall_make_int(tc, res_type, dcCallLongLong(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_FLOAT:
result = MVM_nativecall_make_num(tc, res_type, dcCallFloat(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_DOUBLE:
result = MVM_nativecall_make_num(tc, res_type, dcCallDouble(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_ASCIISTR:
case MVM_NATIVECALL_ARG_UTF8STR:
case MVM_NATIVECALL_ARG_UTF16STR:
result = MVM_nativecall_make_str(tc, res_type, body->ret_type,
(char *)dcCallPointer(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_CSTRUCT:
result = MVM_nativecall_make_cstruct(tc, res_type, dcCallPointer(vm, body->entry_point));
break;
case MVM_NATIVECALL_ARG_CPOINTER:
result = MVM_nativecall_make_cpointer(tc, res_type, dcCallPointer(vm, body->entry_point));
break;
case MVM_NATIVECALL_ARG_CARRAY:
result = MVM_nativecall_make_carray(tc, res_type, dcCallPointer(vm, body->entry_point));
break;
case MVM_NATIVECALL_ARG_CUNION:
result = MVM_nativecall_make_cunion(tc, res_type, dcCallPointer(vm, body->entry_point));
break;
case MVM_NATIVECALL_ARG_CALLBACK:
/* TODO: A callback -return- value means that we have a C method
* that needs to be wrapped similarly to a is native(...) Perl 6
* sub. */
dcCallPointer(vm, body->entry_point);
result = res_type;
break;
case MVM_NATIVECALL_ARG_UCHAR:
result = MVM_nativecall_make_uint(tc, res_type, (DCuchar)dcCallChar(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_USHORT:
result = MVM_nativecall_make_uint(tc, res_type, (DCushort)dcCallShort(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_UINT:
result = MVM_nativecall_make_uint(tc, res_type, (DCuint)dcCallInt(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_ULONG:
result = MVM_nativecall_make_uint(tc, res_type, (DCulong)dcCallLong(vm, entry_point));
break;
case MVM_NATIVECALL_ARG_ULONGLONG:
result = MVM_nativecall_make_uint(tc, res_type, (DCulonglong)dcCallLongLong(vm, entry_point));
break;
default:
MVM_exception_throw_adhoc(tc, "Internal error: unhandled dyncall return type");
}
});
});
SEXP r_dcCall(SEXP sCallVM, SEXP sFuncPtr, SEXP sSignature, SEXP sArgs)
{
DCCallVM* pvm;
void* funcPtr;
const char* signature;
const char* ptr;
int i,l,protect_count;
SEXP r;
pvm = R_ExternalPtrAddr(sCallVM);
if (!pvm) error("callvm is null");
funcPtr = R_ExternalPtrAddr(sFuncPtr);
if (!funcPtr) error("funcptr is null");
signature = CHAR(STRING_ELT(sSignature,0) );
if (!signature) error("signature is null");
dcReset(pvm);
ptr = signature;
l = LENGTH(sArgs);
i = 0;
protect_count = 0;
for(;;) {
char ch = *ptr++;
SEXP arg;
if (ch == '\0') error("invalid signature - no return type specified");
if (ch == ')') break;
if (i >= l) error("not enough arguments for given signature (arg length = %d %d %c)", l,i,ch );
arg = VECTOR_ELT(sArgs,i);
switch(ch) {
case DC_SIGCHAR_BOOL:
{
DCbool value;
if ( isLogical(arg) )
{
value = ( LOGICAL(arg)[0] == 0 ) ? DC_FALSE : DC_TRUE;
}
else
{
value = LOGICAL( coerceVector(arg, LGLSXP) )[0] ? DC_FALSE : DC_TRUE;
}
dcArgBool(pvm, value );
break;
}
case DC_SIGCHAR_INT:
{
int value;
if ( isInteger(arg) )
{
value = INTEGER(arg)[0];
}
else
{
value = INTEGER( coerceVector(arg, INTSXP) )[0];
}
dcArgInt(pvm, value);
break;
}
case DC_SIGCHAR_FLOAT:
{
dcArgFloat( pvm, (float) REAL( coerceVector(arg, REALSXP) )[0] );
break;
}
case DC_SIGCHAR_DOUBLE:
{
double value;
if ( isReal(arg) )
{
value = REAL(arg)[0];
}
else
{
value = REAL( coerceVector(arg,REALSXP) )[0];
}
dcArgDouble( pvm, value );
break;
}
/*
case DC_SIGCHAR_LONG:
{
PROTECT(arg = coerceVector(arg, REALSXP) );
dcArgLong( pvm, (DClong) ( REAL(arg)[0] ) );
UNPROTECT(1);
break;
}
*/
case DC_SIGCHAR_STRING:
{
DCpointer ptr;
if (arg == R_NilValue) ptr = (DCpointer) 0;
else if (isString(arg)) ptr = (DCpointer) CHAR( STRING_ELT(arg,0) );
else {
if (protect_count) UNPROTECT(protect_count);
error("invalid value for C string argument"); break;
}
}
case DC_SIGCHAR_POINTER:
{
DCpointer ptr;
if ( arg == R_NilValue ) ptr = (DCpointer) 0;
else if (isString(arg) ) ptr = (DCpointer) CHAR( STRING_ELT(arg,0) );
else if (isReal(arg) ) ptr = (DCpointer) REAL(arg);
else if (isInteger(arg) ) ptr = (DCpointer) INTEGER(arg);
else if (isLogical(arg) ) ptr = (DCpointer) LOGICAL(arg);
else if (TYPEOF(arg) == EXTPTRSXP) ptr = R_ExternalPtrAddr(arg);
else {
if (protect_count) UNPROTECT(protect_count);
error("invalid signature"); break;
}
dcArgPointer(pvm, ptr);
break;
}
}
++i;
}
if ( i != l )
{
if (protect_count)
UNPROTECT(protect_count);
error ("signature claims to have %d arguments while %d arguments are given", i, l);
}
switch(*ptr) {
case DC_SIGCHAR_BOOL:
PROTECT( r = allocVector(LGLSXP, 1) ); protect_count++;
LOGICAL(r)[0] = ( dcCallBool(pvm, funcPtr) == DC_FALSE ) ? FALSE : TRUE;
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_CHAR:
PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
INTEGER(r)[0] = dcCallChar(pvm, funcPtr);
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_SHORT:
PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
INTEGER(r)[0] = dcCallShort(pvm, funcPtr);
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_LONG:
PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
INTEGER(r)[0] = dcCallLong(pvm, funcPtr);
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_INT:
PROTECT( r = allocVector(INTSXP, 1) ); protect_count++;
INTEGER(r)[0] = dcCallInt(pvm, funcPtr);
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_LONGLONG:
PROTECT( r = allocVector(REALSXP, 1) ); protect_count++;
REAL(r)[0] = (double) ( dcCallLong(pvm, funcPtr) );
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_FLOAT:
PROTECT( r = allocVector(REALSXP, 1) ); protect_count++;
REAL(r)[0] = (double) ( dcCallFloat(pvm, funcPtr) );
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_DOUBLE:
PROTECT( r = allocVector(REALSXP, 1) );
protect_count++;
REAL(r)[0] = dcCallDouble(pvm, funcPtr);
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_POINTER:
PROTECT( r = R_MakeExternalPtr( dcCallPointer(pvm,funcPtr), R_NilValue, R_NilValue ) );
protect_count++;
UNPROTECT(protect_count);
return r;
case DC_SIGCHAR_VOID:
dcCallVoid(pvm,funcPtr);
if (protect_count) UNPROTECT(protect_count);
break;
default:
{
if (protect_count)
UNPROTECT(protect_count);
error("invalid return type signature");
}
break;
}
return R_NilValue;
}
template<> long _call_fn_internal<long>(void* fn_ptr) { return dcCallLong(vm, fn_ptr); }
