cvsuser 03/11/19 07:43:35
Modified: . MANIFEST vtable.tbl
classes array.pmc default.pmc perlint.pmc
config/gen/makefiles root.in
include/parrot parrot.h
ops ops.num pmc.ops
Added: src pmc_freeze.c
Log:
First draft of freeze -- Leo's base code
Revision Changes Path
1.504 +3 -0 parrot/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.503
retrieving revision 1.504
diff -u -w -r1.503 -r1.504
--- MANIFEST 17 Nov 2003 02:28:02 -0000 1.503
+++ MANIFEST 19 Nov 2003 15:43:17 -0000 1.504
@@ -1610,6 +1610,7 @@
include/parrot/parrot.h [devel]include
include/parrot/perltypes.h [devel]include
include/parrot/pmc.h [devel]include
+include/parrot/pmc_freeze.h [devel]include
include/parrot/pobj.h [devel]include
include/parrot/regfuncs.h [devel]include
include/parrot/register.h [devel]include
@@ -2170,6 +2171,7 @@
src/pdb.c []
src/pdump.c []
src/pmc.c []
+src/pmc_freeze.c []
src/register.c []
src/res_lea.c []
src/resources.c []
@@ -2226,6 +2228,7 @@
t/pmc/eval.t []
t/pmc/exception.t []
t/pmc/float.t []
+t/pmc/freeze.t []
t/pmc/intlist.t []
t/pmc/io.t []
t/pmc/iter.t []
1.49 +4 -1 parrot/vtable.tbl
Index: vtable.tbl
===================================================================
RCS file: /cvs/public/parrot/vtable.tbl,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -w -r1.48 -r1.49
--- vtable.tbl 1 Nov 2003 15:00:32 -0000 1.48
+++ vtable.tbl 19 Nov 2003 15:43:17 -0000 1.49
@@ -1,4 +1,4 @@
-# $Id: vtable.tbl,v 1.48 2003/11/01 15:00:32 leo Exp $
+# $Id: vtable.tbl,v 1.49 2003/11/19 15:43:17 dan Exp $
# [MAIN] #default section name
void init()
@@ -284,3 +284,6 @@
INTVAL isa_keyed(PMC* key, STRING* method)
INTVAL isa_keyed_int(INTVAL key, STRING* method)
+void freeze(visit_info* info)
+void thaw (visit_info* info)
+void visit (visit_info* info)
1.70 +34 -1 parrot/classes/array.pmc
Index: array.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/array.pmc,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -w -r1.69 -r1.70
--- array.pmc 20 Oct 2003 17:18:59 -0000 1.69
+++ array.pmc 19 Nov 2003 15:43:20 -0000 1.70
@@ -1,7 +1,7 @@
/* array.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: array.pmc,v 1.69 2003/10/20 17:18:59 dan Exp $
+ * $Id: array.pmc,v 1.70 2003/11/19 15:43:20 dan Exp $
* Overview:
* These are the vtable functions for the Array base class
* Data Structure and Algorithms:
@@ -534,6 +534,39 @@
break;
}
return ret;
+ }
+
+ void visit(visit_info *info) {
+ INTVAL i;
+
+ SUPER(info);
+ /* doesn't handle sparse arrays - test only */
+ for (i = 0; i < VTABLE_elements(INTERP, SELF); ++i) {
+ PMC *child;
+ void *ret = list_get(INTERP, (List *) PMC_data(pmc), i,
+ enum_type_PMC);
+ if (!ret || ret == (void *) -1) {
+ ret = NULL;
+ child = NULL;
+ }
+ else
+ child = *(PMC**)ret;
+ info->thaw_ptr = ret;
+ (info->visit_child_function)(INTERP, child, info);
+ }
+ }
+
+ void freeze(visit_info *info) {
+ IMAGE_IO *io = info->image_io;
+ io->vtable->push_integer(INTERP, io,
+ VTABLE_elements(INTERP, SELF));
+ }
+
+ void thaw(visit_info *info) {
+ IMAGE_IO *io = info->image_io;
+ SUPER(info);
+ DYNSELF.set_integer_native(
+ io->vtable->shift_integer(INTERP, io));
}
}
1.73 +10 -1 parrot/classes/default.pmc
Index: default.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/default.pmc,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -w -r1.72 -r1.73
--- default.pmc 20 Oct 2003 17:44:40 -0000 1.72
+++ default.pmc 19 Nov 2003 15:43:20 -0000 1.73
@@ -1,6 +1,6 @@
/* default.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
- * CVS Info $Id: default.pmc,v 1.72 2003/10/20 17:44:40 dan Exp $
+ * CVS Info $Id: default.pmc,v 1.73 2003/11/19 15:43:20 dan Exp $
* Overview:
* These are the vtable functions for the default PMC class
* Data Structure and Algorithms:
@@ -315,6 +315,15 @@
INTVAL isa (STRING* method) {
return does_isa(INTERP, method, SELF->vtable->isa_str);
+ }
+
+ void visit(visit_info *info) {
+ }
+ void freeze(visit_info *info) {
+ }
+
+ void thaw(visit_info *info) {
+ DYNSELF.init();
}
}
1.51 +12 -1 parrot/classes/perlint.pmc
Index: perlint.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlint.pmc,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -w -r1.50 -r1.51
--- perlint.pmc 23 Oct 2003 08:08:15 -0000 1.50
+++ perlint.pmc 19 Nov 2003 15:43:20 -0000 1.51
@@ -1,7 +1,7 @@
/* perlint.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: perlint.pmc,v 1.50 2003/10/23 08:08:15 leo Exp $
+ * $Id: perlint.pmc,v 1.51 2003/11/19 15:43:20 dan Exp $
* Overview:
* These are the vtable functions for the PerlInt base class
* Data Structure and Algorithms:
@@ -12,6 +12,7 @@
#include "parrot/parrot.h"
#include "parrot/perltypes.h"
+#include <assert.h>
pmclass PerlInt extends perlscalar {
@@ -467,4 +468,14 @@
SELF->cache.int_val --;
}
+ void freeze(visit_info *info) {
+ IMAGE_IO *io = info->image_io;
+ io->vtable->push_integer(INTERP, io, SELF->cache.int_val);
+ }
+
+ void thaw(visit_info *info) {
+ IMAGE_IO *io = info->image_io;
+ SUPER(info);
+ SELF->cache.int_val = io->vtable->shift_integer(INTERP, io);
+ }
}
1.171 +6 -1 parrot/config/gen/makefiles/root.in
Index: root.in
===================================================================
RCS file: /cvs/public/parrot/config/gen/makefiles/root.in,v
retrieving revision 1.170
retrieving revision 1.171
diff -u -w -r1.170 -r1.171
--- root.in 19 Nov 2003 14:52:07 -0000 1.170
+++ root.in 19 Nov 2003 15:43:23 -0000 1.171
@@ -45,6 +45,8 @@
INC=./${inc}
+# generated by config/init/headers.pl
+
NONGEN_HEADERS = ${nongen_headers}
###############################################################################
@@ -174,7 +176,8 @@
$(SRC)/register$(O) $(SRC)/core_ops$(O) $(SRC)/core_ops_prederef$(O)
$(SRC)/core_ops_switch$(O) \
$(SRC)/memory$(O) $(SRC)/objects$(O) ${exec_o} \
$(SRC)/packfile$(O) $(SRC)/stacks$(O) $(SRC)/string$(O) $(SRC)/sub$(O)
$(SRC)/encoding$(O) \
- $(SRC)/chartype$(O) $(SRC)/runops_cores$(O) $(SRC)/trace$(O) $(SRC)/pmc$(O)
$(SRC)/key$(O) $(SRC)/hash$(O) \
+ $(SRC)/chartype$(O) $(SRC)/runops_cores$(O) $(SRC)/trace$(O) \
+ $(SRC)/pmc$(O) $(SRC)/pmc_freeze$(O) $(SRC)/key$(O) $(SRC)/hash$(O) \
$(SRC)/core_pmcs$(O) $(SRC)/platform$(O) ${jit_o} \
${gc_o} $(SRC)/rx$(O) $(SRC)/rxstacks$(O) $(SRC)/intlist$(O) $(SRC)/list$(O) \
$(SRC)/embed$(O) $(SRC)/warnings$(O) ${cg_o} \
@@ -439,6 +442,8 @@
$(SRC)/global_setup$(O) : $(GENERAL_H_FILES)
$(SRC)/pmc$(O) : $(GENERAL_H_FILES)
+
+$(SRC)/pmc_freeze$(O) : $(GENERAL_H_FILES)
$(SRC)/hash$(O) : $(GENERAL_H_FILES)
1.82 +3 -2 parrot/include/parrot/parrot.h
Index: parrot.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/parrot.h,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -w -r1.81 -r1.82
--- parrot.h 30 Oct 2003 06:42:48 -0000 1.81
+++ parrot.h 19 Nov 2003 15:43:26 -0000 1.82
@@ -1,7 +1,7 @@
/* parrot.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: parrot.h,v 1.81 2003/10/30 06:42:48 mrjoltcola Exp $
+ * $Id: parrot.h,v 1.82 2003/11/19 15:43:26 dan Exp $
* Overview:
* General header file includes for the parrot interpreter
* Data Structure and Algorithms:
@@ -225,6 +225,8 @@
#include "parrot/chartype.h"
#include "parrot/string.h"
#include "parrot/hash.h"
+#include "parrot/list.h"
+#include "parrot/pmc_freeze.h"
#include "parrot/vtable.h"
#include "parrot/register.h"
#include "parrot/stacks.h"
@@ -237,7 +239,6 @@
#include "parrot/op.h"
#include "parrot/pmc.h"
#include "parrot/events.h"
-#include "parrot/list.h"
#include "parrot/intlist.h"
#include "parrot/smallobject.h"
#include "parrot/headers.h"
1.12 +3 -0 parrot/ops/ops.num
Index: ops.num
===================================================================
RCS file: /cvs/public/parrot/ops/ops.num,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -w -r1.11 -r1.12
--- ops.num 1 Nov 2003 16:33:26 -0000 1.11
+++ ops.num 19 Nov 2003 15:43:32 -0000 1.12
@@ -1275,3 +1275,6 @@
seti_ind_i_ic 1248
seti_ind_ic_ic 1249
get_addr_i_p 1250
+freeze_s_p 1251
+thaw_p_s 1252
+thaw_p_sc 1253
1.15 +34 -0 parrot/ops/pmc.ops
Index: pmc.ops
===================================================================
RCS file: /cvs/public/parrot/ops/pmc.ops,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -w -r1.14 -r1.15
--- pmc.ops 3 Nov 2003 02:46:43 -0000 1.14
+++ pmc.ops 19 Nov 2003 15:43:33 -0000 1.15
@@ -500,6 +500,40 @@
###############################################################################
+=head2 Freeze, thaw and friends
+
+Ops to PMC freeze, thaw
+
+=over 4
+
+=cut
+
+########################################
+
+=item B<freeze>(out STR, in PMC)
+
+Set $1 to the frozen image of $2.
+
+=item B<thaw>(out PMC, in STR)
+
+Set $1 to a newly created PMC from the inage $2.
+
+=cut
+
+op freeze(out STR, in PMC) {
+ $1 = Parrot_freeze(interpreter, $2);
+ goto NEXT();
+}
+
+op thaw(out PMC, in STR) {
+ $1 = Parrot_thaw(interpreter, $2);
+ goto NEXT();
+}
+
+=back
+
+=cut
+
=head1 COPYRIGHT
Copyright (C) 2001-2003 The Perl Foundation. All rights reserved.
1.1 parrot/src/pmc_freeze.c
Index: pmc_freeze.c
===================================================================
/* pmc_freeze.c
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
* $Id: pmc_freeze.c,v 1.1 2003/11/19 15:43:35 dan Exp $
* Overview:
* Freeze and thaw functionality
* Data Structure and Algorithms:
* Freeze uses the next_for_GC pointer to remeber seen PMCs.
* PMCs are written as IDs (or tags), which are calculated
* from their arena address. This PMC number is multiplied
* by four. The 2 lo bits indicate a seen PMC or a PMC of the
* same type as the previous one respectively.
*
* Thawing PMCs uses a list with (maximum) size of the
* amount of PMCs to keep track of retrieved PMCs.
*
* The individual information of PMCs is frozen/thawed by their
* vtables.
*
* To avoid recursion, the whole functionality is driven by
* pmc->vtable->visit, which is called for the first PMC initially.
* Container PMCs call a "todo-callback" for all contained PMCs.
* The individual action vtable (freeze/thaw) is then called for
* all todo-PMCs.
*
* History:
* Initial version by leo 2003.11.03 - 2003.11.07
* Notes:
* The seen-hash version for freezing might go away sometimes.
* References:
* Lot of discussion on p6i
*/
#include "parrot/parrot.h"
#include <assert.h>
/*
* define this to 1 for testing
*/
#define FREEZE_ASCII 0
/*
* normal freeze can use next_for_GC ptrs or a seen hash
*/
#define FREEZE_USE_NEXT_FOR_GC 1
/*
* when thawing a string longer then this size, we first do a
* DOD run and then block DOD/GC - the system can't give us more headers
*/
#define THAW_BLOCK_DOD_SIZE 100000
/*
* preallocate freeze image for aggregates with this estimation
*/
#if FREEZE_ASCII
# define FREEZE_BYTES_PER_ITEM 17
#else
# define FREEZE_BYTES_PER_ITEM 9
#endif
/*
* image stream functions
*/
/*
* plain ascii - for testing only:
* for speed reasons we mess around with the string buffers directly
* no encoding of strings, no transcoding
*/
static void
str_append(Parrot_Interp interpreter, STRING *s, const void *b, size_t len)
{
size_t used = s->bufused;
size_t need_free = s->buflen - used - len;
/*
* grow by factor 1.5 or such
*/
if (need_free <= 16) {
size_t new_size = s->buflen * 1.5;
if (new_size < s->buflen - need_free + 512)
new_size = s->buflen - need_free + 512;
Parrot_reallocate_string(interpreter, s, new_size);
assert(s->buflen - used - len >= 15);
}
mem_sys_memcopy((void *)((ptrcast_t)s->strstart + used), b, len);
s->bufused += len;
s->strlen += len;
}
static void
push_ascii_integer(Parrot_Interp interpreter, IMAGE_IO *io, INTVAL v)
{
char buffer[128];
sprintf(buffer, "%d ", (int) v);
str_append(interpreter, io->image, buffer, strlen(buffer));
}
static void
push_ascii_pmc(Parrot_Interp interpreter, IMAGE_IO *io, PMC* v)
{
char buffer[128];
sprintf(buffer, "%p ", v);
str_append(interpreter, io->image, buffer, strlen(buffer));
}
static INTVAL
shift_ascii_integer(Parrot_Interp interpreter, IMAGE_IO *io)
{
char *start, *p;
INTVAL i;
p = start = (char*)io->image->strstart;
i = strtoul(p, &p, 10);
++p;
assert(p <= start + io->image->bufused);
io->image->strstart = p;
io->image->bufused -= (p - start);
assert((int)io->image->bufused >= 0);
return i;
}
static PMC*
shift_ascii_pmc(Parrot_Interp interpreter, IMAGE_IO *io)
{
char *start, *p;
int i;
p = start = (char*)io->image->strstart;
i = strtoul(p, &p, 16);
++p;
assert(p <= start + io->image->bufused);
io->image->strstart = p;
io->image->bufused -= (p - start);
assert((int)io->image->bufused >= 0);
return (PMC*) i;
}
/*
* opcode_t io functions
*/
static void
op_append(Parrot_Interp interpreter, STRING *s, opcode_t b, size_t len)
{
size_t used = s->bufused;
size_t need_free = s->buflen - used - len;
/*
* grow by factor 1.5 or such
*/
if (need_free <= 16) {
size_t new_size = s->buflen * 1.5;
if (new_size < s->buflen - need_free + 512)
new_size = s->buflen - need_free + 512;
Parrot_reallocate_string(interpreter, s, new_size);
assert(s->buflen - used - len >= 15);
}
*((opcode_t *)((ptrcast_t)s->strstart + used)) = b;
s->bufused += len;
s->strlen += len;
}
static void
push_opcode_integer(Parrot_Interp interpreter, IMAGE_IO *io, INTVAL v)
{
op_append(interpreter, io->image, (opcode_t)v, sizeof(opcode_t));
}
static void
push_opcode_pmc(Parrot_Interp interpreter, IMAGE_IO *io, PMC* v)
{
op_append(interpreter, io->image, (opcode_t)v, sizeof(opcode_t));
}
static INTVAL
shift_opcode_integer(Parrot_Interp interpreter, IMAGE_IO *io)
{
char *start, *p;
INTVAL i;
p = start = (char*)io->image->strstart;
i = *((opcode_t*) p)++;
assert(p <= start + io->image->bufused);
io->image->strstart = p;
io->image->bufused -= (p - start);
assert((int)io->image->bufused >= 0);
return i;
}
static PMC*
shift_opcode_pmc(Parrot_Interp interpreter, IMAGE_IO *io)
{
return (PMC*) shift_opcode_integer(interpreter, io);
}
/*
* helper functions
*/
/*
* custom key_hash and compare functions
*/
static size_t
key_hash_int(Interp *interpreter, void *value)
{
return (size_t) value;
}
static int
int_compare(Parrot_Interp interp, void *a, void *b)
{
UNUSED(interp);
return a != b;
}
static void
pmc_add_ext(Parrot_Interp interpreter, PMC *pmc)
{
if (pmc->vtable->flags & VTABLE_PMC_NEEDS_EXT)
add_pmc_ext(interpreter, pmc);
}
/*
* set all next_for_GC pointers to NULL
*/
static void
cleanup_next_for_GC_pool(Parrot_Interp interpreter,
struct Small_Object_Pool *pool)
{
struct Small_Object_Arena *arena;
for (arena = pool->last_Arena; arena; arena = arena->prev) {
PMC *p = arena->start_objects;
UINTVAL i;
for (i = 0; i < arena->used; i++) {
if (p->pmc_ext)
p->next_for_GC = NULL;
p = (PMC *)((char *)p + sizeof(PMC));
}
}
}
static void
cleanup_next_for_GC(Parrot_Interp interpreter)
{
cleanup_next_for_GC_pool(interpreter,
interpreter->arena_base->pmc_pool);
cleanup_next_for_GC_pool(interpreter,
interpreter->arena_base->constant_pmc_pool);
}
/*
* this function setup stuff may be replaced by a real PMC
* in the future
* TODO add read/write header functions, e.g. vtable->init_pmc
*/
static image_funcs ascii_funcs = {
push_ascii_integer,
push_ascii_pmc,
shift_ascii_integer,
shift_ascii_pmc
};
static image_funcs opcode_funcs = {
push_opcode_integer,
push_opcode_pmc,
shift_opcode_integer,
shift_opcode_pmc
};
static IMAGE_IO io_init;
static void
ft_init(Parrot_Interp interpreter, visit_info *info)
{
info->image_io = &io_init;
info->image_io->image = info->image;
#if FREEZE_ASCII
info->image_io->vtable = &ascii_funcs;
#else
info->image_io->vtable = &opcode_funcs;
#endif
info->last_type = -1;
info->id_list = pmc_new(interpreter, enum_class_Array);
info->id = 0;
}
static void visit_todo_list(Parrot_Interp, PMC*, visit_info* info);
static void
todo_list_init(Parrot_Interp interpreter, visit_info *info)
{
Hash *hash;
info->visit_child_function = visit_todo_list;
/* we must use PMCs here, so that they get marked properly */
info->todo = pmc_new(interpreter, enum_class_Array);
info->seen = pmc_new_noinit(interpreter, enum_class_PerlHash);
hash = new_hash_x(interpreter, int_compare, key_hash_int,
(hash_mark_key_fn) NULL);
hash->entry_type = enum_type_int;
PObj_custom_mark_SET(info->seen);
PMC_ptr1v(info->seen) = hash;
ft_init(interpreter, info);
}
/*
* freeze, thaw a PMC (id)
*
* the ASCII representation of the PerlArray
* P0 = [P1=666, P2=777, P0]
* may look like this:
* 0xdf4 30 3 0xdf8 33 666 0xdf2 777 0xdf5
* (30 = class_enum_PerlArray, 33 = class_enum_PerlInt, the type of
* the second PerlInt is suppressed, the repeated P0 has bit 0 set)
*/
PARROT_INLINE static void
freeze_pmc(Parrot_Interp interpreter, PMC *pmc, visit_info *info,
int seen, UINTVAL id)
{
IMAGE_IO *io = info->image_io;
INTVAL type = pmc->vtable->base_type;
if (seen) {
id |= 1; /* mark bit 0 if this PMC is known */
}
else if (type == info->last_type) {
id |= 2; /* mark bit 1 and don't write type */
}
io->vtable->push_pmc(interpreter, io, (PMC*)id);
if (! (id & 3)) { /* else write type */
io->vtable->push_integer(interpreter, io, type);
info->last_type = type;
}
}
PARROT_INLINE static int
thaw_pmc(Parrot_Interp interpreter, visit_info *info,
UINTVAL *id, INTVAL *type)
{
PMC *n;
IMAGE_IO *io = info->image_io;
int seen = 0;
n = io->vtable->shift_pmc(interpreter, io);
if ( (UINTVAL) n & 1) { /* seen PMCs have bit 0 set */
seen = 1;
}
else if ( (UINTVAL) n & 2) { /* prev PMC was same type */
*type = info->last_type;
}
else { /* type follows */
info->last_type = *type = io->vtable->shift_integer(interpreter, io);
if (*type <= 0 || *type >= enum_class_max)
internal_exception(1, "Unknown PMC to thaw %d", (int) *type);
}
*id = (UINTVAL) n & ~3;
return seen;
}
/*
* visit/thaw common action functions:
* - freeze PMC
* -
*/
PARROT_INLINE static void
do_action(Parrot_Interp interpreter, PMC *pmc, visit_info *info,
int seen, UINTVAL id)
{
switch (info->what) {
case VISIT_FREEZE_AT_DESTRUCT:
case VISIT_FREEZE_NORMAL:
freeze_pmc(interpreter, pmc, info, seen, id);
info->visit_function = pmc->vtable->freeze;
break;
default:
internal_exception(1, "Illegal action %d", info->what);
break;
}
}
PARROT_INLINE static PMC*
thaw_create_pmc(Parrot_Interp interpreter, PMC *pmc, visit_info *info,
INTVAL type)
{
if (pmc) { /* first thawed PMC - just attach vtable */
pmc->vtable = Parrot_base_vtables[type];
pmc_add_ext(interpreter, pmc);
}
else { /* create a new header */
switch (info->what) {
case VISIT_THAW_NORMAL:
pmc = pmc_new_noinit(interpreter, type);
break;
case VISIT_THAW_CONSTANTS:
pmc = constant_pmc_new_noinit(interpreter, type);
break;
default:
internal_exception(1, "Illegal visit_next type");
break;
}
assert(info->thaw_ptr);
*info->thaw_ptr = pmc;
}
return pmc;
}
PARROT_INLINE static PMC*
do_thaw(Parrot_Interp interpreter, PMC* pmc, visit_info *info, int *seen)
{
UINTVAL id;
INTVAL type;
PMC ** b;
int must_have_seen = thaw_pmc(interpreter, info, &id, &type);
b = list_get(interpreter, PMC_data(info->id_list), id >> 2,
enum_type_PMC);
if (b == (void*)-1)
b = NULL;
else if (b) {
pmc = *(PMC**)b;
if (!pmc)
b = NULL;
}
if (b) {
*seen = 1;
#if FREEZE_USE_NEXT_FOR_GC
/*
* the next_for_GC method doesn't keep track of repeated scalars
* and such, as these are lacking the next_for_GC pointer, so
* these are just duplicated with their data.
* But we track these when thawing, so that we don't create dups
*/
if (!must_have_seen) {
/* so we must consume the bytecode */
VTABLE_thaw(interpreter, pmc, info);
}
#else
assert(must_have_seen);
#endif
*info->thaw_ptr = pmc;
return pmc;
}
assert(!must_have_seen);
*seen = 0;
pmc = thaw_create_pmc(interpreter, pmc, info, type);
info->visit_function = pmc->vtable->thaw;
list_assign(interpreter, PMC_data(info->id_list), id >> 2, pmc,
enum_type_PMC);
/* remember nested aggregates depth first */
if (pmc->pmc_ext)
list_push(interpreter, PMC_data(info->todo), pmc, enum_type_PMC);
return pmc;
}
#if ARENA_DOD_FLAGS
static UINTVAL
id_from_pmc(Parrot_Interp interpreter, PMC* pmc)
{
UINTVAL id = 1; /* first PMC in first arena */
struct Small_Object_Arena *arena, *pmc_arena;
struct Small_Object_Pool *pool;
pool = interpreter->arena_base->pmc_pool;
pmc_arena = GET_ARENA( (PObj*) pmc);
for (arena = pool->last_Arena; arena; arena = arena->prev) {
if (arena == pmc_arena) {
id += GET_OBJ_N(arena, (PObj*) pmc);
return id << 2; /* lo bits are flags */
}
id += arena->total_objects;
}
pool = interpreter->arena_base->constant_pmc_pool;
for (arena = pool->last_Arena; arena; arena = arena->prev) {
if (arena == pmc_arena) {
id += GET_OBJ_N(arena, (PObj*) pmc);
return id << 2;
}
id += arena->total_objects;
}
internal_exception(1, "Couldn't find PMC in arenas");
return -1;
}
#else
static UINTVAL
id_from_pmc(Parrot_Interp interpreter, PMC* pmc)
{
UINTVAL id = 1; /* first PMC in first arena */
struct Small_Object_Arena *arena;
struct Small_Object_Pool *pool;
ptrdiff_t ptr_diff;
pool = interpreter->arena_base->pmc_pool;
for (arena = pool->last_Arena; arena; arena = arena->prev) {
ptr_diff = (ptrdiff_t)pmc - (ptrdiff_t)arena->start_objects;
if (ptr_diff >= 0 && ptr_diff <
(ptrdiff_t)(arena->used * pool->object_size)) {
assert(ptr_diff % pool->object_size == 0);
id += ptr_diff / pool->object_size;
return id << 2;
}
id += arena->total_objects;
}
pool = interpreter->arena_base->constant_pmc_pool;
for (arena = pool->last_Arena; arena; arena = arena->prev) {
ptr_diff = (ptrdiff_t)pmc - (ptrdiff_t)arena->start_objects;
if (ptr_diff >= 0 && ptr_diff <
(ptrdiff_t)(arena->used * pool->object_size)) {
assert(ptr_diff % pool->object_size == 0);
id += ptr_diff / pool->object_size;
return id << 2;
}
id += arena->total_objects;
}
internal_exception(1, "Couldn't find PMC in arenas");
return -1;
}
#endif
/*
* remember next child to visit via the next_for_GC pointer
* generate a unique ID per PMC and freeze the ID not the PMC addr
* so thaw the hash-lookup can be replaced by an array lookup then
* which is a lot faster
*/
PARROT_INLINE static int
next_for_GC_seen(Parrot_Interp interpreter, PMC *pmc, visit_info *info,
UINTVAL *id)
{
int seen = 0;
/*
* we can only remember PMCs with a next_for_GC pointer
* which is located in pmc_ext
*/
if (pmc->pmc_ext) {
/* already seen? */
if (pmc->next_for_GC) {
seen = 1;
goto skip;
}
/* put pmc at the end of the list */
info->mark_ptr->next_for_GC = pmc;
/* make end self-referential */
info->mark_ptr = pmc->next_for_GC = pmc;
}
skip:
*id = id_from_pmc(interpreter, pmc);
return seen;
}
/*
* return true if PMC was seen, else put in on the todo list
* generate ID (tag) for PMC, offset by 4 as are addresses, lo bits
* are flags
*/
PARROT_INLINE static int
todo_list_seen(Parrot_Interp interpreter, PMC *pmc, visit_info *info,
UINTVAL *id)
{
HashBucket *b = hash_get_bucket(interpreter, PMC_ptr1v(info->seen), pmc);
if (b) {
*id = (UINTVAL) b->value;
return 1;
}
info->id += 4; /* next id to freeze */
*id = info->id;
hash_put(interpreter, PMC_ptr1v(info->seen), pmc, (void*)*id);
/* remember containers */
if (pmc->pmc_ext)
list_push(interpreter, PMC_data(info->todo), pmc, enum_type_PMC);
return 0;
}
/*
* visit_child callbacks:
* check if PMC was seen, generate ID for it
* then do the appropriate action
*/
static void
visit_next_for_GC(Parrot_Interp interpreter, PMC* pmc, visit_info* info)
{
UINTVAL id;
int seen = next_for_GC_seen(interpreter, pmc, info, &id);
do_action(interpreter, pmc, info, seen, id);
/*
* TODO probe for class methods that override the default.
* To avoid overhead, we could have an array[class_enums]
* which (after first find_method) has a bit, if a user
* callback is there.
*/
if (!seen)
(info->visit_function)(interpreter, pmc, info);
}
/*
* check seen via the todo list
*/
static void
visit_todo_list(Parrot_Interp interpreter, PMC* pmc, visit_info* info)
{
UINTVAL id;
int seen = todo_list_seen(interpreter, pmc, info, &id);
do_action(interpreter, pmc, info, seen, id);
if (!seen)
(info->visit_function)(interpreter, pmc, info);
}
/*
* callback for thaw - action first, todo-list and seen handling
* is all in do_thaw
*/
static void
visit_todo_list_thaw(Parrot_Interp interpreter, PMC* old, visit_info* info)
{
int seen;
PMC* pmc = do_thaw(interpreter, old, info, &seen);
if (!seen)
(info->visit_function)(interpreter, pmc, info);
}
/*
* work loops:
* put first item on todo list
* run as long as there are itens to be done
*/
static void
visit_loop_next_for_GC(Parrot_Interp interpreter, PMC *current,
visit_info *info)
{
PMC *prev = NULL;
visit_next_for_GC(interpreter, current, info);
if (current->pmc_ext) {
for ( ; current != prev; current = current->next_for_GC) {
VTABLE_visit(interpreter, current, info);
prev = current;
}
}
}
static void
visit_loop_todo_list(Parrot_Interp interpreter, PMC *current,
visit_info *info)
{
List *todo = PMC_data(info->todo);
(info->visit_child_function)(interpreter, current, info);
while (list_length(interpreter, todo)) {
current = *(PMC**)list_shift(interpreter, todo, enum_type_PMC);
VTABLE_visit(interpreter, current, info);
}
}
/*
* allocate image to some estimated size
*/
static void
create_image(Parrot_Interp interpreter, PMC *pmc, visit_info *info)
{
INTVAL len = FREEZE_BYTES_PER_ITEM;
if (VTABLE_does(interpreter, pmc,
string_from_cstring(interpreter, "array", 0)) ||
VTABLE_does(interpreter, pmc,
string_from_cstring(interpreter, "hash", 0))) {
INTVAL items = VTABLE_elements(interpreter, pmc);
/*
* TODO check e.g. first item of aggregate and estimate size
*/
len = items * FREEZE_BYTES_PER_ITEM;
}
info->image = string_make(interpreter, NULL, len, NULL, 0, NULL);
}
/*
* public interface
*/
/*
* freeze_at_destruct must not consume any resources
* (except the image itself)
* It uses the next_for_GC pointer, so its not reentrant and must
* not be interrupted by a DOD run
*/
STRING*
Parrot_freeze_at_destruct(Parrot_Interp interpreter, PMC* pmc)
{
visit_info info;
Parrot_block_DOD(interpreter);
cleanup_next_for_GC(interpreter);
info.what = VISIT_FREEZE_AT_DESTRUCT;
info.mark_ptr = pmc;
info.visit_child_function = visit_next_for_GC;
create_image(interpreter, pmc, &info);
ft_init(interpreter, &info);
visit_loop_next_for_GC(interpreter, pmc, &info);
cleanup_next_for_GC(interpreter);
Parrot_unblock_DOD(interpreter);
return info.image;
}
/*
* freeze using either method
*/
STRING*
Parrot_freeze(Parrot_Interp interpreter, PMC* pmc)
{
#if FREEZE_USE_NEXT_FOR_GC
/*
* we could do a DOD run here before, to free resources
*/
return Parrot_freeze_at_destruct(interpreter, pmc);
#else
/*
* freeze using a todo list and seen hash
* Please note that both have to be PMCs, so that trace_system_stack
* can call mark on the PMCs
*/
visit_info info;
info.what = VISIT_FREEZE_NORMAL;
create_image(interpreter, pmc, &info);
todo_list_init(interpreter, &info);
visit_loop_todo_list(interpreter, pmc, &info);
return info.image;
#endif
}
/*
* thaw could use the next_for_GC pointers as todo-list too,
* but this would need 2 runs through the arenas to clean the
* next_for_GC pointers.
* For now it seems cheaper to use a list for remembering contained
* aggregates. We could of course decide dynamically, which strategy
* to use, e.g.: given a big image, the first thawed item is a small
* aggregate. This implies, it probably contains[1] more nested containers,
* for which the next_for_GC approach could be a win.
* [1] or some big strings :)
*/
PMC*
Parrot_thaw(Parrot_Interp interpreter, STRING* image)
{
visit_info info;
PMC *n = NULL;
int dod_block = 0;
info.image = image;
if (string_length(image) > THAW_BLOCK_DOD_SIZE) {
Parrot_do_dod_run(interpreter, 1);
Parrot_block_DOD(interpreter);
Parrot_block_GC(interpreter);
dod_block = 1;
}
info.what = VISIT_THAW_NORMAL;
todo_list_init(interpreter, &info);
info.visit_child_function = visit_todo_list_thaw;
n = new_pmc_header(interpreter);
visit_loop_todo_list(interpreter, n, &info);
if (dod_block) {
Parrot_unblock_DOD(interpreter);
Parrot_unblock_GC(interpreter);
}
return n;
}
/*
* there are for sure shortcuts to clone faster, e.g. allways
* thaw the image immediately or use a special callback
*
* for now we just do:
*/
PMC*
Parrot_clone(Parrot_Interp interpreter, PMC* pmc)
{
return Parrot_thaw(interpreter, Parrot_freeze(interpreter, pmc));
}
/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
* indent-tabs-mode: nil
* End:
*
* vim: expandtab shiftwidth=4:
*/
