cvs commit: ponie/perl embedvar.h intrpvar.h perl.c perlapi.h sv.c
[email protected] (Nicholas Clark) 28 Apr 2005 22:52:12 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
cvsuser 05/04/28 15:52:12
Modified: perl embedvar.h intrpvar.h perl.c perlapi.h sv.c
Log:
Use a generation count to track deletes from the arena table, and restart
scanning of the list for the current bucket if there is a deletion while we're
midway along it.
Revision Changes Path
1.10 +2 -0 ponie/perl/embedvar.h
Index: embedvar.h
===================================================================
RCS file: /cvs/public/ponie/perl/embedvar.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- embedvar.h 4 Apr 2005 17:46:11 -0000 1.9
+++ embedvar.h 28 Apr 2005 22:52:11 -0000 1.10
@@ -394,6 +394,7 @@
#define PL_subname (vTHX->Isubname)
#define PL_suidscript (vTHX->Isuidscript)
#define PL_sv_arenatable (vTHX->Isv_arenatable)
+#define PL_sv_arenatable_gen (vTHX->Isv_arenatable_gen)
#define PL_sv_count (vTHX->Isv_count)
#define PL_sv_no_p (vTHX->Isv_no_p)
#define PL_sv_objcount (vTHX->Isv_objcount)
@@ -697,6 +698,7 @@
#define PL_Isubname PL_subname
#define PL_Isuidscript PL_suidscript
#define PL_Isv_arenatable PL_sv_arenatable
+#define PL_Isv_arenatable_gen PL_sv_arenatable_gen
#define PL_Isv_count PL_sv_count
#define PL_Isv_no_p PL_sv_no_p
#define PL_Isv_objcount PL_sv_objcount
1.10 +1 -0 ponie/perl/intrpvar.h
Index: intrpvar.h
===================================================================
RCS file: /cvs/public/ponie/perl/intrpvar.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- intrpvar.h 4 Apr 2005 17:46:11 -0000 1.9
+++ intrpvar.h 28 Apr 2005 22:52:11 -0000 1.10
@@ -141,6 +141,7 @@
PERLVAR(Isv_objcount, I32) /* how many objects are currently allocated */
PERLVAR(Isv_root, SV*) /* storage for SVs belonging to interp */
PERLVAR(Isv_arenatable, PTR_TBL_t*) /* table of all active SVs */
+PERLVAR(Isv_arenatable_gen, U32) /* generation count (last deletion */
/* funky return mechanisms */
PERLVAR(Iforkprocess, int) /* so do_open |- can return proc# */
1.19 +1 -0 ponie/perl/perl.c
Index: perl.c
===================================================================
RCS file: /cvs/public/ponie/perl/perl.c,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- perl.c 27 Apr 2005 13:18:30 -0000 1.18
+++ perl.c 28 Apr 2005 22:52:11 -0000 1.19
@@ -272,6 +272,7 @@
#endif
PL_sv_arenatable = Perl_ptr_table_new(aTHX);
+ PL_sv_arenatable_gen = 0;
#ifdef MULTIPLICITY
init_interp();
1.10 +2 -0 ponie/perl/perlapi.h
Index: perlapi.h
===================================================================
RCS file: /cvs/public/ponie/perl/perlapi.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- perlapi.h 4 Apr 2005 17:46:12 -0000 1.9
+++ perlapi.h 28 Apr 2005 22:52:11 -0000 1.10
@@ -553,6 +553,8 @@
#define PL_suidscript (*Perl_Isuidscript_ptr(aTHX))
#undef PL_sv_arenatable
#define PL_sv_arenatable (*Perl_Isv_arenatable_ptr(aTHX))
+#undef PL_sv_arenatable_gen
+#define PL_sv_arenatable_gen (*Perl_Isv_arenatable_gen_ptr(aTHX))
#undef PL_sv_count
#define PL_sv_count (*Perl_Isv_count_ptr(aTHX))
#undef PL_sv_no_p
1.65 +38 -15 ponie/perl/sv.c
Index: sv.c
===================================================================
RCS file: /cvs/public/ponie/perl/sv.c,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- sv.c 23 Apr 2005 16:52:41 -0000 1.64
+++ sv.c 28 Apr 2005 22:52:11 -0000 1.65
@@ -238,8 +238,10 @@
}
LOCK_SV_MUTEX;
--PL_sv_count;
- if (!PL_in_clean_all)
+ if (!PL_in_clean_all) {
Perl_ptr_table_delete(PL_sv_arenatable, p);
+ ++PL_sv_arenatable_gen;
+ }
UNLOCK_SV_MUTEX;
Parrot_PMC_set_intval_intkey(PL_Parrot,MUMBLE(p),
@@ -270,8 +272,11 @@
=cut
*/
-I32
-S_ptr_table_visit(pTHX_ PTR_TBL_t *tbl, SVFUNC_t f, U32 flags, U32 mask)
+
+/* visit(): call the named function for each non-free SV in the arenas. */
+
+STATIC I32
+S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
{
I32 visited = 0;
@@ -280,24 +285,50 @@
UV riter = 0;
UV max;
- if (!tbl || !tbl->tbl_items) {
+ if (!PL_sv_arenatable || !PL_sv_arenatable->tbl_items) {
return 0;
}
- array = tbl->tbl_ary;
+ array = PL_sv_arenatable->tbl_ary;
entry = array[0];
- max = tbl->tbl_max;
+ max = PL_sv_arenatable->tbl_max;
for (;;) {
if (entry) {
SV *sv = entry->oldval;
+ /* This call may well delete the current entry.
+ More fun is that in turn, it might also delete any other entry,
+ including the next entry.
+ So we have to be really defensive and restart traversing this
+ linked list.
+ So we can't even assume that the next entry stays valid.
+ However, we're still assuming 2 things
+ 1: Nothing we call with FCALL leaves the mask such that it will
+ get called again. (Or if it does get re-called, it doesn't
+ matter)
+ 2: Nothing creates as many SVs as it deletes.
+
+ Oops. 2 can be untrue. So we need to use a generation count to
+ track whether anything got deleted, and restart if so.
+ */
entry = entry->next;
- /* This call may well delete the current entry. */
if (SvTYPE(sv) != SVTYPEMASK
&& (((U32)Parrot_PMC_get_intval_intkey(PL_Parrot,MUMBLE(sv), Ponie_I_SV_FLAGS)) & mask) == flags
&& SvREFCNT(sv)) {
+ /* You can't even count tbl->tbl_items and assert that it goes
+ down, because Perl_sv_clear can create 3 or so new SVs
+ as part of deleting 1 other. The obvious one is
+ C<SV* tmpref = newRV(sv);>, but there's also creation
+ in Perl_gv_init and S_hv_fetch_common, all relating to
+ searching for DESTROY methods. */
+ U32 before = PL_sv_arenatable_gen;
(FCALL)(aTHX_ sv);
++visited;
+
+ if (before != PL_sv_arenatable_gen) {
+ /* Something changed, so restart. */
+ entry = array[riter];
+ }
}
}
if (!entry) {
@@ -310,14 +341,6 @@
return visited;
}
-/* visit(): call the named function for each non-free SV in the arenas. */
-
-STATIC I32
-S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
-{
- return S_ptr_table_visit (aTHX_ PL_sv_arenatable, f, flags, mask);
-}
-
#ifdef DEBUGGING
/* called by sv_report_used() for each live SV */