/*
Copyright (C) 2001-2003, The Perl Foundation.
$Id: continuation.pmc 16527 2007-01-09 18:20:53Z tewk $

=head1 NAME

src/pmc/continuation.pmc - Continuation PMC

=head1 DESCRIPTION

A C<Continuation> has a copy of the interpreter's context at the location,
where the Continuation was constructed.
See the L<Glossary|docs/glossary.pod> for more information.

=head2 Functions

=over 4

=cut

*/


#include "parrot/parrot.h"
#include "parrot/oplib/ops.h"
#include <assert.h>


/*

=back

=head2 Methods

=over 4

=cut

*/


/*
 * A Continuation (and RetContinuation, Exception_Handler) has in its
 * context a pointer to the register frame, which contains active objects.
 * Additionally ct->current_cont has he continuation of the caller.
 * To avoid deep recursion during marking of nested subroutines, we
 * need the next_for_GC pointer in the pmc_ext area.
 */

pmclass Continuation need_ext {

/*

=item C<void init()>

Initializes the continuation.

=cut

*/

    void init() {
        PMC_struct_val(SELF) = new_continuation(INTERP, NULL);
        PMC_pmc_val(SELF) = NULL;
        PObj_custom_mark_destroy_SETALL(SELF);
        /* PANIC("don't do that"); */
        /*
         * Whenever we create a continuation, all return continuations
         * up the call chain maybe reused due to invoking the
         * continuation. To avoid that all return continuations are
         * converted to true continuations.
         */
        invalidate_retc_context(INTERP, SELF);
    }

/*

=item C<void mark()>

Marks the continuation as live.

=cut

*/

    void mark() {
        struct Parrot_cont * cc = PMC_cont(SELF);
        if (cc->to_ctx)
            mark_context(INTERP, cc->to_ctx);
        if (cc->dynamic_state)
            mark_stack(INTERP, cc->dynamic_state);
    }

/*

=item C<void destroy()>

Destroys the continuation.

=cut

*/

    void destroy() {
        struct Parrot_cont * cc = PMC_cont(SELF);
        if (cc) {
#if CTX_LEAK_DEBUG
            if (Interp_debug_TEST(interp, PARROT_CTX_DESTROY_DEBUG_FLAG)) {
                fprintf(stderr,
                        "[destroy cont    %p, to_ctx %p, from_ctx %p]\n",
                        (void *)SELF, (void *)cc->to_ctx, (void *)cc->from_ctx);
            }
#endif
            if (cc->from_ctx)
                Parrot_free_context(interp, cc->from_ctx, 0);
            mem_sys_free(cc);
            PMC_struct_val(SELF) = NULL;
        }
    }
/*

=item C<PMC *clone()>

Creates and returns a clone of the continuation.

=cut

*/

    PMC* clone() {
        struct Parrot_cont * cc;
        struct Parrot_cont *cc_self = PMC_cont(SELF);
        PMC* ret = pmc_new_noinit(INTERP, enum_class_Continuation);

        PObj_custom_mark_destroy_SETALL(ret);
        cc = new_continuation(INTERP, cc_self);
        cc->runloop_id = cc_self->runloop_id;
        cc->dynamic_state = cc_self->dynamic_state;
        PMC_struct_val(ret) = cc;
        PMC_pmc_val(ret) = PMC_pmc_val(SELF);
        return ret;
    }

/*

=item C<PMC *set_pmc()>

Assign context.

=cut

*/
    void set_pmc(PMC* src) {
        struct Parrot_cont *cc_self = PMC_cont(SELF);
        struct Parrot_cont *cc_src  = PMC_cont(src);

        memcpy(cc_self, cc_src, sizeof (struct Parrot_cont));
        PMC_pmc_val(SELF) = PMC_pmc_val(src);
    }
/*

=item C<void set_pointer(void *value)>

Sets the pointer to the return instruction.  Also captures the current
dynamic state, and the descriptor address for any returned values.

=cut

*/

    void set_pointer(void* value) {
        opcode_t *pos = value;
        struct Parrot_cont * cc = PMC_cont(SELF);

        cc->address = value;
        cc->dynamic_state = INTERP->dynamic_env;
        cc->runloop_id = INTERP->current_runloop_id;
        if (pos && *pos == PARROT_OP_get_results_pc) {
            cc->current_results = pos;
        }
        else
            cc->current_results = NULL;
    }

/*

=item C<void *get_pointer()>

Returns the pointer to the return instruction.

=cut

*/

    void* get_pointer() {
        return PMC_cont(SELF)->address;
    }
/*

=item C<INTVAL defined()>

=item C<INTVAL get_bool()>

Returns whether the subroutine is defined.

=cut

*/

    INTVAL defined() {
        return PMC_cont(SELF)->address != NULL;
    }

    INTVAL get_bool() {
        return PMC_cont(SELF)->address != NULL;
    }

/*

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

Restores the "context" of the interpreter and returns the branch
destination to continue execution.

=cut

*/

    void* invoke(void* next) {
        struct Parrot_cont * cc = PMC_cont(SELF);
        Stack_Chunk_t *stack_target = cc->dynamic_state;
        Stack_Chunk_t *corresponding_target;
        int stack_delta = 0;
        parrot_context_t *from_ctx = CONTEXT(INTERP->ctx);
        parrot_context_t *to_ctx   = cc->to_ctx;
        opcode_t *pc = cc->address;
        /* [bug: these should be 'isa' tests.  -- rgr, 17-Sep-06.] */
        int exception_continuation_p
            = SELF->vtable->base_type == enum_class_Exception_Handler;
        int ret_continuation_p
            = SELF->vtable->base_type == enum_class_RetContinuation;

        if (interp->current_runloop_id != cc->runloop_id
            /* it's ok if we are exiting to "runloop 0"; there is no such
               runloop, but the only continuation that thinks it came from
               runloop 0 is for the return from the initial sub call. */
            && cc->runloop_id != 0
            /* since a RetContinuation [currently] only returns to the next
               outer frame, exiting to the inner run loop does the right thing,
               since it normally returns to the next outer runloop anyway.  */
            && ! ret_continuation_p) {
            fprintf(stderr, "[oops; continuation %p of type %d "
                    "is trying to jump from runloop %d to runloop %d]\n",
                    (void *) SELF, (int) SELF->vtable->base_type,
                    interp->current_runloop_id, cc->runloop_id);
        }
#if CTX_LEAK_DEBUG
        if (Interp_debug_TEST(interp, PARROT_CTX_DESTROY_DEBUG_FLAG)) {
            fprintf(stderr,
                    "[invoke cont    %p, to_ctx %p, from_ctx %p (refs %d)]\n",
                    (void *) SELF, (void *) to_ctx, (void *) from_ctx, (int) from_ctx->ref_count);
        }
#endif
        if (! to_ctx) {
            real_exception(interp, NULL, INVALID_OPERATION,
                           "Continuation invoked after deactivation.");
        }

        /*
         * Rewind the dynamic environment.
         */
        if (interp->dynamic_env != stack_target) {
            /* compute the "stack delta", which is a measure of how much
               unwinding we have to do.  if negative, we have to pop that many
               entries; if positive, we are going back up the stack.
               [bug: this is not true rewinding.  -- rgr, 30-Sep-06.]
            */
            stack_delta
                = ((int) stack_height(interp, stack_target)
                   - (int) stack_height(interp, interp->dynamic_env));
        }
        /* descend down the target stack until we get to the same depth. */
        corresponding_target = stack_target;
        while (stack_delta > 0) {
            corresponding_target = corresponding_target->prev;
            stack_delta--;
        }
        /* both stacks are now at the same depth.  pop from both until we reach
           their common ancestor. */
        while (interp->dynamic_env != corresponding_target) {
            PMC *cleanup_sub = NULL;
            Stack_Entry_t *e;

            if (! interp->dynamic_env)
                internal_exception(1, "Control stack damaged");
            e = stack_entry(interp, interp->dynamic_env, 0);
            if (! e)
                internal_exception(1, "Control stack damaged");
            if (e->entry_type == STACK_ENTRY_ACTION) {
                /*
                 * Disable automatic cleanup routine execution in stack_pop so
                 * that we can run the action subroutine manually.  This is
                 * because we have to run the sub AFTER it has been popped, lest
                 * a new error in the sub cause an infinite loop when invoking
                 * an error handler.
                 */
                cleanup_sub = UVal_pmc(e->entry);
                e->cleanup = STACK_CLEANUP_NULL;
            }
            (void)stack_pop(INTERP, &interp->dynamic_env,
                            NULL, NO_STACK_ENTRY_TYPE);
            if (cleanup_sub) {
                /* Now it's safe to run. */
                Parrot_runops_fromc_args(interp, cleanup_sub,
                                         "vI", exception_continuation_p);
            }

            /* Keep corresponding_target in sync.  If stack_delta is negative,
             * then dynamic_env is still above it; otherwise, we must step
             * corresponding_target backwards as well.
             */
            if (stack_delta < 0) {
                stack_delta++;
            }
            else {
                corresponding_target = corresponding_target->prev;
            }
        }
        /* run back up the target stack to our destination.  [when we support
           dynamic binding (e.g.), we will have to traverse back up, and will
           therefore need to keep track on the way down.  -- rgr, 30-Sep-06.] */
        interp->dynamic_env = stack_target;

        /* debug print before context is switched */
        if (Interp_trace_TEST(INTERP, PARROT_TRACE_SUB_CALL_FLAG)) {
            PMC *sub = to_ctx->current_sub;

            PIO_eprintf(INTERP, "# Back in sub '%Ss', env %p\n",
                        Parrot_full_sub_name(INTERP, sub),
                        interp->dynamic_env);
        }

        /*
         * set context
         */
        CONTEXT(INTERP->ctx) = to_ctx;
        INTERP->ctx.bp = to_ctx->bp;
        INTERP->ctx.bp_ps = to_ctx->bp_ps;
        if (ret_continuation_p) {
            /* RetContinuation arg passing is handled elsewhere. */
            return pc;
        }

        /* pass args */
        if (cc->current_results) {
            /* where caller wants result */
            to_ctx->current_results = cc->current_results;
        }
        if (to_ctx->current_results && INTERP->current_args) {
            opcode_t *src_indexes, *dest_indexes;
            /*
             * the register pointer is already switched back
             * to the caller, therefore the registers of the
             * sub we are returning from aren't marked, if
             * inside argument passing a DOD run is triggered
             * therefore we have to block DOD
             */
            src_indexes = interp->current_args;
            interp->current_args = NULL;
            dest_indexes = to_ctx->current_results;

            Parrot_block_DOD(INTERP);
            parrot_pass_args(INTERP, from_ctx, to_ctx, src_indexes, dest_indexes,
                    PARROT_PASS_PARAMS);
            Parrot_unblock_DOD(INTERP);
        }

        /* switch segment */
        INTERP->current_args = NULL;
        if (INTERP->code != cc->seg) {
            Parrot_switch_to_cs(INTERP, cc->seg, 1);
        }
        return pc;
    }

/*

=item C<STRING* get_string()>

Experimental: return caller info as a STRING.

=cut

*/

    STRING* get_string() {
        return Parrot_Context_infostr(INTERP, PMC_cont(SELF)->to_ctx);
    }

/*

=item C<METHOD PMC* "caller"()>

Experimental: return caller PMC or Undef if none.

=cut

*/

    METHOD PMC* caller() {
        struct Parrot_cont * cc = PMC_cont(SELF);
        PMC *caller = cc->to_ctx->current_sub;
        if (!caller || !PMC_sub(caller)->seg) {
            caller = pmc_new(INTERP, enum_class_Undef);
        }
        return caller;

    }
/*

=item C<METHOD PMC* "continuation"()>

Experimental: return continuation PMC of this Continuation or Undef if none.

=cut

*/

    METHOD PMC* continuation() {
        struct Parrot_cont * cc = PMC_cont(SELF);
        PMC *cont = cc->to_ctx->current_cont;
        if (cont)
            return cont;
        return pmc_new(INTERP, enum_class_Undef);
    }
}

/*

=back

=head1 HISTORY

Initial revision by sean 2002/08/04.

=cut

*/

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