opcode_t*
PF_store_string(opcode_t *cursor, STRING *s)
{
opcode_t padded_size = s->bufused;
char *charcursor;
size_t i;
if (padded_size % sizeof(opcode_t)) {
padded_size += sizeof(opcode_t) - (padded_size % sizeof(opcode_t));
}
*cursor++ = PObj_get_FLAGS(s); /* only constant_FLAG */
*cursor++ = s->encoding->index;
*cursor++ = s->type->index;
*cursor++ = s->bufused;
/* Switch to char * since rest of string is addressed by
* characters to ensure padding. */
charcursor = (char *)cursor;
if (s->strstart) {
mem_sys_memcopy(charcursor, s->strstart, s->bufused);
charcursor += s->bufused;
if (s->bufused % sizeof(opcode_t)) {
for (i = 0; i < (sizeof(opcode_t) -
(s->bufused % sizeof(opcode_t))); i++) {
*charcursor++ = 0;
}
}
}
assert( ((int)charcursor & 3) == 0);
LVALUE_CAST(char *, cursor) = charcursor;
return cursor;
}
void
Parrot_gc_sweep_pool(PARROT_INTERP,
ARGMOD(Memory_Pools *mem_pools),
ARGMOD(Fixed_Size_Pool *pool))
{
ASSERT_ARGS(Parrot_gc_sweep_pool)
PObj *b;
Fixed_Size_Arena *cur_arena;
UINTVAL total_used = 0;
const UINTVAL object_size = pool->object_size;
const gc_object_fn_type gc_object = pool->gc_object;
const add_free_object_fn_type add_free_object = pool->add_free_object;
/* Run through all the PObj header pools and mark */
for (cur_arena = pool->last_Arena; cur_arena; cur_arena = cur_arena->prev) {
const size_t objects_end = cur_arena->used;
UINTVAL i;
b = (PObj *)cur_arena->start_objects;
/* loop only while there are objects in the arena */
for (i = objects_end; i; --i) {
/* if it's on free list, do nothing */
if (PObj_live_TEST(b)) {
++total_used;
PObj_live_CLEAR(b);
PObj_get_FLAGS(b) &= ~PObj_custom_GC_FLAG;
}
else if (!PObj_on_free_list_TEST(b)) {
/* it must be dead */
if (PObj_is_shared_TEST(b)) {
/* only mess with shared objects if we
* (and thus everyone) is suspended for
* a GC run.
* XXX wrong thing to do with "other" GCs
*/
if (!(interp->thread_data
&& (interp->thread_data->state & THREAD_STATE_SUSPENDED_GC))) {
++total_used;
goto next;
}
}
if (gc_object)
gc_object(interp, mem_pools, pool, b);
add_free_object(interp, mem_pools, pool, b);
}
next:
b = (PObj *)((char *)b + object_size);
}
}
pool->num_free_objects = pool->total_objects - total_used;
}
static void
pf_const_dump_str(PARROT_INTERP, ARGIN(const STRING *self))
{
ASSERT_ARGS(pf_const_dump_str)
Parrot_io_printf(interp, " [ 'PFC_STRING', {\n");
pobj_flag_dump(interp, (long)PObj_get_FLAGS(self));
Parrot_io_printf(interp, " ENCODING => %s,\n", self->encoding->name);
Parrot_io_printf(interp, " SIZE => %ld,\n", self->bufused);
Parrot_io_printf(interp, " DATA => \"%Ss\"\n",
Parrot_str_escape(interp, self));
Parrot_io_printf(interp, " } ],\n");
}
void
mark_special(PARROT_INTERP, ARGMOD(Memory_Pools *mem_pools), ARGIN(PMC *obj))
{
ASSERT_ARGS(mark_special)
PObj_get_FLAGS(obj) |= PObj_custom_GC_FLAG;
/* clearing the flag is much more expensive then testing */
if (!PObj_needs_early_gc_TEST(obj))
PObj_high_priority_gc_CLEAR(obj);
/* mark properties */
Parrot_gc_mark_PMC_alive(interp, PMC_metadata(obj));
if (PObj_custom_mark_TEST(obj)) {
PARROT_ASSERT(!PObj_on_free_list_TEST(obj));
VTABLE_mark(interp, obj);
}
}
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
opcode_t *
blizkost_return_from_invoke(PARROT_INTERP, void *next) {
/* The following code is cargo culted from nci.pmc */
PMC *cont = interp->current_cont;
/*
* If the NCI function was tailcalled, the return result
* is already passed back to the caller of this frame
* - see Parrot_init_ret_nci(). We therefore invoke the
* return continuation here, which gets rid of this frame
* and returns the real return address
*/
if (cont && cont != NEED_CONTINUATION
&& (PObj_get_FLAGS(cont) & SUB_FLAG_TAILCALL)) {
cont = Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp));
next = VTABLE_invoke(interp, cont, next);
}
return (opcode_t *)next;
}
static void
PackFile_Constant_dump(PARROT_INTERP, ARGIN(const PackFile_ConstTable *ct),
ARGIN(const PackFile_Constant *self))
{
ASSERT_ARGS(PackFile_Constant_dump)
PMC *key;
size_t i;
switch (self->type) {
case PFC_NUMBER:
Parrot_io_printf(interp, " [ 'PFC_NUMBER', %g ],\n", self->u.number);
break;
case PFC_STRING:
Parrot_io_printf(interp, " [ 'PFC_STRING', {\n");
pobj_flag_dump(interp, (long)PObj_get_FLAGS(self->u.string));
Parrot_io_printf(interp, " CHARSET => %ld,\n",
self->u.string->charset);
i = self->u.string->bufused;
Parrot_io_printf(interp, " SIZE => %ld,\n",
(long)i);
Parrot_io_printf(interp, " DATA => \"%Ss\"\n",
Parrot_str_escape(interp, self->u.string));
Parrot_io_printf(interp, " } ],\n");
break;
case PFC_KEY:
for (i = 0, key = self->u.key; key; i++) {
GETATTR_Key_next_key(interp, key, key);
}
/* number of key components */
Parrot_io_printf(interp, " [ 'PFC_KEY' (%ld items)\n", i);
/* and now type / value per component */
for (key = self->u.key; key;) {
opcode_t type = PObj_get_FLAGS(key);
Parrot_io_printf(interp, " {\n");
type &= KEY_type_FLAGS;
pobj_flag_dump(interp, (long)PObj_get_FLAGS(key));
switch (type) {
case KEY_integer_FLAG:
Parrot_io_printf(interp, " TYPE => INTEGER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_number_FLAG:
{
const PackFile_Constant *detail;
size_t ct_index;
Parrot_io_printf(interp, " TYPE => NUMBER\n");
ct_index = PackFile_find_in_const(interp, ct, key, PFC_NUMBER);
Parrot_io_printf(interp, " PFC_OFFSET => %ld\n", ct_index);
detail = ct->constants[ct_index];
Parrot_io_printf(interp, " DATA => %ld\n", detail->u.number);
Parrot_io_printf(interp, " },\n");
}
break;
case KEY_string_FLAG:
{
const PackFile_Constant *detail;
size_t ct_index;
Parrot_io_printf(interp, " TYPE => STRING\n");
ct_index = PackFile_find_in_const(interp, ct, key, PFC_STRING);
Parrot_io_printf(interp, " PFC_OFFSET => %ld\n", ct_index);
detail = ct->constants[ct_index];
Parrot_io_printf(interp, " DATA => '%Ss'\n",
detail->u.string);
Parrot_io_printf(interp, " },\n");
}
break;
case KEY_integer_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => I REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_number_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => N REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_string_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => S REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_pmc_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => P REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
default:
Parrot_io_eprintf(NULL, "PackFile_Constant_pack: "
"unsupported constant type\n");
Parrot_exit(interp, 1);
}
GETATTR_Key_next_key(interp, key, key);
}
Parrot_io_printf(interp, " ],\n");
break;
case PFC_PMC:
Parrot_io_printf(interp, " [ 'PFC_PMC', {\n");
{
PMC * const pmc = self->u.key;
Parrot_Sub_attributes *sub;
STRING * const null = Parrot_str_new_constant(interp, "(null)");
STRING *namespace_description;
pobj_flag_dump(interp, (long)PObj_get_FLAGS(pmc));
switch (pmc->vtable->base_type) {
case enum_class_FixedBooleanArray:
case enum_class_FixedFloatArray:
case enum_class_FixedPMCArray:
case enum_class_FixedStringArray:
case enum_class_ResizableBooleanArray:
case enum_class_ResizableIntegerArray:
case enum_class_ResizableFloatArray:
case enum_class_ResizablePMCArray:
case enum_class_ResizableStringArray:
{
const int n = VTABLE_get_integer(interp, pmc);
STRING* const out_buffer = VTABLE_get_repr(interp, pmc);
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\telement count => %d,\n"
"\telements => %Ss,\n",
pmc->vtable->whoami,
n,
out_buffer);
}
break;
case enum_class_Sub:
case enum_class_Coroutine:
PMC_get_sub(interp, pmc, sub);
if (sub->namespace_name) {
switch (sub->namespace_name->vtable->base_type) {
case enum_class_String:
namespace_description = Parrot_str_new(interp, "'", 1);
namespace_description = Parrot_str_append(interp,
namespace_description,
VTABLE_get_string(interp, sub->namespace_name));
namespace_description = Parrot_str_append(interp,
namespace_description,
Parrot_str_new(interp, "'", 1));
break;
case enum_class_Key:
namespace_description =
key_set_to_string(interp, sub->namespace_name);
break;
default:
namespace_description = sub->namespace_name->vtable->whoami;
}
}
else {
namespace_description = null;
}
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\tstart_offs => %d,\n"
"\tend_offs => %d,\n"
"\tname => '%Ss',\n"
"\tsubid => '%Ss',\n"
"\tmethod => '%Ss',\n"
"\tnsentry => '%Ss',\n"
"\tnamespace => %Ss\n"
"\tHLL_id => %d,\n",
pmc->vtable->whoami,
sub->start_offs,
sub->end_offs,
sub->name,
sub->subid,
sub->method_name,
sub->ns_entry_name,
namespace_description,
sub->HLL_id);
break;
case enum_class_FixedIntegerArray:
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\trepr => '%Ss'\n",
pmc->vtable->whoami,
VTABLE_get_repr(interp, pmc));
break;
default:
Parrot_io_printf(interp, "\tno dump info for PMC %ld %Ss\n",
pmc->vtable->base_type, pmc->vtable->whoami);
Parrot_io_printf(interp, "\tclass => %Ss,\n", pmc->vtable->whoami);
}
}
Parrot_io_printf(interp, " } ],\n");
break;
default:
Parrot_io_printf(interp, " [ 'PFC_\?\?\?', type '0x%x' ],\n",
self->type);
break;
}
}