/*
* (call <tag_ffi_cif>
* <closure w/C function pointer>
* <rvalue size in bytes>
* )
*/
cons_t* proc_ffi_call(cons_t* p, environment_t*)
{
assert_length(p, 2, 4);
assert_pointer(tag_ffi_cif, car(p));
assert_type(CLOSURE, cadr(p));
assert_type(INTEGER, caddr(p));
/*
* libffi description of function.
*/
ffi_cif *cif = static_cast<ffi_cif*>(car(p)->pointer->value);
/*
* Pointer to function to call.
*/
if ( cadr(p)->closure->function == NULL )
raise(runtime_exception(
"Can only call foreign C functions; not Scheme procedures"));
void (*funptr)() =
reinterpret_cast<void(*)()>(cadr(p)->closure->function);
/*
* Size of return value.
*/
integer_t size = 0;
if ( length(p)>2 )
size = caddr(p)->number.integer;
if ( size < 0 )
raise(runtime_exception(format(
"Cannot allocate a negative number of bytes: %d", size)));
/*
* Allocate enough memory necessary to hold return data.
*/
value_t *retval = new value_t(size);
/*
* Function arguments (currently unsupported).
*/
void **funargs = NULL;
if ( !nullp(cadddr(p)) ) {
cons_t *args = cadddr(p);
if ( length(args) != cif->nargs )
raise(runtime_exception(format(
"Foreign function expects %d arguments",
cif->nargs)));
funargs = static_cast<void**>(malloc(sizeof(void*)*(cif->nargs+1)));
size_t n=0;
for ( cons_t *a = args; !nullp(a); a = cdr(a), ++n ) {
funargs[n] = make_arg(cif->arg_types[n], car(a));
}
funargs[cif->nargs] = NULL; // TODO: is this necessary?
}
/*
* TODO: Destroy allocated funargs data after ffi_call, unless those are
* pointer values used to store returned data.
*/
ffi_call(cif, funptr, &retval->data, funargs);
return pointer(tag_ffi_retval, retval);
}
SCAN_Name::SCAN_Name(std::string algo_spec)
{
orig_algo_spec = algo_spec;
std::vector<std::pair<size_t, std::string> > name;
size_t level = 0;
std::pair<size_t, std::string> accum = std::make_pair(level, "");
std::string decoding_error = "Bad SCAN name '" + algo_spec + "': ";
algo_spec = global_state().deref_alias(algo_spec);
for(size_t i = 0; i != algo_spec.size(); ++i)
{
char c = algo_spec[i];
if(c == '/' || c == ',' || c == '(' || c == ')')
{
if(c == '(')
++level;
else if(c == ')')
{
if(level == 0)
throw Decoding_Error(decoding_error + "Mismatched parens");
--level;
}
if(c == '/' && level > 0)
accum.second.push_back(c);
else
{
if(accum.second != "")
name.push_back(deref_aliases(accum));
accum = std::make_pair(level, "");
}
}
else
accum.second.push_back(c);
}
if(accum.second != "")
name.push_back(deref_aliases(accum));
if(level != 0)
throw Decoding_Error(decoding_error + "Missing close paren");
if(name.size() == 0)
throw Decoding_Error(decoding_error + "Empty name");
alg_name = name[0].second;
bool in_modes = false;
for(size_t i = 1; i != name.size(); ++i)
{
if(name[i].first == 0)
{
mode_info.push_back(make_arg(name, i));
in_modes = true;
}
else if(name[i].first == 1 && !in_modes)
args.push_back(make_arg(name, i));
}
}
LLVMValueRef gen_call(compile_t* c, ast_t* ast)
{
// Special case calls.
LLVMValueRef special;
if(special_case_call(c, ast, &special))
return special;
AST_GET_CHILDREN(ast, positional, named, postfix);
AST_GET_CHILDREN(postfix, receiver, method);
ast_t* typeargs = NULL;
// Dig through function qualification.
switch(ast_id(receiver))
{
case TK_NEWREF:
case TK_NEWBEREF:
case TK_BEREF:
case TK_FUNREF:
typeargs = method;
AST_GET_CHILDREN_NO_DECL(receiver, receiver, method);
break;
default: {}
}
// Generate the receiver type.
const char* method_name = ast_name(method);
ast_t* type = ast_type(receiver);
gentype_t g;
if(!gentype(c, type, &g))
return NULL;
// Generate the arguments.
LLVMTypeRef f_type = genfun_sig(c, &g, method_name, typeargs);
if(f_type == NULL)
{
ast_error(ast, "couldn't create a signature for '%s'", method_name);
return NULL;
}
size_t count = ast_childcount(positional) + 1;
size_t buf_size = count * sizeof(void*);
LLVMValueRef* args = (LLVMValueRef*)ponyint_pool_alloc_size(buf_size);
LLVMTypeRef* params = (LLVMTypeRef*)ponyint_pool_alloc_size(buf_size);
LLVMGetParamTypes(f_type, params);
ast_t* arg = ast_child(positional);
int i = 1;
while(arg != NULL)
{
LLVMValueRef value = make_arg(c, params[i], arg);
if(value == NULL)
{
ponyint_pool_free_size(buf_size, args);
ponyint_pool_free_size(buf_size, params);
return NULL;
}
args[i] = value;
arg = ast_sibling(arg);
i++;
}
// Generate the receiver. Must be done after the arguments because the args
// could change things in the receiver expression that must be accounted for.
if(call_needs_receiver(postfix, &g))
{
switch(ast_id(postfix))
{
case TK_NEWREF:
case TK_NEWBEREF:
{
ast_t* parent = ast_parent(ast);
ast_t* sibling = ast_sibling(ast);
// If we're constructing an embed field, pass a pointer to the field
// as the receiver. Otherwise, allocate an object.
if((ast_id(parent) == TK_ASSIGN) && (ast_id(sibling) == TK_EMBEDREF))
args[0] = gen_fieldptr(c, sibling);
else
args[0] = gencall_alloc(c, &g);
break;
}
case TK_BEREF:
case TK_FUNREF:
args[0] = gen_expr(c, receiver);
break;
default:
assert(0);
return NULL;
}
} else {
// Use a null for the receiver type.
args[0] = LLVMConstNull(g.use_type);
}
// Always emit location info for a call, to prevent inlining errors. This may
// be disabled in dispatch_function, if the target function has no debug
// info set.
ast_setdebug(ast, true);
dwarf_location(&c->dwarf, ast);
// Static or virtual dispatch.
LLVMValueRef func = dispatch_function(c, ast, &g, args[0], method_name,
typeargs);
LLVMValueRef r = NULL;
if(func != NULL)
{
// If we can error out and we have an invoke target, generate an invoke
// instead of a call.
if(ast_canerror(ast) && (c->frame->invoke_target != NULL))
r = invoke_fun(c, func, args, i, "", true);
else
r = codegen_call(c, func, args, i);
}
ponyint_pool_free_size(buf_size, args);
ponyint_pool_free_size(buf_size, params);
return r;
}