cvsuser 04/11/11 05:26:34
Modified: classes parrotclass.pmc parrotobject.pmc
include/parrot pmc_freeze.h
src pmc_freeze.c
t/pmc freeze.t
Log:
freeze_thaw a class 7 - and objects
* create PMCs a bit later during thaw
* and thaw them earlier so that existing classes are handled properly
* use depth first now for freeze/thaw
* create a separate list for PMCs that need thawfinish
Revision Changes Path
1.30 +12 -16 parrot/classes/parrotclass.pmc
Index: parrotclass.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotclass.pmc,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- parrotclass.pmc 10 Nov 2004 15:54:01 -0000 1.29
+++ parrotclass.pmc 11 Nov 2004 13:26:29 -0000 1.30
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotclass.pmc,v 1.29 2004/11/10 15:54:01 leo Exp $
+$Id: parrotclass.pmc,v 1.30 2004/11/11 13:26:29 leo Exp $
=head1 NAME
@@ -217,6 +217,7 @@
STRING *class_name;
INTVAL new_type;
PMC *ar;
+ PMC *real_class;
/* thaw class name */
class_name = io->vtable->shift_string(INTERP, io);
@@ -226,19 +227,20 @@
*/
new_type = pmc_type(INTERP, class_name);
if (new_type > enum_type_undef) {
+ real_class = Parrot_class_lookup(INTERP, class_name);
+ info->extra = real_class;
info->extra_flags = EXTRA_CLASS_EXISTS;
- *info->thaw_ptr = SELF =
- Parrot_class_lookup(INTERP, class_name);
}
else {
+ real_class = SELF;
SELF.init();
Parrot_new_class(INTERP, SELF, class_name);
}
/* make room for thawed arrays */
- if (PMC_int_val(SELF) == PCD_MAX) {
+ if (PMC_int_val(real_class) == PCD_MAX) {
PMC **class_data;
- resize_attrib_array(SELF, PCD_MAX + 2);
- class_data = (PMC **)PMC_data(SELF);
+ resize_attrib_array(real_class, PCD_MAX + 2);
+ class_data = (PMC **)PMC_data(real_class);
class_data[PCD_MAX] = NULL;
class_data[PCD_MAX + 1] = NULL;
}
@@ -248,18 +250,12 @@
void thawfinish(visit_info *info) {
INTVAL i, n, nold;
- PMC * class = SELF;
+ PMC * class;
PMC *parents, *attribs, *old;
- int ignore = 0; /* XXX */
- PMC **class_data = (PMC **)PMC_data(SELF);
+ PMC **class_data;
- /*
- * we now have two plain arrays: parents and attributes
- * TODO if class did exists compare these with the
- * information in the class
- * TODO don't thaw directly into class array - this destroys
- * existing classes
- */
+ class = SELF;
+ class_data = (PMC**)(PMC_data(class));
old = class_data[PCD_PARENTS];
nold = VTABLE_elements(INTERP, old);
1.34 +24 -3 parrot/classes/parrotobject.pmc
Index: parrotobject.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/parrotobject.pmc,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- parrotobject.pmc 9 Nov 2004 15:07:26 -0000 1.33
+++ parrotobject.pmc 11 Nov 2004 13:26:29 -0000 1.34
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: parrotobject.pmc,v 1.33 2004/11/09 15:07:26 leo Exp $
+$Id: parrotobject.pmc,v 1.34 2004/11/11 13:26:29 leo Exp $
=head1 NAME
@@ -190,6 +190,7 @@
/* 1) visit class */
pos = class_data + POD_CLASS;
+ info->thaw_ptr = pos;
(info->visit_pmc_now)(interpreter, *pos, info);
/* 2) visit the attributes */
@@ -200,12 +201,32 @@
}
}
void freeze(visit_info *info) {
- Parrot_default_freeze(INTERP, SELF, info);
+ IMAGE_IO *io = info->image_io;
+ io->vtable->push_integer(INTERP, io, ATTRIB_COUNT(SELF));
}
+
void thaw(visit_info *info) {
- Parrot_default_thaw(INTERP, SELF, info);
+ IMAGE_IO *io = info->image_io;
+ if (info->extra_flags == EXTRA_IS_PROP_HASH) {
+ SUPER(info);
+ }
+ else if (info->extra_flags == EXTRA_IS_NULL) {
+ INTVAL n = io->vtable->shift_integer(INTERP, io);
+ set_attrib_array_size(SELF, n);
+ ATTRIB_COUNT(SELF) = n;
+ }
}
+
void thawfinish(visit_info *info) {
+ PMC *class = get_attrib_num((SLOTTYPE *)PMC_data(SELF), POD_CLASS);
+ PMC *class_name = get_attrib_num((SLOTTYPE *)PMC_data(class),
+ PCD_CLASS_NAME);
+ PMC *vtable_pmc = get_attrib_num((SLOTTYPE *)PMC_data(class),
+ PCD_OBJECT_VTABLE);
+ SELF->vtable = PMC_struct_val(vtable_pmc);
+ set_attrib_num(SELF, PMC_data(SELF), POD_CLASS_NAME, class_name);
+ set_attrib_flags(SELF);
+ PObj_is_object_SET(SELF);
}
}
1.9 +2 -1 parrot/include/parrot/pmc_freeze.h
Index: pmc_freeze.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pmc_freeze.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- pmc_freeze.h 9 Nov 2004 15:07:28 -0000 1.8
+++ pmc_freeze.h 11 Nov 2004 13:26:32 -0000 1.9
@@ -1,7 +1,7 @@
/* pmc_freeze.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: pmc_freeze.h,v 1.8 2004/11/09 15:07:28 leo Exp $
+ * $Id: pmc_freeze.h,v 1.9 2004/11/11 13:26:32 leo Exp $
* Overview:
* PMC freeze and thaw interface
* Data Structure and Algorithms:
@@ -76,6 +76,7 @@
UINTVAL id; /* freze ID of PMC */
void* extra; /* PMC specific */
extra_flags_enum extra_flags; /* concerning to extra */
+ PMC* thaw_result; /* 1st thawed */
IMAGE_IO *image_io;
} visit_info;
1.30 +91 -80 parrot/src/pmc_freeze.c
Index: pmc_freeze.c
===================================================================
RCS file: /cvs/public/parrot/src/pmc_freeze.c,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- pmc_freeze.c 10 Nov 2004 15:01:16 -0000 1.29
+++ pmc_freeze.c 11 Nov 2004 13:26:33 -0000 1.30
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: pmc_freeze.c,v 1.29 2004/11/10 15:01:16 leo Exp $
+$Id: pmc_freeze.c,v 1.30 2004/11/11 13:26:33 leo Exp $
=head1 NAME
@@ -788,6 +788,9 @@
return;
}
type = pmc->vtable->base_type;
+
+ if (PObj_is_object_TEST(pmc))
+ type = enum_class_ParrotObject;
if (seen) {
if (info->extra_flags) {
id |= 3;
@@ -909,38 +912,28 @@
*/
PARROT_INLINE static PMC*
-thaw_create_pmc(Parrot_Interp interpreter, PMC *pmc, visit_info *info,
+thaw_create_pmc(Parrot_Interp interpreter, visit_info *info,
INTVAL type)
{
- if (!PMC_IS_NULL(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);
- if (info->container) {
- DOD_WRITE_BARRIER(interpreter, info->container, NULL, pmc);
- }
- *info->thaw_ptr = pmc;
+ PMC *pmc = NULL;
+ 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;
}
return pmc;
}
/*
-=item C<PARROT_INLINE static PMC*
-do_thaw(Parrot_Interp interpreter, PMC* pmc, visit_info *info, int *seen)>
+=item C<PARROT_INLINE static void
+do_thaw(Parrot_Interp interpreter, PMC* pmc, visit_info *info)>
Called by C<visit_todo_list_thaw()> to thaw and return a PMC.
@@ -950,8 +943,8 @@
*/
-PARROT_INLINE static PMC*
-do_thaw(Parrot_Interp interpreter, PMC* pmc, visit_info *info, int *seen)
+PARROT_INLINE static void
+do_thaw(Parrot_Interp interpreter, PMC* pmc, visit_info *info)
{
UINTVAL id;
INTVAL type;
@@ -963,9 +956,11 @@
if (!id) {
/* got a NULL PMC */
pmc = PMCNULL;
- *info->thaw_ptr = pmc;
- *seen = 1;
- return pmc;
+ if (!info->thaw_result)
+ info->thaw_result = pmc;
+ else
+ *info->thaw_ptr = pmc;
+ return;
}
pos = list_get(interpreter, PMC_data(info->id_list), id, enum_type_PMC);
@@ -977,10 +972,9 @@
pos = NULL;
}
if (pos) {
- *seen = 1;
if (info->extra_flags) {
VTABLE_thaw(interpreter, pmc, info);
- return pmc;
+ return;
}
#if FREEZE_USE_NEXT_FOR_GC
/*
@@ -998,23 +992,34 @@
#endif
/*
* that's a duplicate
- if (info->container)
- DOD_WRITE_BARRIER(interpreter, info->container, NULL, pmc);
- */
+ if (info->container)
+ DOD_WRITE_BARRIER(interpreter, info->container, NULL, pmc);
+ */
*info->thaw_ptr = pmc;
- return pmc;
+ return;
}
assert(!must_have_seen);
- *seen = 0;
- pmc = thaw_create_pmc(interpreter, pmc, info, type);
+ pmc = thaw_create_pmc(interpreter, info, type);
- info->visit_action = pmc->vtable->thaw;
+ VTABLE_thaw(interpreter, pmc, info);
+ if (info->extra_flags == EXTRA_CLASS_EXISTS) {
+ pmc = info->extra;
+ info->extra = NULL;
+ info->extra_flags = 0;
+ }
+ if (!info->thaw_result)
+ info->thaw_result = pmc;
+ else {
+ if (info->container) {
+ DOD_WRITE_BARRIER(interpreter, info->container, NULL, pmc);
+ }
+ *info->thaw_ptr = pmc;
+ }
list_assign(interpreter, PMC_data(info->id_list), id, pmc,
enum_type_PMC);
- /* remember nested aggregates breadth first */
+ /* remember nested aggregates depth first */
if (pmc->pmc_ext)
- list_push(interpreter, PMC_data(info->todo), pmc, enum_type_PMC);
- return pmc;
+ list_unshift(interpreter, PMC_data(info->todo), pmc, enum_type_PMC);
}
#if ARENA_DOD_FLAGS
@@ -1213,7 +1218,7 @@
hash_put(interpreter, PMC_struct_val(info->seen), pmc, (void*)*id);
/* remember containers */
if (pmc->pmc_ext)
- list_push(interpreter, PMC_data(info->todo), pmc, enum_type_PMC);
+ list_unshift(interpreter, PMC_data(info->todo), pmc, enum_type_PMC);
return 0;
}
@@ -1236,6 +1241,7 @@
{
UINTVAL id;
int seen = next_for_GC_seen(interpreter, pmc, info, &id);
+ internal_exception(1, "todo convert to depth first");
do_action(interpreter, pmc, info, seen, id);
/*
* TODO probe for class methods that override the default.
@@ -1292,9 +1298,7 @@
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_action)(interpreter, pmc, info);
+ do_thaw(interpreter, old, info);
}
/*
@@ -1337,35 +1341,48 @@
*/
-static PMC*
+extern void
+Parrot_default_thawfinish(Interp* interpreter, PMC* pmc, visit_info *info);
+
+static void
visit_loop_todo_list(Parrot_Interp interpreter, PMC *current,
visit_info *info)
{
List *todo = PMC_data(info->todo);
+ PMC *finish_list_pmc;
int i, n;
- PMC *ret = current;
+ List *finish_list;
+ int thawing;
+ int finished_first = 0;
+
+ thawing = info->what == VISIT_THAW_CONSTANTS ||
+ info->what == VISIT_THAW_NORMAL;
+ if (thawing) {
+ /*
+ * create a list that contains PMCs that need thawfinish
+ */
+ finish_list_pmc = pmc_new(interpreter, enum_class_Array);
+ finish_list = PMC_data(finish_list_pmc);
+ }
(info->visit_pmc_now)(interpreter, current, info);
/*
* can't cache upper limit, visit may append items
*/
- i = 0;
again:
- for (; i < (int)list_length(interpreter, todo); ++i) {
- current = *(PMC**)list_get(interpreter, todo, i, enum_type_PMC);
- if (info->extra_flags == EXTRA_CLASS_EXISTS) {
- int is_first = (ret == current);
- info->extra_flags = 0;
- current = *info->thaw_ptr;
- if (is_first)
- ret = current;
- info->thaw_ptr = NULL;
- list_assign(interpreter, todo, i, current, enum_type_PMC);
- }
+ for (; (int)list_length(interpreter, todo); ) {
+ current = *(PMC**)list_shift(interpreter, todo, enum_type_PMC);
VTABLE_visit(interpreter, current, info);
+ if (thawing) {
+ if (current == info->thaw_result)
+ finished_first = 1;
+ if (current->vtable && current->vtable->thawfinish !=
+ Parrot_default_thawfinish)
+ list_unshift(interpreter, finish_list, current,
enum_type_PMC);
+ }
}
- if (info->what == VISIT_THAW_CONSTANTS ||
- info->what == VISIT_THAW_NORMAL) {
+
+ if (thawing) {
/*
* if image isn't consumed, there are some extra data to thaw
*/
@@ -1376,23 +1393,22 @@
/*
* on thawing call thawfinish for each processed PMC
*/
- if (!current->vtable) {
- /* the first created (passed) PMC was NULL -
- * return a NULL PMC
+ if (!finished_first) {
+ /*
+ * the first create PMC might not be in the list,
+ * if it has no pmc_ext
*/
- ret = PMCNULL;
+ list_unshift(interpreter, finish_list,
+ info->thaw_result, enum_type_PMC);
}
- else
- if (!PMC_IS_NULL(current))
- VTABLE_thawfinish(interpreter, current, info);
- n = (int)list_length(interpreter, todo);
+ n = (int)list_length(interpreter, finish_list);
for (i = 0; i < n ; ++i) {
- current = *(PMC**)list_get(interpreter, todo, i, enum_type_PMC);
+ current = *(PMC**)list_get(interpreter, finish_list, i,
+ enum_type_PMC);
if (!PMC_IS_NULL(current))
VTABLE_thawfinish(interpreter, current, info);
}
}
- return ret;
}
/*
@@ -1449,7 +1465,6 @@
run_thaw(Parrot_Interp interpreter, STRING* image, visit_enum_type what)
{
visit_info info;
- PMC *n = NULL;
int dod_block = 0;
UINTVAL bufused;
@@ -1472,15 +1487,11 @@
info.visit_pmc_now = visit_todo_list_thaw;
info.visit_pmc_later = add_pmc_todo_list;
- /*
- * create first PMC, we want to return it
- */
- n = new_pmc_header(interpreter, 0);
- info.thaw_ptr = &n;
+ info.thaw_result = NULL;
/*
* run thaw loop
*/
- n = visit_loop_todo_list(interpreter, n, &info);
+ visit_loop_todo_list(interpreter, NULL, &info);
/*
* thaw does "consume" the image string by incrementing strstart
* and decrementing bufused - restore that
@@ -1493,7 +1504,7 @@
Parrot_unblock_DOD(interpreter);
Parrot_unblock_GC(interpreter);
}
- return n;
+ return info.thaw_result;
}
/*
1.19 +87 -2 parrot/t/pmc/freeze.t
Index: freeze.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/freeze.t,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- freeze.t 10 Nov 2004 15:54:02 -0000 1.18
+++ freeze.t 11 Nov 2004 13:26:34 -0000 1.19
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: freeze.t,v 1.18 2004/11/10 15:54:02 leo Exp $
+# $Id: freeze.t,v 1.19 2004/11/11 13:26:34 leo Exp $
=head1 NAME
@@ -16,7 +16,7 @@
=cut
-use Parrot::Test tests => 21;
+use Parrot::Test tests => 23;
use Test::More;
END { unlink "temp.fpmc"; };
@@ -612,3 +612,88 @@
ok 6
OUTPUT
+output_is(<<'CODE', <<'OUTPUT', "thaw object w attr into same interpreter");
+ newclass P10, "Foo"
+ addattribute P10, ".aa"
+ addattribute P10, ".bb"
+ find_type I4, "Foo"
+ new P10, I4
+ print S10
+ freeze S3, P10
+ open P3, "temp.fpmc", ">"
+ print P3, S3
+ close P3
+ print "ok 1\n"
+
+ thaw P5, S3
+ print "ok 2\n"
+ classname S10, P5
+ print S10
+ print "\n"
+
+ print "ok 3\n"
+ classoffset I5, P5, S10
+ new P6, .PerlString
+ set P6, "ok 5\n"
+ setattribute P5, "Foo\0.aa", P6
+ new P6, .PerlString
+ set P6, "ok 6\n"
+ setattribute P5, "Foo\0.bb", P6
+ print "ok 4\n"
+ getattribute P7, P5, I5
+ print P7
+ inc I5
+ getattribute P7, P5, I5
+ print P7
+ end
+CODE
+ok 1
+ok 2
+Foo
+ok 3
+ok 4
+ok 5
+ok 6
+OUTPUT
+
+output_is(<<'CODE', <<'OUTPUT', "thaw object w attr into new interpreter");
+ set S3, "temp.fpmc"
+ .include "stat.pasm"
+ stat I0, S3, .STAT_FILESIZE
+ gt I0, 1, ok1
+ print "stat failed\n"
+ exit 1
+ok1:
+ open P3, S3, "<"
+ read S3, P3, I0
+ close P3
+
+ thaw P5, S3
+ print "ok 2\n"
+ classname S10, P5
+ print S10
+ print "\n"
+
+ print "ok 3\n"
+ classoffset I5, P5, S10
+ new P6, .PerlString
+ set P6, "ok 5\n"
+ setattribute P5, "Foo\0.aa", P6
+ new P6, .PerlString
+ set P6, "ok 6\n"
+ setattribute P5, "Foo\0.bb", P6
+ print "ok 4\n"
+ getattribute P7, P5, I5
+ print P7
+ inc I5
+ getattribute P7, P5, I5
+ print P7
+ end
+CODE
+ok 2
+Foo
+ok 3
+ok 4
+ok 5
+ok 6
+OUTPUT
