coroutine.pmc

/*
Copyright (C) 2001-2011, Parrot Foundation.

=head1 NAME

src/pmc/coroutine.pmc - Co-Routine PMC

=head1 DESCRIPTION

C<Coroutine> extends C<Sub> to provide a subroutine that can
stop in the middle, and start back up later at the point at which it
stopped. See the L<Glossary|docs/glossary.pod> for more information.

=head2 Flags

=over 4

=item private0 call flip flop

=item private3 restore current sub after "flop".  Used by generators.

=back

=head2 Methods

=over 4

=cut

*/

#include "parrot/oplib/ops.h"

/* 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(PMC *sub_pmc))
        __attribute__nonnull__(1)
        __attribute__nonnull__(2);

#define ASSERT_ARGS_print_sub_name __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
       PARROT_ASSERT_ARG(interp) \
    , PARROT_ASSERT_ARG(sub_pmc))
/* 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_pmc)>

static function to print coroutine information (for tracing/debugging)

=cut

*/

static void
print_sub_name(PARROT_INTERP, ARGIN(PMC *sub_pmc))
{
    /* It's actually a Parrot_coroutine, but this avoids casting warnings. */
    PMC           *ctx;
    Interp * const tracer = (interp->pdb && interp->pdb->debugger) ?
            interp->pdb->debugger :
            interp;

    GETATTR_Coroutine_ctx(interp, sub_pmc, ctx);

    Parrot_io_eprintf(tracer, "# %s coroutine '%Ss'",
        !(PObj_get_FLAGS(sub_pmc) & SUB_FLAG_CORO_FF) ?
        "Calling" : "yielding from",
        Parrot_sub_full_sub_name(interp, sub_pmc));

    if (!PMC_IS_NULL(ctx) && (PObj_get_FLAGS(sub_pmc) & SUB_FLAG_CORO_FF)) {
        Parrot_io_eprintf(tracer, " to '%Ss'",
                Parrot_sub_full_sub_name(interp,
                    Parrot_pcc_get_sub(interp, Parrot_pcc_get_caller_ctx(interp, ctx))));
    }

    Parrot_io_eprintf(tracer, "\n# ");
    print_pbc_location(interp);
}

pmclass Coroutine extends Sub provides invokable auto_attrs {
    ATTR INTVAL             yield;      /* yield in process */
    ATTR opcode_t          *address;    /* next address to run - toggled each time */
    ATTR PackFile_ByteCode *caller_seg; /* bytecode segment */

/*

=item C<void init()>

Initializes the coroutine.

=item C<PMC *clone()>

Clone the coroutine.

=cut

*/

    VTABLE void init() {
        SET_ATTR_seg(INTERP, SELF, INTERP->code);
        SET_ATTR_ctx(INTERP, SELF, PMCNULL);

        PObj_custom_mark_destroy_SETALL(SELF);
    }


/*

=item C<PMC * clone()>

Clones the coroutine.

=cut

*/

    VTABLE PMC *clone() {
        PMC * const ret = Parrot_pmc_new(INTERP, SELF->vtable->base_type);

        PObj_custom_mark_destroy_SETALL(ret);

        memcpy((Parrot_Coroutine_attributes *)PMC_data(ret),
                (Parrot_Coroutine_attributes *)PMC_data(SELF),
                sizeof (Parrot_Coroutine_attributes));

        return ret;
    }

/*

=item C<void increment()>

Signals the start of a yield.

=cut

*/

    VTABLE void increment() {
        SET_ATTR_yield(INTERP, SELF, 1);
    }

/*

=item C<opcode_t *invoke(void *next)>

Swaps the "context".

=cut

*/

    VTABLE opcode_t *invoke(void *next) {
        PMC               *ctx;
        opcode_t          *dest;
        PackFile_ByteCode *wanted_seg;
        opcode_t * const   next_op = (opcode_t *)next;
        PMC      * const signature = Parrot_pcc_get_signature(INTERP,
                                            CURRENT_CONTEXT(INTERP));

        if (Interp_trace_TEST(INTERP, PARROT_TRACE_SUB_CALL_FLAG))
            print_sub_name(INTERP, SELF);

        GET_ATTR_ctx(INTERP, SELF, ctx);

        if (PMC_IS_NULL(ctx)) {
            PackFile_ByteCode *seg;
            size_t             start_offs;
            const UINTVAL     *n_regs_used;
            PMC               *lex_info;
            PMC * const        caller_ctx = CURRENT_CONTEXT(INTERP);
            PMC               *ctx        = Parrot_pcc_get_signature(INTERP, caller_ctx);
            PMC               *ccont      = INTERP->current_cont;

            if (ccont == NEED_CONTINUATION) {
                ccont = pmc_new(INTERP, enum_class_Continuation);
                VTABLE_set_pointer(INTERP, ccont, next_op);
            }

            if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL)
                Parrot_ex_throw_from_c_args(INTERP, NULL, CONTROL_ERROR,
                        "tail call to coroutine not allowed");

            /* first time set current sub, cont, object */
            if (PMC_IS_NULL(ctx))
                ctx = Parrot_pmc_new(INTERP, enum_class_CallContext);

            Parrot_pcc_set_context(INTERP, ctx);

            GET_ATTR_n_regs_used(INTERP, SELF, n_regs_used);
            Parrot_pcc_allocate_registers(INTERP, ctx, n_regs_used);
            Parrot_pcc_set_caller_ctx(INTERP, ctx, caller_ctx);
            Parrot_pcc_init_context(INTERP, ctx, caller_ctx);

            SET_ATTR_ctx(INTERP, SELF, ctx);

            SETATTR_Continuation_from_ctx(INTERP, ccont, ctx);

            Parrot_pcc_set_sub(INTERP, ctx, SELF);
            Parrot_pcc_set_continuation(INTERP, ctx, ccont);
            Parrot_pcc_set_object(INTERP, ctx, PMCNULL);

            INTERP->current_cont   = PMCNULL;

            GET_ATTR_lex_info(INTERP, SELF, lex_info);

            /* create pad if needed */
            if (!PMC_IS_NULL(lex_info)) {
                const INTVAL hlltype = Parrot_hll_get_ctx_HLL_type(INTERP, enum_class_LexPad);
                PMC * const lexpad = Parrot_pmc_new_init(INTERP, hlltype, lex_info);
                Parrot_pcc_set_lex_pad(INTERP, ctx, lexpad);
                VTABLE_set_pointer(INTERP, lexpad, ctx);
            }

            GET_ATTR_seg(INTERP, SELF, seg);
            PObj_get_FLAGS(SELF) |= SUB_FLAG_CORO_FF;
            wanted_seg            = seg;

            GET_ATTR_start_offs(INTERP, SELF, start_offs);
            SET_ATTR_caller_seg(INTERP, SELF, INTERP->code);
            SET_ATTR_address(INTERP, SELF, seg->base.data + start_offs);
        }

        /* if calling the Coro we need the segment of the Coro */
        else if (!(PObj_get_FLAGS(SELF) & SUB_FLAG_CORO_FF)) {
            PackFile_ByteCode *seg;
            PMC               *ctx;
            PMC               *ccont;

            GET_ATTR_ctx(INTERP, SELF, ctx);
            ccont = Parrot_pcc_get_continuation(INTERP, ctx);

            PObj_get_FLAGS(SELF) |= SUB_FLAG_CORO_FF;

            GET_ATTR_seg(INTERP, SELF, seg);
            wanted_seg            = seg;

            /* remember segment of caller */
            SET_ATTR_caller_seg(INTERP, SELF, INTERP->code);



            /* and the recent call context */
            SETATTR_Continuation_to_ctx(INTERP, ccont, CURRENT_CONTEXT(INTERP));
            Parrot_pcc_set_caller_ctx(INTERP, ctx, CURRENT_CONTEXT(INTERP));

            /* set context to coroutine context */
            Parrot_pcc_set_context(INTERP, ctx);
        }
        else {
            INTVAL             yield;
            PMC               *ccont, *ctx, *to_ctx;
            PackFile_ByteCode *caller_seg;

            GET_ATTR_yield(INTERP, SELF, yield);

            if (!yield)
                Parrot_ex_throw_from_c_args(INTERP, NULL, CONTROL_ERROR,
                               "Cannot resume dead coroutine.");

            SET_ATTR_yield(INTERP, SELF, 0);

            GET_ATTR_ctx(INTERP, SELF, ctx);
            ccont = Parrot_pcc_get_continuation(INTERP, ctx);

            GETATTR_Continuation_to_ctx(INTERP, ccont, to_ctx);

            PObj_get_FLAGS(SELF) &= ~SUB_FLAG_CORO_FF;
            GET_ATTR_caller_seg(INTERP, SELF, caller_seg);

            /* switch back to last remembered code seg and context */
            wanted_seg = caller_seg;

            if (PMC_IS_NULL(to_ctx)) {
                /* This still isn't quite right, but it beats segfaulting.  See
                   the "Call an exited coroutine" case in t/pmc/coroutine.t; the
                   problem is that the defunct coroutine yields up one more
                   result before we get here.  -- rgr, 7-Oct-06.
                 * This may be unneeded after the yield fix, see TT #1003
                 */
                Parrot_ex_throw_from_c_args(INTERP, NULL, CONTROL_ERROR,
                               "Cannot resume dead coroutine.");
            }

            Parrot_pcc_set_context(INTERP, to_ctx);
        }

        Parrot_pcc_set_signature(INTERP, CURRENT_CONTEXT(INTERP), signature);

        /* toggle address */
        GET_ATTR_address(INTERP, SELF, dest);
        SET_ATTR_address(INTERP, SELF, (opcode_t *)next);

        if (INTERP->code != wanted_seg)
            Parrot_switch_to_cs(INTERP, wanted_seg, 1);

        return dest;
    }

}

/*

=back

=cut

*/

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