Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tag: RELEASE_0_4_13
Fetching contributors…

Cannot retrieve contributors at this time

353 lines (294 sloc) 9.078 kb
/*
Copyright (C) 2001-2003, The Perl Foundation.
$Id$
=head1 NAME
src/pmc/eval.pmc - Dynamic code evaluation
=head1 DESCRIPTION
C<Eval> extends C<Closure> to provide C<eval>-like dynamic code
evaluation and execution.
=head2 Methods
=over 4
=cut
*/
#include "parrot/parrot.h"
static void
clear_fixups(Interp *interp, Parrot_sub *sub_data)
{
opcode_t i, ci;
PackFile_ByteCode *seg;
PackFile_FixupTable *ft;
PackFile_ConstTable *ct;
PMC *sub;
seg = sub_data->seg;
if (!seg)
return;
ft = seg->fixups;
if (!ft)
return;
ct = seg->const_table;
if (!ct)
return;
for (i = 0; i < ft->fixup_count; i++) {
switch (ft->fixups[i]->type) {
case enum_fixup_sub:
ci = ft->fixups[i]->offset;
sub = ct->constants[ci]->u.key;
if (PMC_sub(sub)) {
PMC_sub(sub)->seg = NULL;
PMC_sub(sub)->eval_pmc = NULL;
}
ct->constants[ci]->u.key = NULL;
ft->fixups[i]->type = 0;
}
}
}
static PMC*
get_sub(Interp *interp, PMC* self, int idx)
{
opcode_t i, n, ci;
PackFile_ByteCode *seg;
PackFile_FixupTable *ft;
PackFile_ConstTable *ct;
PMC *sub;
seg = PMC_sub(self)->seg;
if (!seg)
return PMCNULL;
ft = seg->fixups;
if (!ft)
return PMCNULL;
ct = seg->const_table;
if (!ct)
return PMCNULL;
for (i = n = 0; i < ft->fixup_count; i++) {
switch (ft->fixups[i]->type) {
case enum_fixup_sub:
if (n++ != idx)
continue;
ci = ft->fixups[i]->offset;
sub = ct->constants[ci]->u.key;
return sub;
}
}
return PMCNULL;
}
static void
mark_subs(Interp *interp, PMC* self)
{
opcode_t i, ci;
PackFile_ByteCode *seg;
PackFile_FixupTable *ft;
PackFile_ConstTable *ct;
PMC *sub;
seg = PMC_sub(self)->seg;
if (!seg)
return;
ft = seg->fixups;
if (!ft)
return;
ct = seg->const_table;
if (!ct)
return;
for (i = 0; i < ft->fixup_count; i++) {
switch (ft->fixups[i]->type) {
case enum_fixup_sub:
ci = ft->fixups[i]->offset;
sub = ct->constants[ci]->u.key;
pobject_lives(interp, (PObj*)sub);
}
}
}
pmclass Eval extends Sub need_ext {
void init() {
Parrot_sub *sub_data;
SUPER();
sub_data = PMC_sub(SELF);
PObj_custom_mark_destroy_SETALL(SELF);
sub_data->seg = NULL;
}
/*
=item C<opcode_t *invoke(void *next)>
Invokes the first subroutine in the eval code.
=cut
*/
opcode_t* invoke(void *next) {
PMC *sub = SELF.get_pmc_keyed_int(0);
return VTABLE_invoke(INTERP, sub, next);
}
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.
*
* TODO walk the fixups for this segment, 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.
*/
Parrot_sub *sub_data;
PackFile_Segment *seg;
PackFile_ByteCode *cur_cs;
sub_data = PMC_sub(SELF);
if (!sub_data)
return;
clear_fixups(INTERP, sub_data);
cur_cs = sub_data->seg;
if (!cur_cs)
return;
/* TODO create PF API, move it there */
seg = (PackFile_Segment *)cur_cs->const_table;
if (seg) {
PackFile_Segment_destroy(INTERP, seg);
}
seg = (PackFile_Segment *)cur_cs->debugs;
if (seg) {
PackFile_Segment_destroy(INTERP, seg);
}
seg = (PackFile_Segment *)cur_cs->fixups;
if (seg) {
PackFile_Segment_destroy(INTERP, seg);
cur_cs->fixups = NULL;
}
seg = cur_cs->pic_index;
if (seg) {
PackFile_Segment_destroy(INTERP, seg);
}
seg = (PackFile_Segment *)cur_cs;
PackFile_Segment_destroy(INTERP, seg);
sub_data->seg = NULL;
PMC_struct_val(SELF) = NULL;
mem_sys_free(sub_data);
SUPER();
}
void mark() {
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
*/
STRING* get_string() {
STRING *res;
PackFile *pf;
size_t size, aligned_size;
PackFile_ByteCode *seg;
pf = PackFile_new(INTERP, 0);
seg = PMC_sub(SELF)->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);
if (seg->pic_index)
PackFile_add_segment(INTERP, &pf->directory,
(PackFile_Segment *)seg->pic_index);
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 = string_make_empty(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 DOD while doing the packing, since GC run during a pack
has been observed to cause problems. There may be a Better Fix.
See RT #40410 for example of the problem (note on line that
segfaults, it is *cursor that is pointing to dealloced memory). */
Parrot_block_DOD(INTERP);
PackFile_pack(INTERP, pf, (opcode_t *)res->strstart);
Parrot_unblock_DOD(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
*/
PMC* get_pmc_keyed_int(INTVAL key) {
return get_sub(INTERP, SELF, key);
}
/*
=item C<void freeze(visit_info *info)>
Archives the evaled code
=item C<void thaw(visit_info *info)>
Unarchives the code.
=cut
*/
void freeze(visit_info *info) {
IMAGE_IO *io = info->image_io;
STRING *packed = SELF.get_string();
io->vtable->push_string(INTERP, io, packed);
SUPER(info);
}
void thaw(visit_info *info) {
IMAGE_IO *io = info->image_io;
PackFile *pf;
STRING *packed;
size_t i;
PackFile_Segment *seg;
struct Parrot_sub * sub;
packed = io->vtable->shift_string(INTERP, io);
SUPER(info);
sub = PMC_sub(SELF);
pf = PackFile_new(INTERP, 0);
if (!PackFile_unpack(INTERP, pf, (opcode_t *)packed->strstart,
packed->strlen))
real_exception(INTERP, NULL, E_IOError,
"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_sub(SELF)->seg = (PackFile_ByteCode *)seg;
break;
}
}
pf->directory.num_segments = 0;
/*
* XXX 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); */
}
}
/*
=back
=head1 HISTORY
Initial version by leo 2003/01/16.
=cut
*/
/*
* Local variables:
* c-file-style: "parrot"
* End:
* vim: expandtab shiftwidth=4:
*/
Jump to Line
Something went wrong with that request. Please try again.