/*
Copyright (C) 2001-2003, The Perl Foundation.
$Id: coroutine.pmc 17084 2007-02-20 20:03:37Z paultcochrane $

=head1 NAME

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

=head1 DESCRIPTION

C<Coroutine> extends C<Continuation> 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/parrot.h"
#include "parrot/oplib/ops.h"
#include <assert.h>

/*
 * XXX put these into exceptions.h
 */


#define TRY \
    do { \
        new_internal_exception(INTERP); \
        if (!setjmp(INTERP->exceptions->destination))

#define CATCH \
    else

#define ENDTRY \
    } while (0); \
    do { \
        Parrot_exception *e = INTERP->exceptions; \
        INTERP->exceptions = e->prev; \
        INTERP->exc_free_list = e; \
    } while (0)


#define THROW(e)  \
    do { \
        exceptions->err = e; \
        longjmp(exceptions->dest, 1); \
    } while (0)

static void
print_sub_name(Interp* interp, PMC* sub)
{
    struct Parrot_coro * co = PMC_coro(sub);
    Interp *tracer;

    tracer = interp->debugger ?
        interp->debugger : interp;
    PIO_eprintf(tracer, "# %s coro '%Ss'",
        !(PObj_get_FLAGS(sub) & SUB_FLAG_CORO_FF) ?
        "Calling" : "yielding from",
        Parrot_full_sub_name(interp, sub));
    if (co->ctx &&
        (PObj_get_FLAGS(sub) & SUB_FLAG_CORO_FF)) {
        PIO_eprintf(tracer, " to '%Ss'",
                Parrot_full_sub_name(interp,
                    co->ctx->caller_ctx->current_sub));
    }
    PIO_eprintf(tracer, "\n# ");
    print_pbc_location(interp);
}

pmclass Coroutine extends Sub need_ext {

/*

=item C<void init()>

Initializes the co-routine.

=item C<PMC* clone()>

Clone the couroutine.

=cut

*/

    void init() {
        PMC_struct_val(SELF) = new_coroutine(INTERP);
        PMC_pmc_val(SELF) = NULL;
        PObj_custom_mark_destroy_SETALL(SELF);
    }

    PMC* clone() {
        struct Parrot_coro * sub;
        PMC* ret = pmc_new_noinit(INTERP, SELF->vtable->base_type);
        PObj_custom_mark_destroy_SETALL(ret);
        sub = mem_sys_allocate(sizeof (struct Parrot_coro));
        PMC_struct_val(ret) = sub;
        PMC_pmc_val(ret) = NULL;
        memcpy(sub, PMC_sub(SELF), sizeof (struct Parrot_coro));
        sub->name = string_copy(INTERP, sub->name);
        return ret;
    }

/*

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

Swaps the "context".

=cut

*/

    void* invoke(void* next) {
        struct Parrot_coro * co = PMC_coro(SELF);
        parrot_context_t *caller_ctx;
        struct PackFile_ByteCode *wanted_seg;
        struct Stack_Chunk *state;
        opcode_t * dest = co->address;
        parrot_context_t *ctx;
        PMC *ccont;

        if (Interp_trace_TEST(INTERP, PARROT_TRACE_SUB_CALL_FLAG)) {
            print_sub_name(INTERP, SELF);
        }
        if (!co->ctx) {
            /* TODO factor out common code with Sub.invoke
             *      and inherit it
             */
            ccont = INTERP->current_cont;
            if (ccont == NEED_CONTINUATION) {
                ccont = new_ret_continuation_pmc(interp, next);
            }
            if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) {
                real_exception(INTERP, NULL, E_Exception,
                        "tail call to coro not allowed");
            }
            caller_ctx = CONTEXT(INTERP->ctx);
            /*
             * first time set current sub, cont, object
             */
            Parrot_alloc_context(INTERP, co->n_regs_used);
            co->ctx = ctx = CONTEXT(INTERP->ctx);
            co->dynamic_state = interp->dynamic_env;
            ctx->caller_ctx = caller_ctx;
            PMC_cont(ccont)->from_ctx = ctx;
            ctx->current_sub = SELF;
            ctx->current_HLL = co->HLL_id;
            ctx->current_namespace = co->namespace_stash;
            ctx->current_cont = ccont;
            ctx->current_object = NULL;
            INTERP->current_object = NULL;
            INTERP->current_cont = NULL;

            /* create pad if needed */
            if (!PMC_IS_NULL(co->lex_info)) {
                ctx->lex_pad = pmc_new_init(INTERP,
                        Parrot_get_ctx_HLL_type(interp,
                            enum_class_LexPad),
                        co->lex_info);
                VTABLE_set_pointer(INTERP, ctx->lex_pad, ctx);
            }

            PObj_get_FLAGS(SELF) |= SUB_FLAG_CORO_FF;
            wanted_seg = co->seg;
            co->caller_seg = INTERP->code;
            co->address = co->seg->base.data + co->start_offs;
        }
        /* if calling the Coro we need the segment of the Coro */
        else if (!(PObj_get_FLAGS(SELF) & SUB_FLAG_CORO_FF)) {
            PObj_get_FLAGS(SELF) |= SUB_FLAG_CORO_FF;
            wanted_seg = co->seg;
            /* remember segment of caller */
            co->caller_seg = INTERP->code;
            ctx = co->ctx;
            /* and the recent call context */
            ccont = ctx->current_cont;
            ctx->caller_ctx = PMC_cont(ccont)->to_ctx = CONTEXT(INTERP->ctx);
            /* set context to coro context */
            state = interp->dynamic_env;
            interp->dynamic_env = co->dynamic_state;
            co->dynamic_state = state;
            CONTEXT(INTERP->ctx) = ctx;
            INTERP->ctx.bp = ctx->bp;
            INTERP->ctx.bp_ps = ctx->bp_ps;
        }
        else {
            PObj_get_FLAGS(SELF) &= ~SUB_FLAG_CORO_FF;
            /* switch back to last remembered code seg and context */
            wanted_seg = co->caller_seg;
            ccont = co->ctx->current_cont;
            ctx = PMC_cont(ccont)->to_ctx;
            if (! 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.
                */
                real_exception(INTERP, NULL, E_Exception,
                               "Cannot resume dead coroutine.");
            }
            state = interp->dynamic_env;
            interp->dynamic_env = co->dynamic_state;
            co->dynamic_state = state;
            CONTEXT(INTERP->ctx) = ctx;
            INTERP->ctx.bp = ctx->bp;
            INTERP->ctx.bp_ps = ctx->bp_ps;
        }

        /* toggle address */
        dest = co->address;
        co->address = next;
        if (INTERP->code != wanted_seg) {
            Parrot_switch_to_cs(INTERP, wanted_seg, 1);
        }
        return dest;
    }

/*

=item C<void mark()>

Marks the coroutine as live.

=cut

*/

    void mark() {
        struct Parrot_coro *c = PMC_coro(SELF);
        if (c && c->ctx)
            mark_context(INTERP, c->ctx);
        if (c && c->dynamic_state)
            mark_stack(INTERP, c->dynamic_state);
        SUPER();
    }
}

/*

=back

=head1 HISTORY

Initial version by Melvin on 2002/06/6.

=cut

*/

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