experimental.ops

/*
** experimental.ops
*/

BEGIN_OPS_PREAMBLE

#include "parrot/scheduler_private.h"
#include "pmc/pmc_task.h"

END_OPS_PREAMBLE
=head1 NAME

experimental.ops - Experimental Opcodes

=cut

=head1 DESCRIPTION

This file contains experimental opcodes.

These opcodes should be considered implicitly deprecated - that is, they
may be removed in any release.

If you rely on any of these opcodes, please open an issue at
L<https://github.com/parrot/parrot/issues>

When making changes to any ops file, run C<make bootstrap-ops> to regenerate
all generated ops files.

=cut

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

=head2 More Experimental Ops

=over 4

=item B<trap>()

Break into debugger. Implementation notes:

 - x86/gcc ... works with gdb
 - ppc/gcc ... works with gdb, to proceed: gdb> p $pc = $pc + 4
 - TODO

For other architectures, this is a C<noop>.

=cut

op trap() :deprecated {
#if defined(__GNUC__) && defined(i386)
    __asm__("int3");       /* opcode 0xcc */
#endif
#if defined(__GNUC__) && defined(PPC)
    __asm__("trap");       /* opcode tr 31, 0, 0 */
#endif
}

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

Sets the opcode_t* label value for the given PMC. This is basically only
useful for PMCs such as Sub, Continuation, ExceptionHandler and derivatives

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

Gets the opcode_t* label value from the given PMC. This is basically only
useful for PMCs such as Sub, Continuation, ExceptionHandler and derivatives

=cut

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

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

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

Gets a unique(*) ID for a PMC.

This may or may not be based on the pointer of the PMC, but almost certainly is
not the raw pointer value.

(*) Uniqueness of these IDs is only guarranteed within code to which this PMC is
currently visible (ie: not across processes, or share-nothing threads, and not
beyond the lifetime of the PMC).

=cut

inline op get_id(out INT, in PMC) {
    $1 = Parrot_hash_pointer((void *)$2, interp->hash_seed);
}

=item B<fetch>(out PMC, in PMC, in PMC, in PMC)

Fetches a value from $2, keyed by $3 into $1.  If the resulting PMC is PMCNULL,
uses the type in $4 to create and return a new PMC.

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

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

=cut

inline op fetch(out PMC, in PMC, in PMC, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        $1 = Parrot_pmc_new_from_type(interp, $4);
    }
}

inline op fetch(out PMC, in PMC, in INT, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_int(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        $1 = Parrot_pmc_new_from_type(interp, $4);
    }
}

inline op fetch(out PMC, in PMC, in STR, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_str(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        $1 = Parrot_pmc_new_from_type(interp, $4);
    }
}

=item B<vivify>(out PMC, in PMC, in PMC, in PMC)

Fetches a value from $2, keyed by $3 into $1.  If the resulting PMC is PMCNULL,
uses the type in $4 to create and return a new PMC.

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

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

=cut

inline op vivify(out PMC, in PMC, in PMC, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        $1 = Parrot_pmc_new_from_type(interp, $4);

        VTABLE_set_pmc_keyed(interp, $2, $3, $1);
    }
}

inline op vivify(out PMC, in PMC, in INT, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_int(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        $1 = Parrot_pmc_new_from_type(interp, $4);

        VTABLE_set_pmc_keyed_int(interp, $2, $3, $1);
    }
}

inline op vivify(out PMC, in PMC, in STR, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_str(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        $1 = Parrot_pmc_new_from_type(interp, $4);

        VTABLE_set_pmc_keyed_str(interp, $2, $3, $1);
    }
}

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

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

=cut


op new(out PMC, in STR, in INT) {
    STRING * const name   = $2;
    PMC    * const _class = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp))
                          ? Parrot_oo_get_class_str(interp, name)
                          : PMCNULL;

    if (!PMC_IS_NULL(_class)) {
        PMC * const initial = Parrot_pmc_new(interp,
                                      Parrot_hll_get_ctx_HLL_type(interp, enum_class_Integer));
        VTABLE_set_integer_native(interp, initial, $3);
        $1 = VTABLE_instantiate(interp, _class, initial);
    }
    else {
        const INTVAL type = Parrot_pmc_get_type_str(interp, name);
        if (type <= 0) {
            opcode_t *dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(),
                EXCEPTION_NO_CLASS,
                "Class '%Ss' not found", name);
            goto ADDRESS(dest);
        }
        $1 = Parrot_pmc_new_init_int(interp, type, $3);
    }
}


op new(out PMC, in PMC, in INT) {
    PMC * const  name_key = $2;

    /* get_class() returns a PMCProxy for core types, so check for core PMCs */
    const INTVAL type = Parrot_pmc_get_type(interp, name_key);

    /* if it's clearly a PIR-level PMC */
    if (type > enum_class_core_max) {
        PMC * const _class = Parrot_oo_get_class(interp, name_key);
        if (!PMC_IS_NULL(_class)) {
            PMC * const initial = Parrot_pmc_new(interp,
                Parrot_hll_get_ctx_HLL_type(interp, enum_class_Integer));
            VTABLE_set_integer_native(interp, initial, $3);
            $1 = VTABLE_instantiate(interp, _class, initial);
        }
    }

    /* if it's a core PMC */
    else if (type > enum_class_default)
        $1 = Parrot_pmc_new_init_int(interp, type, $3);

    /* it's a typo */
    else {
        opcode_t * const dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(),
            EXCEPTION_NO_CLASS,
            "Class '%Ss' not found", VTABLE_get_repr(interp, name_key));
        goto ADDRESS(dest);
    }
}

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

=cut

op root_new(out PMC, in PMC, in INT) {
    PMC * const  name_key = $2;

    /* get_class() returns a PMCProxy for core types, so check for core PMCs */
    const INTVAL type = Parrot_pmc_get_type(interp, name_key);

    /* if it's clearly a PIR-level PMC */
    if (type > enum_class_core_max) {
        PMC * const root_ns  = interp->root_namespace;
        PMC * const ns       = Parrot_ns_get_namespace_keyed(interp, root_ns, name_key);
        PMC * const _class   = Parrot_oo_get_class(interp, ns);
        if (!PMC_IS_NULL(_class)) {
            PMC * const initial = Parrot_pmc_new(interp,
                Parrot_hll_get_ctx_HLL_type(interp, enum_class_Integer));
            VTABLE_set_integer_native(interp, initial, $3);
            $1 = VTABLE_instantiate(interp, _class, initial);
        }
    }

    /* if it's a core PMC */
    else if (type > enum_class_default)
        $1 = Parrot_pmc_new_init_int(interp, type, $3);

    /* it's a typo */
    else {
        opcode_t * const dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(),
            EXCEPTION_NO_CLASS,
            "Class '%Ss' not found", VTABLE_get_repr(interp, name_key));
        goto ADDRESS(dest);
    }
}

=item B<receive>(out PMC)

Receive a message sent to the current task.

If there is no waiting message, block and wait.

=cut

op receive(out PMC) {
    opcode_t *const dest = expr NEXT();
    PMC *cur_task = Parrot_cx_current_task(interp);
    Parrot_Task_attributes *tdata = PARROT_TASK(cur_task);
    int msg_count;
    if (PMC_IS_NULL(tdata->mailbox)) {
        tdata->mailbox = Parrot_pmc_new(interp, enum_class_PMCList);
        PARROT_GC_WRITE_BARRIER(interp, cur_task);
        msg_count = 0;
    }
    else
        msg_count = VTABLE_elements(interp, tdata->mailbox);

    if (msg_count > 0) {
        $1 = VTABLE_shift_pmc(interp, tdata->mailbox);
        goto ADDRESS(dest);
    }
    else {
        TASK_recv_block_SET(cur_task);
        (void) Parrot_cx_stop_task(interp, cur_opcode);
        goto ADDRESS(0);
    }
}

=item B<wait>(in PMC)

Block and wait for a task to complete.

=cut

op wait(in PMC) {
    opcode_t *const next = expr NEXT();
    PMC *task = $1;
    PMC *cur_task;
    Parrot_Task_attributes *tdata;

    if (!VTABLE_isa(interp, task, Parrot_str_new_constant(interp, "Task")))
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
            "Argument to wait op must be a Task.\n");

    cur_task = Parrot_cx_stop_task(interp, next);
    tdata    = PARROT_TASK(task);
    if (PMC_IS_NULL(tdata->waiters)) {
        tdata->waiters = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
        PARROT_GC_WRITE_BARRIER(interp, task);
    }
    VTABLE_push_pmc(interp, tdata->waiters, cur_task);

    goto ADDRESS(0);
}

=item B<pass>()

Pass the rest of the current quantum and schedule the next
task in the task queue.

=cut

op pass() {
    opcode_t *const next = expr NEXT();
    opcode_t *const addr = Parrot_cx_preempt_task(interp, interp->scheduler, next);
    goto ADDRESS(addr);
}

=back

=head1 COPYRIGHT

Copyright (C) 2001-2011, Parrot Foundation.

=head1 LICENSE

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

=cut

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