/* Helper to make an introspection call, possibly with :local. */
static PMC * introspection_call(PARROT_INTERP, PMC *WHAT, PMC *HOW, STRING *name, INTVAL local) {
PMC *old_ctx, *cappy;
/* Look up method; if there is none hand back a null. */
PMC *meth = VTABLE_find_method(interp, HOW, name);
if (PMC_IS_NULL(meth))
return meth;
/* Set up call capture. */
old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
cappy = Parrot_pmc_new(interp, enum_class_CallContext);
VTABLE_push_pmc(interp, cappy, HOW);
VTABLE_push_pmc(interp, cappy, WHAT);
if (local)
VTABLE_set_integer_keyed_str(interp, cappy, Parrot_str_new_constant(interp, "local"), 1);
/* Call. */
Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
/* Grab result. */
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
return VTABLE_get_pmc_keyed_int(interp, cappy, 0);
}
static void
pcf_void_PMC(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef void(* func_t)(PMC *);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
PMC * t_1; PMC * v_1;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1);
v_1 = t_1;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
(*fn_pointer)(v_1);
Parrot_pcc_set_call_from_c_args(interp, call_object, "");
}
static void
pcf_cstr(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef char *(* func_t)(void);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
STRING * t_0; char * v_0;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "");
;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
v_0 = (*fn_pointer)();
t_0 = Parrot_str_new(interp, v_0, 0);
Parrot_pcc_set_call_from_c_args(interp, call_object, "S", t_0);
}
/* Adds a method. */
static void add_method(PARROT_INTERP, PMC *nci) {
PMC * unused;
/* Get methods table out of meta-object. */
PMC *capture = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *self = VTABLE_get_pmc_keyed_int(interp, capture, 0);
PMC *methods = ((KnowHOWREPRInstance *)PMC_data(self))->body.methods;
/* Get name and method to add. */
STRING *name = VTABLE_get_string_keyed_int(interp, capture, 2);
PMC *method = VTABLE_get_pmc_keyed_int(interp, capture, 3);
UNUSED(nci);
/* Add it, and return added method as result. */
VTABLE_set_pmc_keyed_str(interp, methods, name, method);
unused = Parrot_pcc_build_call_from_c_args(interp, capture, "P", method);
}
static void
pcf_double(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef double(* func_t)(void);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
FLOATVAL t_0; double v_0;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "");
;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
v_0 = (*fn_pointer)();
t_0 = (FLOATVAL)v_0;
Parrot_pcc_set_call_from_c_args(interp, call_object, "N", t_0);
}
static void
pcf_int_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef int(* func_t)(void *);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
INTVAL t_0; int v_0;
PMC * t_1; void * v_1;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "P", &t_1);
v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
v_0 = (*fn_pointer)(v_1);
t_0 = (INTVAL)v_0;
Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0);
}
/* This takes a signature element and either runs the closure to get a default
* value if there is one, or creates an appropriate undefined-ish thingy. */
static PMC *
Rakudo_binding_handle_optional(PARROT_INTERP, llsig_element *sig_info, PMC *lexpad) {
PMC *cur_lex;
/* Is the "get default from outer" flag set? */
if (sig_info->flags & SIG_ELEM_DEFAULT_FROM_OUTER) {
PMC *outer_ctx = Parrot_pcc_get_outer_ctx(interp, CURRENT_CONTEXT(interp));
PMC *outer_lexpad = Parrot_pcc_get_lex_pad(interp, outer_ctx);
return VTABLE_get_pmc_keyed_str(interp, outer_lexpad, sig_info->variable_name);
}
/* Do we have a default value closure? */
else if (!PMC_IS_NULL(sig_info->default_closure)) {
/* Run it to get a value. */
PMC *result = PMCNULL;
Parrot_sub_capture_lex(interp, sig_info->default_closure);
Parrot_ext_call(interp, sig_info->default_closure, "->P", &result);
return result;
}
/* Did the value already get initialized to something? (We can avoid re-creating a
* PMC if so.) */
else if (!PMC_IS_NULL(cur_lex = VTABLE_get_pmc_keyed_str(interp, lexpad, sig_info->variable_name))) {
/* Yes; if $ sigil then we want to bind set value in it to be the
* type object of the default type. */
if (!(sig_info->flags & (SIG_ELEM_ARRAY_SIGIL | SIG_ELEM_HASH_SIGIL)))
VTABLE_set_pmc(interp, cur_lex, sig_info->nominal_type);
return cur_lex;
}
/* Otherwise, go by sigil to pick the correct default type of value. */
else {
if (sig_info->flags & SIG_ELEM_ARRAY_SIGIL) {
return Rakudo_binding_create_positional(interp, PMCNULL, ARRAY_str);
}
else if (sig_info->flags & SIG_ELEM_HASH_SIGIL) {
return Rakudo_binding_create_hash(interp, pmc_new(interp, enum_class_Hash));
}
else {
return pmc_new_init(interp, pmc_type(interp, P6_SCALAR_str),
sig_info->nominal_type);
}
}
}
static void
pcf_int_cstr(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef int(* func_t)(char *);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
INTVAL t_0; int v_0;
STRING * t_1; char * v_1;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "S", &t_1);
v_1 = STRING_IS_NULL(t_1) ? NULL : Parrot_str_to_cstring(interp, t_1);
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
v_0 = (*fn_pointer)(v_1);
t_0 = (INTVAL)v_0;
t_1 = Parrot_str_new(interp, v_1, 0);
Parrot_pcc_set_call_from_c_args(interp, call_object, "IS", t_0, t_1);
}
PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
static opcode_t *
runops_cgoto_core(PARROT_INTERP, ARGIN(Parrot_runcore_t *runcore), ARGIN(opcode_t *pc))
{
ASSERT_ARGS(runops_cgoto_core)
/* disable pc */
Parrot_pcc_set_pc(interp, CURRENT_CONTEXT(interp), NULL);
#ifdef HAVE_COMPUTED_GOTO
pc = cg_core(pc, interp);
return pc;
#else
UNUSED(pc);
Parrot_io_eprintf(interp,
"Computed goto unavailable in this configuration.\n");
Parrot_exit(interp, 1);
#endif
}
static void
pcf_char_short_char(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef char(* func_t)(short, char);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
INTVAL t_0; char v_0;
INTVAL t_1; short v_1;
INTVAL t_2; char v_2;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "II", &t_1, &t_2);
v_1 = (short)t_1;
v_2 = (char)t_2;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
v_0 = (*fn_pointer)(v_1, v_2);
t_0 = (INTVAL)v_0;
Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0);
}
static void
pcf_void_ptr_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef void(* func_t)(void *, int, int);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
PMC * t_1; void * v_1;
INTVAL t_2; int v_2;
INTVAL t_3; int v_3;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "PII", &t_1, &t_2, &t_3);
v_1 = PMC_IS_NULL(t_1) ? NULL : VTABLE_get_pointer(interp, t_1);;
v_2 = (int)t_2;
v_3 = (int)t_3;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
(*fn_pointer)(v_1, v_2, v_3);
Parrot_pcc_set_call_from_c_args(interp, call_object, "");
}
static void
pcf_void_float_float_float(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef void(* func_t)(float, float, float);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
FLOATVAL t_1; float v_1;
FLOATVAL t_2; float v_2;
FLOATVAL t_3; float v_3;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "NNN", &t_1, &t_2, &t_3);
v_1 = (float)t_1;
v_2 = (float)t_2;
v_3 = (float)t_3;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
(*fn_pointer)(v_1, v_2, v_3);
Parrot_pcc_set_call_from_c_args(interp, call_object, "");
}
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
opcode_t *
blizkost_return_from_invoke(PARROT_INTERP, void *next) {
/* The following code is cargo culted from nci.pmc */
PMC *cont = interp->current_cont;
/*
* If the NCI function was tailcalled, the return result
* is already passed back to the caller of this frame
* - see Parrot_init_ret_nci(). We therefore invoke the
* return continuation here, which gets rid of this frame
* and returns the real return address
*/
if (cont && cont != NEED_CONTINUATION
&& (PObj_get_FLAGS(cont) & SUB_FLAG_TAILCALL)) {
cont = Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp));
next = VTABLE_invoke(interp, cont, next);
}
return (opcode_t *)next;
}
static void
pcf_int_int_int_int(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef int(* func_t)(int, int, int);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
INTVAL t_0; int v_0;
INTVAL t_1; int v_1;
INTVAL t_2; int v_2;
INTVAL t_3; int v_3;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "III", &t_1, &t_2, &t_3);
v_1 = (int)t_1;
v_2 = (int)t_2;
v_3 = (int)t_3;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
v_0 = (*fn_pointer)(v_1, v_2, v_3);
t_0 = (INTVAL)v_0;
Parrot_pcc_set_call_from_c_args(interp, call_object, "I", t_0);
}
PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
static opcode_t *
runops_fast_core(PARROT_INTERP, ARGIN(Parrot_runcore_t *runcore), ARGIN(opcode_t *pc))
{
ASSERT_ARGS(runops_fast_core)
/* disable pc */
Parrot_pcc_set_pc(interp, CURRENT_CONTEXT(interp), NULL);
while (pc) {
/* TODO
* Decide do we need check here.
* Fast-core cause segfaults even on test suite
if (pc < code_start || pc >= code_end)
Parrot_ex_throw_from_c_args(interp, NULL, 1,
"attempt to access code outside of current code segment");
*/
DO_OP(pc, interp);
}
return pc;
}
static void
pcf_ptr(PARROT_INTERP, PMC *nci, SHIM(PMC *self))
{
typedef void *(* func_t)(void);
func_t fn_pointer;
void *orig_func;
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const call_object = Parrot_pcc_get_signature(interp, ctx);
PMC * t_0; void * v_0;
Parrot_pcc_fill_params_from_c_args(interp, call_object, "");
;
GETATTR_NCI_orig_func(interp, nci, orig_func);
fn_pointer = (func_t)D2FPTR(orig_func);
v_0 = (*fn_pointer)();
if (v_0 != NULL) {
t_0 = Parrot_pmc_new(interp, enum_class_UnManagedStruct);
VTABLE_set_pointer(interp, t_0, v_0);
}
else {
t_0 = PMCNULL;
};
Parrot_pcc_set_call_from_c_args(interp, call_object, "P", t_0);
}
/* Composes the meta-object. */
static void compose(PARROT_INTERP, PMC *nci) {
PMC *repr_info_hash, *repr_info, *type_info, *attr_list, *attr_iter, *unused;
PMC *capture = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *self = VTABLE_get_pmc_keyed_int(interp, capture, 0);
PMC *obj = VTABLE_get_pmc_keyed_int(interp, capture, 1);
UNUSED(nci);
/* Do REPR composition. */
repr_info = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
type_info = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
VTABLE_push_pmc(interp, repr_info, type_info);
VTABLE_push_pmc(interp, type_info, obj);
attr_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
attr_iter = VTABLE_get_iter(interp, ((KnowHOWREPRInstance *)PMC_data(self))->body.attributes);
while (VTABLE_get_bool(interp, attr_iter)) {
PMC *attr = VTABLE_shift_pmc(interp, attr_iter);
PMC *attr_hash = Parrot_pmc_new(interp, enum_class_Hash);;
VTABLE_set_string_keyed_str(interp, attr_hash, name_str,
REPR(attr)->box_funcs->get_str(interp, STABLE(attr), OBJECT_BODY(attr)));
VTABLE_push_pmc(interp, attr_list, attr_hash);
}
VTABLE_push_pmc(interp, type_info, attr_list);
VTABLE_push_pmc(interp, type_info, Parrot_pmc_new(interp, enum_class_ResizablePMCArray));
repr_info_hash = Parrot_pmc_new(interp, enum_class_Hash);
VTABLE_set_pmc_keyed_str(interp, repr_info_hash, attribute_str, repr_info);
REPR(obj)->compose(interp, STABLE(obj), repr_info_hash);
/* Set up method and type caches. */
STABLE(obj)->method_cache = ((KnowHOWREPRInstance *)PMC_data(self))->body.methods;
STABLE(obj)->mode_flags = METHOD_CACHE_AUTHORITATIVE;
STABLE(obj)->type_check_cache_length = 1;
STABLE(obj)->type_check_cache = (PMC **)mem_sys_allocate(sizeof(PMC *));
STABLE(obj)->type_check_cache[0] = obj;
unused = Parrot_pcc_build_call_from_c_args(interp, capture, "P", obj);
}
/* Creates a new type with this HOW as its meta-object. */
static void new_type(PARROT_INTERP, PMC *nci) {
PMC * unused;
/* We first create a new HOW instance. */
PMC *capture = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *self = VTABLE_get_pmc_keyed_int(interp, capture, 0);
PMC *HOW = REPR(self)->allocate(interp, STABLE(self));
/* See if we have a representation name; if not default to P6opaque. */
STRING *repr_name = VTABLE_exists_keyed_str(interp, capture, repr_str) ?
VTABLE_get_string_keyed_str(interp, capture, repr_str) :
p6opaque_str;
/* Create a new type object of the desired REPR. (Note that we can't
* default to KnowHOWREPR here, since it doesn't know how to actually
* store attributes, it's just for bootstrapping knowhow's. */
REPROps *repr_to_use = REPR_get_by_name(interp, repr_name);
PMC *type_object = repr_to_use->type_object_for(interp, HOW);
/* See if we were given a name; put it into the meta-object if so. */
STRING *name = VTABLE_exists_keyed_str(interp, capture, name_str) ?
VTABLE_get_string_keyed_str(interp, capture, name_str) :
empty_str;
UNUSED(nci);
REPR(HOW)->initialize(interp, STABLE(HOW), OBJECT_BODY(HOW));
((KnowHOWREPRInstance *)PMC_data(HOW))->body.name = name;
PARROT_GC_WRITE_BARRIER(interp, HOW);
/* Set .WHO to an empty hash. */
STABLE(type_object)->WHO = Parrot_pmc_new(interp, enum_class_Hash);
PARROT_GC_WRITE_BARRIER(interp, STABLE_PMC(type_object));
/* Put it into capture to act as return value. */
unused = Parrot_pcc_build_call_from_c_args(interp, capture, "P", type_object);
}
static void
Stop(ProfilerObject *pObj, ProfilerContext *self, ProfilerEntry *entry)
{
PY_LONG_LONG tt, it;
tt = pObj->currentTime - self->t0;
tt -= self->paused;
it = tt - self->subt;
if (self->previous) {
self->previous->subt += tt;
self->previous->paused += self->paused;
}
CURRENT_CONTEXT(pObj) = self->previous;
--entry->recursionLevel;
if (!self->is_recursion)
entry->tt += tt;
else
++entry->recursivecallcount;
entry->it += it;
entry->callcount++;
if ((pObj->flags & POF_SUBCALLS) && self->previous) {
/* find or create an entry for me in my caller's entry */
ProfilerEntry *caller = self->previous->ctxEntry;
ProfilerSubEntry *subentry = getSubEntry(pObj, caller, entry);
if (subentry) {
--subentry->recursionLevel;
if (!self->is_subcall_recursion)
subentry->tt += tt;
else
++subentry->recursivecallcount;
subentry->it += it;
++subentry->callcount;
}
}
}
Prints the bytecode location of the warning or error to C<Parrot_io_STDERR>.
=cut
*/
PARROT_EXPORT
void
print_pbc_location(PARROT_INTERP)
{
ASSERT_ARGS(print_pbc_location)
Interp * const tracer = (interp->pdb && interp->pdb->debugger) ?
interp->pdb->debugger :
interp;
Parrot_io_eprintf(tracer, "%Ss\n",
Parrot_sub_Context_infostr(interp, CURRENT_CONTEXT(interp)));
}
/*
=item C<static INTVAL print_warning(PARROT_INTERP, STRING *msg)>
Prints the warning message and the bytecode location.
=cut
*/
static INTVAL
print_warning(PARROT_INTERP, ARGIN_NULLOK(STRING *msg))
{
/* Binds a single argument into the lexpad, after doing any checks that are
* needed. Also handles any type captures. If there is a sub signature, then
* re-enters the binder. Returns one of the BIND_RESULT_* codes. */
static INTVAL
Rakudo_binding_bind_one_param(PARROT_INTERP, PMC *lexpad, Rakudo_Signature *signature, Rakudo_Parameter *param,
Rakudo_BindVal orig_bv, INTVAL no_nom_type_check, STRING **error) {
PMC *decont_value = NULL;
INTVAL desired_native;
Rakudo_BindVal bv;
/* Check if boxed/unboxed expections are met. */
desired_native = param->flags & SIG_ELEM_NATIVE_VALUE;
if (desired_native == 0 && orig_bv.type == BIND_VAL_OBJ ||
desired_native == SIG_ELEM_NATIVE_INT_VALUE && orig_bv.type == BIND_VAL_INT ||
desired_native == SIG_ELEM_NATIVE_NUM_VALUE && orig_bv.type == BIND_VAL_NUM ||
desired_native == SIG_ELEM_NATIVE_STR_VALUE && orig_bv.type == BIND_VAL_STR)
{
/* We have what we want. */
bv = orig_bv;
}
else if (desired_native == 0) {
/* We need to do a boxing operation. */
bv.type = BIND_VAL_OBJ;
bv.val.o = create_box(interp, orig_bv);
}
else {
storage_spec spec;
decont_value = Rakudo_cont_decontainerize(interp, orig_bv.val.o);
spec = REPR(decont_value)->get_storage_spec(interp, STABLE(decont_value));
switch (desired_native) {
case SIG_ELEM_NATIVE_INT_VALUE:
if (spec.can_box & STORAGE_SPEC_CAN_BOX_INT) {
bv.type = BIND_VAL_INT;
bv.val.i = REPR(decont_value)->box_funcs->get_int(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
}
else {
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native int",
param->variable_name);
return BIND_RESULT_FAIL;
}
break;
case SIG_ELEM_NATIVE_NUM_VALUE:
if (spec.can_box & STORAGE_SPEC_CAN_BOX_NUM) {
bv.type = BIND_VAL_NUM;
bv.val.n = REPR(decont_value)->box_funcs->get_num(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
}
else {
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native num",
param->variable_name);
return BIND_RESULT_FAIL;
}
break;
case SIG_ELEM_NATIVE_STR_VALUE:
if (spec.can_box & STORAGE_SPEC_CAN_BOX_STR) {
bv.type = BIND_VAL_STR;
bv.val.s = REPR(decont_value)->box_funcs->get_str(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
}
else {
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native str",
param->variable_name);
return BIND_RESULT_FAIL;
}
break;
default:
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native type",
param->variable_name);
return BIND_RESULT_FAIL;
}
decont_value = NULL;
}
/* By this point, we'll either have an object that we might be able to
* bind if it passes the type check, or a native value that needs no
* further checking. */
if (bv.type == BIND_VAL_OBJ) {
/* Ensure the value is a 6model object; if not, marshall it to one. */
if (bv.val.o->vtable->base_type != smo_id) {
bv.val.o = Rakudo_types_parrot_map(interp, bv.val.o);
if (bv.val.o->vtable->base_type != smo_id) {
*error = Parrot_sprintf_c(interp, "Unmarshallable foreign language value passed for parameter '%S'",
param->variable_name);
return BIND_RESULT_FAIL;
}
}
/* We pretty much always need to de-containerized value, so get it
* right off. */
decont_value = Rakudo_cont_decontainerize(interp, bv.val.o);
/* Skip nominal type check if not needed. */
if (!no_nom_type_check) {
PMC *nom_type;
/* Is the nominal type generic and in need of instantiation? (This
* can happen in (::T, T) where we didn't learn about the type until
* during the signature bind). */
if (param->flags & SIG_ELEM_NOMINAL_GENERIC) {
PMC *HOW = STABLE(param->nominal_type)->HOW;
PMC *ig = VTABLE_find_method(interp, HOW, INSTANTIATE_GENERIC_str);
Parrot_ext_call(interp, ig, "PiPP->P", HOW, param->nominal_type,
lexpad, &nom_type);
}
else {
nom_type = param->nominal_type;
}
/* If not, do the check. If the wanted nominal type is Mu, then
* anything goes. */
if (nom_type != Rakudo_types_mu_get() &&
(decont_value->vtable->base_type != smo_id ||
!STABLE(decont_value)->type_check(interp, decont_value, nom_type))) {
/* Type check failed; produce error if needed. */
if (error) {
PMC * got_how = STABLE(decont_value)->HOW;
PMC * exp_how = STABLE(nom_type)->HOW;
PMC * got_name_meth = VTABLE_find_method(interp, got_how, NAME_str);
PMC * exp_name_meth = VTABLE_find_method(interp, exp_how, NAME_str);
STRING * expected, * got;
Parrot_ext_call(interp, got_name_meth, "PiP->S", got_how, bv.val.o, &got);
Parrot_ext_call(interp, exp_name_meth, "PiP->S", exp_how, nom_type, &expected);
*error = Parrot_sprintf_c(interp, "Nominal type check failed for parameter '%S'; expected %S but got %S instead",
param->variable_name, expected, got);
}
/* Report junction failure mode if it's a junction. */
return junc_or_fail(interp, decont_value);
}
/* Also enforce definedness constraints. */
if (param->flags & SIG_ELEM_DEFINEDNES_CHECK) {
INTVAL defined = IS_CONCRETE(decont_value);
if (defined && param->flags & SIG_ELEM_UNDEFINED_ONLY) {
if (error)
*error = Parrot_sprintf_c(interp,
"Parameter '%S' requires a type object, but an object instance was passed",
param->variable_name);
return junc_or_fail(interp, decont_value);
}
if (!defined && param->flags & SIG_ELEM_DEFINED_ONLY) {
if (error)
*error = Parrot_sprintf_c(interp,
"Parameter '%S' requires an instance, but a type object was passed",
param->variable_name);
return junc_or_fail(interp, decont_value);
}
}
}
}
/* Do we have any type captures to bind? */
if (!PMC_IS_NULL(param->type_captures)) {
Rakudo_binding_bind_type_captures(interp, lexpad, param, bv);
}
/* Do a coercion, if one is needed. */
if (!PMC_IS_NULL(param->coerce_type)) {
/* Coercing natives not possible - nothing to call a method on. */
if (bv.type != BIND_VAL_OBJ) {
*error = Parrot_sprintf_c(interp,
"Unable to coerce natively typed parameter '%S'",
param->variable_name);
return BIND_RESULT_FAIL;
}
/* Only coerce if we don't already have the correct type. */
if (!STABLE(decont_value)->type_check(interp, decont_value, param->coerce_type)) {
PMC *coerce_meth = VTABLE_find_method(interp, decont_value, param->coerce_method);
if (!PMC_IS_NULL(coerce_meth)) {
Parrot_ext_call(interp, coerce_meth, "Pi->P", decont_value, &decont_value);
}
else {
/* No coercion method availale; whine and fail to bind. */
if (error) {
PMC * got_how = STABLE(decont_value)->HOW;
PMC * got_name_meth = VTABLE_find_method(interp, got_how, NAME_str);
STRING * got;
Parrot_ext_call(interp, got_name_meth, "PiP->S", got_how, decont_value, &got);
*error = Parrot_sprintf_c(interp,
"Unable to coerce value for '%S' from %S to %S; no coercion method defined",
param->variable_name, got, param->coerce_method);
}
return BIND_RESULT_FAIL;
}
}
}
/* If it's not got attributive binding, we'll go about binding it into the
* lex pad. */
if (!(param->flags & SIG_ELEM_BIND_ATTRIBUTIVE) && !STRING_IS_NULL(param->variable_name)) {
/* Is it native? If so, just go ahead and bind it. */
if (bv.type != BIND_VAL_OBJ) {
switch (bv.type) {
case BIND_VAL_INT:
VTABLE_set_integer_keyed_str(interp, lexpad, param->variable_name, bv.val.i);
break;
case BIND_VAL_NUM:
VTABLE_set_number_keyed_str(interp, lexpad, param->variable_name, bv.val.n);
break;
case BIND_VAL_STR:
VTABLE_set_string_keyed_str(interp, lexpad, param->variable_name, bv.val.s);
break;
}
}
/* Otherwise it's some objecty case. */
else if (param->flags & SIG_ELEM_IS_RW) {
/* XXX TODO Check if rw flag is set; also need to have a
* wrapper container that carries extra constraints. */
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bv.val.o);
}
else if (param->flags & SIG_ELEM_IS_PARCEL) {
/* Just bind the thing as is into the lexpad. */
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bv.val.o);
}
else {
/* If it's an array, copy means make a new one and store,
* and a normal bind is a straightforward binding plus
* adding a constraint. */
if (param->flags & SIG_ELEM_ARRAY_SIGIL) {
PMC *bindee = decont_value;
if (param->flags & SIG_ELEM_IS_COPY) {
bindee = Rakudo_binding_create_positional(interp,
Parrot_pmc_new(interp, enum_class_ResizablePMCArray));
Rakudo_cont_store(interp, bindee, decont_value, 0, 0);
}
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bindee);
}
/* If it's a hash, similar approach to array. */
else if (param->flags & SIG_ELEM_HASH_SIGIL) {
PMC *bindee = decont_value;
if (param->flags & SIG_ELEM_IS_COPY) {
bindee = Rakudo_binding_create_hash(interp,
Parrot_pmc_new(interp, enum_class_Hash));
Rakudo_cont_store(interp, bindee, decont_value, 0, 0);
}
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bindee);
}
/* If it's a scalar, we always need to wrap it into a new
* container and store it, for copy or ro case (the rw bit
* in the container descriptor takes care of the rest). */
else {
PMC *new_cont = Rakudo_cont_scalar_from_descriptor(interp, param->container_descriptor);
Rakudo_cont_store(interp, new_cont, decont_value, 0, 0);
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, new_cont);
}
}
}
/* Is it the invocant? If so, also have to bind to self lexical. */
if (param->flags & SIG_ELEM_INVOCANT)
VTABLE_set_pmc_keyed_str(interp, lexpad, SELF_str, decont_value);
/* Handle any constraint types (note that they may refer to the parameter by
* name, so we need to have bound it already). */
if (!PMC_IS_NULL(param->post_constraints)) {
PMC * code_type = Rakudo_types_code_get();
PMC * const constraints = param->post_constraints;
INTVAL num_constraints = VTABLE_elements(interp, constraints);
INTVAL i;
for (i = 0; i < num_constraints; i++) {
/* Check we meet the constraint. */
PMC *cons_type = VTABLE_get_pmc_keyed_int(interp, constraints, i);
PMC *accepts_meth = VTABLE_find_method(interp, cons_type, ACCEPTS);
PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *cappy = Parrot_pmc_new(interp, enum_class_CallContext);
if (STABLE(cons_type)->type_check(interp, cons_type, code_type))
Parrot_sub_capture_lex(interp,
VTABLE_get_attr_keyed(interp, cons_type, code_type, DO_str));
VTABLE_push_pmc(interp, cappy, cons_type);
switch (bv.type) {
case BIND_VAL_OBJ:
VTABLE_push_pmc(interp, cappy, bv.val.o);
break;
case BIND_VAL_INT:
VTABLE_push_integer(interp, cappy, bv.val.i);
break;
case BIND_VAL_NUM:
VTABLE_push_float(interp, cappy, bv.val.n);
break;
case BIND_VAL_STR:
VTABLE_push_string(interp, cappy, bv.val.s);
break;
}
Parrot_pcc_invoke_from_sig_object(interp, accepts_meth, cappy);
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
if (!VTABLE_get_bool(interp, VTABLE_get_pmc_keyed_int(interp, cappy, 0))) {
if (error)
*error = Parrot_sprintf_c(interp, "Constraint type check failed for parameter '%S'",
param->variable_name);
return BIND_RESULT_FAIL;
}
}
}
/* If it's attributive, now we assign it. */
if (param->flags & SIG_ELEM_BIND_ATTRIBUTIVE) {
INTVAL result = Rakudo_binding_assign_attributive(interp, lexpad, param, bv, decont_value, error);
if (result != BIND_RESULT_OK)
return result;
}
/* If it has a sub-signature, bind that. */
if (!PMC_IS_NULL(param->sub_llsig) && bv.type == BIND_VAL_OBJ) {
/* Turn value into a capture, unless we already have one. */
PMC *capture = PMCNULL;
INTVAL result;
if (param->flags & SIG_ELEM_IS_CAPTURE) {
capture = decont_value;
}
else {
PMC *meth = VTABLE_find_method(interp, decont_value, Parrot_str_new(interp, "Capture", 0));
if (PMC_IS_NULL(meth)) {
if (error)
*error = Parrot_sprintf_c(interp, "Could not turn argument into capture");
return BIND_RESULT_FAIL;
}
Parrot_ext_call(interp, meth, "Pi->P", decont_value, &capture);
}
/* Recurse into signature binder. */
result = Rakudo_binding_bind(interp, lexpad, param->sub_llsig,
capture, no_nom_type_check, error);
if (result != BIND_RESULT_OK)
{
if (error) {
/* Note in the error message that we're in a sub-signature. */
*error = Parrot_str_concat(interp, *error,
Parrot_str_new(interp, " in sub-signature", 0));
/* Have we a variable name? */
if (!STRING_IS_NULL(param->variable_name)) {
*error = Parrot_str_concat(interp, *error,
Parrot_str_new(interp, " of parameter ", 0));
*error = Parrot_str_concat(interp, *error, param->variable_name);
}
}
return result;
}
}
/* Binding of this parameter was thus successful - we're done. */
return BIND_RESULT_OK;
}
static PMC* find_best_candidate(PARROT_INTERP, Rakudo_md_candidate_info **candidates,
INTVAL num_candidates, PMC *capture, opcode_t *next,
PMC *dispatcher, INTVAL many) {
Rakudo_md_candidate_info **cur_candidate = candidates;
Rakudo_md_candidate_info **possibles = mem_allocate_n_typed(num_candidates + 1, Rakudo_md_candidate_info *);
PMC *junctional_res = PMCNULL;
PMC *many_res = many ? Parrot_pmc_new(interp, enum_class_ResizablePMCArray) : PMCNULL;
const INTVAL num_args = VTABLE_elements(interp, capture);
INTVAL possibles_count = 0;
INTVAL pure_type_result = 1;
INTVAL type_check_count;
INTVAL type_mismatch;
/* We expect a Parrot capture in the multi-dispatcher, always. */
struct Pcc_cell * pc_positionals = NULL;
if (capture->vtable->base_type == enum_class_CallContext) {
GETATTR_CallContext_positionals(interp, capture, pc_positionals);
}
else {
mem_sys_free(possibles);
Parrot_ex_throw_from_c_args(interp, next, 1,
"INTERNAL ERROR: multi-dispatcher must be given a low level capture");
}
/* Iterate over the candidates and collect best ones; terminate
* when we see two nulls (may break out earlier). */
while (1) {
INTVAL i;
if (*cur_candidate == NULL) {
/* We've hit the end of a tied group now. If any of them have a
* bindability check requirement, we'll do any of those now. */
if (possibles_count) {
Rakudo_md_candidate_info **new_possibles = NULL;
INTVAL new_possibles_count = 0;
INTVAL i;
for (i = 0; i < possibles_count; i++) {
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), NULL);
/* First, if there's a required named parameter and it was
* not passed, we can very quickly eliminate this candidate
* without doing a full bindability check. */
if (possibles[i]->req_named) {
if (!VTABLE_exists_keyed_str(interp, capture, possibles[i]->req_named)) {
/* Required named arg not passed, so we eliminate
* it right here. Flag that we've built a list of
* new possibles, and that this was not a pure
* type-based result that we can cache. */
if (!new_possibles)
new_possibles = mem_allocate_n_typed(num_candidates, Rakudo_md_candidate_info *);
pure_type_result = 0;
continue;
}
}
/* Otherwise, may need full bind check. */
if (possibles[i]->bind_check) {
/* We'll invoke the sub (but not re-enter the runloop)
* and then attempt to bind the signature. */
PMC *cthunk, *lexpad, *sig;
opcode_t *where;
INTVAL bind_check_result;
Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data(possibles[i]->sub);
cthunk = Parrot_pmc_getprop(interp, code_obj->_do,
Parrot_str_new(interp, "COMPILER_THUNK", 0));
if (!PMC_IS_NULL(cthunk)) {
/* We need to do the tie-break on something not yet compiled.
* Get it compiled. */
Parrot_ext_call(interp, cthunk, "->");
}
Parrot_pcc_reuse_continuation(interp, CURRENT_CONTEXT(interp), next);
where = VTABLE_invoke(interp, possibles[i]->sub, next);
lexpad = Parrot_pcc_get_lex_pad(interp, CURRENT_CONTEXT(interp));
sig = possibles[i]->signature;
bind_check_result = Rakudo_binding_bind(interp, lexpad,
sig, capture, 0, NULL);
where = VTABLE_invoke(interp, Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp)), where);
/* If we haven't got a possibles storage space, allocate it now. */
if (!new_possibles)
new_possibles = mem_allocate_n_typed(num_candidates, Rakudo_md_candidate_info *);
/* If we don't fail, need to put this one onto the list
* (note that needing a junction dispatch is OK). */
if (bind_check_result != BIND_RESULT_FAIL) {
new_possibles[new_possibles_count] = possibles[i];
new_possibles_count++;
}
/* Since we had to do a bindability check, this is not
* a result we can cache on nominal type. */
pure_type_result = 0;
}
/* Otherwise, it's just nominal; accept it. */
else {
if (!new_possibles)
new_possibles = mem_allocate_n_typed(num_candidates, Rakudo_md_candidate_info *);
new_possibles[new_possibles_count] = possibles[i];
new_possibles_count++;
}
}
/* If we have an updated list of possibles, free old one and use this
* new one from here on in. */
if (new_possibles) {
mem_sys_free(possibles);
possibles = new_possibles;
possibles_count = new_possibles_count;
}
}
/* Now we have eliminated any that fail the bindability check.
* See if we need to push it onto the many list and continue.
* Otherwise, we have the result we were looking for. */
if (many) {
for (i = 0; i < possibles_count; i++)
VTABLE_push_pmc(interp, many_res, possibles[i]->sub);
possibles_count = 0;
}
else if (possibles_count) {
break;
}
/* Keep looping and looking, unless we really hit the end. */
if (cur_candidate[1]) {
cur_candidate++;
continue;
}
else {
break;
}
}
/* Introspects the parents. Since a KnowHOW doesn't support inheritance,
* just hand back an empty list. */
static void parents(PARROT_INTERP, PMC *nci) {
PMC * unused;
PMC *capture = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *empty = Parrot_pmc_new(interp, enum_class_FixedPMCArray);
unused = Parrot_pcc_build_call_from_c_args(interp, capture, "P", empty);
}
int
Parrot_gc_trace_root(PARROT_INTERP,
ARGMOD(Memory_Pools *mem_pools),
Parrot_gc_trace_type trace)
{
ASSERT_ARGS(Parrot_gc_trace_root)
PObj *obj;
/* note: adding locals here did cause increased GC runs */
mark_context_start();
if (trace == GC_TRACE_SYSTEM_ONLY) {
trace_system_areas(interp, mem_pools);
return 0;
}
/* We have to start somewhere; the interpreter globals is a good place */
if (!mem_pools->gc_mark_start) {
mem_pools->gc_mark_start
= mem_pools->gc_mark_ptr
= interp->iglobals;
}
/* mark the list of iglobals */
Parrot_gc_mark_PMC_alive(interp, interp->iglobals);
/* mark the current continuation */
obj = (PObj *)interp->current_cont;
if (obj && obj != (PObj *)NEED_CONTINUATION)
Parrot_gc_mark_PMC_alive(interp, (PMC *)obj);
/* mark the current context. */
Parrot_gc_mark_PMC_alive(interp, CURRENT_CONTEXT(interp));
/* mark the dynamic environment. */
Parrot_gc_mark_PMC_alive(interp, interp->dynamic_env);
/* mark the vtables: the data, Class PMCs, etc. */
mark_vtables(interp);
/* mark the root_namespace */
Parrot_gc_mark_PMC_alive(interp, interp->root_namespace);
/* mark the concurrency scheduler */
Parrot_gc_mark_PMC_alive(interp, interp->scheduler);
/* s. packfile.c */
mark_const_subs(interp);
/* mark caches and freelists */
mark_object_cache(interp);
/* Now mark the class hash */
Parrot_gc_mark_PMC_alive(interp, interp->class_hash);
/* Now mark the HLL stuff */
Parrot_gc_mark_PMC_alive(interp, interp->HLL_info);
Parrot_gc_mark_PMC_alive(interp, interp->HLL_namespace);
/* Mark the registry */
PARROT_ASSERT(interp->gc_registry);
Parrot_gc_mark_PMC_alive(interp, interp->gc_registry);
/* Mark the MMD cache. */
if (interp->op_mmd_cache)
Parrot_mmd_cache_mark(interp, interp->op_mmd_cache);
/* Walk the iodata */
Parrot_IOData_mark(interp, interp->piodata);
if (trace == GC_TRACE_FULL)
trace_system_areas(interp, mem_pools);
/* quick check to see if we have already marked all impatient PMCs. If we
have, return 0 and exit here. This will alert other parts of the GC
that if we are in a lazy run we can just stop it. */
if (mem_pools->lazy_gc
&& mem_pools->num_early_PMCs_seen >= mem_pools->num_early_gc_PMCs)
return 0;
return 1;
}
