/* 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; }