eval.pmc

/*
Copyright (C) 2001-2010, Parrot Foundation.
$Id$

=head1 NAME

src/pmc/eval.pmc - Dynamic code evaluation

=head1 DESCRIPTION

C<Eval> extends C<Sub> to provide C<eval>-like dynamic code
evaluation and execution.

=head2 Methods

=over 4

=cut

*/

#include "pmc/pmc_sub.h"

/* HEADERIZER HFILE: none */
/* HEADERIZER BEGIN: static */
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */

static void clear_fixups(PARROT_INTERP,
    ARGIN(const Parrot_Sub_attributes *sub_data))
        __attribute__nonnull__(1)
        __attribute__nonnull__(2);

PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
static PMC* get_sub(PARROT_INTERP, ARGIN(PMC *self), int idx)
        __attribute__nonnull__(1)
        __attribute__nonnull__(2);

static void mark_subs(PARROT_INTERP, ARGIN(PMC *self))
        __attribute__nonnull__(1)
        __attribute__nonnull__(2);

#define ASSERT_ARGS_clear_fixups __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
       PARROT_ASSERT_ARG(interp) \
    , PARROT_ASSERT_ARG(sub_data))
#define ASSERT_ARGS_get_sub __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
       PARROT_ASSERT_ARG(interp) \
    , PARROT_ASSERT_ARG(self))
#define ASSERT_ARGS_mark_subs __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
       PARROT_ASSERT_ARG(interp) \
    , PARROT_ASSERT_ARG(self))
/* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
/* HEADERIZER END: static */

/*

=item C<static void clear_fixups(PARROT_INTERP, const Parrot_Sub_attributes
*sub_data)>



=cut

*/

static void
clear_fixups(PARROT_INTERP, ARGIN(const Parrot_Sub_attributes *sub_data))
{
    ASSERT_ARGS(clear_fixups)

    PackFile_ByteCode * const seg = sub_data->seg;

    if (seg) {
        PackFile_FixupTable * const ft = seg->fixups;
        if (ft) {
            PackFile_ConstTable * const ct = seg->const_table;
            if (ct) {
                INTVAL i;
                for (i = 0; i < ft->fixup_count; ++i) {
                    PackFile_FixupEntry * const e = ft->fixups + i;

                    if (e->type == enum_fixup_sub) {
                        opcode_t  ci             = e->offset;

                        ct->constants[ci].u.key = NULL;
                        e->type                  = 0;
                    }
                }
            }
        }
    }
}

/*

=item C<static PMC* get_sub(PARROT_INTERP, PMC *self, int idx)>



=cut

*/

PARROT_WARN_UNUSED_RESULT
PARROT_CAN_RETURN_NULL
static PMC*
get_sub(PARROT_INTERP, ARGIN(PMC *self), int idx)
{
    ASSERT_ARGS(get_sub)

    Parrot_Sub_attributes *sub;
    PackFile_ByteCode     *seg;

    PMC_get_sub(interp, self, sub);
    seg = sub->seg;

    if (seg) {
        PackFile_FixupTable * const ft = seg->fixups;
        if (ft) {
            PackFile_ConstTable * const ct = seg->const_table;
            if (ct) {
                INTVAL i, n;
                for (i = n = 0; i < ft->fixup_count; ++i) {
                    const PackFile_FixupEntry * const e = ft->fixups + i;

                    if (e->type == enum_fixup_sub) {
                        opcode_t ci = e->offset;

                        if (n++ == idx)
                            return ct->constants[ci].u.key;
                    }
                }
            }
        }
    }

    return PMCNULL;
}

/*

=item C<static void mark_subs(PARROT_INTERP, PMC *self)>



=cut

*/

static void
mark_subs(PARROT_INTERP, ARGIN(PMC *self))
{
    ASSERT_ARGS(mark_subs)

    Parrot_Sub_attributes *sub;
    PackFile_ByteCode   *seg;

    PMC_get_sub(interp, self, sub);
    seg = sub->seg;

    if (seg) {
        PackFile_FixupTable * const ft = seg->fixups;
        if (ft) {
            PackFile_ConstTable * const ct = seg->const_table;
            if (ct) {
                INTVAL i;
                for (i = 0; i < ft->fixup_count; ++i) {
                    const PackFile_FixupEntry * const e = ft->fixups + i;

                    if (e->type == enum_fixup_sub) {
                        opcode_t  ci  = e->offset;
                        PMC      *sub = ct->constants[ci].u.key;

                        Parrot_gc_mark_PMC_alive(interp, sub);
                    }
                }
            }
        }
    }
}

pmclass Eval extends Sub provides invokable auto_attrs {

    VTABLE void init() {
        Parrot_Sub_attributes *sub_data;
        SUPER();

        PMC_get_sub(INTERP, SELF, sub_data);
        sub_data->seg = NULL;
        PObj_custom_mark_destroy_SETALL(SELF);
    }
/*

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

Invokes the first subroutine in the eval code.

=cut

*/

    VTABLE opcode_t *invoke(void *next) {
        PMC *sub = SELF.get_pmc_keyed_int(0);
        return VTABLE_invoke(INTERP, sub, next);
    }

    VTABLE void destroy() {
        /*
         * If the compiled code contained any .sub (or .pcc.sub)
         * subroutines, these subs got installed in the globals
         * during compiling this bytecode segment.
         *
         * These globals still exist, calling them will segfault
         * as the segment is destroyed now.
         *
         * TT # 1230:
         * Walk the fixups, locate globals and nullify the Sub PMC
         * This probably needs a pointer into the globals.
         *
         * OTOH - if the global exists - this eval pmc ought
         *        to be alive and destroy isn't called.
         */
        PackFile_Segment  *seg;
        PackFile_ByteCode *cur_cs;
        Parrot_Sub_attributes *sub_data;

        PMC_get_sub(INTERP, SELF, sub_data);

        if (!sub_data) {
            SUPER();
            return;
        }

        clear_fixups(INTERP, sub_data);
        cur_cs = sub_data->seg;

        if (!cur_cs) {
            SUPER();
            return;
        }

        /* XXX Quick and dirty fix for TT #995 */
        if ((struct PackFile *)cur_cs == INTERP->initial_pf
                || cur_cs == INTERP->code) {
            SUPER();
            return;
        }

        /* TT #1315 create PF API, move it there */
        seg = (PackFile_Segment *)cur_cs->const_table;
        if (seg) {
            PackFile_Segment_destroy(INTERP, seg);
            cur_cs->const_table = NULL;
        }

        seg = (PackFile_Segment *)cur_cs->debugs;
        if (seg) {
            PackFile_Segment_destroy(INTERP, seg);
            cur_cs->debugs = NULL;
        }

        seg = (PackFile_Segment *)cur_cs->fixups;
        if (seg) {
            PackFile_Segment_destroy(INTERP, seg);
            cur_cs->fixups = NULL;
        }

        seg = (PackFile_Segment *)cur_cs;
        if (seg)
            PackFile_Segment_destroy(INTERP, seg);

        sub_data->seg = NULL;

        SUPER();
    }

    VTABLE void mark() {
        SUPER();
        mark_subs(INTERP, SELF);
    }

/*

=item C<STRING *get_string>

Get a STRING representing the bytecode for this code segment, suitable
for writing to disc and later loading via C<load_bytecode>.

=cut

*/

    VTABLE STRING *get_string() {
        Parrot_Sub_attributes *sub;
        PackFile          *pf  = PackFile_new(INTERP, 0);
        PackFile_ByteCode *seg;
        STRING            *res;
        size_t             size, aligned_size;

        PMC_get_sub(INTERP, SELF, sub);
        seg = sub->seg;

        PackFile_add_segment(INTERP, &pf->directory, (PackFile_Segment *)seg);

        if (seg->const_table)
            PackFile_add_segment(INTERP, &pf->directory,
                    (PackFile_Segment *)seg->const_table);

        if (seg->debugs)
            PackFile_add_segment(INTERP, &pf->directory,
                    (PackFile_Segment *)seg->debugs);

        if (seg->fixups)
            PackFile_add_segment(INTERP, &pf->directory,
                    (PackFile_Segment *)seg->fixups);

        size = PackFile_pack_size(INTERP, pf) * sizeof (opcode_t);

        /*
         * work around packfile bug:
         * as far as I have checked it the story is:
         * - PackFile_pack_size() assumes 16 byte alignment but doesn't
         *   have the actual start of the code (packed)
         * - PackFile_pack() uses 16 bye alignment relative to the start
         *   of the code, which isn't really the same
         * Therefore align code at 16, which should give the desired
         * effect
         */
        aligned_size = size + 15;
        res          = Parrot_str_new_noinit(INTERP, enum_stringrep_one,
                                         aligned_size);
        res->strlen  = res->bufused = size;

        if ((size_t)(res->strstart) & 0xf) {
            char *adr     = res->strstart;
            adr          += 16 - ((size_t)adr & 0xf);
            res->strstart = adr;
        }

        /* We block GC while doing the packing, since GC run during a pack
           has been observed to cause problems. There may be a Better Fix.
           See http://rt.perl.org/rt3/Ticket/Display.html?id=40410
           for example of the problem (note on line that
           segfaults, it is *cursor that is pointing to dealloced memory). */
        Parrot_block_GC_mark(INTERP);
        PackFile_pack(INTERP, pf, (opcode_t *)res->strstart);
        Parrot_unblock_GC_mark(INTERP);

        /* now remove all segments from directory again and destroy
         * the packfile */
        pf->directory.num_segments = 0;
        PackFile_destroy(INTERP, pf);

        return res;
    }

/*

=item C<PMC *get_pmc_keyed_int(INTVAL key)>

Returns the Sub PMC of the element at index C<key> or PMCNULL.

=cut

*/

    VTABLE PMC *get_pmc_keyed_int(INTVAL key) {
        return get_sub(INTERP, SELF, key);
    }

/*

=item C<void freeze(PMC *info)>

Archives the evaled code

=item C<void thaw(PMC *info)>

Unarchives the code.

=cut

*/

    VTABLE void freeze(PMC *info) {
        STRING   *packed = SELF.get_string();
        VTABLE_push_string(INTERP, info, packed);

        SUPER(info);
    }

    VTABLE void thaw(PMC *info) {
        STRING           *packed = VTABLE_shift_string(INTERP, info);
        PackFile         *pf;
        PackFile_Segment *seg;
        Parrot_Sub_attributes *sub;
        size_t            i;

        SUPER(info);
        pf = PackFile_new(INTERP, 0);

        if (!PackFile_unpack(INTERP, pf, (opcode_t *)packed->strstart,
                packed->strlen))
            Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_EXTERNAL_ERROR,
                "couldn't unpack packfile");

        do_sub_pragmas(INTERP, pf->cur_cs, PBC_PBC, SELF);

        for (i = 0; i < pf->directory.num_segments; ++i) {
            seg = pf->directory.segments[i];

            if (seg->type == PF_BYTEC_SEG) {
                PMC_get_sub(INTERP, SELF, sub);
                sub->seg = (PackFile_ByteCode *)seg;
                break;
            }
        }

        pf->directory.num_segments = 0;

        /*
         * TT #1292 this isn't ok - it seems that the packfile
         *     gets attached to INTERP->code and is
         *     destroyed again during interpreter destruction
         */
        /* PackFile_destroy(INTERP, pf); */
    }

    VTABLE INTVAL elements() {
        INTVAL                 n = 0;
        Parrot_Sub_attributes *sub;
        PackFile_ByteCode     *seg;

        PMC_get_sub(INTERP, SELF, sub);
        seg = sub->seg;

        if (seg) {
            PackFile_FixupTable *const ft = seg->fixups;
            if (ft) {
                INTVAL i;
                for (i = n = 0; i < ft->fixup_count; ++i) {
                    const PackFile_FixupEntry * const e = ft->fixups + i;

                    if (e->type == enum_fixup_sub)
                        ++n;
                }
            }
        }

        return n;
    }
}

/*

=back

=head1 HISTORY

Initial version by leo 2003/01/16.

=cut

*/

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