PARROT_EXPORT
void
Parrot_pa_destroy(PARROT_INTERP, ARGIN(Parrot_Pointer_Array *self))
{
ASSERT_ARGS(Parrot_pa_destroy)
size_t i;
for (i = 0; i < self->total_chunks; i++)
mem_sys_free(self->chunks[i]);
mem_sys_free(self->chunks);
}
/* This Parrot-specific addition to the API is used to free an object. */
static void gc_free(PARROT_INTERP, PMC *obj) {
NFAInstance *nfa = (NFAInstance *)PMC_data(obj);
INTVAL i;
for (i = 0; i < nfa->body.num_states; i++)
if (nfa->body.states[i])
mem_sys_free(nfa->body.states[i]);
mem_sys_free(nfa->body.num_state_edges);
mem_sys_free(nfa);
PMC_data(obj) = NULL;
}
void
Parrot_schedule_broadcast_qentry(QUEUE_ENTRY* entry)
{
Parrot_Interp interp;
parrot_event* event;
size_t i;
event = entry->data;
switch (event->type) {
case EVENT_TYPE_SIGNAL:
edebug((stderr, "broadcast signal\n"));
/*
* we don't have special signal handlers in usercode yet
* e.g.:
* install handler like exception handler *and*
* set a interpreter flag, that a handler exists
* we then could examine that flag (after LOCKing it)
* and dispatch the exception to all interpreters that
* handle it
* Finally, we send the first (main) interpreter that signal
*
* For now just send to all.
*
*/
switch(event->u.signal) {
case SIGINT:
if (n_interpreters) {
LOCK(interpreter_array_mutex);
for (i = 1; i < n_interpreters; ++i) {
edebug((stderr, "deliver SIGINT to %d\n", i));
interp = interpreter_array[i];
if (interp)
Parrot_schedule_interp_qentry(interp,
dup_entry(entry));
}
UNLOCK(interpreter_array_mutex);
}
interp = interpreter_array[0];
Parrot_schedule_interp_qentry(interp, entry);
edebug((stderr, "deliver SIGINT to 0\n"));
break;
default:
mem_sys_free(entry);
mem_sys_free(event);
}
break;
default:
mem_sys_free(entry);
mem_sys_free(event);
internal_exception(1, "Unknown event to broadcast");
break;
}
}
/* This is called to do any cleanup of resources when an object gets
* embedded inside another one. Never called on a top-level object. */
static void gc_cleanup(PARROT_INTERP, STable *st, void *data) {
NativeCallBody *body = (NativeCallBody *)data;
UNUSED(interp);
UNUSED(st);
if (body->lib_name)
Parrot_str_free_cstring(body->lib_name);
if (body->lib_handle)
dlFreeLibrary(body->lib_handle);
if (body->arg_types)
mem_sys_free(body->arg_types);
if (body->arg_info)
mem_sys_free(body->arg_info);
}
/* This Parrot-specific addition to the API is used to free a repr instance. */
static void gc_free_repr(PARROT_INTERP, STable *st) {
P6opaqueREPRData *repr_data = (P6opaqueREPRData *)st->REPR_data;
if (repr_data->name_to_index_mapping)
mem_sys_free(repr_data->name_to_index_mapping);
if (repr_data->gc_pmc_mark_offsets)
mem_sys_free(repr_data->gc_pmc_mark_offsets);
if (repr_data->gc_str_mark_offsets)
mem_sys_free(repr_data->gc_str_mark_offsets);
if (repr_data->auto_viv_values)
mem_sys_free(repr_data->auto_viv_values);
mem_sys_free(st->REPR_data);
st->REPR_data = NULL;
}
static void*
do_event(Parrot_Interp interpreter, parrot_event* event, void *next)
{
edebug((stderr, "do_event %s\n", et(event)));
switch (event->type) {
case EVENT_TYPE_TERMINATE:
next = NULL; /* this will terminate the run loop */
break;
case EVENT_TYPE_SIGNAL:
interpreter->sleeping = 0;
/* generate exception */
event_to_exception(interpreter, event);
/* not reached - will longjmp */
break;
case EVENT_TYPE_TIMER:
/* run ops, save registers */
Parrot_runops_fromc_save(interpreter,
event->u.timer_event.sub);
break;
case EVENT_TYPE_CALL_BACK:
edebug((stderr, "starting user cb\n"));
Parrot_run_callback(interpreter, event->u.call_back.cbi,
event->u.call_back.external_data);
break;
case EVENT_TYPE_SLEEP:
interpreter->sleeping = 0;
break;
default:
fprintf(stderr, "Unhandled event type %d\n", event->type);
break;
}
mem_sys_free(event);
return next;
}
static void*
wait_for_wakeup(Parrot_Interp interpreter, void *next)
{
QUEUE_ENTRY *entry;
parrot_event* event;
QUEUE * tq = interpreter->task_queue;
interpreter->sleeping = 1;
/*
* event handler likes callbacks or timers are run as normal code
* so inside such an even handler function another event might get
* handled, which is good (higher priority events can interrupt
* other event handler) OTOH we must ensure that all state changes
* are done in do_event and we should probably suspend nested
* event handlers sometimes
*
* FIXME: the same is true for the *next param:
* get rid of that, instead mangle the resume flags
* and offset to stop the runloop
*
*/
while (interpreter->sleeping) {
entry = wait_for_entry(tq);
event = (parrot_event* )entry->data;
mem_sys_free(entry);
edebug((stderr, "got ev %s head : %p\n", et(event), tq->head));
next = do_event(interpreter, event, next);
}
edebug((stderr, "woke up\n"));
return next;
}
static ParrotIO *
PIO_unix_accept(theINTERP, ParrotIOLayer *layer, ParrotIO *io)
{
int newsock;
int newsize;
ParrotIO *newio;
newio = PIO_new(interpreter, PIO_F_SOCKET, 0, PIO_F_READ|PIO_F_WRITE);
if((newsock = accept(io->fd, (struct sockaddr *)&newio->remote,
(socklen_t *)&newsize)) == -1)
{
fprintf(stderr, "accept: errno=%d", errno);
/* Didn't get far enough, free the io */
mem_sys_free(newio);
return NULL;
}
newio->fd = newsock;
/* XXX FIXME: Need to do a getsockname and getpeername here to
* fill in the sockaddr_in structs for local and peer */
/* Optionally do a gethostyaddr() to resolve remote IP address.
* This should be based on an option set in the master socket
*/
return newio;
}
PARROT_EXPORT
void
Parrot_list_destroy(SHIM_INTERP, ARGMOD(Linked_List* list))
{
ASSERT_ARGS(Parrot_list_destroy)
mem_sys_free(list);
}
/* This Parrot-specific addition to the API is used to free an object. */
static void gc_free(PARROT_INTERP, PMC *obj) {
P6opaqueREPRData *repr_data = (P6opaqueREPRData *)STABLE(obj)->REPR_data;
if (repr_data->allocation_size)
Parrot_gc_free_fixed_size_storage(interp, repr_data->allocation_size, PMC_data(obj));
else
mem_sys_free(PMC_data(obj));
PMC_data(obj) = NULL;
}
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;
}
/* Serializes the data. */
static void serialize(PARROT_INTERP, STable *st, void *data, SerializationWriter *writer) {
mp_int *i = &((P6bigintBody *)data)->i;
int len;
char *buf;
mp_radix_size(i, 10, &len);
buf = (char *) mem_sys_allocate(len);
mp_toradix_n(i, buf, 10, len);
/* len - 1 because buf is \0-terminated */
writer->write_str(interp, writer, Parrot_str_new(interp, buf, len - 1));
mem_sys_free(buf);
}
void
Parrot_setenv(PARROT_INTERP, STRING *str_name, STRING *str_value)
{
char * const name = Parrot_str_to_cstring(interp, str_name);
char * const value = Parrot_str_to_cstring(interp, str_value);
assert(name != NULL);
assert(value != NULL);
{
const int name_len = strlen(name);
const int value_len = strlen(value);
{
char * const envstring = (char * const)mem_internal_allocate(
name_len /* name */
+ 1 /* '=' */
+ value_len /* value */
+ 1); /* string terminator */
/* Save a bit of time, by using the fact we already have the
lengths, avoiding strcat */
strcpy(envstring, name);
strcpy(envstring + name_len, "=");
strcpy(envstring + name_len + 1, value);
Parrot_str_free_cstring(name);
Parrot_str_free_cstring(value);
if (_putenv(envstring) == 0) {
/* success */
mem_sys_free(envstring);
}
else {
mem_sys_free(envstring);
Parrot_x_force_error_exit(interp, 1,
"Unable to set environment variable %s=%s",
name, value);
}
}
}
}
void Parrot_exit(int status) {
handler_node_t *node, *next_node;
/* call all the exit handlers */
for (node = exit_handler_list; node; node = next_node) {
(node->function)(status, node->arg);
next_node = node->next;
mem_sys_free(node);
}
exit(status);
}
/* This Parrot-specific addition to the API is used to free an object. */
static void gc_free(PARROT_INTERP, PMC *obj) {
P6opaqueREPRData *repr_data = (P6opaqueREPRData *)STABLE(obj)->REPR_data;
INTVAL i;
/* Cleanup any nested reprs that need it. */
if (repr_data->gc_cleanup_slots) {
for (i = 0; repr_data->gc_cleanup_slots[i] >= 0; i++) {
INTVAL offset = repr_data->attribute_offsets[repr_data->gc_cleanup_slots[i]];
STable *st = repr_data->flattened_stables[repr_data->gc_cleanup_slots[i]];
st->REPR->gc_cleanup(interp, st, (char *)OBJECT_BODY(obj) + offset);
}
}
if (repr_data->allocation_size && !PObj_flag_TEST(private0, obj))
Parrot_gc_free_fixed_size_storage(interp, repr_data->allocation_size, PMC_data(obj));
else
mem_sys_free(PMC_data(obj));
PMC_data(obj) = NULL;
}
void *
Parrot_do_handle_events(Parrot_Interp interpreter, int restore, void *next)
{
QUEUE_ENTRY *entry;
parrot_event* event;
QUEUE * tq = interpreter->task_queue;
if (restore)
disable_event_checking(interpreter);
if (!peek_entry(tq))
return next;
while (peek_entry(tq)) {
entry = pop_entry(tq);
event = (parrot_event* )entry->data;
mem_sys_free(entry);
next = do_event(interpreter, event, next);
}
return next;
}
STRING *
Parrot_getenv(PARROT_INTERP, ARGIN(STRING *str_name))
{
char * const name = Parrot_str_to_cstring(interp, str_name);
const DWORD size = GetEnvironmentVariable(name, NULL, 0);
char *buffer = NULL;
STRING *retv;
if (size == 0) {
Parrot_str_free_cstring(name);
return NULL;
}
buffer = (char *)mem_sys_allocate(size);
GetEnvironmentVariable(name, buffer, size);
Parrot_str_free_cstring(name);
retv = Parrot_str_from_platform_cstring(interp, buffer);
mem_sys_free(buffer);
return retv;
}
static void set_str(PARROT_INTERP, STable *st, void *data, STRING *value) {
CStrBody *body = (CStrBody *) data;
PMC *old_ctx, *cappy, *meth, *enc_pmc;
STRING *enc;
STR_VTABLE *encoding;
if(body->cstr)
mem_sys_free(body->cstr);
/* Look up "encoding" method. */
meth = VTABLE_find_method(interp, st->WHAT,
Parrot_str_new_constant(interp, "encoding"));
if (PMC_IS_NULL(meth))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"CStr representation expects an 'encoding' method, specifying the encoding");
old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
cappy = Parrot_pmc_new(interp, enum_class_CallContext);
VTABLE_push_pmc(interp, cappy, st->WHAT);
Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
enc_pmc = decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, cappy, 0));
enc = REPR(enc_pmc)->box_funcs->get_str(interp, STABLE(enc_pmc), OBJECT_BODY(enc_pmc));
if (STRING_equal(interp, enc, Parrot_str_new_constant(interp, "utf8")))
encoding = Parrot_utf8_encoding_ptr;
else if (STRING_equal(interp, enc, Parrot_str_new_constant(interp, "utf16")))
encoding = Parrot_utf16_encoding_ptr;
else if (STRING_equal(interp, enc, Parrot_str_new_constant(interp, "ascii")))
encoding = Parrot_ascii_encoding_ptr;
else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Unknown encoding passed to CStr representation");
body->cstr = Parrot_str_to_encoded_cstring(interp, value, encoding);
}
INTVAL
Parrot_Run_OS_Command(PARROT_INTERP, STRING *command)
{
DWORD status = 0;
STARTUPINFO si;
PROCESS_INFORMATION pi;
char* const cmd = (char *)mem_sys_allocate(command->strlen + 4);
char* const shell = Parrot_getenv(interp, Parrot_str_new(interp, "ComSpec", strlen("ComSpec")));
char* const cmdin = Parrot_str_to_cstring(interp, command);
strcpy(cmd, "/c ");
strcat(cmd, cmdin);
Parrot_str_free_cstring(cmdin);
memset(&si, 0, sizeof (si));
si.cb = sizeof (si);
memset(&pi, 0, sizeof (pi));
/* Start the child process. */
if (!CreateProcess(shell, cmd, 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);
if (!GetExitCodeProcess(pi.hProcess, &status)) {
Parrot_warn(interp, PARROT_WARNINGS_PLATFORM_FLAG,
"Process completed: Failed to get exit code.");
}
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
Parrot_str_free_cstring(shell);
mem_sys_free(cmd);
/* Return exit code left shifted by 8 for POSIX emulation. */
return status << 8;
}
/* This Parrot-specific addition to the API is used to free an object. */
static void gc_free(PARROT_INTERP, PMC *obj) {
mem_sys_free(PMC_data(obj));
PMC_data(obj) = NULL;
}
opcode_t *
runops_slow_core(struct Parrot_Interp *interpreter, opcode_t *pc)
{
#ifdef USE_TRACE_INTERP
Interp * trace_i;
struct Parrot_Context *trace_ctx;
#endif
opcode_t *opc, *ostart, *oend;
static size_t dod, gc;
#ifdef code_start
# undef code_start
#endif
#ifdef code_end
# undef code_end
#endif
#define code_start interpreter->code->byte_code
#define code_end (interpreter->code->byte_code + \
interpreter->code->cur_cs->base.size)
#ifdef USE_TRACE_INTERP
if (Interp_flags_TEST(interpreter, PARROT_TRACE_FLAG)) {
trace_i = make_interpreter(interpreter, NO_FLAGS);
Parrot_init(trace_i);
/* remeber old context */
trace_ctx = mem_sys_allocate(sizeof(struct Parrot_Context));
mem_sys_memcopy(trace_ctx, &trace_i->ctx,
sizeof(struct Parrot_Context));
/* copy in current */
mem_sys_memcopy(&trace_i->ctx, &interpreter->ctx,
sizeof(struct Parrot_Context));
trace_i->code = interpreter->code;
Interp_flags_SET(trace_i, PARROT_EXTERN_CODE_FLAG);
}
#endif
dod = interpreter->dod_runs;
gc = interpreter->collect_runs;
while (pc) {/* && pc >= code_start && pc < code_end) {*/
interpreter->cur_pc = pc;
opc = pc;
ostart = code_start;
oend = code_end;
DO_OP(pc, interpreter);
if (Interp_flags_TEST(interpreter, PARROT_TRACE_FLAG)) {
#ifdef USE_TRACE_INTERP
mem_sys_memcopy(&trace_i->ctx, &interpreter->ctx,
sizeof(struct Parrot_Context));
trace_op(trace_i, ostart, oend, opc);
#else
trace_op(interpreter, ostart, oend, opc);
#endif
if (dod != interpreter->dod_runs) {
dod = interpreter->dod_runs;
PIO_printf(interpreter, " DOD\n");
}
if (gc != interpreter->collect_runs) {
gc = interpreter->collect_runs;
PIO_printf(interpreter, " GC\n");
}
}
}
#ifdef USE_TRACE_INTERP
if (Interp_flags_TEST(interpreter, PARROT_TRACE_FLAG)) {
/* restore trace context */
mem_sys_memcopy(&trace_i->ctx, trace_ctx,
sizeof(struct Parrot_Context));
mem_sys_free(trace_ctx);
}
#endif
/* if (pc && (pc < code_start || pc >= code_end)) {
internal_exception(INTERP_ERROR,
"Error: Control left bounds of byte-code block (now at location %d)!\n",
(int)(pc - code_start));
}*/
#undef code_start
#undef code_end
return pc;
}
/* This Parrot-specific addition to the API is used to free an object. */
static void gc_free(PARROT_INTERP, PMC *obj) {
UNUSED(interp);
mp_clear(&((P6bigintInstance *)PMC_data(obj))->body.i);
mem_sys_free(PMC_data(obj));
PMC_data(obj) = NULL;
}
static void gc_free(PARROT_INTERP, PMC *obj) {
CStrBody *body = (CStrBody *) OBJECT_BODY(obj);
if(IS_CONCRETE(obj) && body->cstr)
mem_sys_free(body->cstr);
}
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;
}
}
static int
process_events(QUEUE* event_q)
{
FLOATVAL now;
QUEUE_ENTRY *entry;
parrot_event* event;
while (( entry = peek_entry(event_q))) {
/*
* one or more entries arrived - we hold the mutex again
* so we have to use the nonsyc_pop_entry to pop off event entries
*/
event = NULL;
switch (entry->type) {
case QUEUE_ENTRY_TYPE_EVENT:
entry = nosync_pop_entry(event_q);
event = entry->data;
break;
case QUEUE_ENTRY_TYPE_TIMED_EVENT:
event = entry->data;
now = Parrot_floatval_time();
/*
* if the timer_event isn't due yet, ignore the event
* (we were signalled on insert of the event)
* wait until we get at it again when time has elapsed
*/
if (now < event->u.timer_event.abs_time)
return 1;
entry = nosync_pop_entry(event_q);
/*
* if event is repeated dup and reinsert it
*/
if (event->u.timer_event.interval) {
if (event->u.timer_event.repeat) {
if (event->u.timer_event.repeat != -1)
event->u.timer_event.repeat--;
nosync_insert_entry(event_q,
dup_entry_interval(entry, now));
}
}
break;
default:
internal_exception(1, "Unknown queue entry");
}
assert(event);
if (event->type == EVENT_TYPE_NONE) {
mem_sys_free(entry);
mem_sys_free(event);
continue;
}
else if (event->type == EVENT_TYPE_EVENT_TERMINATE) {
mem_sys_free(entry);
mem_sys_free(event);
return 0;
}
/*
* now insert entry in interpreter task queue
*/
if (event->interp) {
Parrot_schedule_interp_qentry(event->interp, entry);
}
else {
Parrot_schedule_broadcast_qentry(entry);
}
} /* while events */
return 1;
}
/* This Parrot-specific addition to the API is used to free an object. */
static void gc_free(PARROT_INTERP, PMC *obj) {
UNUSED(interp);
mem_sys_free(PMC_data(obj));
PMC_data(obj) = NULL;
}
PARROT_EXPORT
PARROT_CAN_RETURN_NULL
PackFile *
Parrot_pbc_read(PARROT_INTERP, ARGIN_NULLOK(const char *fullname), const int debug)
{
PackFile *pf;
char *program_code;
FILE *io = NULL;
INTVAL is_mapped = 0;
INTVAL program_size;
#ifdef PARROT_HAS_HEADER_SYSMMAN
int fd = -1;
#endif
if (!fullname || STREQ(fullname, "-")) {
/* read from STDIN */
io = stdin;
/* read 1k at a time */
program_size = 0;
}
else {
STRING * const fs = string_make(interp, fullname, strlen(fullname),
NULL, 0);
/* can't read a file that doesn't exist */
if (!Parrot_stat_info_intval(interp, fs, STAT_EXISTS)) {
Parrot_io_eprintf(interp, "Parrot VM: Can't stat %s, code %i.\n",
fullname, errno);
return NULL;
}
/* we may need to relax this if we want to read bytecode from pipes */
if (!Parrot_stat_info_intval(interp, fs, STAT_ISREG)) {
Parrot_io_eprintf(interp,
"Parrot VM: '%s', is not a regular file %i.\n",
fullname, errno);
return NULL;
}
program_size = Parrot_stat_info_intval(interp, fs, STAT_FILESIZE);
#ifndef PARROT_HAS_HEADER_SYSMMAN
io = fopen(fullname, "rb");
if (!io) {
Parrot_io_eprintf(interp, "Parrot VM: Can't open %s, code %i.\n",
fullname, errno);
return NULL;
}
#endif /* PARROT_HAS_HEADER_SYSMMAN */
}
#ifdef PARROT_HAS_HEADER_SYSMMAN
again:
#endif
/* if we've opened a file (or stdin) with PIO, read it in */
if (io) {
char *cursor;
size_t chunk_size = program_size > 0 ? program_size : 1024;
INTVAL wanted = program_size;
size_t read_result;
program_code = mem_allocate_n_typed(chunk_size, char);
cursor = program_code;
program_size = 0;
while ((read_result = fread(cursor, 1, chunk_size, io)) > 0) {
program_size += read_result;
if (program_size == wanted)
break;
chunk_size = 1024;
mem_realloc_n_typed(program_code, program_size + chunk_size, char);
if (!program_code) {
Parrot_io_eprintf(interp,
"Parrot VM: Could not reallocate buffer "
"while reading packfile from PIO.\n");
fclose(io);
return NULL;
}
cursor = (char *)(program_code + program_size);
}
if (ferror(io)) {
Parrot_io_eprintf(interp,
"Parrot VM: Problem reading packfile from PIO: code %d.\n",
ferror(io));
fclose(io);
mem_sys_free(program_code);
return NULL;
}
fclose(io);
}
else {
/* if we've gotten here, we opted not to use PIO to read the file.
* use mmap */
#ifdef PARROT_HAS_HEADER_SYSMMAN
/* check that fullname isn't NULL, just in case */
if (!fullname)
/* This Parrot-specific addition to the API is used to free an object. */
static void gc_free(PARROT_INTERP, PMC *obj) {
gc_cleanup(interp, STABLE(obj), OBJECT_BODY(obj));
mem_sys_free(PMC_data(obj));
PMC_data(obj) = NULL;
}
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
static STRING *
to_encoding(PARROT_INTERP, ARGIN(STRING *src), ARGIN_NULLOK(STRING *dest))
{
ASSERT_ARGS(to_encoding)
#if PARROT_HAS_ICU
UErrorCode err;
int dest_len;
UChar *p;
#endif
int src_len;
int in_place = dest == NULL;
STRING *result;
if (src->encoding == Parrot_utf16_encoding_ptr ||
src->encoding == Parrot_ucs2_encoding_ptr)
return in_place ? src : Parrot_str_copy(interp, src);
/*
* TODO adapt string creation functions
*/
src_len = src->strlen;
if (in_place) {
result = src;
}
else {
result = dest;
}
if (!src_len) {
result->charset = Parrot_unicode_charset_ptr;
result->encoding = Parrot_ucs2_encoding_ptr;
result->strlen = result->bufused = 0;
return result;
}
/*
u_strFromUTF8(UChar *dest,
int32_t destCapacity,
int32_t *pDestLength,
const char *src,
int32_t srcLength,
UErrorCode *pErrorCode);
*/
#if PARROT_HAS_ICU
if (in_place) {
/* need intermediate memory */
p = (UChar *)mem_sys_allocate(src_len * sizeof (UChar));
}
else {
Parrot_gc_reallocate_string_storage(interp, dest, sizeof (UChar) * src_len);
p = (UChar *)dest->strstart;
}
if (src->charset == Parrot_iso_8859_1_charset_ptr ||
src->charset == Parrot_ascii_charset_ptr) {
for (dest_len = 0; dest_len < (int)src->strlen; ++dest_len) {
p[dest_len] = (UChar)((unsigned char*)src->strstart)[dest_len];
}
}
else {
err = U_ZERO_ERROR;
u_strFromUTF8(p, src_len,
&dest_len, src->strstart, src->bufused, &err);
if (!U_SUCCESS(err)) {
/*
* have to resize - required len in UChars is in dest_len
*/
if (in_place)
p = (UChar *)mem_sys_realloc(p, dest_len * sizeof (UChar));
else {
result->bufused = dest_len * sizeof (UChar);
Parrot_gc_reallocate_string_storage(interp, dest,
sizeof (UChar) * dest_len);
p = (UChar *)dest->strstart;
}
u_strFromUTF8(p, dest_len,
&dest_len, src->strstart, src->bufused, &err);
PARROT_ASSERT(U_SUCCESS(err));
}
}
result->bufused = dest_len * sizeof (UChar);
if (in_place) {
Parrot_gc_reallocate_string_storage(interp, src, src->bufused);
memcpy(src->strstart, p, src->bufused);
mem_sys_free(p);
}
result->charset = Parrot_unicode_charset_ptr;
result->encoding = Parrot_utf16_encoding_ptr;
result->strlen = src_len;
/* downgrade if possible */
if (dest_len == (int)src->strlen)
result->encoding = Parrot_ucs2_encoding_ptr;
return result;
#else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_LIBRARY_ERROR,
"no ICU lib loaded");
#endif
}
/* 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);
}
}
