Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 847cb9bcc7
Fetching contributors…

Cannot retrieve contributors at this time

1208 lines (854 sloc) 36.109 kB
/*
Copyright (C) 2001-2012, Parrot Foundation.
=head1 NAME
src/pmc/sub.pmc - Subroutine
=head1 DESCRIPTION
These are the vtable functions for the Sub (subroutine) base class
=head2 Functions
=over 4
=cut
*/
#include "parrot/oplib/ops.h"
#include "parrot/oplib/core_ops.h"
#include "sub.str"
/* HEADERIZER HFILE: none */
/* HEADERIZER BEGIN: static */
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
static void print_sub_name(PARROT_INTERP, ARGIN_NULLOK(PMC *sub))
__attribute__nonnull__(1);
#define ASSERT_ARGS_print_sub_name __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
PARROT_ASSERT_ARG(interp))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */
/* HEADERIZER END: static */
/*
=item C<static void print_sub_name(PARROT_INTERP, PMC *sub)>
static function to print the name of the sub (for tracing/debugging)
=cut
*/
static void
print_sub_name(PARROT_INTERP, ARGIN_NULLOK(PMC *sub))
{
ASSERT_ARGS(print_sub_name)
Interp * const tracer = (interp->pdb && interp->pdb->debugger)
? interp->pdb->debugger
: interp;
/* sub was located via globals */
Parrot_io_eprintf(tracer, "# Calling sub '%Ss'\n# ",
Parrot_sub_full_sub_name(interp, sub));
print_pbc_location(interp);
}
pmclass Sub auto_attrs provides invokable {
ATTR PackFile_ByteCode *seg; /* bytecode segment */
ATTR size_t start_offs; /* sub entry in ops from seg->base.data */
ATTR size_t end_offs;
ATTR INTVAL HLL_id; /* see src/hll.c XXX or per segment? */
ATTR PMC *namespace_name; /* where this Sub is in - this is either
* a String or a [Key] and describes
* the relative path in the NameSpace
*/
ATTR PMC *namespace_stash; /* the actual hash, HLL::namespace */
ATTR STRING *name; /* name of the sub */
ATTR STRING *method_name; /* method name of the sub */
ATTR STRING *ns_entry_name; /* ns entry name of the sub */
ATTR STRING *subid; /* The ID of the sub. */
ATTR INTVAL vtable_index; /* index in Parrot_vtable_slot_names */
ATTR PMC *multi_signature; /* list of types for MMD */
ATTR UINTVAL n_regs_used[4]; /* INSP in PBC */
ATTR PMC *lex_info; /* LexInfo PMC */
ATTR PMC *outer_sub; /* :outer for closures */
ATTR PMC *ctx; /* the context this sub is in */
ATTR UINTVAL comp_flags; /* compile time and additional flags */
ATTR Parrot_sub_arginfo *arg_info; /* Argument counts and flags. */
ATTR PMC *outer_ctx; /* outer context, if a closure */
/*
=item C<void init()>
Initializes the subroutine.
=cut
*/
/*
* Sub PMC's flags usage:
* - private0 ... Coroutine flip/flop - C exception handler
* - private1 ... _IS_OUTER - have to preserve context
* as some other sub has :outer(this)
* - private2 ... tailcall invoked this Sub
* - private3 ... pythonic coroutine generator flag
* - private4 ... :main (originally @MAIN)
* - private5 ... :load (originally @LOAD)
* - private6 ... :immediate (originally @IMMEDIATE)
* - private7 ... :postcomp (originally @POSTCOMP)
*
* see also the enum in include/parrot/sub.h
*/
VTABLE void init() {
Parrot_Sub_attributes * const attrs =
PMC_data_typed(SELF, Parrot_Sub_attributes *);
attrs->seg = INTERP->code;
attrs->outer_sub = PMCNULL;
attrs->multi_signature = PMCNULL;
attrs->namespace_name = PMCNULL;
attrs->vtable_index = -1;
PObj_custom_mark_destroy_SETALL(SELF);
}
/*
=item C<void init_pmc()>
Initializes the "detached" subroutine from passed Hash. "Detached" means that
surboutine is fully constructed but not attached to interpreter.
=cut
*/
VTABLE void init_pmc(PMC* init) {
Parrot_Sub_attributes * const attrs =
PMC_data_typed(SELF, Parrot_Sub_attributes *);
STRING *field = CONST_STRING(INTERP, "start_offs");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->start_offs = VTABLE_get_integer_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "end_offs");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->end_offs = VTABLE_get_integer_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "HLL_id");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->HLL_id = VTABLE_get_integer_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "namespace_name");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->namespace_name = VTABLE_get_pmc_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "namespace_stash");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->namespace_stash = VTABLE_get_pmc_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "name");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->name = VTABLE_get_string_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "method_name");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->method_name = VTABLE_get_string_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "ns_entry_name");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->ns_entry_name = VTABLE_get_string_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "subid");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->subid = VTABLE_get_string_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "vtable_index");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->vtable_index = VTABLE_get_integer_keyed_str(INTERP, init, field);
else
attrs->vtable_index = -1;
field = CONST_STRING(INTERP, "multi_signature");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->multi_signature = VTABLE_get_pmc_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "lex_info");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->lex_info = VTABLE_get_pmc_keyed_str(INTERP, init, field);
field = CONST_STRING(INTERP, "outer_sub");
if (VTABLE_exists_keyed_str(INTERP, init, field))
attrs->outer_sub = VTABLE_get_pmc_keyed_str(INTERP, init, field);
/* comp_flags is actually UINTVAL */
field = CONST_STRING(INTERP, "comp_flags");
if (VTABLE_exists_keyed_str(INTERP, init, field)) {
const UINTVAL flags = (UINTVAL)VTABLE_get_integer_keyed_str(INTERP, init, field);
/* Mask comp flags only */
attrs->comp_flags = flags & SUB_COMP_FLAG_MASK;
}
/* In order to create Sub dynamicaly we have to set PObj flags */
field = CONST_STRING(INTERP, "pf_flags");
if (VTABLE_exists_keyed_str(INTERP, init, field)) {
const UINTVAL flags = (UINTVAL)VTABLE_get_integer_keyed_str(INTERP, init, field);
/* Mask Sub specific flags only */
PObj_get_FLAGS(SELF) |= flags & SUB_FLAG_PF_MASK;
}
field = CONST_STRING(INTERP, "n_regs_used");
if (VTABLE_exists_keyed_str(INTERP, init, field)) {
PMC * const tmp = VTABLE_get_pmc_keyed_str(INTERP, init, field);
INTVAL i;
for (i = 0; i < 4; ++i)
attrs->n_regs_used[i] = VTABLE_get_integer_keyed_int(INTERP, tmp, i);
}
field = CONST_STRING(INTERP, "arg_info");
if (VTABLE_exists_keyed_str(INTERP, init, field)) {
PMC * const tmp = VTABLE_get_pmc_keyed_str(INTERP, init, field);
/* Allocate structure to store argument information in. */
attrs->arg_info = mem_gc_allocate_zeroed_typed(INTERP,
Parrot_sub_arginfo);
/*
Hash.get_integer_keyed_str return 0 if key doesn't exists.
So, don't check existence of key, just use it.
NB: Don't split line. CONST_STRING b0rked.
*/
attrs->arg_info->pos_required = VTABLE_get_integer_keyed_str(INTERP, tmp, CONST_STRING(INTERP, "pos_required"));
attrs->arg_info->pos_optional = VTABLE_get_integer_keyed_str(INTERP, tmp, CONST_STRING(INTERP, "pos_optional"));
attrs->arg_info->pos_slurpy = VTABLE_get_integer_keyed_str(INTERP, tmp, CONST_STRING(INTERP, "pos_slurpy"));
attrs->arg_info->named_required = VTABLE_get_integer_keyed_str(INTERP, tmp, CONST_STRING(INTERP, "named_required"));
attrs->arg_info->named_optional = VTABLE_get_integer_keyed_str(INTERP, tmp, CONST_STRING(INTERP, "named_optional"));
attrs->arg_info->named_slurpy = VTABLE_get_integer_keyed_str(INTERP, tmp, CONST_STRING(INTERP, "named_slurpy"));
}
/* C<ctx> not handled here, and shouldn't be, because of run-time nature. */
PObj_custom_mark_destroy_SETALL(SELF);
}
/*
=item C<void destroy()>
Destroys the subroutine.
=cut
*/
VTABLE void destroy() {
Parrot_Sub_attributes * const sub = PARROT_SUB(SELF);
if (sub && sub->arg_info)
mem_gc_free(INTERP, sub->arg_info);
}
/*
=item C<STRING *get_string()>
Returns the name of the subroutine.
=item C<void set_string_native(STRING *subname)>
Sets the name of the subroutine.
=cut
*/
VTABLE STRING *get_string() {
STRING *name;
GET_ATTR_name(INTERP, SELF, name);
return name;
}
VTABLE void set_string_native(STRING *subname) {
SET_ATTR_name(INTERP, SELF, subname);
}
/*
=item C<void set_pointer(void *value)>
Sets the pointer to the actual subroutine.
*** Don't use that - use C<.const 'Sub'> in PIR instead ***
=cut
*/
VTABLE void set_pointer(void *value) {
UNUSED(value)
Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_INVALID_OPERATION,
"Don't set the address of a sub\nuse .const 'Sub' instead");
}
/*
=item C<void *get_pointer()>
Returns the address of the actual subroutine.
=cut
*/
VTABLE void *get_pointer() {
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
return sub->seg->base.data + sub->start_offs;
}
/*
=item C<INTVAL get_integer_keyed(PMC *key)>
I<This just unconditionally returns the start of bytecode. It's wrong,
wrong, wrong, *WRONG*. And there's no other good way, so it's here for
now.> -DRS
=cut
*/
VTABLE INTVAL get_integer_keyed(PMC *key) {
UNUSED(key)
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
return (INTVAL) (sub->seg->base.data);
}
/*
=item C<INTVAL defined()>
=item C<INTVAL get_bool()>
Returns True.
=cut
*/
VTABLE INTVAL defined() {
return 1;
}
VTABLE INTVAL get_bool() {
return 1;
}
/*
=item C<opcode_t *invoke(void *next)>
Invokes the subroutine.
=cut
*/
VTABLE opcode_t *invoke(void *next) {
PMC * const caller_ctx = CURRENT_CONTEXT(INTERP);
PMC *ccont = INTERP->current_cont;
/* plain subroutine call
* create new context, place it in interpreter */
PMC *context = Parrot_pcc_get_signature(INTERP, caller_ctx);
Parrot_Sub_attributes *sub;
opcode_t *pc;
PMC_get_sub(INTERP, SELF, sub);
if (Interp_trace_TEST(INTERP, PARROT_TRACE_SUB_CALL_FLAG))
print_sub_name(INTERP, SELF);
/*
* A remark WRT tail calls
*
* we have:
* sub A:
* ...
* B()
* ...
* sub B:
* ...
* .return C(...)
*
* that is the sub B() returns whatever C() returns.
*
* We are just calling the sub C().
* If the private2 flag is set, this code is called by a
* tailcall opcode.
*
* We allocate a new register frame and recycle it
* immediately after argument passing.
*
*/
pc = sub->seg->base.data + sub->start_offs;
INTERP->current_cont = NULL;
PARROT_ASSERT(!PMC_IS_NULL(ccont));
if (PMC_IS_NULL(context))
context = Parrot_pmc_new(INTERP, enum_class_CallContext);
Parrot_pcc_set_context(INTERP, context);
Parrot_pcc_set_caller_ctx(INTERP, context, caller_ctx);
/* support callcontext reuse */
if (context == caller_ctx)
Parrot_pcc_free_registers(INTERP, context);
Parrot_pcc_allocate_registers(INTERP, context, sub->n_regs_used);
Parrot_pcc_init_context(INTERP, context, caller_ctx);
Parrot_pcc_set_sub(INTERP, context, SELF);
Parrot_pcc_set_continuation(INTERP, context, ccont);
Parrot_pcc_set_constants(INTERP, context, sub->seg->const_table);
/* check recursion/call depth */
if (Parrot_pcc_inc_recursion_depth(INTERP, context) > INTERP->recursion_limit)
Parrot_ex_throw_from_c_args(INTERP, next, EXCEPTION_INTERNAL_PANIC,
"maximum recursion depth exceeded");
/* and copy set context variables */
PARROT_GC_WRITE_BARRIER(interp, ccont);
PARROT_CONTINUATION(ccont)->from_ctx = context;
/* if this is an outer sub, then we need to set sub->ctx
* to the new context */
if (PObj_get_FLAGS(SELF) & SUB_FLAG_IS_OUTER) {
PARROT_GC_WRITE_BARRIER(interp, SELF);
sub->ctx = context;
}
/* create pad if needed
* TODO move this up in front of argument passing
* and factor out common code with coroutine pmc
*/
if (!PMC_IS_NULL(sub->lex_info)) {
Parrot_pcc_set_lex_pad(INTERP, context, Parrot_pmc_new_init(INTERP,
Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_LexPad),
sub->lex_info));
VTABLE_set_pointer(INTERP, Parrot_pcc_get_lex_pad(INTERP, context), context);
}
/* set outer context */
if (!PMC_IS_NULL(sub->outer_ctx))
Parrot_pcc_set_outer_ctx(INTERP, context, sub->outer_ctx);
else {
/* autoclose */
PMC *c = context;
PMC *outer_c = Parrot_pcc_get_outer_ctx(INTERP, c);
for (c = context;
PMC_IS_NULL(outer_c);
c = outer_c, outer_c = Parrot_pcc_get_outer_ctx(INTERP, c)) {
PMC *outer_pmc;
Parrot_Sub_attributes *current_sub, *outer_sub;
PMC_get_sub(INTERP, Parrot_pcc_get_sub(INTERP, c), current_sub);
outer_pmc = current_sub->outer_sub;
if (PMC_IS_NULL(outer_pmc))
break;
PMC_get_sub(INTERP, outer_pmc, outer_sub);
if (PMC_IS_NULL(outer_sub->ctx)) {
PMC * const dummy = Parrot_alloc_context(INTERP,
outer_sub->n_regs_used, PMCNULL);
Parrot_pcc_set_sub(INTERP, dummy, outer_pmc);
if (!PMC_IS_NULL(outer_sub->lex_info)) {
Parrot_pcc_set_lex_pad(INTERP, dummy,
Parrot_pmc_new_init(INTERP,
Parrot_hll_get_ctx_HLL_type(INTERP,
enum_class_LexPad), outer_sub->lex_info));
VTABLE_set_pointer(INTERP,
Parrot_pcc_get_lex_pad(INTERP, dummy), dummy);
}
if (!PMC_IS_NULL(outer_sub->outer_ctx))
Parrot_pcc_set_outer_ctx(INTERP, dummy,
outer_sub->outer_ctx);
PARROT_GC_WRITE_BARRIER(interp, outer_pmc);
outer_sub->ctx = dummy;
}
Parrot_pcc_set_outer_ctx(INTERP, c, outer_sub->ctx);
outer_c = outer_sub->ctx;
}
}
/* switch code segment if needed */
if (INTERP->code != sub->seg)
Parrot_switch_to_cs(INTERP, sub->seg, 1);
return pc;
}
/*
=item C<PMC *clone()>
Creates and returns a clone of the subroutine.
=cut
*/
VTABLE PMC *clone() {
PMC * const ret = Parrot_pmc_new(INTERP, SELF->vtable->base_type);
Parrot_Sub_attributes *dest_sub;
Parrot_Sub_attributes *sub;
/* XXX Why? */
/* we have to mark it ourselves */
PObj_custom_mark_destroy_SETALL(ret);
PMC_get_sub(INTERP, SELF, dest_sub);
PMC_get_sub(INTERP, ret, sub);
/* first set the sub struct, Parrot_str_copy may cause GC */
*sub = *dest_sub;
/* Be sure not to share arg_info. */
dest_sub->arg_info = NULL;
return ret;
}
/*
=item C<void assign_pmc(PMC *other)>
Set SELF to the data in other.
=cut
*/
VTABLE void set_pmc(PMC *other) {
SELF.assign_pmc(other);
}
VTABLE void assign_pmc(PMC *other) {
/* only handle the case where the other PMC is the same type */
if (other->vtable->base_type == SELF->vtable->base_type) {
Parrot_Sub_attributes *my_sub;
Parrot_Sub_attributes *other_sub;
PMC_get_sub(INTERP, SELF, my_sub);
PMC_get_sub(INTERP, other, other_sub);
/* copy the sub struct */
memmove(my_sub, other_sub, sizeof (Parrot_Sub_attributes));
}
else
Parrot_ex_throw_from_c_args(INTERP, NULL,
EXCEPTION_INVALID_OPERATION,
"Can't assign a non-Sub type to a Sub");
}
/*
=item C<void mark()>
Marks the sub as live.
=cut
*/
VTABLE void mark() {
Parrot_Sub_attributes * const sub = PARROT_SUB(SELF);
if (!sub)
return;
Parrot_gc_mark_STRING_alive(INTERP, sub->name);
Parrot_gc_mark_STRING_alive(INTERP, sub->subid);
Parrot_gc_mark_STRING_alive(INTERP, sub->method_name);
Parrot_gc_mark_STRING_alive(INTERP, sub->ns_entry_name);
Parrot_gc_mark_PMC_alive(INTERP, sub->ctx);
Parrot_gc_mark_PMC_alive(INTERP, sub->lex_info);
Parrot_gc_mark_PMC_alive(INTERP, sub->outer_ctx);
Parrot_gc_mark_PMC_alive(INTERP, sub->outer_sub);
Parrot_gc_mark_PMC_alive(INTERP, sub->namespace_name);
Parrot_gc_mark_PMC_alive(INTERP, sub->multi_signature);
Parrot_gc_mark_PMC_alive(INTERP, sub->namespace_stash);
/* XXX
* Workaround for things that subclass sub but don't point into packfiles
* (eg: EventHandler)
* TODO: use inheritance properly to avoid this
*/
if (sub->seg)
Parrot_gc_mark_PMC_alive(INTERP, sub->seg->base.pf->view);
}
/*
=item C<INTVAL is_equal(PMC *value)>
Returns whether the two subroutines are equal.
=cut
*/
MULTI INTVAL is_equal(PMC *value) {
Parrot_Sub_attributes *my_sub, *value_sub;
PMC_get_sub(INTERP, SELF, my_sub);
PMC_get_sub(INTERP, value, value_sub);
return SELF->vtable == value->vtable
&& (my_sub)->start_offs == (value_sub)->start_offs
&& (my_sub)->seg == (value_sub)->seg;
}
/*
=item C<void visit(PMC *info)>
This is used by freeze/thaw to visit the contents of the sub.
=item C<void freeze(PMC *info)>
Archives the subroutine.
=cut
*/
VTABLE void visit(PMC *info) {
VISIT_PMC_ATTR(INTERP, info, SELF, Sub, namespace_name);
VISIT_PMC_ATTR(INTERP, info, SELF, Sub, multi_signature);
VISIT_PMC_ATTR(INTERP, info, SELF, Sub, outer_sub);
/*
* XXX visit_pmc_now is wrong, because it breaks
* depth-first visit inside the todo list
* TODO change all user visit functions to use
* visit_pmc (the todo renamed visit_pm_later)
*
* Therefore the hash must be last during visit for now.
*/
VISIT_PMC_ATTR(INTERP, info, SELF, Sub, lex_info);
SUPER(info);
}
VTABLE void freeze(PMC *info) {
Parrot_Sub_attributes *sub;
STRING *hll_name;
int i;
SUPER(info);
PMC_get_sub(INTERP, SELF, sub);
/*
* we currently need to write these items:
* - start offset in byte-code segment
* - end offset in byte-code segment
* - segment TODO ???
* - flags (i.e. :load pragma and such)
* - name of the sub's label
* - method name
* - ns entry name
* - namespace
* - HLL_id
* - multi_signature
* - n_regs_used[i]
* - lex_info
* - vtable_index
* - subid
*/
VTABLE_push_integer(INTERP, info, (INTVAL) sub->start_offs);
VTABLE_push_integer(INTERP, info, (INTVAL) sub->end_offs);
VTABLE_push_integer(INTERP, info,
(INTVAL)(PObj_get_FLAGS(SELF) & SUB_FLAG_PF_MASK));
VTABLE_push_string(INTERP, info, sub->name);
if (!sub->method_name)
sub->method_name = CONST_STRING(INTERP, "");
VTABLE_push_string(INTERP, info, sub->method_name);
if (!sub->ns_entry_name)
sub->ns_entry_name = CONST_STRING(INTERP, "");
VTABLE_push_string(INTERP, info, sub->ns_entry_name);
hll_name = Parrot_hll_get_HLL_name(INTERP, sub->HLL_id);
if (!hll_name)
hll_name = CONST_STRING(INTERP, "");
VTABLE_push_string(INTERP, info, hll_name);
VTABLE_push_integer(INTERP, info, (INTVAL)sub->comp_flags);
VTABLE_push_integer(INTERP, info, sub->vtable_index);
for (i = 0; i < 4; ++i)
VTABLE_push_integer(INTERP, info, sub->n_regs_used[i]);
if (!sub->subid)
sub->subid = CONST_STRING(INTERP, "");
VTABLE_push_string(INTERP, info, sub->subid);
}
/*
=item C<void thaw(PMC *info)>
Unarchives the subroutine.
=cut
*/
VTABLE void thaw(PMC *info) {
Parrot_Sub_attributes *sub;
INTVAL flags;
int i;
STATICSELF.init();
PMC_get_sub(INTERP, SELF, sub);
/* we get relative offsets */
sub->start_offs = (size_t) VTABLE_shift_integer(INTERP, info);
sub->end_offs = (size_t) VTABLE_shift_integer(INTERP, info);
flags = VTABLE_shift_integer(INTERP, info);
PObj_get_FLAGS(SELF) |= flags & SUB_FLAG_PF_MASK;
sub->name = VTABLE_shift_string(INTERP, info);
sub->method_name = VTABLE_shift_string(INTERP, info);
sub->ns_entry_name = VTABLE_shift_string(INTERP, info);
/* lookup or create HLL */
sub->HLL_id = Parrot_hll_register_HLL(INTERP,
VTABLE_shift_string(INTERP, info));
sub->comp_flags = VTABLE_shift_integer(INTERP, info);
sub->vtable_index = VTABLE_shift_integer(INTERP, info);
for (i = 0; i < 4; ++i)
sub->n_regs_used[i] = VTABLE_shift_integer(INTERP, info);
sub->subid = VTABLE_shift_string(INTERP, info);
}
/*
=item C<PMC *inspect()>
Returns the full set of meta-data about the sub.
=cut
*/
VTABLE PMC *inspect()
{
/* Create a hash, then use inspect_str to get all of its data */
PMC * const metadata = Parrot_pmc_new(INTERP, enum_class_Hash);
STRING * const pos_required_str = CONST_STRING(INTERP, "pos_required");
STRING * const pos_optional_str = CONST_STRING(INTERP, "pos_optional");
STRING * const named_required_str = CONST_STRING(INTERP, "named_required");
STRING * const named_optional_str = CONST_STRING(INTERP, "named_optional");
STRING * const pos_slurpy_str = CONST_STRING(INTERP, "pos_slurpy");
STRING * const named_slurpy_str = CONST_STRING(INTERP, "named_slurpy");
VTABLE_set_pmc_keyed_str(INTERP, metadata, pos_required_str,
VTABLE_inspect_str(INTERP, SELF, pos_required_str));
VTABLE_set_pmc_keyed_str(INTERP, metadata, pos_optional_str,
VTABLE_inspect_str(INTERP, SELF, pos_optional_str));
VTABLE_set_pmc_keyed_str(INTERP, metadata, named_required_str,
VTABLE_inspect_str(INTERP, SELF, named_required_str));
VTABLE_set_pmc_keyed_str(INTERP, metadata, named_optional_str,
VTABLE_inspect_str(INTERP, SELF, named_optional_str));
VTABLE_set_pmc_keyed_str(INTERP, metadata, pos_slurpy_str,
VTABLE_inspect_str(INTERP, SELF, pos_slurpy_str));
VTABLE_set_pmc_keyed_str(INTERP, metadata, named_slurpy_str,
VTABLE_inspect_str(INTERP, SELF, named_slurpy_str));
return metadata;
}
/*
=item C<PMC *inspect_str(STRING *what)>
Returns the specified item of metadata about the sub. Allowable
values are:
=over 4
=item pos_required
The number of required positional arguments
=item pos_optional
The number of optional positional arguments
=item named_required
The number of required named arguments
=item named_optional
The number of optional named arguments
=item pos_slurpy
1 if it takes slurpy positional arguments, 0 if not
=item named_slurpy
1 if it takes slurpy named arguments, 0 if not
=back
=cut
*/
VTABLE PMC *inspect_str(STRING *what)
{
Parrot_Sub_attributes *sub;
PMC *retval;
INTVAL count_found = -1;
PMC_get_sub(INTERP, SELF, sub);
/* If the argument info hasn't been generated yet, generate it. */
if (!sub->arg_info) {
/* Get pointer into the bytecode where this sub starts. */
const opcode_t *pc = sub->seg->base.data + sub->start_offs;
op_lib_t *core_ops = PARROT_GET_CORE_OPLIB(INTERP);
/* Allocate structure to store argument information in. */
sub->arg_info = mem_gc_allocate_zeroed_typed(INTERP,
Parrot_sub_arginfo);
/* If the first instruction is a get_params... */
if (OPCODE_IS(INTERP, sub->seg, *pc, core_ops, PARROT_OP_get_params_pc)) {
/* Get the signature (the next thing in the bytecode). */
PMC * const sig = sub->seg->const_table->pmc.constants[*(++pc)];
/* Iterate over the signature and compute argument counts. */
const INTVAL sig_length = VTABLE_elements(INTERP, sig);
int i;
ASSERT_SIG_PMC(sig);
for (i = 0; i < sig_length; ++i) {
int sig_item = VTABLE_get_integer_keyed_int(INTERP, sig, i);
if (PARROT_ARG_SLURPY_ARRAY_ISSET(sig_item)){
if (PARROT_ARG_NAME_ISSET(sig_item))
sub->arg_info->named_slurpy = 1;
else
sub->arg_info->pos_slurpy = 1;
}
else if (PARROT_ARG_NAME_ISSET(sig_item)) {
++i;
sig_item = VTABLE_get_integer_keyed_int(INTERP, sig, i);
if (PARROT_ARG_OPTIONAL_ISSET(sig_item))
++sub->arg_info->named_optional;
else
++sub->arg_info->named_required;
}
else if (!PARROT_ARG_OPT_FLAG_ISSET(sig_item)) {
if (PARROT_ARG_OPTIONAL_ISSET(sig_item))
++sub->arg_info->pos_optional;
else
++sub->arg_info->pos_required;
}
}
}
}
/* Return the requested argument information */
if (STRING_equal(INTERP, what, CONST_STRING(INTERP, "pos_required"))) {
count_found = (INTVAL)sub->arg_info->pos_required;
}
else if (STRING_equal(INTERP, what, CONST_STRING(INTERP, "pos_optional"))) {
count_found = (INTVAL)sub->arg_info->pos_optional;
}
else if (STRING_equal(INTERP, what, CONST_STRING(INTERP, "pos_slurpy"))) {
count_found = (INTVAL)sub->arg_info->pos_slurpy;
}
else if (STRING_equal(INTERP, what, CONST_STRING(INTERP, "named_required"))) {
count_found = (INTVAL)sub->arg_info->named_required;
}
else if (STRING_equal(INTERP, what, CONST_STRING(INTERP, "named_optional"))) {
count_found = (INTVAL)sub->arg_info->named_optional;
}
else if (STRING_equal(INTERP, what, CONST_STRING(INTERP, "named_slurpy"))) {
count_found = (INTVAL)sub->arg_info->named_slurpy;
}
else
Parrot_ex_throw_from_c_args(INTERP, NULL,
EXCEPTION_INVALID_OPERATION,
"Unknown introspection value '%S'", what);
retval = Parrot_pmc_new_init_int(INTERP, enum_class_Integer, count_found);
return retval;
}
/*
=back
=head2 METHODS
=over 4
=item C<INTVAL start_offs()>
Returns the start offset of the Sub.
=item C<INTVAL end_offs()>
Returns the end offset of the Sub.
=item C<PMC *get_namespace()>
Returns the namespace PMC, where the Sub is defined.
TODO return C<namespace_stash> instead.
=item C<INTVAL __get_regs_used(char *kind)>
Returns the number of used registers for register kinds "I", "S", "P", "N".
=item C<PMC *get_lexinfo()>
Returns the LexInfo PMC, if any or a Null PMC.
=item C<PMC *get_multisig()>
Returns the MMD signature PMC, if any, or a Null PMC.
=item C<PMC *get_outer()>
Gets the sub that is the outer of this one, if any, or a Null PMC.
=item C<void set_outer(PMC *outer)>
Sets the sub that is the outer of this one.
=item C<void set_outer_ctx(PMC *outer_ctx)>
Set the outer context to be used on the next invocation of this sub.
=item C<INTVAL arity()>
Returns the arity of the Sub (the number of arguments, excluding optional and
slurpy arguments).
=cut
*/
METHOD start_offs() {
Parrot_Sub_attributes *sub;
INTVAL start_offs;
PMC_get_sub(INTERP, SELF, sub);
start_offs = sub->start_offs;
RETURN(INTVAL start_offs);
}
METHOD end_offs() {
Parrot_Sub_attributes *sub;
INTVAL end_offs;
PMC_get_sub(INTERP, SELF, sub);
end_offs = sub->end_offs;
RETURN(INTVAL end_offs);
}
METHOD get_namespace() {
PMC *_namespace;
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
/*
XXX Rakudo's failing with this code on ASSERT. Why???
GET_ATTR_namespace_stash(INTERP, SELF, _namespace);
PARROT_ASSERT(_namespace == sub->namespace_stash || !"consistency!!!");
*/
_namespace = sub->namespace_stash;
RETURN(PMC *_namespace);
}
METHOD __get_regs_used(STRING *reg) {
/* TODO switch to canonical NiSP order
* see also imcc/reg_alloc.c */
STRING * const types = CONST_STRING(INTERP, "INSP");
Parrot_Sub_attributes *sub;
INTVAL regs_used;
INTVAL kind;
PMC_get_sub(INTERP, SELF, sub);
PARROT_ASSERT(sub->n_regs_used);
if (!reg || Parrot_str_length(INTERP, reg) != 1)
Parrot_ex_throw_from_c_args(INTERP, NULL,
EXCEPTION_INVALID_OPERATION,
"illegal register kind '%Ss'", reg);
kind = STRING_index(INTERP, types, reg, 0);
if (kind == -1)
Parrot_ex_throw_from_c_args(INTERP, NULL,
EXCEPTION_INVALID_OPERATION, "illegal register kind '%Ss'", reg);
regs_used = sub->n_regs_used[kind];
RETURN(INTVAL regs_used);
}
METHOD get_lexinfo() {
PMC *lexinfo;
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
lexinfo = sub->lex_info ? sub->lex_info : PMCNULL;
RETURN(PMC *lexinfo);
}
METHOD get_subid() {
STRING *subid;
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
subid = sub->subid ? sub->subid : CONST_STRING(INTERP, "");
RETURN(STRING *subid);
}
METHOD get_outer() {
PMC *outersub;
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
outersub = sub->outer_sub ? sub->outer_sub : PMCNULL;
RETURN(PMC *outersub);
}
METHOD set_outer(PMC *outer) {
/* Set outer sub. */
Parrot_Sub_attributes *sub;
PMC *outer_ctx;
PMC_get_sub(INTERP, SELF, sub);
sub->outer_sub = outer;
/* Make sure outer flag of that sub is set. */
PObj_get_FLAGS(outer) |= SUB_FLAG_IS_OUTER;
/* Ensure we have lex info. */
if (PMC_IS_NULL(sub->lex_info)) {
const INTVAL lex_info_id = Parrot_hll_get_ctx_HLL_type(INTERP,
enum_class_LexInfo);
sub->lex_info = Parrot_pmc_new_init(INTERP, lex_info_id, SELF);
}
/* Clear any existing outer context */
sub->outer_ctx = PMCNULL;
/* If we've got a context around for the outer sub, set it as the
* outer context. */
outer_ctx = CURRENT_CONTEXT(INTERP);
while (!PMC_IS_NULL(outer_ctx)) {
if (Parrot_pcc_get_sub(INTERP, outer_ctx) == outer) {
sub->outer_ctx = outer_ctx;
break;
}
outer_ctx = Parrot_pcc_get_caller_ctx(INTERP, outer_ctx);
}
}
METHOD set_outer_ctx(PMC *outer_ctx) {
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
sub->outer_ctx = outer_ctx;
}
METHOD get_multisig() {
PMC *multisig;
Parrot_Sub_attributes *sub;
PMC_get_sub(INTERP, SELF, sub);
multisig = sub->multi_signature ? sub->multi_signature : PMCNULL;
RETURN(PMC *multisig);
}
METHOD arity() {
PMC * const pos_required = VTABLE_inspect_str(INTERP, SELF, CONST_STRING(INTERP, "pos_required"));
PMC * const named_required = VTABLE_inspect_str(INTERP, SELF, CONST_STRING(INTERP, "named_required"));
const INTVAL arity = VTABLE_get_integer(INTERP, pos_required)
+ VTABLE_get_integer(INTERP, named_required);
RETURN(INTVAL arity);
}
/*
=item C<INTVAL comp_flags()>
=item C<INTVAL pf_flags()>
(Experimental) Returns Sub flags.
=item C<PMC *get_packfile()>
(Experimental) Returns the packfile that contains this Sub
=back
=cut
*/
METHOD comp_flags() {
Parrot_Sub_attributes *sub;
INTVAL flags;
PMC_get_sub(INTERP, SELF, sub);
flags = sub->comp_flags;
RETURN(INTVAL flags);
}
METHOD pf_flags() {
/* Only PF specific flags */
INTVAL flags = PObj_get_FLAGS(SELF) & SUB_FLAG_PF_MASK;
RETURN(INTVAL flags);
}
METHOD get_packfile() {
Parrot_Sub_attributes *sub;
PMC *view;
PMC_get_sub(INTERP, SELF, sub);
view = sub->seg->base.pf->view;
if (!view)
view = PMCNULL;
RETURN(PMC * view);
}
}
/*
* Local variables:
* c-file-style: "parrot"
* End:
* vim: expandtab shiftwidth=4 cinoptions='\:2=2' :
*/
Jump to Line
Something went wrong with that request. Please try again.