cvsuser 04/08/20 04:25:41
Modified: classes ref.pmc sharedref.pmc tqueue.pmc
t/op gc.t
Log:
gc subsystems 9 - ref and tqueue write barriers
Revision Changes Path
1.21 +2 -1 parrot/classes/ref.pmc
Index: ref.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/ref.pmc,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -w -r1.20 -r1.21
--- ref.pmc 29 Jul 2004 08:17:11 -0000 1.20
+++ ref.pmc 20 Aug 2004 11:25:36 -0000 1.21
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: ref.pmc,v 1.20 2004/07/29 08:17:11 leo Exp $
+$Id: ref.pmc,v 1.21 2004/08/20 11:25:36 leo Exp $
=head1 NAME
@@ -151,6 +151,7 @@
void set_pmc(PMC* other) {
PObj_active_destroy_CLEAR(SELF);
+ DOD_WRITE_BARRIER(INTERP, SELF, PMC_pmc_val(SELF), other);
SELF.init_pmc(other);
}
1.18 +24 -3 parrot/classes/sharedref.pmc
Index: sharedref.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/sharedref.pmc,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -w -r1.17 -r1.18
--- sharedref.pmc 17 Jul 2004 16:01:05 -0000 1.17
+++ sharedref.pmc 20 Aug 2004 11:25:36 -0000 1.18
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: sharedref.pmc,v 1.17 2004/07/17 16:01:05 leo Exp $
+$Id: sharedref.pmc,v 1.18 2004/08/20 11:25:36 leo Exp $
=head1 NAME
@@ -95,7 +95,7 @@
void init () {
- internal_exception(1, "SharedRef init without PMC\n");
+ SUPER();
}
/*
@@ -144,6 +144,7 @@
void init_pmc_props(PMC* init, PMC* props) {
SUPER(init, props);
+ PObj_active_destroy_SET(SELF);
}
/*
@@ -173,6 +174,25 @@
SUPER();
}
+/*
+
+=item C<void set_pmc(PMC *other)>
+
+Sets the referenced PMC to C<*other>.
+
+=item C<PMC* get_pmc()>
+
+Catch dereferencing. This would unshare the refered PMC.
+
+=cut
+
+*/
+
+ void set_pmc(PMC* other) {
+ SUPER(other);
+ PObj_active_destroy_SET(SELF);
+ }
+
PMC* get_pmc () {
internal_exception(1, "deref not allowed");
return NULL;
@@ -182,7 +202,8 @@
=item C<void destroy()>
-Destroys the reference.
+Destroys the refered object and itself. This probably nees destroy oderdering
+or at least a detection if the refered PMC is already destroyed.
=cut
1.9 +3 -2 parrot/classes/tqueue.pmc
Index: tqueue.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/tqueue.pmc,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- tqueue.pmc 21 Feb 2004 11:50:10 -0000 1.8
+++ tqueue.pmc 20 Aug 2004 11:25:36 -0000 1.9
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: tqueue.pmc,v 1.8 2004/02/21 11:50:10 mikescott Exp $
+$Id: tqueue.pmc,v 1.9 2004/08/20 11:25:36 leo Exp $
=head1 NAME
@@ -188,6 +188,7 @@
(VTABLE_IS_CONST_FLAG | VTABLE_IS_SHARED_FLAG)))
VTABLE_share(INTERP, item);
+ DOD_WRITE_BARRIER(INTERP, SELF, NULL, item);
entry->data = item;
entry->type = QUEUE_ENTRY_TYPE_NONE;
/* s. tsq.c:queue_push */
1.17 +136 -2 parrot/t/op/gc.t
Index: gc.t
===================================================================
RCS file: /cvs/public/parrot/t/op/gc.t,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -w -r1.16 -r1.17
--- gc.t 19 Aug 2004 11:48:19 -0000 1.16
+++ gc.t 20 Aug 2004 11:25:41 -0000 1.17
@@ -1,6 +1,6 @@
#! perl -w
# Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-# $Id: gc.t,v 1.16 2004/08/19 11:48:19 leo Exp $
+# $Id: gc.t,v 1.17 2004/08/20 11:25:41 leo Exp $
=head1 NAME
@@ -17,7 +17,7 @@
=cut
-use Parrot::Test tests => 16;
+use Parrot::Test tests => 18;
output_is( <<'CODE', '1', "sweep 1" );
interpinfo I1, 2 # How many DOD runs have we done already?
@@ -582,3 +582,137 @@
CODE
ok
OUTPUT
+
+output_is(<<'CODE', <<OUTPUT, "write barrier 3 - ref");
+ null I2
+ set I3, 10
+lp3:
+ null I0
+ set I1, 100
+ new P5, .Ref
+ new P0, .Integer
+ needs_destroy P0
+ # force partial sweep
+ # ref should now be black
+ sweep 0
+ # store white hash in ref - needs a barrier
+ new P1, .PerlHash
+ setref P5, P1
+ null P1
+ new P0, .Integer
+ needs_destroy P0
+ null P0
+ # force full sweep
+ sweep 0
+ deref P1, P5
+lp1:
+ new P0, .Integer
+ new P2, .Ref, P0
+ set P0, I0
+ set S0, I0
+ set P1[S0], P2
+ if I0, not_0
+ new P0, .Integer
+not_0:
+ new P3, .Undef
+ new P4, .Undef
+ inc I0
+ lt I0, I1, lp1
+
+ null I0
+ deref P1, P5
+ # trace 1
+lp2:
+ set S0, I0
+ set P2, P1[S0]
+ deref P2, P2
+ eq P2, I0, ok
+ print "nok\n"
+ print "I0: "
+ print I0
+ print " P2: "
+ print P2
+ print " type: "
+ typeof S0, P2
+ print S0
+ print " I2: "
+ print I2
+ print "\n"
+ exit 1
+ok:
+ inc I0
+ lt I0, I1, lp2
+ inc I2
+ lt I2, I3, lp3
+ print "ok\n"
+ end
+
+CODE
+ok
+OUTPUT
+
+output_is(<<'CODE', <<OUTPUT, "write barrier 4 - tqueue");
+ null I2
+ set I3, 100
+lp3:
+ null I0
+ set I1, 10
+ new P5, .TQueue
+ new P0, .PerlInt
+ needs_destroy P0
+ # force partial sweep
+ # P5 should now be black
+ sweep 0
+ # store white queue P1 in black P5 - needs a barrier
+ new P1, .TQueue
+ push P5, P1
+ null P1
+ new P0, .PerlInt
+ needs_destroy P0
+ # force sweep
+ sweep 0
+ shift P1, P5
+ push P5, P1
+lp1:
+ new P0, .PerlInt
+ needs_destroy P0
+ # force sweep
+ sweep 0
+ set P0, I0
+ new P2, .TQueue
+ push P2, P0
+ push P1, P2
+ new P3, .Undef
+ new P4, .Undef
+ inc I0
+ lt I0, I1, lp1
+
+ null I0
+ shift P1, P5
+lp2:
+ shift P2, P1
+ shift P2, P2
+ eq P2, I0, ok
+ print "nok\n"
+ print "I0: "
+ print I0
+ print " P2: "
+ print P2
+ print " type: "
+ typeof S0, P2
+ print S0
+ print " I2: "
+ print I2
+ print "\n"
+ exit 1
+ok:
+ inc I0
+ lt I0, I1, lp2
+ inc I2
+ lt I2, I3, lp3
+ print "ok\n"
+ end
+
+CODE
+ok
+OUTPUT
