/*
 * $Id: /mirror/trunk/src/ops/core.ops 35154 2009-01-07T14:12:23.146823Z jonathan  $
** core.ops
*/

#include "parrot/dynext.h"
#include "parrot/embed.h"
#include "../interp_guts.h"

VERSION = PARROT_VERSION;

=head1 NAME

core.ops - Parrot Core Ops

=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
RT#42381 search the library path to locate the file.

=cut

inline op noop() :base_core {
}

inline op cpu_ret() {
#ifdef __GNUC__
#  ifdef I386
    __asm__("ret");
#  endif
#endif
}

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 (interp->run_core & PARROT_CGOTO_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, op_lib.core_type);
    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);
}

=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<branch_cs>(in STR)

Intersegment branch to location in fixup table named $1.

=cut

inline op branch_cs(in STR) :base_loop :check_event :flow {
    PackFile_FixupEntry * fe;
    {
        char * const label = string_to_cstring(interp, $1);
        fe = PackFile_find_fixup_entry(interp, enum_fixup_label, label);
        string_cstring_free(label);
    }

    if (!fe) {
        opcode_t * handler= Parrot_ex_throw_from_op_args(interp, NULL,
            EXCEPTION_INVALID_OPERATION,
            "branch_cs: fixup for '%Ss' not found", $1);
        goto ADDRESS(handler);
    }
    else {
        interp->resume_offset = fe->offset;
        Parrot_switch_to_cs(interp, fe->seg, 1);
        mem_sys_free(fe);
    }
    interp->resume_flag = 2;
    goto ADDRESS(0);
}

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

=item B<bsr>(in LABEL)

Branch to the location specified by $1. Push the current location onto the call
stack for later returning.

=cut

inline op bsr(in LABEL) :base_core :check_event :flow {
    stack_push(interp, &interp->dynamic_env,
             expr NEXT(),  STACK_ENTRY_DESTINATION, STACK_CLEANUP_NULL);
    goto OFFSET($1);
}

=item B<ret>()

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

=cut

inline op ret() :flow {
    goto POP();
}

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

=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<jsr>(in LABEL)

Jump to the location specified by register $1. Push the current
location onto the call stack for later returning.

=cut

inline op jsr(in LABEL) :base_core :check_event :flow {
    opcode_t * loc;
    stack_push(interp, &interp->dynamic_env,
             expr NEXT(),  STACK_ENTRY_DESTINATION, STACK_CLEANUP_NULL);
    loc = INTVAL2PTR(opcode_t *, $1);
    goto ADDRESS(loc);
}

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

=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 (string_bool(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 (!string_bool(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                   = (opcode_t *)p->vtable->invoke(interp, p, dest);

    goto ADDRESS(dest);
}

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

    interp->current_object = NULL;
    interp->current_cont = $2;
    dest = (opcode_t *)p->vtable->invoke(interp, p, expr NEXT());
    goto ADDRESS(dest);
}

inline op yield() :flow {
    opcode_t *dest = expr NEXT();
    PMC * const p = CONTEXT(interp)->current_sub;
    dest = (opcode_t *)p->vtable->invoke(interp, p, dest);
    goto ADDRESS(dest);
}

inline op tailcall(invar PMC) :flow {
    opcode_t *dest;
    PMC * const p = $1;
    dest = expr NEXT();
    interp->current_cont = CONTEXT(interp)->current_cont;
    PObj_get_FLAGS(interp->current_cont) |= SUB_FLAG_TAILCALL;
    dest = (opcode_t *)p->vtable->invoke(interp, p, dest);
    goto ADDRESS(dest);
}

inline op returncc() :flow {
    PMC * const p = CONTEXT(interp)->current_cont;
    opcode_t * const dest = (opcode_t *)p->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 _this = CUR_OPCODE;
    PMC * const signature = $1;
    INTVAL argc;

    /* for now just point to the opcode */
    interp->current_args = _this;
    argc = SIG_ELEMS(signature);
    goto OFFSET(argc + 2);
}

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

    CONTEXT(interp)->current_results = _this;
    argc = SIG_ELEMS(signature);
    goto OFFSET(argc + 2);
}

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

    interp->current_params = _this;
    ctx = CONTEXT(interp);
    ccont = ctx->current_cont;

    caller_ctx = ctx->caller_ctx;

    src_indexes = interp->current_args;
    dst_indexes = interp->current_params;
    /* the args and params are now 'used.' */
    interp->current_args = NULL;
    interp->current_params = NULL;

    parrot_pass_args(interp, caller_ctx, ctx, src_indexes, dst_indexes, PARROT_PASS_PARAMS);
    if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) {
        PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL;
        --ctx->recursion_depth;
        ctx->caller_ctx = caller_ctx->caller_ctx;
        /* ordinarily, this will free the context immediately, but not if the
           sub created a closure (or continuation, or . . .).  */
        Parrot_free_context(interp, caller_ctx, 1);
        interp->current_args = NULL;
    }
    argc = SIG_ELEMS(signature);
    goto OFFSET(argc + 2);
}

op set_returns(inconst PMC) :flow {
    opcode_t * const _this = CUR_OPCODE;
    Parrot_Context *ctx;
    PMC *ccont;
    PMC *signature = $1;
    INTVAL argc;
    opcode_t *src_indexes, *dest_indexes;

    interp->current_returns = _this;
    ctx = CONTEXT(interp);
    ccont = ctx->current_cont;

    if (PMC_cont(ccont)->address) {
        /* Call is from runops_fromc */
        Parrot_Context * const caller_ctx = PMC_cont(ccont)->to_ctx;
        if (! caller_ctx) {
            /* there is no point calling Parrot_ex_throw_..., because
               PDB_backtrace can't deal with a missing to_ctx either. */
            exit_fatal(1, "No caller_ctx for continuation %p.", ccont);
        }

        src_indexes = interp->current_returns;
        dest_indexes = caller_ctx->current_results;
        interp->current_returns = NULL;
        /* does this need to be here */
        interp->current_args = NULL;

        parrot_pass_args(interp, ctx, caller_ctx, src_indexes, dest_indexes, PARROT_PASS_RESULTS);
    }
    else if (ctx->caller_ctx->results_signature) {
    /* We have a dynamic result signature, from pcc_invoke */
        parrot_pass_args(interp, ctx, ctx->caller_ctx, interp->current_returns,
                ctx->caller_ctx->current_results, PARROT_PASS_RESULTS);
    }
    argc = SIG_ELEMS(signature);
    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) {
    /* Get context of callee from return continuation. */
    PMC * const cc = CONTEXT(interp)->current_cont;
    PMC *sig = NULL;
    if (cc && PMC_cont(cc)->to_ctx) {
        /* caller context has results */
        opcode_t * const results = PMC_cont(cc)->to_ctx->current_results;
        if (results) {
            /* get results PMC index and get PMC. */
            sig = PF_CONST(PMC_cont(cc)->seg, results[1])->u.key;
        }
    }

    /* 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 = PTR2OPCODE_T(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,
            string_from_cstring(interp, "exception", 9));
}

inline op throw(invar PMC) :flow {
    opcode_t *dest;
    opcode_t *const ret    = expr NEXT();
    PMC            *resume = new_ret_continuation_pmc(interp, ret);
    /*
     * We might return here after handling the exception, so mark the
     * current context appropriately.
     */
    Parrot_context_ref(interp, CONTEXT(interp));
    VTABLE_set_attr_str(interp, $1, const_string(interp, "resume"), resume);
    dest = Parrot_ex_throw_from_op(interp, $1, ret);
    goto ADDRESS(dest);
}

inline op throw(invar PMC, invar PMC) :flow {
    opcode_t * const dest = Parrot_ex_throw_from_op(interp, $1,
                                VTABLE_get_pointer(interp, $2));
    goto ADDRESS(dest);
}

inline op rethrow(invar PMC) :flow {
    opcode_t * const dest = Parrot_ex_rethrow_from_op(interp, $1);
    goto ADDRESS(dest);
}

inline op count_eh(out INT) {
    $1 = Parrot_cx_count_handlers_typed(interp,
            string_from_cstring(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,
                        const_string(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,
                        const_string(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             *resume    = new_ret_continuation_pmc(interp, ret);
        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,
                        const_string(interp, "resume"), resume);
    dest = Parrot_ex_throw_from_op(interp, exception, ret);
    goto ADDRESS(dest);
}

inline op pushmark(in INT) {
    Parrot_push_mark(interp, $1);
}

inline op popmark(in INT) {
    Parrot_pop_mark(interp, $1);
}

inline op pushaction(invar PMC) {
    Parrot_push_action(interp, $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, .DOD_RUNS, .COLLECT_RUNS, .ACTIVE_PMCS, .ACTIVE_BUFFERS,
.TOTAL_PMCS, .TOTAL_BUFFERS, .HEADER_ALLOCS_SINCE_COLLECT,
.MEM_ALLOCS_SINCE_COLLECT, .TOTAL_COPIED, .IMPATIENT_PMCS, .LAZY_DOD_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 *)PMC_data($1);
    Interp_flags_SET(new_interp, PARROT_EXTERN_CODE_FLAG);
    new_interp->code = interp->code;
    runops(new_interp, REL_PC + $2);
}

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

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



=back

=cut

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

=head2 Dead Object Detection/Garbage Collection

Opcodes that interact with the DOD and GC subsystems.

=over 4

=cut

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

=item B<sweep>(inconst INT)

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

=over

=item * 0

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

=item * 1

Trigger a dead object detection (DOD) sweep unconditionally.

=back

=cut

op sweep(inconst INT) {
    if ($1)
        Parrot_do_dod_run(interp, 0);
    else
        if (interp->arena_base->num_early_DOD_PMCs)
            Parrot_do_dod_run(interp, GC_lazy_FLAG);
}

=item B<collect>()

Trigger a garbage collection.

=cut

op collect() {
    Parrot_go_collect(interp);
}

=item B<sweepoff>()

Disable DOD sweeps. (Nestable)

=cut

op sweepoff() {
    Parrot_block_GC_mark(interp);
}

=item B<sweepon>()

Re-enable DOD sweeps.

=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) {
     PObj_needs_early_DOD_SET($1);
     ++interp->arena_base->num_early_DOD_PMCs;
}

=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 = string_to_cstring(interp, ($3));
    void * const ptr  = Parrot_dlsym(
                            PMC_IS_NULL($2) ? NULL :
                            VTABLE_defined(interp, $2) ? PMC_data($2) :
                            NULL,
                            name);

    funcptr_t 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;
    }
    string_cstring_free(name);
}

op dlvar(out PMC, invar PMC, in STR) {
    char * const name = string_to_cstring(interp, ($3));
    void * const p = Parrot_dlsym(PMC_IS_NULL($2) ? NULL : PMC_data($2), 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);
        PMC_data($1) = p;
    }
    string_cstring_free(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, The Perl 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:
 */
