Ejemplo n.º 1
0
/*
 * (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);
}
Ejemplo n.º 2
0
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));
      }
   }
Ejemplo n.º 3
0
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;
}