core.ops

/*
 * $Id$
** core.ops
*/

BEGIN_OPS_PREAMBLE

#include "parrot/dynext.h"
#include "parrot/embed.h"
#include "parrot/runcore_api.h"
#include "pmc/pmc_continuation.h"
#include "pmc/pmc_parrotlibrary.h"

END_OPS_PREAMBLE

=head1 NAME

core.ops - Core Opcodes

=cut

=head1 DESCRIPTION

Parrot's core library of ops.

Core operations are primarily flow control and interpreter
introspection.

=cut

# ' for emacs

###############################################################################

=head2 Basic ops

These are the fundamental operations.
Please note: These opcodes must not be moved; they must have
exactly these opcode numbers. Opcodes ending with underscores are for
internal use only; don't emit these opcodes.

=over 4

=cut

########################################

=item B<end>()

Halts the interpreter. (Must be op #0, CORE_OPS_end). See also B<exit>.

=cut

inline op end() :base_core :check_event :flow {
    HALT();
}


########################################

=item B<noop>()

Does nothing other than waste an iota of time and 32 bits of bytecode space.
(Must be op #1, CORE_OPS_noop)

=item B<cpu_ret>()

Emit a cpu return instruction. This is used to return from CGP core
to JIT code. Note: Do B<not> use this opcode. It is for internal use only.
(Must be op #2, CORE_OPS_cpu_ret)

=item B<check_events>()

Check the event queue and run event handlers if there are unhandled events.
Note: This opcode is mainly for testing. It should not be necessary to ever
use it explicitly.
(Must be op #3, CORE_OPS_check_events).

=item B<check_events__>()

Check the event queue and run event handlers if there are unhandled events.
Note: Do B<not> use this opcode. It is for internal use only.
(Must be op #4, CORE_OPS_check_events__).

=item B<wrapper__>()

Internal opcode to wrap unknown ops from loaded opcode libs.
Don't use.
(Must be op #5, CORE_OPS_wrapper__).

=item B<prederef__>()

Internal opcode to prederef opcodes on the fly.
Don't use.
(Must be op #6, CORE_OPS_prederef__).

=item B<reserved>(inconst INT)

Reserve 1 more fix entry.

=item B<load_bytecode>(in STR)

Load Parrot bytecode from file $1, and search the library path to locate the
file.

=cut

inline op noop() :base_core {
}

inline op cpu_ret() {
    /* We only want to call __asm__("ret") if we're in the JIT core. Otherwise
       we want to throw an error. Seriously people: Do not use this opcode
       directly in PIR. Ever. It absolutely makes no sense and it doesn't do
       anything productive. You've been warned. */
   if (PARROT_RUNCORE_JIT_OPS_TEST(interp->run_core)) {
#ifdef __GNUC__
#  ifdef I386
        __asm__("ret");
#  endif
#endif
    }
    else {
        opcode_t * const handler= Parrot_ex_throw_from_op_args(interp,
            NULL, EXCEPTION_INVALID_OPERATION,
            "cpu_ret: May not use this opcode from PIR source");
        goto ADDRESS(handler);
    }
}

inline op check_events() :base_core :flow {
    opcode_t *next = expr NEXT();
    Parrot_cx_check_tasks(interp, interp->scheduler);
    goto ADDRESS(next);   /* force this being a branch op */
}

inline op check_events__() :internal :flow {
    opcode_t *_this = CUR_OPCODE;
    /* Restore op_func_table. */
    disable_event_checking(interp);
    Parrot_cx_handle_tasks(interp, interp->scheduler);
    goto ADDRESS(_this);   /* force this being a branch op */
}

inline op wrapper__() :internal :flow {
    opcode_t *pc = CUR_OPCODE;
    DO_OP(pc, interp);
    goto ADDRESS(pc);
}

inline op prederef__() :internal :flow {
    opcode_t * const _this = CUR_OPCODE;
    if (PARROT_RUNCORE_CGOTO_OPS_TEST(interp->run_core)) {
        /* must be CGP then - check for events in not yet prederefed code */
        Parrot_cx_runloop_wake(interp, interp->scheduler);
    /*    _this = CHECK_EVENTS(interp, _this); */
    }
    do_prederef((void**)cur_opcode, interp, interp->run_core);
    goto ADDRESS(_this); /* force this being a branch op */
}

inline op reserved(inconst INT) {
    /* reserve 1 entries */
}

inline op load_bytecode(in STR) :load_file {
    Parrot_load_bytecode(interp, $1);
}

=item B<load_language>(in STR)

Load the compiler libraries for a language $1. Search the library path to
locate the main compiler file in the standard locations.

=cut

inline op load_language(in STR) :load_file {
    Parrot_load_language(interp, $1);
}

=back

=cut

###############################################################################

=head2 Control flow

The control flow opcodes check conditions and manage program flow.

=over 4

=cut

########################################

=item B<branch>(in LABEL)

Branch forward or backward by the amount in $1.

=cut

inline op branch(in LABEL) :base_loop :flow {
    goto OFFSET($1);
}


########################################

=item B<local_branch>(invar PMC, in LABEL)

Go to the location specified by the label in $2. Push the current location onto
the stack passed in $1 for later returning.

=cut

inline op local_branch(invar PMC, in LABEL) :base_core :check_event :flow {
    INTVAL return_addr;
    opcode_t *dest = expr NEXT();

    if (PMC_IS_NULL($1) || $1->vtable->base_type != enum_class_ResizableIntegerArray) {
        opcode_t * handler = Parrot_ex_throw_from_op_args(interp, dest,
            EXCEPTION_INVALID_OPERATION,
            "Must pass a valid integer array to 'local_branch'");
        goto ADDRESS(handler);
    }

    return_addr = PTR2INTVAL(dest);
    VTABLE_push_integer(interp, $1, return_addr);

    goto OFFSET($2);
}

=item B<local_return>(invar PMC)

Pop the location off the top of the call stack and go there.

=cut

inline op local_return(invar PMC) :flow {
    INTVAL return_addr;
    opcode_t *next;
    opcode_t *dest = expr NEXT();

    if (PMC_IS_NULL($1) || $1->vtable->base_type != enum_class_ResizableIntegerArray) {
        opcode_t *handler = Parrot_ex_throw_from_op_args(interp, dest,
            EXCEPTION_INVALID_OPERATION,
            "Must pass a valid integer array to 'local_return'");
        goto ADDRESS(handler);
    }

    return_addr = VTABLE_pop_integer(interp, $1);
    next = INTVAL2PTR(opcode_t *, return_addr);

    /* The return address must be within the current code segment. */
    if (! (next >= interp->code->base.data
           && next < (interp->code->base.data + interp->code->base.size))) {
        opcode_t *handler = Parrot_ex_throw_from_op_args(interp, dest,
            EXCEPTION_INVALID_OPERATION,
            "Address for 'local_return' must be within the current code segment");
        goto ADDRESS(handler);
    }

    goto ADDRESS(next);
}

########################################

=item B<jump>(in LABEL)

Jump to the address held in register $1.

=cut

inline op jump(in LABEL) :base_loop :flow {
    opcode_t * const loc = INTVAL2PTR(opcode_t *, $1);
    goto ADDRESS(loc);
}

########################################

=item B<enternative>()

Internal opcode used to jump from normal bytecode into a JITted version.

=cut

op enternative() :flow {
    opcode_t * const addr = run_native(interp, CUR_OPCODE,
            interp->code->base.data);
    goto ADDRESS(addr);
}

=back

=cut

###############################################################################

=head2 Conditional branch operations

These operations perform a conditional relative branch. If the condition is
met, the branch happens.  Otherwise control falls to the next operation.

=over 4

=cut

########################################

=item B<if>(invar INT, inconst LABEL)

=item B<if>(invar NUM, inconst LABEL)

=item B<if>(invar PMC, inconst LABEL)

=item B<if>(invar STR, inconst LABEL)

Check register $1. If true, branch by $2.

=cut

inline op if (invar INT, inconst LABEL) {
    if ($1 != 0)
        goto OFFSET($2);
}

inline op if (invar NUM, inconst LABEL) {
    if (!FLOAT_IS_ZERO($1))
        goto OFFSET($2);
}

op if (invar STR, inconst LABEL) {
    if (Parrot_str_boolean(interp, $1))
        goto OFFSET($2);
}

op if (invar PMC, inconst LABEL) {
    if (VTABLE_get_bool(interp, $1))
        goto OFFSET($2);
}

########################################

=item B<unless>(invar INT, inconst LABEL)

=item B<unless>(invar NUM, inconst LABEL)

=item B<unless>(invar PMC, inconst LABEL)

=item B<unless>(invar STR, inconst LABEL)

Check register $1. If false, branch by $2.

=cut

inline op unless(invar INT, inconst LABEL) {
    if ($1 == 0)
        goto OFFSET($2);
}

inline op unless(invar NUM, inconst LABEL) {
    if (FLOAT_IS_ZERO($1))
        goto OFFSET($2);
}

op unless(invar STR, inconst LABEL) {
    if (!Parrot_str_boolean(interp, $1))
        goto OFFSET($2);
}

op unless(invar PMC, inconst LABEL) {
    if (!VTABLE_get_bool(interp, $1))
        goto OFFSET($2);
}

=back

=cut

###############################################################################

=head2 Subroutine operations

These operations are used to generate and call subroutines and
continuations.

=over 4

=cut

########################################

=item B<invokecc>(invar PMC)

Call the subroutine in $1 and generate a new return continuation, if needed.
For example, a NCI subroutine which executes code in some C library will not
create a continuation, nor will anything but the first call to a coroutine.

=item B<invoke>(invar PMC, invar PMC)

Call the subroutine in $1 and use continuation $2.

=item B<yield>()

Yield results from a coroutine.

=item B<tailcall>(invar PMC)

Call the subroutine in $1 and use the current continuation as the subs
continuation.

=item B<returncc>()

Return from the sub or method via the current continuation.

=item B<capture_lex>(invar PMC)

Capture the current lexical state of the inner subroutine PMC.

=item B<newclosure>(out PMC, invar PMC)

Create a closure of the given subroutine PMC by cloning the sub's state.

=cut

inline op invokecc(invar PMC) :flow {
    PMC      * const p     = $1;
    opcode_t *dest         = expr NEXT();

    interp->current_object = NULL;
    interp->current_cont   = NEED_CONTINUATION;
    dest                   = VTABLE_invoke(interp, p, dest);

    goto ADDRESS(dest);
}

inline op invoke(invar PMC, invar PMC) :flow {
    opcode_t   *dest       = expr NEXT();
    PMC * const p          = $1;

    interp->current_object = NULL;
    interp->current_cont   = $2;

    dest = VTABLE_invoke(interp, p, dest);
    goto ADDRESS(dest);
}

inline op yield() :flow {
    opcode_t   *dest = expr NEXT();
    PMC * const p    = Parrot_pcc_get_sub(interp, CURRENT_CONTEXT(interp));

    VTABLE_increment(interp, p);
    dest = VTABLE_invoke(interp, p, dest);

    goto ADDRESS(dest);
}

inline op tailcall(invar PMC) :flow {
    PMC * const p               = $1;
    opcode_t   *dest            = expr NEXT();
    PMC * const ctx             = CURRENT_CONTEXT(interp);
    PMC * const parent_ctx      = Parrot_pcc_get_caller_ctx(interp, ctx);
    PMC * const this_call_sig   = Parrot_pcc_get_signature(interp, ctx);
    PMC * const parent_call_sig = Parrot_pcc_get_signature(interp, parent_ctx);
    interp->current_cont        = Parrot_pcc_get_continuation(interp, ctx);

    Parrot_pcc_merge_signature_for_tailcall(interp, parent_call_sig, this_call_sig);

    /* Detach continuation from current CallContext to avoid marking dead object. */
    /* RetContinuation will kill itself after invoke */
    if (interp->current_cont->vtable->base_type == enum_class_RetContinuation
        && Parrot_pcc_do_run_ops(interp, p)) {
        PMC_cont(interp->current_cont)->from_ctx = parent_ctx;
        Parrot_pcc_set_continuation(interp, ctx, PMCNULL);
    }

    SUB_FLAG_TAILCALL_SET(interp->current_cont);
    dest = VTABLE_invoke(interp, p, dest);
    goto ADDRESS(dest);
}

inline op returncc() :flow {
    PMC * const p = Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp));
    opcode_t * const dest = VTABLE_invoke(interp, p, expr NEXT());
    goto ADDRESS(dest);
}

inline op capture_lex(invar PMC) {
    Parrot_capture_lex(interp, $1);
}

inline op newclosure(out PMC, invar PMC) {
    $1 = parrot_new_closure(interp, $2);
}

=back

=head2 Function argument opcode

Implementations of function argument and params handling

=over 4

=item B<set_args>(inconst PMC /* , ... */)

Define arguments for the next function call.

=item B<get_results>(inconst PMC /* , ... */)

Define return values for the next function call.

=item B<get_params>(inconst PMC /* , ... */)

Define function parameters for this subroutine.

=item B<set_returns>(inconst PMC /* , ... */)

Define return results for the subroutine return statement.

For all of these opcodes the passed invar PMC constant is the string
representation of a FixedIntegerArray with one flag word per argument.
The flags are documented currently in F<include/parrot/enums.h> only.

After this argument a variable amount of arguments must follow according
to the elements of the signature array.

=cut


op set_args(inconst PMC) :flow {
    opcode_t * const raw_args = CUR_OPCODE;
    PMC * const signature = $1;
    PMC * call_sig;
    INTVAL argc;

    call_sig = Parrot_pcc_build_sig_object_from_op(interp,
            PMCNULL, signature, raw_args);
    Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_sig);

    argc = VTABLE_elements(interp, signature);
    goto OFFSET(argc + 2);
}

op get_results(inconst PMC) :flow {
    opcode_t * const raw_returns = CUR_OPCODE;
    PMC * const signature = $1;
    PMC * call_sig;
    INTVAL argc;

    call_sig = Parrot_pcc_build_sig_object_returns_from_op(interp,
            Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp)),
            signature, raw_returns);
    Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_sig);

    argc = VTABLE_elements(interp, signature);
    goto OFFSET(argc + 2);
}

op get_params(inconst PMC) :flow {
    opcode_t * const raw_params = CUR_OPCODE;
    PMC *caller_ctx, *ctx;
    PMC *ccont, *call_object;
    PMC * const signature = $1;
    INTVAL argc;

    ctx     = CURRENT_CONTEXT(interp);
    ccont   = Parrot_pcc_get_continuation(interp, ctx);

    caller_ctx  = Parrot_pcc_get_caller_ctx(interp, ctx);
    call_object = Parrot_pcc_get_signature(interp, caller_ctx);

    Parrot_pcc_fill_params_from_op(interp, call_object, signature, raw_params);

    /* TODO Factor out with Sub.invoke */
    if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) {
        PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL;
        Parrot_pcc_dec_recursion_depth(interp, ctx);
        Parrot_pcc_set_caller_ctx(interp, ctx, Parrot_pcc_get_caller_ctx(interp, caller_ctx));
    }
    argc = VTABLE_elements(interp, signature);
    goto OFFSET(argc + 2);
}

op set_returns(inconst PMC) :flow {
    opcode_t * const raw_returns = CUR_OPCODE;
    PMC      *signature          = $1;
    PMC      *ctx                = CURRENT_CONTEXT(interp);
    PMC      *caller_ctx         = Parrot_pcc_get_caller_ctx(interp, ctx);
    PMC      *call_object        = Parrot_pcc_get_signature(interp, caller_ctx);
    INTVAL    argc               = VTABLE_elements(interp, signature);

    Parrot_pcc_fill_returns_from_op(interp, call_object, signature, raw_returns);

    Parrot_pcc_set_signature(interp, ctx, NULL);

    goto OFFSET(argc + 2);
}

=item B<result_info>(out PMC)

Returns the get_results signature PMC of the caller. This PMC is a
FixedIntegerPMCArray. The number of elements of this PMC is equal to the number
of return values that are expected.  The individual bits per entry are
specified in F<docs/pdds/pdd03_calling_conventions.pod>.

=cut

inline op result_info(out PMC) {
    PMC *caller_ctx  = Parrot_pcc_get_caller_ctx(interp, CURRENT_CONTEXT(interp));
    PMC *call_object = Parrot_pcc_get_signature(interp, caller_ctx);
    PMC *sig = VTABLE_get_attr_str(interp, call_object,
            Parrot_str_new_constant(interp, "return_flags"));

    /* If no elements, hand back empty array; otherwise PMC. */
    if (!sig)
        $1 = pmc_new(interp, enum_class_FixedIntegerArray);
    else
        $1 = sig;
}

=back

=head2 Address manipulation

=for clarity

=cut

=over 4

=item B<set_addr>(out INT, inconst LABEL)

Sets register $1 to the current address plus the offset $2.

=item B<set_addr>(invar PMC, inconst LABEL)

Sets PMC in register $1 to the current address plus the offset $2.

=item B<set_addr>(invar PMC, invar LABEL)

Sets PMC in register $1 to the absolute address $2 obtained from B<get_addr>.

=item B<get_addr>(out INT, invar PMC)

Sets $1 to the absolute address of the Sub PMC $2.

=cut

inline op set_addr(out INT, inconst LABEL) {
    $1 = PTR2INTVAL(CUR_OPCODE + $2);
}

inline op set_addr(invar PMC, inconst LABEL) {
    VTABLE_set_pointer(interp, $1, (CUR_OPCODE + $2));
}

inline op set_addr(invar PMC, invar LABEL) {
    VTABLE_set_pointer(interp, $1, (void*)$2);
}

inline op get_addr(out INT, invar PMC) {
    void *ptr = VTABLE_get_pointer(interp, $2);
    $1        = (INTVAL)ptr;
}

=back

=cut

########################################

=head2 Concurrency operations

=over 4

=item B<schedule>(invar PMC)

Register a task with the concurrency scheduler. Details about the task are
stored within the task PMC.

inline op schedule(invar PMC) {
    Parrot_cx_schedule_task(interp, $1);
}

=item B<addhandler>(invar PMC)

Add an event or exception handler to the concurrency scheduler. Details about
the handler are stored within the handler PMC.

inline op addhandler(invar PMC) {
    Parrot_cx_add_handler(interp, $1);
}

=back

=cut

########################################

=head2 Exception handling

=over 4

=item B<push_eh>(inconst LABEL)

Create an exception handler for the given catch label and push it onto
the exception handler stack.

=item B<push_eh>(invar PMC)

Push an invokable PMC onto the exception handler stack.

=item B<pop_eh>()

Pop the most recently placed exception off the handler stack.

=item B<throw>(invar PMC)

Throw the exception in $1 with current continuation.

=item B<throw>(invar PMC, invar PMC)

Throw the exception in $1 with continuation from $2.

=item B<rethrow>(invar PMC)

Only valid inside an exception handler. Rethrow the exception $1.

=item B<count_eh>(out INT)

Get a count of currently active exception handlers on the stack.

=item B<die>(in STR)

=item B<die>(in PMC)

Die with message $1

=item B<die>(in INT, in INT)

Die with severity $1 and error $2. If severity is .EXCEPT_DOOMED,
call _exit($2). The latter isn't catchable.

=item B<exit>(in INT)

Exit the interpreter with exit_status $1. If you want to communicate an
extended exit status, create an exception with severity B<EXCEPT_exit>
and throw it.

=item B<pushmark>(in INT)

Push a mark labeled $1 onto the dynamic environment.

=item B<popmark>(in INT)

Pop all items off the dynamic environment to the given mark.

=item B<pushaction>(invar PMC)

Push the given Sub PMC $1 onto the dynamic environment.  If the dynamic
environment is unwound due to a C<popmark>, subroutine return, or an exception,
the subroutine will be invoked with an integer argument: C<0> means a normal
return; C<1> means an exception has been raised.

=cut

inline op push_eh(inconst LABEL) {
    PMC * const eh = pmc_new(interp, enum_class_ExceptionHandler);
    VTABLE_set_pointer(interp, eh, CUR_OPCODE + $1);
    Parrot_cx_add_handler_local(interp, eh);
}

inline op push_eh(invar PMC) {
    Parrot_cx_add_handler_local(interp, $1);
}

inline op pop_eh() {
    Parrot_cx_delete_handler_local(interp,
            Parrot_str_new(interp, "exception", 9));
}

inline op throw(invar PMC) :flow {
    PMC * except = $1;
    opcode_t *dest;
    opcode_t *const ret    = expr NEXT();
    PMC            *resume = new_ret_continuation_pmc(interp, ret);
    if (PMC_IS_NULL(except) || except->vtable->base_type != enum_class_Exception)
        except = Parrot_ex_build_exception(interp, EXCEPT_fatal,
                EXCEPTION_UNIMPLEMENTED,
                Parrot_str_new_constant(interp, "Not a throwable object"));

    VTABLE_set_attr_str(interp, except, Parrot_str_new_constant(interp, "resume"), resume);
    dest = Parrot_ex_throw_from_op(interp, except, ret);
    goto ADDRESS(dest);
}

inline op throw(invar PMC, invar PMC) :flow {
    opcode_t * dest;
    PMC * except = $1;
    if (PMC_IS_NULL(except) || except->vtable->base_type != enum_class_Exception)
        except = Parrot_ex_build_exception(interp, EXCEPT_fatal,
                EXCEPTION_UNIMPLEMENTED,
                Parrot_str_new_constant(interp, "Not a throwable object"));
    dest = Parrot_ex_throw_from_op(interp, $1,
                                VTABLE_get_pointer(interp, $2));
    goto ADDRESS(dest);
}

inline op rethrow(invar PMC) :flow {
    opcode_t * dest;
    if (PMC_IS_NULL($1) || $1->vtable->base_type != enum_class_Exception) {
        opcode_t * const ret = expr NEXT();
        PMC * except = Parrot_ex_build_exception(interp, EXCEPT_fatal,
                EXCEPTION_UNIMPLEMENTED,
                Parrot_str_new_constant(interp, "Not a throwable object"));
        dest = Parrot_ex_throw_from_op(interp, except, ret);
        goto ADDRESS(dest);
    }
    dest = Parrot_ex_rethrow_from_op(interp, $1);
    goto ADDRESS(dest);
}

inline op count_eh(out INT) {
    $1 = Parrot_cx_count_handlers_local(interp,
            Parrot_str_new(interp, "exception", 9));
}

inline op die(in STR) :flow {
    opcode_t        *dest;
    opcode_t * const ret       = expr NEXT();
    PMC             *resume    = new_ret_continuation_pmc(interp, ret);
    PMC             *exception = Parrot_ex_build_exception(interp, EXCEPT_error,
                                    CONTROL_ERROR, $1);

    VTABLE_set_attr_str(interp, exception,
                        Parrot_str_new_constant(interp, "resume"), resume);
    dest = Parrot_ex_throw_from_op(interp, exception, ret);
    goto ADDRESS(dest);
}

inline op die(in PMC) :flow {
    opcode_t        *dest;
    opcode_t * const ret       = expr NEXT();
    PMC             *resume    = new_ret_continuation_pmc(interp, ret);
    STRING          *msg       = PMC_IS_NULL($1)
                               ? NULL : VTABLE_get_string(interp, $1);
    PMC             *exception =
        Parrot_ex_build_exception(interp, EXCEPT_error, CONTROL_ERROR, msg);

    VTABLE_set_attr_str(interp, exception,
                        Parrot_str_new_constant(interp, "resume"), resume);
    dest = Parrot_ex_throw_from_op(interp, exception, ret);
    goto ADDRESS(dest);
}

inline op die(in INT, in INT) :flow {
    if ($1 == EXCEPT_doomed)
        _exit($2);
    else {
        opcode_t * const ret       = expr NEXT();
        PMC             *exception = Parrot_ex_build_exception(interp, $1,
                                                               $2, NULL);
        opcode_t * const dest      = Parrot_ex_throw_from_op(interp,
                                                             exception, ret);
        goto ADDRESS(dest);
    }
}

inline op exit(in INT) :flow {
    opcode_t        *dest;
    opcode_t * const ret       = expr NEXT();
    PMC             *resume    = new_ret_continuation_pmc(interp, ret);
    PMC             *exception = Parrot_ex_build_exception(interp, EXCEPT_exit,
                                                      $1, NULL);
    VTABLE_set_attr_str(interp, exception,
                        Parrot_str_new_constant(interp, "resume"), resume);
    VTABLE_set_integer_keyed_str(interp, exception,
        Parrot_str_new_constant(interp, "exit_code"), $1);
    dest = Parrot_ex_throw_from_op(interp, exception, ret);
    goto ADDRESS(dest);
}

inline op pushmark(in INT) {
    PMC * const newint = pmc_new(interp, enum_class_Integer);
    VTABLE_set_integer_native(interp, newint, $1);
    VTABLE_push_pmc(interp, interp->dynamic_env, newint);
}

inline op popmark(in INT) {
    opcode_t * dest;
    opcode_t * const ret = expr NEXT();
    int found = 0;
    while (VTABLE_elements(interp, interp->dynamic_env)) {
        PMC * const item = VTABLE_pop_pmc(interp, interp->dynamic_env);
        if (item->vtable->base_type == enum_class_Integer
         && VTABLE_get_integer(interp, item) == $1) {
            found = 1;
            break;
        }

        else if (item->vtable->base_type == enum_class_Sub
              || item->vtable->base_type == enum_class_NCI)
            Parrot_pcc_invoke_sub_from_c_args(interp, item, "I->", 0);
    }
    if (!found)
        dest = Parrot_ex_throw_from_op_args(interp, ret, 1, "Mark %d not found", $1);
}

inline op pushaction(invar PMC) {
    VTABLE_push_pmc(interp, interp->dynamic_env, $1);
}

=back

=cut

###############################################################################

=head2 Interpreter operations

These operations inspect or modify the interpreter itself, possibly
affecting its subsequent operation.

=over 4

=cut

########################################

=item B<debug>(in INT)

If $1 is zero, turn off debugging. Otherwise turn debug flag $1 on.

=cut

inline op debug(in INT) :flow {
    if ($1 != 0) { Interp_debug_SET(interp,   $1); }
    else         { Interp_debug_CLEAR(interp, PARROT_ALL_DEBUG_FLAGS); }
    restart NEXT();
}


########################################

=item B<bounds>(in INT)

If $1 is zero, turn off byte code bounds checking. Otherwise turn it on.

=cut

inline op bounds(in INT) :flow {
    if ($1 != 0) { Parrot_set_flag(interp,   PARROT_BOUNDS_FLAG); }
    else         { Interp_flags_CLEAR(interp, PARROT_BOUNDS_FLAG); }
    restart NEXT();
}


########################################

=item B<profile>(in INT)

If $1 is zero, turn off profiling. Otherwise turn it on.

=cut

inline op profile(in INT) :flow {
    if ($1 != 0) { Parrot_set_flag(interp,   PARROT_PROFILE_FLAG); }
    else         { Interp_flags_CLEAR(interp, PARROT_PROFILE_FLAG); }
    restart NEXT();
}


########################################

=item B<trace>(in INT)

If $1 is zero, turn off tracing. Otherwise turn trace flag $1 on.

=cut

inline op trace(in INT) :flow {
    if ($1 != 0) { Parrot_set_trace(interp,   $1); }
    else         { Parrot_clear_trace(interp, PARROT_ALL_TRACE_FLAGS); }
    restart NEXT();
}

########################################

=item B<gc_debug>(in INT)

If $1 is zero, turn off GC_DEBUG. Otherwise turn it on.

=cut

inline op gc_debug(in INT) {
    if ($1 != 0) { Interp_flags_SET(interp,   PARROT_GC_DEBUG_FLAG); }
    else         { Interp_flags_CLEAR(interp, PARROT_GC_DEBUG_FLAG); }
}

########################################

=item B<interpinfo>

Fetch some piece of information about the interpreter and put it in $1.
Possible values for $2 are defined in F<runtime/parrot/include/interpinfo.pasm>.
The valid constants for each return value are:

=over 4

=item B<interpinfo>(out INT, in INT)

.TOTAL_MEM_ALLOC, .GC_MARK_RUNS, .GC_COLLECT_RUNS, .ACTIVE_PMCS, .ACTIVE_BUFFERS,
.TOTAL_PMCS, .TOTAL_BUFFERS, .HEADER_ALLOCS_SINCE_COLLECT,
.MEM_ALLOCS_SINCE_COLLECT, .TOTAL_COPIED, .IMPATIENT_PMCS, .GC_LAZY_MARK_RUNS,
.EXTENDED_PMCS, .RUNCORE

=item B<interpinfo>(out PMC, in INT)

.CURRENT_SUB, .CURRENT_CONT, .CURRENT_OBJECT, .CURRENT_LEXPAD

=item B<interpinfo>(out STR, in INT)

.EXECUTABLE_FULLNAME, .EXECUTABLE_BASENAME, .RUNTIME_PREFIX

=back

=cut

op interpinfo(out INT, in INT) {
    $1 = interpinfo(interp, $2);
}

op interpinfo(out PMC, in INT) {
    $1 = interpinfo_p(interp, $2);
}

op interpinfo(out STR, in INT) {
    $1 = interpinfo_s(interp, $2);
}

=item B<warningson>(in INT)

Turns on warnings categories. Categories already turned on will stay on.
Initial setting is currently all warnings off.  Include F<warnings.pasm> to
access the categories. Refer to that file for the current list of warnings
available.

=over 4

=back

To turn on multiple categories, OR the category numbers together.

=cut

inline op warningson(in INT) {
    PARROT_WARNINGS_on(interp, $1);
}

=item B<warningsoff>(in INT)

Turns off warnings categories.  Categories already turned off will
stay off.  See the documentation for B<warningson> for category
numbers.

=cut

inline op warningsoff(in INT) {
    PARROT_WARNINGS_off(interp, $1);
}

=item B<errorson>(in INT)

Turns on error categories. Categories already turned on will stay on.  To
access these from PASM, include F<errors.pasm>.  The current categories are:

=over 4

=item .PARROT_ERRORS_GLOBALS_FLAG

Throw an exception if global doesn't exist.  Default: on.

=item .PARROT_ERRORS_OVERFLOW_FLAG

Throw math overflow instead of promoting to BigInt.  Default: off.

=item .PARROT_ERRORS_PARAM_COUNT_FLAG

Throw exception on argument <-> param count mismatch.  Default: off.

=item .PARROT_ERRORS_RESULT_COUNT_FLAG

Throw exception on return <-> result count mismatch.  Default: off.

=item .PARROT_ERRORS_ALL_FLAG

=back

To turn on multiple categories, OR the category numbers together.

=cut

inline op errorson(in INT) {
    PARROT_ERRORS_on(interp, $1);
}

=item B<errorsoff>(in INT)

Turns off errors categories.  Categories already turned off will
stay off.  See the documentation for B<errorson> for category
numbers.

=cut

inline op errorsoff(in INT) {
    PARROT_ERRORS_off(interp, $1);
}

########################################

=item B<runinterp>(invar PMC, in LABEL)

Run the code starting at offset $2 within interpreter $1.

=item B<getinterp>(out PMC)

Get the current ParrotInterpreter.

=cut

op runinterp(invar PMC, in LABEL) {
    Interp * const new_interp = (Interp *)VTABLE_get_pointer(interp, $1);
    Interp_flags_SET(new_interp, PARROT_EXTERN_CODE_FLAG);
    Parrot_switch_to_cs(new_interp, interp->code, 1);
    runops(new_interp, REL_PC + $2);
}

op getinterp(out PMC) {
    $1 = VTABLE_get_pmc_keyed_int(interp, interp->iglobals,
           IGLOBALS_INTERPRETER);
}

#######################################



=back

=cut

###############################################################################

=head2 Garbage Collection

Opcodes that interact with the GC subsystem.

=over 4

=cut

########################################

=item B<sweep>(inconst INT)

Triggers a GC run, based on the value of $1, where:

=over

=item * 0

Trigger a GC run only if there are things that have flagged themselves as
really needing to be collected.

=item * 1

Trigger a GC run unconditionally.

=back

=cut

op sweep(inconst INT) {
    if ($1)
        Parrot_gc_mark_and_sweep(interp, 0);
    else
        if (Parrot_gc_impatient_pmcs(interp))
            Parrot_gc_mark_and_sweep(interp, GC_lazy_FLAG);
}

=item B<collect>()

Trigger a garbage collection.

=cut

op collect() {
    Parrot_gc_compact_memory_pool(interp);
}

=item B<sweepoff>()

Disable GC runs. (Nestable)

=cut

op sweepoff() {
    Parrot_block_GC_mark(interp);
}

=item B<sweepon>()

Re-enable GC runs.

=cut

op sweepon() {
    Parrot_unblock_GC_mark(interp);
}

=item B<collectoff>()

Disable GC runs (nestable).

=cut

op collectoff() {
    Parrot_block_GC_sweep(interp);
}

=item B<collecton>()

Re-enable GC.

=cut

op collecton() {
    Parrot_unblock_GC_sweep(interp);
}

=item B<needs_destroy>(invar PMC)

Mark the PMC wanting destruction as soon as possible, for example
when unused during the lazy sweep, triggered by C<sweep 0>.

=cut

op needs_destroy(invar PMC) {
    Parrot_gc_pmc_needs_early_collection(interp, $1);
}

=back

=head2 Native Call Interface

Opcodes for interfacing with C functions in shared libraries.

=over 4

=cut

########################################

=item B<loadlib>(out PMC, in STR)

Load a dynamic link library named $2 and store it in $1.

=item B<dlfunc>(out PMC, invar PMC, in STR, in STR)

Look up symbol $3 in library $2 with signature $4, and put the
corresponding sub object in $1. Note that you need the signature so we
can build or find an appropriate thunking function.

=item B<dlvar>(out PMC, invar PMC, in STR)

Look up symbol $3 in library $2. We assume that this is actually a
variable address rather than a function address, and build an
UnManagedStruct PMC and stick the address into its data pointer.

=item B<compreg>(out PMC, in STR)

Get the compiler object for source type $2.  The returned compiler
object should provide a C<compile> method for translating code
in the source type.  However, some Parrot compilers such as
C<PIR> and C<PASM> currently return a sub that is to be
invoked directly on the source.

=item B<compreg>(in STR, invar PMC)

Register $2 as the compiler object for source type $1.

=item B<new_callback>(out PMC, invar PMC, invar PMC, in STR)

Create a callback stub $1 for PASM subroutine $2 with userdata $3 and
callback function signature $4. Only 2 argument signatures with
signature chars I<U[1iscpt]> or I<[1iscpt]U>  are handled currently.
But these cover a lot of callback signatures. Please note that the
userdata PMC I<U> has to be handled transparently by the caller of
the callback function.

=cut

inline op loadlib(out PMC, in STR) {
    $1 = Parrot_load_lib(interp, $2, NULL);
}

op dlfunc(out PMC, invar PMC, in STR, in STR) {
    char * const  name      = Parrot_str_to_cstring(interp, ($3));
    void         *dl_handle = NULL;
    void         *ptr       = NULL;
    funcptr_t     p;

    if (!PMC_IS_NULL($2) && $2->vtable->base_type == enum_class_ParrotLibrary) {
        dl_handle = ((Parrot_ParrotLibrary_attributes*)PMC_data($2))->dl_handle;
    }

    ptr = Parrot_dlsym(
            PMC_IS_NULL($2) ? NULL :
            VTABLE_defined(interp, $2) ? dl_handle :
            NULL,
            name);

    p = D2FPTR(ptr);

    if (p == NULLfunc) {
        const char * err = Parrot_dlerror();
        Parrot_warn(interp, PARROT_WARNINGS_UNDEF_FLAG,
                "Symbol '%s' not found: %s\n", name, err ? err : "unknown reason");
        $1 = pmc_new(interp, enum_class_Undef);
    }
    else {
        $1 = pmc_new(interp, enum_class_NCI);
        VTABLE_set_pointer_keyed_str(interp, $1, $4, F2DPTR(p));
        PObj_get_FLAGS($1) |= PObj_private1_FLAG;
    }
    Parrot_str_free_cstring(name);
}

op dlvar(out PMC, invar PMC, in STR) {
    char * const  name      = Parrot_str_to_cstring(interp, ($3));
    void *        p         = NULL;
    void         *dl_handle = NULL;

    if (!PMC_IS_NULL($2) && $2->vtable->base_type == enum_class_ParrotLibrary) {
        dl_handle = ((Parrot_ParrotLibrary_attributes*)PMC_data($2))->dl_handle;
        p         = Parrot_dlsym(PMC_IS_NULL($2) ? NULL : dl_handle, name);
    }
    if (p == NULL) {
        const char * const err = Parrot_dlerror();
        Parrot_warn(interp, PARROT_WARNINGS_UNDEF_FLAG,
                "Symbol '%s' not found: %s\n", name, err ? err : "unknown reason");
        $1 = pmc_new(interp, enum_class_Undef);
    }
    else {
        /* At this point we have the symbol's address. We just need to build
           a PMC with it so we can get and set the value */
        $1 = pmc_new(interp, enum_class_UnManagedStruct);
        VTABLE_set_pointer(interp, $1, p);
    }
    Parrot_str_free_cstring(name);
}

inline op compreg(in STR, invar PMC) {
    PMC * const compreg_hash = VTABLE_get_pmc_keyed_int(interp,
            interp->iglobals, IGLOBALS_COMPREG_HASH);
    VTABLE_set_pmc_keyed_str(interp, compreg_hash, $1, $2);
}

inline op compreg(out PMC, in STR) {
    PMC * const compreg_hash = VTABLE_get_pmc_keyed_int(interp,
            interp->iglobals, IGLOBALS_COMPREG_HASH);
    $1 = VTABLE_get_pmc_keyed_str(interp, compreg_hash, $2);
}

op new_callback(out PMC, invar PMC, invar PMC, in STR) {
    $1 = Parrot_make_cb(interp, $2, $3, $4);
}

=back

=cut

###############################################################################

=head2 Annotations operations

These operations relate to bytecode annotations.

=over 4

=cut

########################################

=item B<annotations>(out PMC)

Gets all bytecode annotations in effect at the current point, in a Hash.
If there are none, returns an empty Hash.

=cut

inline op annotations(out PMC) {
    if (interp->code->annotations) {
        opcode_t const cur_pos = (expr NEXT()) - interp->code->base.data;
        $1 = PackFile_Annotations_lookup(interp, interp->code->annotations,
                cur_pos, NULL);
    }
    else {
        $1 = pmc_new(interp, enum_class_Hash);
    }
    goto NEXT();
}

=item B<annotations>(out PMC, in STR)

Gets the bytecode annotation with the given name that is in effect at the
current point. Returns PMCNULL if there is none.

=cut

inline op annotations(out PMC, in STR) {
    if (interp->code->annotations) {
        opcode_t const cur_pos = (expr NEXT()) - interp->code->base.data;
        $1 = PackFile_Annotations_lookup(interp, interp->code->annotations,
                cur_pos, $2);
    }
    else {
        $1 = PMCNULL;
    }
    goto NEXT();
}

=back

=cut

###############################################################################

=head1 COPYRIGHT

Copyright (C) 2001-2008, Parrot Foundation.

=head1 LICENSE

This program is free software. It is subject to the same license
as the Parrot interpreter itself.

=cut

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */