int blizkost_slurpy_to_stack(BLIZKOST_NEXUS, PMC *positional, PMC *named) { int num_pos, i, stkdepth; PMC *iter; dBNPERL; dBNINTERP; dSP; stkdepth = 0; /* Stick on positional arguments. */ num_pos = VTABLE_elements(interp, positional); for (i = 0; i < num_pos; i++) { PMC *pos_arg = VTABLE_get_pmc_keyed_int(interp, positional, i); XPUSHs(blizkost_marshal_arg(nexus, pos_arg)); stkdepth++; } /* Stick on named arguments (we unbundle them to a string * followed by the argument. */ iter = VTABLE_get_iter(interp, named); while (VTABLE_get_bool(interp, iter)) { STRING *arg_name = VTABLE_shift_string(interp, iter); PMC *arg_value = VTABLE_get_pmc_keyed_str(interp, named, arg_name); char *c_arg_name = Parrot_str_to_cstring(interp, arg_name); XPUSHs(sv_2mortal(newSVpv(c_arg_name, strlen(c_arg_name)))); XPUSHs(blizkost_marshal_arg(nexus, arg_value)); stkdepth += 2; } PUTBACK; return stkdepth; }
/* Given an SC and an index, fetch the object stored there. */ PMC * SC_get_object(PARROT_INTERP, PMC *sc, INTVAL idx) { PMC *objects; GETATTR_SerializationContext_root_objects(interp, sc, objects); if (idx >= VTABLE_elements(interp, objects)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "No object at index %d", idx); return VTABLE_get_pmc_keyed_int(interp, objects, idx); }
INTVAL Parrot_Run_OS_Command_Argv(PARROT_INTERP, PMC *cmdargs) { DWORD status = 0; STARTUPINFO si; PROCESS_INFORMATION pi; int pmclen; int cmdlinelen = 1000; int cmdlinepos = 0; char *cmdline = (char *)mem_sys_allocate(cmdlinelen); int i; /* Ensure there's something in the PMC array. */ pmclen = VTABLE_elements(interp, cmdargs); if (pmclen == 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN, "Empty argument array for spawnw"); /* Now build command line. */ for (i = 0; i < pmclen; i++) { STRING * const s = VTABLE_get_string_keyed_int(interp, cmdargs, i); char * const cs = Parrot_str_to_cstring(interp, s); if (cmdlinepos + (int)s->strlen + 3 > cmdlinelen) { cmdlinelen += s->strlen + 4; cmdline = (char *)mem_sys_realloc(cmdline, cmdlinelen); } strcpy(cmdline + cmdlinepos, "\""); strcpy(cmdline + cmdlinepos + 1, cs); strcpy(cmdline + cmdlinepos + 1 + s->strlen, "\" "); cmdlinepos += s->strlen + 3; } /* Start the child process. */ memset(&si, 0, sizeof (si)); si.cb = sizeof (si); memset(&pi, 0, sizeof (pi)); if (!CreateProcess(NULL, cmdline, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN, "Can't spawn child process"); WaitForSingleObject(pi.hProcess, INFINITE); /* Get exit code. */ if (!GetExitCodeProcess(pi.hProcess, &status)) { Parrot_warn(interp, PARROT_WARNINGS_PLATFORM_FLAG, "Process completed: Failed to get exit code."); } /* Clean up. */ CloseHandle(pi.hProcess); CloseHandle(pi.hThread); mem_sys_free(cmdline); /* Return exit code left shifted by 8 for POSIX emulation. */ return status << 8; }
/* Given an SC, looks up the index of an object that is in its root set. */ INTVAL SC_find_object_idx(PARROT_INTERP, PMC *sc, PMC *obj) { PMC *to_search; INTVAL i, count; GETATTR_SerializationContext_root_objects(interp, sc, to_search); count = VTABLE_elements(interp, to_search); for (i = 0; i < count; i++) if (VTABLE_get_pmc_keyed_int(interp, to_search, i) == obj) return i; Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Object does not exist in serialization context"); }
PARROT_CAN_RETURN_NULL static PMC * make_local_copy(PARROT_INTERP, ARGIN(Parrot_Interp from), ARGIN(PMC *arg)) { ASSERT_ARGS(make_local_copy) PMC *ret_val; STRING * const _sub = interp->vtables[enum_class_Sub]->whoami; STRING * const _multi_sub = interp->vtables[enum_class_MultiSub]->whoami; if (PMC_IS_NULL(arg)) { ret_val = PMCNULL; } else if (PObj_is_PMC_shared_TEST(arg)) { ret_val = arg; } else if (VTABLE_isa(from, arg, _multi_sub)) { INTVAL i = 0; const INTVAL n = VTABLE_elements(from, arg); ret_val = Parrot_pmc_new(interp, enum_class_MultiSub); for (i = 0; i < n; ++i) { PMC *const orig = VTABLE_get_pmc_keyed_int(from, arg, i); PMC *const copy = make_local_copy(interp, from, orig); VTABLE_push_pmc(interp, ret_val, copy); } } else if (VTABLE_isa(from, arg, _sub)) { /* this is a workaround for cloning subroutines not actually * working as one might expect mainly because the segment is * not correctly copied */ Parrot_Sub_attributes *ret_val_sub, *arg_sub; ret_val = Parrot_clone(interp, arg); PMC_get_sub(interp, ret_val, ret_val_sub); PMC_get_sub(interp, arg, arg_sub); ret_val_sub->seg = arg_sub->seg; /* Skip vtable overrides and methods. */ if (ret_val_sub->vtable_index == -1 && !(ret_val_sub->comp_flags & SUB_COMP_FLAG_METHOD)) { Parrot_ns_store_sub(interp, ret_val); } } else { ret_val = Parrot_clone(interp, arg); } return ret_val; }
/* Takes an STable and adds it to this SC's root set, and installs a * reposession entry. */ void SC_repossess_stable(PARROT_INTERP, PMC *target_sc, PMC *orig_sc, PMC *st_pmc) { PMC *rep_indexes, *rep_scs; /* Add to root set. */ PMC *stables; INTVAL new_slot; GETATTR_SerializationContext_root_stables(interp, target_sc, stables); new_slot = VTABLE_elements(interp, stables); VTABLE_set_pmc_keyed_int(interp, stables, new_slot, st_pmc); /* Add repossession entry. */ GETATTR_SerializationContext_rep_indexes(interp, target_sc, rep_indexes); GETATTR_SerializationContext_rep_scs(interp, target_sc, rep_scs); VTABLE_push_integer(interp, rep_indexes, (new_slot << 1) | 1); VTABLE_push_pmc(interp, rep_scs, orig_sc); }
INTVAL Parrot_Run_OS_Command_Argv(PARROT_INTERP, PMC *cmdargs) { pid_t child; int len = VTABLE_elements(interp, cmdargs); if (len == 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN, "Empty argument array for execvp"); child = fork(); /* Did we fail? */ if (-1 == child) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN, "Can't spawn child process"); /* Are we the parent or child? */ if (child) { /* parent */ int status; pid_t returnstat = waitpid(child, &status, 0); UNUSED(returnstat); return status; } else { /* child. Be horribly profligate with memory, since we're about to be something else */ int status, i; STRING *s; char *cmd; char **argv = mem_gc_allocate_n_typed(interp, (len+1), char*); for (i = 0; i < len; ++i) { s = VTABLE_get_string_keyed_int(interp, cmdargs, i); argv[i] = Parrot_str_to_cstring(interp, s); } cmd = argv[0]; argv[i] = NULL; status = execvp(cmd, argv); /* if we get here, something's horribly wrong... */ if (status) { exit(status); } } return 1; /* make gcc happy */ }
/* This function gets shared with perl6.ops for the perl6_parcel_from_rpa op. */ PMC * Rakudo_binding_parcel_from_rpa(PARROT_INTERP, PMC *rpa, PMC *fill) { PMC *type = Rakudo_types_parcel_get(); PMC *parcel = REPR(type)->allocate(interp, STABLE(type)); VTABLE_set_attr_keyed(interp, parcel, type, STORAGE_str, rpa); if (!PMC_IS_NULL(fill)) { INTVAL elems = VTABLE_elements(interp, rpa); INTVAL i; for (i = 0; i < elems; i++) { if (PMC_IS_NULL(VTABLE_get_pmc_keyed_int(interp, rpa, i))) VTABLE_set_pmc_keyed_int(interp, rpa, i, fill); } } return parcel; }
void get_complex_value_from_pmc(PARROT_INTERP, PMC * value, FLOATVAL * real, FLOATVAL * imag) { if (PMC_IS_NULL(value)) { *real = 0.0; *imag = 0.0; } else if (VTABLE_does(interp, value, Parrot_str_new(interp, "complex", 7))) { *real = VTABLE_get_number_keyed_int(interp, value, 0); *imag = VTABLE_get_number_keyed_int(interp, value, 1); } else if (VTABLE_does(interp, value, Parrot_str_new(interp, "array", 5))) { const INTVAL size = VTABLE_elements(interp, value); if(size <= 2) { *real = (size == 0) ? 0.0 : VTABLE_get_number_keyed_int(interp, value, 0); *imag = (size < 2) ? 0.0 : VTABLE_get_number_keyed_int(interp, value, 1); } else Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "PLA: array too long to be converted into complex number"); } else if (VTABLE_does(interp, value, Parrot_str_new(interp, "float", 5))) { *real = VTABLE_get_number(interp, value); *imag = 0.0; } else if (VTABLE_does(interp, value, Parrot_str_new(interp, "integer", 7))) { const INTVAL _r = VTABLE_get_integer(interp, value); *real = (FLOATVAL)_r; *imag = 0.0; } else if (VTABLE_does(interp, value, Parrot_str_new(interp, "string", 6))) { PMC * const c = get_external_pmc_init(interp, enum_class_Complex, value); *real = VTABLE_get_number_keyed_int(interp, c, 0); *imag = VTABLE_get_number_keyed_int(interp, c, 1); } else Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS, "PLA: cannot set unknown PMC type"); }
/* Compile time trial binding; tries to determine at compile time whether * certain binds will/won't work. */ INTVAL Rakudo_binding_trial_bind(PARROT_INTERP, PMC *sig_pmc, PMC *capture) { INTVAL i, num_pos_args, got_prim; INTVAL cur_pos_arg = 0; Rakudo_Signature *sig = (Rakudo_Signature *)PMC_data(sig_pmc); PMC *params = sig->params; INTVAL num_params = VTABLE_elements(interp, params); /* Grab arguments. */ struct Pcc_cell * pc_positionals = NULL; if (capture->vtable->base_type == enum_class_CallContext) GETATTR_CallContext_positionals(interp, capture, pc_positionals); else return TRIAL_BIND_NOT_SURE; /* Set up statics. */ if (!smo_id) setup_binder_statics(interp); /* Walk through the signature and consider the parameters. */ num_pos_args = VTABLE_elements(interp, capture); for (i = 0; i < num_params; i++) { Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data( VTABLE_get_pmc_keyed_int(interp, params, i)); /* If the parameter is anything other than a boring old * required positional parameter, we won't analyze it. */ if (param->flags & ~( SIG_ELEM_MULTI_INVOCANT | SIG_ELEM_IS_PARCEL | SIG_ELEM_IS_COPY | SIG_ELEM_ARRAY_SIGIL | SIG_ELEM_HASH_SIGIL | SIG_ELEM_NATIVE_VALUE)) return TRIAL_BIND_NOT_SURE; if (!PMC_IS_NULL(param->named_names)) return TRIAL_BIND_NOT_SURE; if (!PMC_IS_NULL(param->post_constraints)) return TRIAL_BIND_NOT_SURE; if (!PMC_IS_NULL(param->type_captures)) return TRIAL_BIND_NOT_SURE; /* Did we pass too few required arguments? If so, fail. */ if (cur_pos_arg >= num_pos_args) return TRIAL_BIND_NO_WAY; /* Otherwise, need to consider type. */ got_prim = pc_positionals[cur_pos_arg].type; if (param->flags & SIG_ELEM_NATIVE_VALUE) { if (got_prim == BIND_VAL_OBJ) { /* We got an object; if we aren't sure we can unbox, we can't * be sure about the dispatch. */ PMC *arg = pc_positionals[cur_pos_arg].u.p; storage_spec spec = REPR(arg)->get_storage_spec(interp, STABLE(arg)); switch (param->flags & SIG_ELEM_NATIVE_VALUE) { case SIG_ELEM_NATIVE_INT_VALUE: if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_INT)) return TRIAL_BIND_NOT_SURE; break; case SIG_ELEM_NATIVE_NUM_VALUE: if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_NUM)) return TRIAL_BIND_NOT_SURE; break; case SIG_ELEM_NATIVE_STR_VALUE: if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_STR)) return TRIAL_BIND_NOT_SURE; break; default: /* WTF... */ return TRIAL_BIND_NOT_SURE; } } else { /* If it's the wrong type of native, there's no way it * can ever bind. */ if ((param->flags & SIG_ELEM_NATIVE_INT_VALUE) && got_prim != BIND_VAL_INT || (param->flags & SIG_ELEM_NATIVE_NUM_VALUE) && got_prim != BIND_VAL_NUM || (param->flags & SIG_ELEM_NATIVE_STR_VALUE) && got_prim != BIND_VAL_STR) return TRIAL_BIND_NO_WAY; } } else { /* Work out a parameter type to consider, and see if it matches. */ PMC * const arg = got_prim == BIND_VAL_OBJ ? pc_positionals[cur_pos_arg].u.p : got_prim == BIND_VAL_INT ? Rakudo_types_int_get() : got_prim == BIND_VAL_NUM ? Rakudo_types_num_get() : Rakudo_types_str_get(); if (param->nominal_type != Rakudo_types_mu_get() && !STABLE(arg)->type_check(interp, arg, param->nominal_type)) { /* If it failed because we got a junction, may auto-thread; * hand back "not sure" for now. */ if (STABLE(arg)->WHAT == Rakudo_types_junction_get()) return TRIAL_BIND_NOT_SURE; /* It failed to, but that doesn't mean it can't work at runtime; * we perhaps want an Int, and the most we know is we have an Any, * which would include Int. However, the Int ~~ Str case can be * rejected now, as there's no way it'd ever match. Basically, we * just flip the type check around. */ return STABLE(param->nominal_type)->type_check(interp, param->nominal_type, arg) ? TRIAL_BIND_NOT_SURE : TRIAL_BIND_NO_WAY; } } /* Continue to next argument. */ cur_pos_arg++; } /* If we have any left over arguments, it's a binding fail. */ if (cur_pos_arg < num_pos_args) return TRIAL_BIND_NO_WAY; /* Otherwise, if we get there, all is well. */ return TRIAL_BIND_OK; }
PARROT_CANNOT_RETURN_NULL PMC * Parrot_oo_clone_object(PARROT_INTERP, ARGIN(PMC *pmc), ARGMOD_NULLOK(PMC *dest)) { ASSERT_ARGS(Parrot_oo_clone_object) Parrot_Object_attributes *obj = PARROT_OBJECT(pmc); Parrot_Object_attributes *cloned_guts; Parrot_Class_attributes *_class; PMC *cloned; INTVAL num_classes; INTVAL i, num_attrs; if (!PMC_IS_NULL(dest)) { cloned = dest; } else { cloned = Parrot_pmc_new_noinit(interp, enum_class_Object); } _class = PARROT_CLASS(obj->_class); PARROT_ASSERT(_class); num_classes = VTABLE_elements(interp, _class->all_parents); /* Set custom GC mark and destroy on the object. */ PObj_custom_mark_SET(cloned); PObj_custom_destroy_SET(cloned); /* Flag that it is an object */ PObj_is_object_SET(cloned); /* Now clone attributes list.class. */ cloned_guts = (Parrot_Object_attributes *) PMC_data(cloned); cloned_guts->_class = obj->_class; cloned_guts->attrib_store = VTABLE_clone(interp, obj->attrib_store); num_attrs = VTABLE_elements(interp, cloned_guts->attrib_store); for (i = 0; i < num_attrs; ++i) { PMC * const to_clone = VTABLE_get_pmc_keyed_int(interp, cloned_guts->attrib_store, i); if (!PMC_IS_NULL(to_clone)) { VTABLE_set_pmc_keyed_int(interp, cloned_guts->attrib_store, i, VTABLE_clone(interp, to_clone)); } } /* Some of the attributes may have been the PMCs providing storage for any * PMCs we inherited from; also need to clone those. */ if (CLASS_has_alien_parents_TEST(obj->_class)) { int j; /* Locate any PMC parents. */ for (j = 0; j < num_classes; ++j) { PMC * const cur_class = VTABLE_get_pmc_keyed_int(interp, _class->all_parents, j); if (cur_class->vtable->base_type == enum_class_PMCProxy) { /* Clone this PMC too. */ STRING * const proxy = CONST_STRING(interp, "proxy"); VTABLE_set_attr_keyed(interp, cloned, cur_class, proxy, VTABLE_clone(interp, VTABLE_get_attr_keyed(interp, cloned, cur_class, proxy))); } } } /* And we have ourselves a clone. */ return cloned; }
/* Performs a change of type, where possible. */ static void change_type(PARROT_INTERP, PMC *obj, PMC *new_type) { P6opaqueInstance *instance = (P6opaqueInstance *)PMC_data(obj); P6opaqueREPRData *cur_repr_data = (P6opaqueREPRData *)STABLE(obj)->REPR_data; P6opaqueREPRData *new_repr_data = (P6opaqueREPRData *)STABLE(new_type)->REPR_data; STRING *mro_str = Parrot_str_new_constant(interp, "mro"); PMC *cur_mro, *new_mro; INTVAL cur_mro_elems, new_mro_elems, mro_is_suffix; /* Ensure we're not trying to change the type of a type object. */ if (PObj_flag_TEST(private0, obj)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Cannot change the type of a type object"); /* Ensure that the destination type REPR is P6opaque also. */ if (REPR(obj) != REPR(new_type)) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "P6opaque can only change type to another type with P6opaque REPR"); /* Ensure that MRO of new type has current type's MRO as a suffix. */ mro_is_suffix = 1; cur_mro = introspection_call(interp, STABLE(obj)->WHAT, STABLE(obj)->HOW, mro_str, 0); new_mro = introspection_call(interp, STABLE(new_type)->WHAT, STABLE(new_type)->HOW, mro_str, 0); cur_mro_elems = VTABLE_elements(interp, cur_mro); new_mro_elems = VTABLE_elements(interp, new_mro); if (new_mro_elems >= cur_mro_elems) { INTVAL start = new_mro_elems - cur_mro_elems; INTVAL i; for (i = 0; i < cur_mro_elems; i++) { PMC *cur_elem = VTABLE_get_pmc_keyed_int(interp, cur_mro, i); PMC *new_elem = VTABLE_get_pmc_keyed_int(interp, new_mro, i + start); if (decontainerize(interp, cur_elem) != decontainerize(interp, new_elem)) { mro_is_suffix = 0; break; } } } else { mro_is_suffix = 0; } if (!mro_is_suffix) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "P6opaque only supports type changes where the MRO of the original type is a suffix of the MRO of the new type"); /* If the new REPR never calculated it's object layout, do so now. */ if (!new_repr_data->allocation_size) { compute_allocation_strategy(interp, new_type, new_repr_data); PARROT_GC_WRITE_BARRIER(interp, STABLE_PMC(new_type)); } /* Reallocate ourself to the new allocation size, if needed, and * ensure new chunk of the memory is zeroed. Note that we can't * really re-alloc, we need to go deal with the fixed size pool * allocator. */ if (new_repr_data->allocation_size > cur_repr_data->allocation_size) { P6opaqueInstance *new_body = (P6opaqueInstance *) Parrot_gc_allocate_fixed_size_storage(interp, new_repr_data->allocation_size); memset(new_body, 0, new_repr_data->allocation_size); memcpy(new_body, instance, cur_repr_data->allocation_size); PMC_data(obj) = new_body; Parrot_gc_free_fixed_size_storage(interp, cur_repr_data->allocation_size, instance); instance = new_body; } /* Finally, we're ready to switch the S-Table pointer. */ instance->common.stable = STABLE_PMC(new_type); PARROT_GC_WRITE_BARRIER(interp, obj); }
/* Locates all of the attributes. Puts them onto a flattened, ordered * list of attributes (populating the passed flat_list). Also builds * the index mapping for doing named lookups. Note index is not related * to the storage position. */ static PMC * index_mapping_and_flat_list(PARROT_INTERP, PMC *WHAT, P6opaqueREPRData *repr_data) { PMC *flat_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); PMC *class_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); PMC *attr_map_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); STRING *attributes_str = Parrot_str_new_constant(interp, "attributes"); STRING *parents_str = Parrot_str_new_constant(interp, "parents"); STRING *name_str = Parrot_str_new_constant(interp, "name"); STRING *mro_str = Parrot_str_new_constant(interp, "mro"); INTVAL current_slot = 0; INTVAL num_classes, i; P6opaqueNameMap * result = NULL; /* Get the MRO. */ PMC *mro = introspection_call(interp, WHAT, STABLE(WHAT)->HOW, mro_str, 0); INTVAL mro_idx = VTABLE_elements(interp, mro); /* Walk through the parents list. */ while (mro_idx) { /* Get current class in MRO. */ PMC *current_class = decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, mro, --mro_idx)); PMC *HOW = STABLE(current_class)->HOW; /* Get its local parents. */ PMC *parents = introspection_call(interp, current_class, HOW, parents_str, 1); INTVAL num_parents = VTABLE_elements(interp, parents); /* Get attributes and iterate over them. */ PMC *attributes = introspection_call(interp, current_class, HOW, attributes_str, 1); PMC *attr_map = PMCNULL; PMC *attr_iter = VTABLE_get_iter(interp, attributes); while (VTABLE_get_bool(interp, attr_iter)) { /* Get attribute. */ PMC * attr = VTABLE_shift_pmc(interp, attr_iter); /* Get its name. */ PMC *name_pmc = accessor_call(interp, attr, name_str); STRING *name = VTABLE_get_string(interp, name_pmc); /* Allocate a slot. */ if (PMC_IS_NULL(attr_map)) attr_map = Parrot_pmc_new(interp, enum_class_Hash); VTABLE_set_pmc_keyed_str(interp, attr_map, name, Parrot_pmc_new_init_int(interp, enum_class_Integer, current_slot)); current_slot++; /* Push attr onto the flat list. */ VTABLE_push_pmc(interp, flat_list, attr); } /* Add to class list and map list. */ VTABLE_push_pmc(interp, class_list, current_class); VTABLE_push_pmc(interp, attr_map_list, attr_map); /* If there's more than one parent, flag that we in an MI * situation. */ if (num_parents > 1) repr_data->mi = 1; } /* We can now form the name map. */ num_classes = VTABLE_elements(interp, class_list); result = (P6opaqueNameMap *) mem_sys_allocate_zeroed(sizeof(P6opaqueNameMap) * (1 + num_classes)); for (i = 0; i < num_classes; i++) { result[i].class_key = VTABLE_get_pmc_keyed_int(interp, class_list, i); result[i].name_map = VTABLE_get_pmc_keyed_int(interp, attr_map_list, i); } repr_data->name_to_index_mapping = result; return flat_list; }
PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL SV * blizkost_marshal_arg(BLIZKOST_NEXUS, PMC *arg) { struct sv *result = NULL; dBNPERL; dBNINTERP; /* If it's a P5Scalar PMC, then we just fetch the SV from it - trivial * round-tripping. */ if (VTABLE_isa(interp, arg, CONST_STRING(interp, "P5Scalar"))) { GETATTR_P5Scalar_sv(interp, arg, result); } /* XXX At this point, we should probably wrap it up in a tied Perl 5 * scalar so we can round-trip Parrot objects to. However, that's hard, * so for now we cheat on a few special cases and just panic otherwise. */ else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Integer"))) { result = sv_2mortal(newSViv(VTABLE_get_integer(interp, arg))); } else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Float"))) { result = sv_2mortal(newSVnv(VTABLE_get_number(interp, arg))); } else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "P5Namespace"))) { STRING *pkg; char *c_str; GETATTR_P5Namespace_ns_name(interp, arg, pkg); c_str = Parrot_str_to_cstring(interp, pkg); result = sv_2mortal(newSVpv(c_str, strlen(c_str))); } else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "String"))) { char *c_str = Parrot_str_to_cstring(interp, VTABLE_get_string(interp, arg)); result = sv_2mortal(newSVpv(c_str, strlen(c_str))); } else if (VTABLE_does(interp, arg, CONST_STRING(interp, "invokable"))) { CV *wrapper = blizkost_wrap_callable(nexus, arg); result = sv_2mortal(newRV_inc((SV*)wrapper)); } else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "array"))) { PMC *iter; struct av *array = newAV(); iter = VTABLE_get_iter(interp, arg); while (VTABLE_get_bool(interp, iter)) { PMC *item = VTABLE_shift_pmc(interp, iter); struct sv *marshaled = blizkost_marshal_arg(nexus, item); av_push( array, marshaled); } result = newRV_inc((SV*)array); } else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "hash"))) { PMC *iter = VTABLE_get_iter(interp, arg); struct hv *hash = newHV(); INTVAL n = VTABLE_elements(interp, arg); INTVAL i; for(i = 0; i < n; i++) { STRING *s = VTABLE_shift_string(interp, iter); char *c_str = Parrot_str_to_cstring(interp, s); struct sv *val = blizkost_marshal_arg(nexus, VTABLE_get_pmc_keyed_str(interp, arg, s)); hv_store(hash, c_str, strlen(c_str), val, 0); } result = newRV_inc((SV*)hash); } else { Parrot_ex_throw_from_c_args(interp, NULL, 1, "Sorry, we do not support marshaling most things to Perl 5 yet."); } return result; }
/* Takes a signature along with positional and named arguments and binds them * into the provided lexpad (actually, anything that has a Hash interface will * do). Returns BIND_RESULT_OK if binding works out, BIND_RESULT_FAIL if there * is a failure and BIND_RESULT_JUNCTION if the failure was because of a * Junction being passed (meaning we need to auto-thread). */ INTVAL Rakudo_binding_bind_llsig(PARROT_INTERP, PMC *lexpad, PMC *llsig, PMC *capture, INTVAL no_nom_type_check, STRING **error) { INTVAL i; INTVAL bind_fail; INTVAL cur_pos_arg = 0; INTVAL num_pos_args = VTABLE_elements(interp, capture); PMC *named_names = PMCNULL; llsig_element **elements; INTVAL num_elements; PMC *named_to_pos_cache; /* Lazily allocated array of bindings to positionals of nameds. */ PMC **pos_from_named = NULL; /* If we do have some named args, we want to make a clone of the hash * to work on. We'll delete stuff from it as we bind, and what we have * left over can become the slurpy hash or - if we aren't meant to be * taking one - tell us we have a problem. */ PMC *named_args_copy = PMCNULL; /* If we have a |$foo that's followed by slurpies, then we can suppress * any future arity checks. */ INTVAL suppress_arity_fail = 0; /* Check that we have a valid signature and pull the bits out of it. */ if (!lls_id) setup_binder_statics(interp); if (llsig->vtable->base_type != lls_id) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Internal Error: Rakudo_binding_bind_llsig passed invalid signature"); GETATTR_P6LowLevelSig_elements(interp, llsig, elements); GETATTR_P6LowLevelSig_num_elements(interp, llsig, num_elements); GETATTR_P6LowLevelSig_named_to_pos_cache(interp, llsig, named_to_pos_cache); /* Build nameds -> position hash for named positional arguments, * if it was not yet built. */ if (PMC_IS_NULL(named_to_pos_cache)) { named_to_pos_cache = pmc_new(interp, enum_class_Hash); PARROT_GC_WRITE_BARRIER(interp, llsig); SETATTR_P6LowLevelSig_named_to_pos_cache(interp, llsig, named_to_pos_cache); for (i = 0; i < num_elements; i++) { /* If we find a named argument, we're done with the positionals. */ if (!PMC_IS_NULL(elements[i]->named_names)) break; /* Skip slurpies (may be a slurpy block, so can't just break). */ if (elements[i]->flags & SIG_ELEM_SLURPY) continue; /* Provided it has a name... */ if (!STRING_IS_NULL(elements[i]->variable_name)) { /* Strip any sigil, then stick in named to positional array. */ STRING *store = elements[i]->variable_name; STRING *sigil = Parrot_str_substr(interp, store, 0, 1); STRING *twigil = Parrot_str_substr(interp, store, 1, 1); if (Parrot_str_equal(interp, sigil, SCALAR_SIGIL_str) || Parrot_str_equal(interp, sigil, ARRAY_SIGIL_str) || Parrot_str_equal(interp, sigil, HASH_SIGIL_str)) store = Parrot_str_substr(interp, store, 1, Parrot_str_byte_length(interp, store)); if (Parrot_str_equal(interp, twigil, BANG_TWIGIL_str)) store = Parrot_str_substr(interp, store, 1, Parrot_str_byte_length(interp, store)); VTABLE_set_integer_keyed_str(interp, named_to_pos_cache, store, i); } } } /* If we've got a CallContext, just has an attribute with list of named * parameter names. Otherwise, it's a Capture and we need to do .hash and * grab out the keys. */ if (capture->vtable->base_type == enum_class_CallContext || VTABLE_isa(interp, capture, CALLCONTEXT_str)) { named_names = VTABLE_get_attr_str(interp, capture, Parrot_str_new(interp, "named", 0)); } else if (VTABLE_isa(interp, capture, CAPTURE_str)) { PMC *meth = VTABLE_find_method(interp, capture, Parrot_str_new(interp, "!PARROT_NAMEDS", 0)); PMC *hash = PMCNULL; PMC *iter; Parrot_ext_call(interp, meth, "Pi->P", capture, &hash); iter = VTABLE_get_iter(interp, hash); if (VTABLE_get_bool(interp, iter)) { named_names = pmc_new(interp, enum_class_ResizableStringArray); while (VTABLE_get_bool(interp, iter)) VTABLE_push_string(interp, named_names, VTABLE_shift_string(interp, iter)); } } else { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Internal Error: Rakudo_binding_bind_llsig passed invalid Capture"); } /* First, consider named arguments, to see if there are any that we will * be wanting to bind positionally. */ if (!PMC_IS_NULL(named_names)) { PMC *iter = VTABLE_get_iter(interp, named_names); named_args_copy = pmc_new(interp, enum_class_Hash); while (VTABLE_get_bool(interp, iter)) { STRING *name = VTABLE_shift_string(interp, iter); if (VTABLE_exists_keyed_str(interp, named_to_pos_cache, name)) { /* Found one. We'll stash it away for quick access to bind it * later. */ INTVAL pos = VTABLE_get_integer_keyed_str(interp, named_to_pos_cache, name); if (!pos_from_named) pos_from_named = mem_allocate_n_zeroed_typed(num_elements, PMC *); pos_from_named[pos] = VTABLE_get_pmc_keyed_str(interp, capture, name); } else { /* Otherwise, we'll enter it into the hash of things to bind * to nameds. */ VTABLE_set_pmc_keyed_str(interp, named_args_copy, name, VTABLE_get_pmc_keyed_str(interp, capture, name)); } }
/* Takes a signature along with positional and named arguments and binds them * into the provided lexpad (actually, anything that has a Hash interface will * do). Returns BIND_RESULT_OK if binding works out, BIND_RESULT_FAIL if there * is a failure and BIND_RESULT_JUNCTION if the failure was because of a * Junction being passed (meaning we need to auto-thread). */ INTVAL Rakudo_binding_bind(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc, PMC *capture, INTVAL no_nom_type_check, STRING **error) { INTVAL i, num_pos_args; INTVAL bind_fail = 0; INTVAL cur_pos_arg = 0; Rakudo_Signature *sig = (Rakudo_Signature *)PMC_data(sig_pmc); PMC *params = sig->params; INTVAL num_params = VTABLE_elements(interp, params); Rakudo_BindVal cur_bv; /* If we do have some named args, we want to make a clone of the hash * to work on. We'll delete stuff from it as we bind, and what we have * left over can become the slurpy hash or - if we aren't meant to be * taking one - tell us we have a problem. */ PMC *named_args_copy = PMCNULL; /* If we have a |$foo that's followed by slurpies, then we can suppress * any future arity checks. */ INTVAL suppress_arity_fail = 0; /* If it's a Parrot capture, it may contain natively typed arguments. * NOTE: This is a really an encapsulation breakage; if Parrot folks * change stuff and this breaks, it's not Parrot's fault. */ struct Pcc_cell * pc_positionals = NULL; /* Set up statics. */ if (!smo_id) setup_binder_statics(interp); /* If we've got a CallContext, just has an attribute with list of named * parameter names. Otherwise, it's probably a Perl 6 Capture and we need * to extract its parts. */ if (capture->vtable->base_type == enum_class_CallContext) { PMC *named_names = VTABLE_get_attr_str(interp, capture, NAMED_str); if (!PMC_IS_NULL(named_names)) { PMC *iter = VTABLE_get_iter(interp, named_names); named_args_copy = Parrot_pmc_new(interp, enum_class_Hash); while (VTABLE_get_bool(interp, iter)) { STRING *name = VTABLE_shift_string(interp, iter); VTABLE_set_pmc_keyed_str(interp, named_args_copy, name, VTABLE_get_pmc_keyed_str(interp, capture, name)); } } GETATTR_CallContext_positionals(interp, capture, pc_positionals); } else if (capture->vtable->base_type == smo_id && STABLE(capture)->type_check(interp, capture, Rakudo_types_capture_get())) { PMC *captype = Rakudo_types_capture_get(); PMC *list_part = VTABLE_get_attr_keyed(interp, capture, captype, LIST_str); PMC *hash_part = VTABLE_get_attr_keyed(interp, capture, captype, HASH_str); capture = Rakudo_isnqplist(list_part) ? list_part : Parrot_pmc_new(interp, enum_class_ResizablePMCArray); if (hash_part->vtable->base_type == enum_class_Hash) { PMC *iter = VTABLE_get_iter(interp, hash_part); named_args_copy = Parrot_pmc_new(interp, enum_class_Hash); while (VTABLE_get_bool(interp, iter)) { STRING *arg_copy_name = VTABLE_shift_string(interp, iter); VTABLE_set_pmc_keyed_str(interp, named_args_copy, arg_copy_name, VTABLE_get_pmc_keyed_str(interp, hash_part, arg_copy_name)); } } } else { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Internal Error: Rakudo_binding_bind passed invalid Capture"); } /* Now we'll walk through the signature and go about binding things. */ num_pos_args = VTABLE_elements(interp, capture); for (i = 0; i < num_params; i++) { Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data( VTABLE_get_pmc_keyed_int(interp, params, i)); /* Is it looking for us to bind a capture here? */ if (param->flags & SIG_ELEM_IS_CAPTURE) { /* Capture the arguments from this point forwards into a Capture. * Of course, if there's no variable name we can (cheaply) do pretty * much nothing. */ if (STRING_IS_NULL(param->variable_name)) { bind_fail = BIND_RESULT_OK; } else { PMC *captype = Rakudo_types_capture_get(); PMC *capsnap = REPR(captype)->allocate(interp, STABLE(captype)); PMC *pos_args = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); PMC *named_args = Parrot_pmc_new(interp, enum_class_Hash); INTVAL k; VTABLE_set_attr_keyed(interp, capsnap, captype, LIST_str, pos_args); VTABLE_set_attr_keyed(interp, capsnap, captype, HASH_str, named_args); for (k = cur_pos_arg; k < num_pos_args; k++) { cur_bv = get_positional_bind_val(interp, pc_positionals, capture, k); VTABLE_push_pmc(interp, pos_args, cur_bv.type == BIND_VAL_OBJ ? cur_bv.val.o : create_box(interp, cur_bv)); } if (!PMC_IS_NULL(named_args_copy)) { PMC *iter = VTABLE_get_iter(interp, named_args_copy); while (VTABLE_get_bool(interp, iter)) { STRING *name = VTABLE_shift_string(interp, iter); VTABLE_set_pmc_keyed_str(interp, named_args, name, VTABLE_get_pmc_keyed_str(interp, named_args_copy, name)); } } cur_bv.type = BIND_VAL_OBJ; cur_bv.val.o = capsnap; bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv, no_nom_type_check, error); } if (bind_fail) { return bind_fail; } else if (i + 1 == num_params) { /* Since a capture acts as "the ultimate slurpy" in a sense, if * this is the last parameter in the signature we can return * success right off the bat. */ return BIND_RESULT_OK; } else { Rakudo_Parameter *next_param = (Rakudo_Parameter *)PMC_data( VTABLE_get_pmc_keyed_int(interp, params, i + 1)); if (next_param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED)) suppress_arity_fail = 1; } } /* Could it be a named slurpy? */ else if (param->flags & SIG_ELEM_SLURPY_NAMED) { /* Can cheat a bit if it's the default method %_. * We give the hash to the lexpad. */ if (param->flags & SIG_ELEM_METHOD_SLURPY_NAMED && lexpad->vtable->base_type == p6l_id) { SETATTR_Perl6LexPad_default_named_slurpy(interp, lexpad, named_args_copy); PARROT_GC_WRITE_BARRIER(interp, lexpad); } else { /* We'll either take the current named arguments copy hash which * will by definition contain all unbound named parameters and use * that, or just create an empty one. */ PMC *slurpy = PMC_IS_NULL(named_args_copy) ? Parrot_pmc_new(interp, enum_class_Hash) : named_args_copy; cur_bv.type = BIND_VAL_OBJ; cur_bv.val.o = Rakudo_binding_create_hash(interp, slurpy); bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv, no_nom_type_check, error); if (bind_fail) return bind_fail; } /* Nullify named arguments hash now we've consumed it, to mark all * is well. */ named_args_copy = PMCNULL; } /* Otherwise, maybe it's a positional. */ else if (PMC_IS_NULL(param->named_names)) { /* Slurpy or LoL-slurpy? */ if (param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_LOL)) { /* Create Perl 6 array, create RPA of all remaining things, then * store it. */ PMC *temp = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); while (cur_pos_arg < num_pos_args) { cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg); VTABLE_push_pmc(interp, temp, cur_bv.type == BIND_VAL_OBJ ? cur_bv.val.o : create_box(interp, cur_bv)); cur_pos_arg++; } cur_bv.type = BIND_VAL_OBJ; cur_bv.val.o = param->flags & SIG_ELEM_SLURPY_POS ? Rakudo_binding_create_positional(interp, temp) : Rakudo_binding_create_lol(interp, temp); bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv, no_nom_type_check, error); if (bind_fail) return bind_fail; } /* Otherwise, a positional. */ else { /* Do we have a value?. */ if (cur_pos_arg < num_pos_args) { /* Easy - just bind that. */ cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg); bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv, no_nom_type_check, error); if (bind_fail) return bind_fail; cur_pos_arg++; } else { /* No value. If it's optional, fetch a default and bind that; * if not, we're screwed. Note that we never nominal type check * an optional with no value passed. */ if (param->flags & SIG_ELEM_IS_OPTIONAL) { cur_bv.type = BIND_VAL_OBJ; cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad); bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv, 0, error); if (bind_fail) return bind_fail; } else { if (error) *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 0); return BIND_RESULT_FAIL; } } } } /* Else, it's a non-slurpy named. */ else { /* Try and get hold of value. */ PMC *value = PMCNULL; INTVAL num_names = VTABLE_elements(interp, param->named_names); INTVAL j; if (!PMC_IS_NULL(named_args_copy)) { for (j = 0; j < num_names; j++) { STRING *name = VTABLE_get_string_keyed_int(interp, param->named_names, j); value = VTABLE_get_pmc_keyed_str(interp, named_args_copy, name); if (!PMC_IS_NULL(value)) { /* Found a value. Delete entry from to-bind args and stop looking. */ VTABLE_delete_keyed_str(interp, named_args_copy, name); break; } } } /* Did we get one? */ if (PMC_IS_NULL(value)) { /* Nope. We'd better hope this param was optional... */ if (param->flags & SIG_ELEM_IS_OPTIONAL) { cur_bv.type = BIND_VAL_OBJ; cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad); bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv, 0, error); } else if (!suppress_arity_fail) { if (error) *error = Parrot_sprintf_c(interp, "Required named parameter '%S' not passed", VTABLE_get_string_keyed_int(interp, param->named_names, 0)); return BIND_RESULT_FAIL; } } else { cur_bv.type = BIND_VAL_OBJ; cur_bv.val.o = value; bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv, 0, error); } /* If we got a binding failure, return it. */ if (bind_fail) return bind_fail; } } /* Do we have any left-over args? */ if (cur_pos_arg < num_pos_args && !suppress_arity_fail) { /* Oh noes, too many positionals passed. */ if (error) *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 1); return BIND_RESULT_FAIL; } if (!PMC_IS_NULL(named_args_copy) && VTABLE_elements(interp, named_args_copy)) { /* Oh noes, unexpected named args. */ if (error) { INTVAL num_extra = VTABLE_elements(interp, named_args_copy); PMC *iter = VTABLE_get_iter(interp, named_args_copy); if (num_extra == 1) { *error = Parrot_sprintf_c(interp, "Unexpected named parameter '%S' passed", VTABLE_shift_string(interp, iter)); } else { INTVAL first = 1; STRING *comma = Parrot_str_new(interp, ", ", 0); *error = Parrot_sprintf_c(interp, "%d unexpected named parameters passed (", num_extra); while (VTABLE_get_bool(interp, iter)) { STRING *name = VTABLE_shift_string(interp, iter); if (!first) *error = Parrot_str_concat(interp, *error, comma); else first = 0; *error = Parrot_str_concat(interp, *error, name); } *error = Parrot_str_concat(interp, *error, Parrot_str_new(interp, ")", 0)); } } return BIND_RESULT_FAIL; } /* If we get here, we're done. */ return BIND_RESULT_OK; }
/* Registers a representation. It this is ever made public, it should first be * made thread-safe. */ static void register_repr(PARROT_INTERP, STRING *name, PMC *repr) { INTVAL ID = VTABLE_elements(interp, repr_registry); VTABLE_push_pmc(interp, repr_registry, repr); VTABLE_set_integer_keyed_str(interp, repr_name_to_id_map, name, ID); }
/* Locates all of the attributes. Puts them onto a flattened, ordered * list of attributes (populating the passed flat_list). Also builds * the index mapping for doing named lookups. Note index is not related * to the storage position. */ static PMC * index_mapping_and_flat_list(PARROT_INTERP, PMC *mro, CStructREPRData *repr_data) { PMC *flat_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); PMC *class_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); PMC *attr_map_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray); STRING *name_str = Parrot_str_new_constant(interp, "name"); INTVAL current_slot = 0; INTVAL num_classes, i; CStructNameMap * result = NULL; /* Walk through the parents list. */ INTVAL mro_idx = VTABLE_elements(interp, mro); while (mro_idx) { /* Get current class in MRO. */ PMC *type_info = VTABLE_get_pmc_keyed_int(interp, mro, --mro_idx); PMC *current_class = decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, type_info, 0)); /* Get its local parents; make sure we're not doing MI. */ PMC *parents = VTABLE_get_pmc_keyed_int(interp, type_info, 2); INTVAL num_parents = VTABLE_elements(interp, parents); if (num_parents <= 1) { /* Get attributes and iterate over them. */ PMC *attributes = VTABLE_get_pmc_keyed_int(interp, type_info, 1); PMC *attr_map = PMCNULL; PMC *attr_iter = VTABLE_get_iter(interp, attributes); while (VTABLE_get_bool(interp, attr_iter)) { /* Get attribute. */ PMC * attr = VTABLE_shift_pmc(interp, attr_iter); /* Get its name. */ PMC *name_pmc = VTABLE_get_pmc_keyed_str(interp, attr, name_str); STRING *name = VTABLE_get_string(interp, name_pmc); /* Allocate a slot. */ if (PMC_IS_NULL(attr_map)) attr_map = Parrot_pmc_new(interp, enum_class_Hash); VTABLE_set_pmc_keyed_str(interp, attr_map, name, Parrot_pmc_new_init_int(interp, enum_class_Integer, current_slot)); current_slot++; /* Push attr onto the flat list. */ VTABLE_push_pmc(interp, flat_list, attr); } /* Add to class list and map list. */ VTABLE_push_pmc(interp, class_list, current_class); VTABLE_push_pmc(interp, attr_map_list, attr_map); } else { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "CStruct representation does not support multiple inheritance"); } } /* We can now form the name map. */ num_classes = VTABLE_elements(interp, class_list); result = (CStructNameMap *) mem_sys_allocate_zeroed(sizeof(CStructNameMap) * (1 + num_classes)); for (i = 0; i < num_classes; i++) { result[i].class_key = VTABLE_get_pmc_keyed_int(interp, class_list, i); result[i].name_map = VTABLE_get_pmc_keyed_int(interp, attr_map_list, i); } repr_data->name_to_index_mapping = result; return flat_list; }
/* This works out an allocation strategy for the object. It takes care of * "inlining" storage of attributes that are natively typed, as well as * noting unbox targets. */ static void compute_allocation_strategy(PARROT_INTERP, PMC *repr_info, CStructREPRData *repr_data) { STRING *type_str = Parrot_str_new_constant(interp, "type"); PMC *flat_list; /* * We have to block GC mark here. Because "repr" is assotiated with some * PMC which is not accessible in this function. And we have to write * barrier this PMC because we are poking inside it guts directly. We * do have WB in caller function, but it can be triggered too late is * any of allocation will cause GC run. * * This is kind of minor evil until after I'll find better solution. */ Parrot_block_GC_mark(interp); /* Compute index mapping table and get flat list of attributes. */ flat_list = index_mapping_and_flat_list(interp, repr_info, repr_data); /* If we have no attributes in the index mapping, then just the header. */ if (repr_data->name_to_index_mapping[0].class_key == NULL) { repr_data->struct_size = 1; /* avoid 0-byte malloc */ } /* Otherwise, we need to compute the allocation strategy. */ else { /* We track the size of the struct, which is what we'll want offsets into. */ INTVAL cur_size = 0; /* Get number of attributes and set up various counters. */ INTVAL num_attrs = VTABLE_elements(interp, flat_list); INTVAL info_alloc = num_attrs == 0 ? 1 : num_attrs; INTVAL cur_obj_attr = 0; INTVAL cur_str_attr = 0; INTVAL cur_init_slot = 0; INTVAL i; /* Allocate location/offset arrays and GC mark info arrays. */ repr_data->num_attributes = num_attrs; repr_data->attribute_locations = (INTVAL *) mem_sys_allocate(info_alloc * sizeof(INTVAL)); repr_data->struct_offsets = (INTVAL *) mem_sys_allocate(info_alloc * sizeof(INTVAL)); repr_data->flattened_stables = (STable **) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *)); repr_data->member_types = (PMC** ) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *)); /* Go over the attributes and arrange their allocation. */ for (i = 0; i < num_attrs; i++) { /* Fetch its type; see if it's some kind of unboxed type. */ PMC *attr = VTABLE_get_pmc_keyed_int(interp, flat_list, i); PMC *type = VTABLE_get_pmc_keyed_str(interp, attr, type_str); INTVAL type_id = REPR(type)->ID; INTVAL bits = sizeof(void *) * 8; INTVAL align = ALIGNOF1(void *); if (!PMC_IS_NULL(type)) { /* See if it's a type that we know how to handle in a C struct. */ storage_spec spec = REPR(type)->get_storage_spec(interp, STABLE(type)); if (spec.inlineable == STORAGE_SPEC_INLINED && (spec.boxed_primitive == STORAGE_SPEC_BP_INT || spec.boxed_primitive == STORAGE_SPEC_BP_NUM)) { /* It's a boxed int or num; pretty easy. It'll just live in the * body of the struct. Instead of masking in i here (which * would be the parallel to how we handle boxed types) we * repurpose it to store the bit-width of the type, so * that get_attribute_ref can find it later. */ bits = spec.bits; align = spec.align; if (bits % 8) { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "CStruct only supports native types that are a multiple of 8 bits wide (was passed: %ld)", bits); } repr_data->attribute_locations[i] = (bits << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_IN_STRUCT; repr_data->flattened_stables[i] = STABLE(type); if (REPR(type)->initialize) { if (!repr_data->initialize_slots) repr_data->initialize_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL)); repr_data->initialize_slots[cur_init_slot] = i; cur_init_slot++; } } else if(spec.can_box & STORAGE_SPEC_CAN_BOX_STR) { /* It's a string of some kind. */ repr_data->num_child_objs++; repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_STRING; repr_data->member_types[i] = type; } else if(type_id == get_ca_repr_id()) { /* It's a CArray of some kind. */ repr_data->num_child_objs++; repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_CARRAY; repr_data->member_types[i] = type; } else if(type_id == get_cs_repr_id()) { /* It's a CStruct. */ repr_data->num_child_objs++; repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_CSTRUCT; repr_data->member_types[i] = type; } else if(type_id == get_cp_repr_id()) { /* It's a CPointer. */ repr_data->num_child_objs++; repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_CPTR; repr_data->member_types[i] = type; } else { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "CStruct representation only implements native int and float members so far"); } } else { Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "CStruct representation requires the types of all attributes to be specified"); } /* Do allocation. */ /* C structure needs careful alignment. If cur_size is not aligned * to align bytes (cur_size % align), make sure it is before we * add the next element. */ if (cur_size % align) { cur_size += align - cur_size % align; } repr_data->struct_offsets[i] = cur_size; cur_size += bits / 8; } /* Finally, put computed allocation size in place; it's body size plus * header size. Also number of markables and sentinels. */ repr_data->struct_size = cur_size; if (repr_data->initialize_slots) repr_data->initialize_slots[cur_init_slot] = -1; } Parrot_unblock_GC_mark(interp); }
void parrot_init_library_paths(PARROT_INTERP) { ASSERT_ARGS(parrot_init_library_paths) PMC *paths; STRING *entry; STRING *versionlib = NULL; STRING *builddir = NULL; PMC * const iglobals = interp->iglobals; PMC * const config_hash = VTABLE_get_pmc_keyed_int(interp, iglobals, (INTVAL)IGLOBALS_CONFIG_HASH); /* create the lib_paths array */ PMC * const lib_paths = Parrot_pmc_new_init_int(interp, enum_class_FixedPMCArray, PARROT_LIB_PATH_SIZE); VTABLE_set_pmc_keyed_int(interp, iglobals, IGLOBALS_LIB_PATHS, lib_paths); if (VTABLE_elements(interp, config_hash)) { STRING * const libkey = CONST_STRING(interp, "libdir"); STRING * const verkey = CONST_STRING(interp, "versiondir"); STRING * const builddirkey = CONST_STRING(interp, "build_dir"); STRING * const installed = CONST_STRING(interp, "installed"); versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey); entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey); versionlib = Parrot_str_concat(interp, versionlib, entry); if (!VTABLE_get_integer_keyed_str(interp, config_hash, installed)) builddir = VTABLE_get_string_keyed_str(interp, config_hash, builddirkey); } /* each is an array of strings */ /* define include paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_INCLUDE, paths); { /* EXPERIMENTAL: add include path from environment */ const char *envvar = Parrot_getenv(interp, Parrot_str_new_constant(interp, "PARROT_INCLUDE")); if (envvar != NULL && envvar[0]) { entry = Parrot_str_new(interp, envvar, 0); VTABLE_push_string(interp, paths, entry); } } if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/")); VTABLE_push_string(interp, paths, entry); entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/")); VTABLE_push_string(interp, paths, entry); } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/")); VTABLE_push_string(interp, paths, entry); } /* define library paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LIBRARY, paths); { /* EXPERIMENTAL: add library path from environment */ const char *envvar = Parrot_getenv(interp, Parrot_str_new_constant(interp, "PARROT_LIBRARY")); if (envvar != NULL && envvar[0]) { entry = Parrot_str_new(interp, envvar, 0); VTABLE_push_string(interp, paths, entry); } } if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/")); VTABLE_push_string(interp, paths, entry); } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/library/")); VTABLE_push_string(interp, paths, entry); } /* define languages paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LANG, paths); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/")); VTABLE_push_string(interp, paths, entry); } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/languages/")); VTABLE_push_string(interp, paths, entry); } /* define dynext paths */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_DYNEXT, paths); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/")); VTABLE_push_string(interp, paths, entry); } entry = CONST_STRING(interp, "dynext/"); VTABLE_push_string(interp, paths, entry); if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/dynext/")); VTABLE_push_string(interp, paths, entry); } /* shared exts */ paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_DYN_EXTS, paths); /* no CONST_STRING here - the c2str.pl preprocessor needs "real strs" */ entry = Parrot_str_new_constant(interp, PARROT_LOAD_EXT); VTABLE_push_string(interp, paths, entry); /* OS/X has .dylib and .bundle */ if (!STREQ(PARROT_LOAD_EXT, PARROT_SHARE_EXT)) { entry = Parrot_str_new_constant(interp, PARROT_SHARE_EXT); VTABLE_push_string(interp, paths, entry); } #ifdef PARROT_PLATFORM_LIB_PATH_INIT_HOOK PARROT_PLATFORM_LIB_PATH_INIT_HOOK(interp, lib_paths); #endif }
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; } }
/* =item C<static void print_constant_table(PARROT_INTERP, PMC *output)> Prints the contents of the constants table. =cut */ static void print_constant_table(PARROT_INTERP, ARGIN(PMC *output)) { ASSERT_ARGS(print_constant_table) const PackFile_ConstTable *ct = interp->code->const_table; INTVAL i; /* TODO: would be nice to print the name of the file as well */ Parrot_io_fprintf(interp, output, "=head1 Constant-table\n\n"); for (i = 0; i < ct->num.const_count; i++) Parrot_io_fprintf(interp, output, "NUM_CONST(%d): %f\n", i, ct->num.constants[i]); for (i = 0; i < ct->str.const_count; i++) Parrot_io_fprintf(interp, output, "STR_CONST(%d): %S\n", i, ct->str.constants[i]); for (i = 0; i < ct->pmc.const_count; i++) { PMC * const c = ct->pmc.constants[i]; Parrot_io_fprintf(interp, output, "PMC_CONST(%d): ", i); switch (c->vtable->base_type) { /* each PBC file has a ParrotInterpreter, but it can't * stringify by itself */ case enum_class_ParrotInterpreter: Parrot_io_fprintf(interp, output, "'ParrotInterpreter'"); break; /* FixedIntegerArrays used for signatures, handy to print */ case enum_class_FixedIntegerArray: { const INTVAL n = VTABLE_elements(interp, c); INTVAL j; Parrot_io_fprintf(interp, output, "["); for (j = 0; j < n; ++j) { const INTVAL val = VTABLE_get_integer_keyed_int(interp, c, j); Parrot_io_fprintf(interp, output, "%d", val); if (j < n - 1) Parrot_io_fprintf(interp, output, ","); } Parrot_io_fprintf(interp, output, "]"); break; } case enum_class_NameSpace: case enum_class_String: case enum_class_Key: case enum_class_ResizableStringArray: { STRING * const s = VTABLE_get_string(interp, c); if (s) Parrot_io_fprintf(interp, output, "%Ss", s); break; } case enum_class_Sub: Parrot_io_fprintf(interp, output, "%S", VTABLE_get_string(interp, c)); break; default: Parrot_io_fprintf(interp, output, "(PMC constant)"); break; } Parrot_io_fprintf(interp, output, "\n"); } Parrot_io_fprintf(interp, output, "\n=cut\n\n"); }
/* 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; }
/* Performs a multiple dispatch using the candidates held in the passed * DispatcherSub and using the arguments in the passed capture. */ PMC *nqp_multi_dispatch(PARROT_INTERP, PMC *dispatcher, PMC *capture) { /* Get list and number of dispatchees. */ PMC *dispatchees = PARROT_DISPATCHERSUB(dispatcher)->dispatchees; const INTVAL num_candidates = VTABLE_elements(interp, dispatchees); /* Count arguments. */ const INTVAL num_args = VTABLE_elements(interp, capture); /* Initialize dispatcher state. */ INTVAL type_mismatch; INTVAL possibles_count = 0; candidate_info **possibles = mem_allocate_n_typed(num_candidates, candidate_info *); INTVAL type_check_count; /* Get sorted candidate list. * XXX We'll cache this in the future. */ candidate_info** candidates = sort_candidates(interp, dispatchees); candidate_info** cur_candidate = candidates; /* Ensure we know what is a 6model object and what is not. */ if (!smo_id) smo_id = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "SixModelObject", 0)); /* 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) { /* If we have some possible candidate(s), we're done in this loop. */ if (possibles_count) break; /* Otherwise, we keep looping and looking, unless we really hit the end. */ if (cur_candidate[1]) { cur_candidate++; continue; } else { break; } } /* Check if it's admissable by arity. */ if (num_args < (*cur_candidate)->min_arity || num_args > (*cur_candidate)->max_arity) { cur_candidate++; continue; } /* Check if it's admissable by type. */ type_check_count = (*cur_candidate)->num_types > num_args ? num_args : (*cur_candidate)->num_types; type_mismatch = 0; for (i = 0; i < type_check_count; i++) { PMC * const param = VTABLE_get_pmc_keyed_int(interp, capture, i); PMC * const param_type = param->vtable->base_type == smo_id ? STABLE(param)->WHAT : PMCNULL; PMC * const type_obj = (*cur_candidate)->types[i]; INTVAL const definedness = (*cur_candidate)->definednesses[i]; if (param_type != type_obj && !is_narrower_type(interp, param_type, type_obj)) { type_mismatch = 1; break; } if (definedness) { /* Have a constraint on the definedness. */ INTVAL defined = param->vtable->base_type == smo_id ? IS_CONCRETE(param) : VTABLE_defined(interp, param); if ((!defined && definedness == DEFINED_ONLY) || (defined && definedness == UNDEFINED_ONLY)) { type_mismatch = 1; break; } } } if (type_mismatch) { cur_candidate++; continue; } /* If we get here, it's an admissable candidate; add to list. */ possibles[possibles_count] = *cur_candidate; possibles_count++; cur_candidate++; } /* Cache the result if there's a single chosen one. */ if (possibles_count == 1) { /* XXX TODO: Cache entry. */ } /* Need a unique candidate. */ if (possibles_count == 1) { PMC *result = possibles[0]->sub; mem_sys_free(possibles); return result; } else if (possibles_count == 0) { /* Get signatures of all possible candidates. We dump them in the * order in which we search for them. */ STRING *signatures = Parrot_str_new(interp, "", 0); cur_candidate = candidates; while (1) { if (!cur_candidate[0] && !cur_candidate[1]) break; /* XXX TODO: add sig dumping. if (cur_candidate[0]) signatures = dump_signature(interp, signatures, (*cur_candidate)->sub); */ cur_candidate++; } mem_sys_free(possibles); Parrot_ex_throw_from_c_args(interp, NULL, 1, "No applicable candidates found to dispatch to for '%Ss'. Available candidates are:\n%Ss", VTABLE_get_string(interp, candidates[0]->sub), signatures); } else { /* Get signatures of ambiguous candidates. */ STRING *signatures = Parrot_str_new(interp, "", 0); INTVAL i; /* XXX TODO: sig dumping for (i = 0; i < possibles_count; i++) signatures = dump_signature(interp, signatures, possibles[i]->sub); */ mem_sys_free(possibles); Parrot_ex_throw_from_c_args(interp, NULL, 1, "Ambiguous dispatch to multi '%Ss'. Ambiguous candidates had signatures:\n%Ss", VTABLE_get_string(interp, candidates[0]->sub), signatures); } }
/* 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, PMC *llsig, llsig_element *sig_info, PMC *value, INTVAL no_nom_type_check, STRING **error) { /* If we need to do a type check, do one. */ if (!no_nom_type_check) { /* See if we get a hit in the type cache. */ INTVAL cache_matched = 0; INTVAL value_type = VTABLE_type(interp, value); if (value_type != 0) { INTVAL i; for (i = 0; i < NOM_TYPE_CACHE_SIZE; i++) { if (sig_info->nom_type_cache[i] == value_type) { cache_matched = 1; break; } } } /* If not, do the check. */ if (!cache_matched) { PMC * const type_obj = sig_info->nominal_type; PMC * accepts_meth = VTABLE_find_method(interp, type_obj, ACCEPTS); PMC * result = PMCNULL; Parrot_ext_call(interp, accepts_meth, "PiP->P", type_obj, value, &result); if (VTABLE_get_bool(interp, result)) { /* Cache if possible. */ if (value_type != 0 && value_type != p6r_id && value_type != p6o_id) { INTVAL i; for (i = 0; i < NOM_TYPE_CACHE_SIZE; i++) { if (sig_info->nom_type_cache[i] == 0) { sig_info->nom_type_cache[i] = value_type; PARROT_GC_WRITE_BARRIER(interp, llsig); break; } } } } else { /* Type check failed. However, for language inter-op, we do some * extra checks if the type is just Positional, Associative, or * Callable and the thingy we have matches those enough. */ /* XXX TODO: Implement language interop checks. */ if (error) { STRING * const perl = PERL_str; PMC * perl_meth = VTABLE_find_method(interp, type_obj, perl); PMC * how_meth = VTABLE_find_method(interp, value, HOW); STRING * expected, * got; PMC * value_how, * value_type; Parrot_ext_call(interp, perl_meth, "Pi->S", type_obj, &expected); Parrot_ext_call(interp, how_meth, "Pi->P", value, &value_how); value_type = VTABLE_get_attr_str(interp, value_how, SHORTNAME_str); got = VTABLE_get_string(interp, value_type); *error = Parrot_sprintf_c(interp, "Nominal type check failed for parameter '%S'; expected %S but got %S instead", sig_info->variable_name, expected, got); } if (VTABLE_isa(interp, value, JUNCTION_str)) return BIND_RESULT_JUNCTION; else return BIND_RESULT_FAIL; } } } /* Do we have any type captures to bind? */ if (!PMC_IS_NULL(sig_info->type_captures)) Rakudo_binding_bind_type_captures(interp, lexpad, sig_info, value); /* Do a coercion, if one is needed. */ if (!STRING_IS_NULL(sig_info->coerce_to)) { PMC *coerce_meth = VTABLE_find_method(interp, value, sig_info->coerce_to); if (!PMC_IS_NULL(coerce_meth)) { Parrot_ext_call(interp, coerce_meth, "Pi->P", value, &value); } else { /* No coercion method availale; whine and fail to bind. */ if (error) { PMC * how_meth = VTABLE_find_method(interp, value, HOW); PMC * value_how, * value_type; STRING * got; Parrot_ext_call(interp, how_meth, "Pi->P", value, &value_how); value_type = VTABLE_get_attr_str(interp, value_how, SHORTNAME_str); got = VTABLE_get_string(interp, value_type); *error = Parrot_sprintf_c(interp, "Unable to coerce value for '%S' from %S to %S; no coercion method defined", sig_info->variable_name, got, sig_info->coerce_to); } return BIND_RESULT_FAIL; } } /* If it's not got attributive binding, we'll go about binding it into the * lex pad. */ if (!(sig_info->flags & SIG_ELEM_BIND_ATTRIBUTIVE)) { /* Is it "is rw"? */ if (sig_info->flags & SIG_ELEM_IS_RW) { /* XXX TODO Check if rw flag is set. */ if (!STRING_IS_NULL(sig_info->variable_name)) VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, value); } else if (sig_info->flags & SIG_ELEM_IS_PARCEL) { /* Just bind the thing as is into the lexpad. */ if (!STRING_IS_NULL(sig_info->variable_name)) VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, value); } else if (sig_info->flags & SIG_ELEM_IS_COPY) { /* Place the value into a new container instead of binding to an existing one */ value = descalarref(interp, value); if (!STRING_IS_NULL(sig_info->variable_name)) { PMC *copy, *ref, *store_meth; if (sig_info->flags & SIG_ELEM_ARRAY_SIGIL) { copy = Rakudo_binding_create_positional(interp, PMCNULL, ARRAY_str); store_meth = VTABLE_find_method(interp, copy, STORE_str); Parrot_ext_call(interp, store_meth, "PiP", copy, value); } else if (sig_info->flags & SIG_ELEM_HASH_SIGIL) { copy = Rakudo_binding_create_hash(interp, pmc_new(interp, enum_class_Hash)); store_meth = VTABLE_find_method(interp, copy, STORE_str); Parrot_ext_call(interp, store_meth, "PiP", copy, value); } else { copy = pmc_new_init(interp, p6s_id, value); VTABLE_setprop(interp, copy, SCALAR_str, copy); } VTABLE_setprop(interp, copy, RW_str, copy); VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, copy); } } else { /* Read only. Wrap it into a ObjectRef, mark readonly and bind it. */ if (!STRING_IS_NULL(sig_info->variable_name)) { PMC *ref = pmc_new_init(interp, or_id, value); if (!(sig_info->flags & (SIG_ELEM_ARRAY_SIGIL | SIG_ELEM_HASH_SIGIL))) VTABLE_setprop(interp, ref, SCALAR_str, ref); VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, ref); } } } /* Is it the invocant? If so, also have to bind to self lexical. */ if (sig_info->flags & SIG_ELEM_INVOCANT) VTABLE_set_pmc_keyed_str(interp, lexpad, SELF_str, 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(sig_info->post_constraints)) { PMC * const constraints = sig_info->post_constraints; INTVAL num_constraints = VTABLE_elements(interp, constraints); PMC * result = PMCNULL; INTVAL i; for (i = 0; i < num_constraints; i++) { PMC *cons_type = VTABLE_get_pmc_keyed_int(interp, constraints, i); PMC *accepts_meth = VTABLE_find_method(interp, cons_type, ACCEPTS); if (VTABLE_isa(interp, cons_type, BLOCK_str)) Parrot_sub_capture_lex(interp, VTABLE_get_attr_str(interp, cons_type, DO_str)); Parrot_ext_call(interp, accepts_meth, "PiP->P", cons_type, value, &result); if (!VTABLE_get_bool(interp, result)) { if (error) *error = Parrot_sprintf_c(interp, "Constraint type check failed for parameter '%S'", sig_info->variable_name); return BIND_RESULT_FAIL; } } } /* If it's attributive, now we assign it. */ if (sig_info->flags & SIG_ELEM_BIND_ATTRIBUTIVE) { INTVAL result = Rakudo_binding_assign_attributive(interp, lexpad, sig_info, value, error); if (result != BIND_RESULT_OK) return result; } /* If it has a sub-signature, bind that. */ if (!PMC_IS_NULL(sig_info->sub_llsig)) { /* Turn value into a capture, unless we already have one. */ PMC *capture = PMCNULL; INTVAL result; if (sig_info->flags & SIG_ELEM_IS_CAPTURE) { capture = value; } else { PMC *meth = VTABLE_find_method(interp, 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", value, &capture); } /* Recurse into signature binder. */ result = Rakudo_binding_bind_llsig(interp, lexpad, sig_info->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(sig_info->variable_name)) { *error = Parrot_str_concat(interp, *error, Parrot_str_new(interp, " of parameter ", 0)); *error = Parrot_str_concat(interp, *error, sig_info->variable_name); } } return result; } } /* Binding of this parameter was thus successful - we're done. */ return BIND_RESULT_OK; }
/* This works out an allocation strategy for the object. It takes care of * "inlining" storage of attributes that are natively typed, as well as * noting unbox targets. */ static void compute_allocation_strategy(PARROT_INTERP, PMC *WHAT, P6opaqueREPRData *repr_data) { STRING *type_str = Parrot_str_new_constant(interp, "type"); STRING *box_target_str = Parrot_str_new_constant(interp, "box_target"); STRING *avcont_str = Parrot_str_new_constant(interp, "auto_viv_container"); PMC *flat_list; /* * We have to block GC mark here. Because "repr" is assotiated with some * PMC which is not accessible in this function. And we have to write * barrier this PMC because we are poking inside it guts directly. We * do have WB in caller function, but it can be triggered too late is * any of allocation will cause GC run. * * This is kind of minor evil until after I'll find better solution. */ Parrot_block_GC_mark(interp); /* Compute index mapping table and get flat list of attributes. */ flat_list = index_mapping_and_flat_list(interp, WHAT, repr_data); /* If we have no attributes in the index mapping, then just the header. */ if (repr_data->name_to_index_mapping[0].class_key == NULL) { repr_data->allocation_size = sizeof(P6opaqueInstance); } /* Otherwise, we need to compute the allocation strategy. */ else { /* We track the size of the body part, since that's what we want offsets into. */ INTVAL cur_size = 0; /* Get number of attributes and set up various counters. */ INTVAL num_attrs = VTABLE_elements(interp, flat_list); INTVAL info_alloc = num_attrs == 0 ? 1 : num_attrs; INTVAL cur_pmc_attr = 0; INTVAL cur_init_slot = 0; INTVAL cur_mark_slot = 0; INTVAL cur_cleanup_slot = 0; INTVAL cur_unbox_slot = 0; INTVAL i; /* Allocate offset array and GC mark info arrays. */ repr_data->num_attributes = num_attrs; repr_data->attribute_offsets = (INTVAL *) mem_sys_allocate(info_alloc * sizeof(INTVAL)); repr_data->flattened_stables = (STable **) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *)); repr_data->unbox_int_slot = -1; repr_data->unbox_num_slot = -1; repr_data->unbox_str_slot = -1; /* Go over the attributes and arrange their allocation. */ for (i = 0; i < num_attrs; i++) { PMC *attr = VTABLE_get_pmc_keyed_int(interp, flat_list, i); /* Fetch its type and box target flag, if available. */ PMC *type = accessor_call(interp, attr, type_str); PMC *box_target = accessor_call(interp, attr, box_target_str); PMC *av_cont = accessor_call(interp, attr, avcont_str); /* Work out what unboxed type it is, if any. Default to a boxed. */ INTVAL unboxed_type = STORAGE_SPEC_BP_NONE; INTVAL bits = sizeof(PMC *) * 8; if (!PMC_IS_NULL(type)) { /* Get the storage spec of the type and see what it wants. */ storage_spec spec = REPR(type)->get_storage_spec(interp, STABLE(type)); if (spec.inlineable == STORAGE_SPEC_INLINED) { /* Yes, it's something we'll flatten. */ unboxed_type = spec.boxed_primitive; bits = spec.bits; repr_data->flattened_stables[i] = STABLE(type); /* Does it need special initialization? */ if (REPR(type)->initialize) { if (!repr_data->initialize_slots) repr_data->initialize_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL)); repr_data->initialize_slots[cur_init_slot] = i; cur_init_slot++; } /* Does it have special GC needs? */ if (REPR(type)->gc_mark) { if (!repr_data->gc_mark_slots) repr_data->gc_mark_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL)); repr_data->gc_mark_slots[cur_mark_slot] = i; cur_mark_slot++; } if (REPR(type)->gc_cleanup) { if (!repr_data->gc_cleanup_slots) repr_data->gc_cleanup_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL)); repr_data->gc_cleanup_slots[cur_cleanup_slot] = i; cur_cleanup_slot++; } /* Is it a target for box/unbox operations? */ if (!PMC_IS_NULL(box_target) && VTABLE_get_bool(interp, box_target)) { /* If it boxes a primitive, note that. */ switch (unboxed_type) { case STORAGE_SPEC_BP_INT: if (repr_data->unbox_int_slot >= 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Duplicate box_target for native int"); repr_data->unbox_int_slot = i; break; case STORAGE_SPEC_BP_NUM: if (repr_data->unbox_num_slot >= 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Duplicate box_target for native num"); repr_data->unbox_num_slot = i; break; case STORAGE_SPEC_BP_STR: if (repr_data->unbox_str_slot >= 0) Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, "Duplicate box_target for native str"); repr_data->unbox_str_slot = i; break; default: /* nothing, just suppress 'missing default' warning */ break; } /* Also list in the by-repr unbox list. */ if (repr_data->unbox_slots == NULL) repr_data->unbox_slots = (P6opaqueBoxedTypeMap *) mem_sys_allocate_zeroed(info_alloc * sizeof(P6opaqueBoxedTypeMap)); repr_data->unbox_slots[cur_unbox_slot].repr_id = REPR(type)->ID; repr_data->unbox_slots[cur_unbox_slot].slot = i; cur_unbox_slot++; } } } /* Handle PMC attributes, which need marking and may have auto-viv needs. */ if (unboxed_type == STORAGE_SPEC_BP_NONE) { if (!repr_data->gc_pmc_mark_offsets) repr_data->gc_pmc_mark_offsets = (INTVAL *) mem_sys_allocate_zeroed(info_alloc * sizeof(INTVAL)); repr_data->gc_pmc_mark_offsets[cur_pmc_attr] = cur_size; cur_pmc_attr++; if (!PMC_IS_NULL(av_cont)) { if (!repr_data->auto_viv_values) repr_data->auto_viv_values = (PMC **) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *)); repr_data->auto_viv_values[i] = av_cont; } } /* Do allocation. */ /* XXX TODO Alignment! Important when we get int1, int8, etc. */ repr_data->attribute_offsets[i] = cur_size; cur_size += bits / 8; } /* Finally, put computed allocation size in place; it's body size plus * header size. Also number of markables and sentinels. */ repr_data->allocation_size = cur_size + sizeof(P6opaqueInstance); repr_data->gc_pmc_mark_offsets_count = cur_pmc_attr; if (repr_data->initialize_slots) repr_data->initialize_slots[cur_init_slot] = -1; if (repr_data->gc_mark_slots) repr_data->gc_mark_slots[cur_mark_slot] = -1; if (repr_data->gc_cleanup_slots) repr_data->gc_cleanup_slots[cur_cleanup_slot] = -1; } Parrot_unblock_GC_mark(interp); }
Takes an interpreter name and (optional) entry name. Returns a pointer to the new entry. Used by Parrot_hll_register_HLL. =cut */ PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT static PMC* new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name)) { ASSERT_ARGS(new_hll_entry) PMC * const hll_info = interp->HLL_info; const INTVAL id = VTABLE_elements(interp, hll_info); PMC *entry_id; PMC * const entry = Parrot_pmc_new_constant_init_int(interp, enum_class_FixedPMCArray, e_HLL_MAX); if (entry_name && !STRING_IS_EMPTY(entry_name)) { VTABLE_set_pmc_keyed_str(interp, hll_info, entry_name, entry); } else VTABLE_push_pmc(interp, hll_info, entry); entry_id = Parrot_pmc_new_constant_init_int(interp, enum_class_Integer, id); VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_id, entry_id);
PARROT_EXPORT void Parrot_lib_update_paths_from_config_hash(PARROT_INTERP) { ASSERT_ARGS(Parrot_lib_update_paths_from_config_hash) STRING * versionlib = NULL; STRING * entry = NULL; STRING * builddir = NULL; PMC * const lib_paths = VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_LIB_PATHS); PMC * const config_hash = VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_CONFIG_HASH); PMC * paths; if (VTABLE_elements(interp, config_hash)) { STRING * const libkey = CONST_STRING(interp, "libdir"); STRING * const verkey = CONST_STRING(interp, "versiondir"); STRING * const builddirkey = CONST_STRING(interp, "build_dir"); STRING * const installed = CONST_STRING(interp, "installed"); versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey); entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey); versionlib = Parrot_str_concat(interp, versionlib, entry); if (!VTABLE_get_integer_keyed_str(interp, config_hash, installed)) builddir = VTABLE_get_string_keyed_str(interp, config_hash, builddirkey); } paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_INCLUDE); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/")); VTABLE_push_string(interp, paths, entry); entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/")); VTABLE_push_string(interp, paths, entry); } paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LIBRARY); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/library/")); VTABLE_push_string(interp, paths, entry); } paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LANG); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/languages/")); VTABLE_push_string(interp, paths, entry); } paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_DYNEXT); if (!STRING_IS_NULL(builddir)) { entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/")); VTABLE_push_string(interp, paths, entry); } if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/dynext/")); VTABLE_push_string(interp, paths, entry); } }