cvs commit: ponie/perl embedvar.h intrpvar.h perl.c perl.h perlapi.h scope.c sv.c
[email protected] (Nicholas Clark) 3 May 2005 22:16:31 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
cvsuser 05/05/03 15:16:30
Modified: perl embedvar.h intrpvar.h perl.c perl.h perlapi.h
scope.c sv.c
Log:
All the attempts at restarting the scan in S_visit are doomed to failure in
increasingly subtle ways - bite the bullet and don't delete from or split the
hash if we're iterating over it.
In turn, all this comes about because trying to change from a linked list of
pining SVs to a ResizablePMCArray caused lots of increasingly subtle breakages
with the old scheme. So now we have all the PMCs pining for the fjords in their
own special little PMC, which can easily be flushed in free_tmps.
Revision Changes Path
1.13 +2 -2 ponie/perl/embedvar.h
Index: embedvar.h
===================================================================
RCS file: /cvs/public/ponie/perl/embedvar.h,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- embedvar.h 30 Apr 2005 10:18:59 -0000 1.12
+++ embedvar.h 3 May 2005 22:16:29 -0000 1.13
@@ -398,8 +398,8 @@
#define PL_sv_count (vTHX->Isv_count)
#define PL_sv_no_p (vTHX->Isv_no_p)
#define PL_sv_objcount (vTHX->Isv_objcount)
+#define PL_sv_pining (vTHX->Isv_pining)
#define PL_sv_placeholder_p (vTHX->Isv_placeholder_p)
-#define PL_sv_root (vTHX->Isv_root)
#define PL_sv_undef_p (vTHX->Isv_undef_p)
#define PL_sv_yes_p (vTHX->Isv_yes_p)
#define PL_sys_intern (vTHX->Isys_intern)
@@ -702,8 +702,8 @@
#define PL_Isv_count PL_sv_count
#define PL_Isv_no_p PL_sv_no_p
#define PL_Isv_objcount PL_sv_objcount
+#define PL_Isv_pining PL_sv_pining
#define PL_Isv_placeholder_p PL_sv_placeholder_p
-#define PL_Isv_root PL_sv_root
#define PL_Isv_undef_p PL_sv_undef_p
#define PL_Isv_yes_p PL_sv_yes_p
#define PL_Isys_intern PL_sys_intern
1.11 +2 -2 ponie/perl/intrpvar.h
Index: intrpvar.h
===================================================================
RCS file: /cvs/public/ponie/perl/intrpvar.h,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- intrpvar.h 28 Apr 2005 22:52:11 -0000 1.10
+++ intrpvar.h 3 May 2005 22:16:29 -0000 1.11
@@ -139,9 +139,9 @@
/* memory management */
PERLVAR(Isv_count, I32) /* how many SV* are currently allocated */
PERLVAR(Isv_objcount, I32) /* how many objects are currently allocated */
-PERLVAR(Isv_root, SV*) /* storage for SVs belonging to interp */
+
+PERLVAR(Isv_pining, Parrot_PMC) /* SVs that are playing dead. */
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.26 +18 -10 ponie/perl/perl.c
Index: perl.c
===================================================================
RCS file: /cvs/public/ponie/perl/perl.c,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- perl.c 3 May 2005 16:12:19 -0000 1.25
+++ perl.c 3 May 2005 22:16:29 -0000 1.26
@@ -216,6 +216,20 @@
{SVt_PVMG, "Perl5PVMG"},\
*/
+STATIC Parrot_Int
+type_or_bail (const char *typename) {
+ Parrot_Int type = Parrot_PMC_typenum(PL_Parrot, typename);
+
+ if (!type) {
+ const char *bail = "Could not find PMC type '";
+ write(2, bail, strlen(bail) + 1);
+ write(2, typename, strlen(typename));
+ write(2, "'\n", 2);
+ abort();
+ }
+ return type;
+}
+
void
perl_construct(pTHXx)
{
@@ -267,15 +281,7 @@
int j;
while (i->name) {
- Parrot_Int type = Parrot_PMC_typenum(PL_Parrot, i->name);
-
- if (!type) {
- const char *bail = "Could not find PMC type '";
- write(2, bail, strlen(bail) + 1);
- write(2, i->name, strlen(i->name));
- write(2, "'\n", 2);
- abort();
- }
+ Parrot_Int type = type_or_bail(i->name);
PL_pmcname[i->array_index] = type;
++i;
if (type > max_type)
@@ -299,7 +305,9 @@
#endif
PL_sv_arenatable = Perl_ptr_table_new(aTHX);
- PL_sv_arenatable_gen = 0;
+
+ PL_sv_pining = Parrot_PMC_new(PL_Parrot, type_or_bail("ResizablePMCArray"));
+ Parrot_register_pmc(PL_Parrot, PL_sv_pining);
#ifdef MULTIPLICITY
init_interp();
1.13 +2 -0 ponie/perl/perl.h
Index: perl.h
===================================================================
RCS file: /cvs/public/ponie/perl/perl.h,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- perl.h 19 Apr 2005 19:04:13 -0000 1.12
+++ perl.h 3 May 2005 22:16:29 -0000 1.13
@@ -2586,6 +2586,8 @@
struct ptr_tbl_ent** tbl_ary;
UV tbl_max;
UV tbl_items;
+ U32 iteration_nesting;
+ U32 pending_deletes;
};
#if defined(iAPX286) || defined(M_I286) || defined(I80286)
1.13 +2 -2 ponie/perl/perlapi.h
Index: perlapi.h
===================================================================
RCS file: /cvs/public/ponie/perl/perlapi.h,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- perlapi.h 30 Apr 2005 10:18:59 -0000 1.12
+++ perlapi.h 3 May 2005 22:16:30 -0000 1.13
@@ -561,10 +561,10 @@
#define PL_sv_no_p (*Perl_Isv_no_p_ptr(aTHX))
#undef PL_sv_objcount
#define PL_sv_objcount (*Perl_Isv_objcount_ptr(aTHX))
+#undef PL_sv_pining
+#define PL_sv_pining (*Perl_Isv_pining_ptr(aTHX))
#undef PL_sv_placeholder_p
#define PL_sv_placeholder_p (*Perl_Isv_placeholder_p_ptr(aTHX))
-#undef PL_sv_root
-#define PL_sv_root (*Perl_Isv_root_ptr(aTHX))
#undef PL_sv_undef_p
#define PL_sv_undef_p (*Perl_Isv_undef_p_ptr(aTHX))
#undef PL_sv_yes_p
1.11 +4 -12 ponie/perl/scope.c
Index: scope.c
===================================================================
RCS file: /cvs/public/ponie/perl/scope.c,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- scope.c 19 Apr 2005 19:04:13 -0000 1.10
+++ scope.c 3 May 2005 22:16:30 -0000 1.11
@@ -146,19 +146,11 @@
SvREFCNT_dec(sv); /* note, can modify tmps_ix!!! */
}
}
- /* Hack - need to defer freeing SV heads, as things expect to be able to
- access them and say "oops, SvBREAK". */
+ /* Hack - need to defer freeing SV heads immediately, as things expect to
+ be able to access them and say "oops, SvBREAK". */
- /* Is the SV mutex needed outside 5005 threads? */
- LOCK_SV_MUTEX;
- while (PL_sv_root) {
- SV *tofree = PL_sv_root;
- PL_sv_root = SvANY(tofree);
- UNLOCK_SV_MUTEX;
- Parrot_unregister_pmc(PL_Parrot, MUMBLE(tofree));
- LOCK_SV_MUTEX;
- }
- UNLOCK_SV_MUTEX;
+ /* But this is the point where we can free them all. */
+ Parrot_PMC_set_intval(PL_Parrot, PL_sv_pining, 0);
}
STATIC SV *
1.81 +72 -18 ponie/perl/sv.c
Index: sv.c
===================================================================
RCS file: /cvs/public/ponie/perl/sv.c,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -r1.80 -r1.81
--- sv.c 3 May 2005 15:36:03 -0000 1.80
+++ sv.c 3 May 2005 22:16:30 -0000 1.81
@@ -211,6 +211,7 @@
# define new_SV(p) (p)=S_new_SV(aTHX)
void Perl_ptr_table_delete(pTHX_ PTR_TBL_t *tbl, void *sv);
+void Perl_ptr_table_cleanup(pTHX_ PTR_TBL_t *tbl);
STATIC void
S_del_SV(pTHX_ SV *p)
@@ -224,7 +225,6 @@
--PL_sv_count;
if (!PL_in_clean_all) {
Perl_ptr_table_delete(PL_sv_arenatable, p);
- ++PL_sv_arenatable_gen;
}
UNLOCK_SV_MUTEX;
@@ -234,14 +234,11 @@
if (!PL_in_clean_all) {
FREE_SV_DEBUG_FILE(p);
- /* Is the SV mutex needed outside 5005 threads? */
- LOCK_SV_MUTEX;
Parrot_PMC_set_pointer_intkey(PL_Parrot, MUMBLE(p),
Ponie_P_PINE_FOR_FJORDS,
- (void *)PL_sv_root
- );
- PL_sv_root = (p);
- UNLOCK_SV_MUTEX;
+ 0);
+ Parrot_PMC_push_pmc(PL_Parrot, PL_sv_pining, MUMBLE(p));
+ Parrot_unregister_pmc(PL_Parrot, MUMBLE(p));
}
}
@@ -269,7 +266,7 @@
register PTR_TBL_ENT_t **array;
register PTR_TBL_ENT_t *entry;
- UV riter = 0;
+ UV riter;
UV max;
if (!PL_sv_arenatable || !PL_sv_arenatable->tbl_items) {
@@ -279,6 +276,8 @@
array = PL_sv_arenatable->tbl_ary;
entry = array[0];
max = PL_sv_arenatable->tbl_max;
+ PL_sv_arenatable->iteration_nesting++;
+ riter = 0;
for (;;) {
if (entry) {
@@ -299,7 +298,8 @@
track whether anything got deleted, and restart if so.
*/
entry = entry->next;
- if (SvTYPE(sv) != SVTYPEMASK
+ /* sv can be 0 now because it marks a pending delete. */
+ if (sv && 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
@@ -308,14 +308,28 @@
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;
+ /*U32 before = PL_sv_arenatable_gen; -- see below */
(FCALL)(aTHX_ sv);
++visited;
- if (before != PL_sv_arenatable_gen) {
+ /* None of this restart works, even the most brutal version,
+ a goto back to the start of the function, for some reason
+ ends up with calls to things prematurely freed.
+ if (before != PL_sv_arenatable_gen) {*/
/* Something changed, so restart. */
- entry = array[riter];
- }
+ /* Nope. This isn't good enough. Almost, but not quite:
+ entry = array[riter];
+
+ (gdb) p max
+ $11 = 16383
+ (gdb) p *PL_sv_arenatable
+ $12 = {tbl_ary = 0xb5dbc008, tbl_max = 32767, tbl_items = 16908}
+
+ Yes, we had a split and our cached array pointer is
+ wrong.
+ */
+ /*goto restart;
+ }*/
}
}
if (!entry) {
@@ -325,6 +339,11 @@
entry = array[riter];
}
}
+ if (--PL_sv_arenatable->iteration_nesting == 0 &&
+ PL_sv_arenatable->pending_deletes) {
+ /* We can run a cleanup. */
+ Perl_ptr_table_cleanup(aTHX_ PL_sv_arenatable);
+ }
return visited;
}
@@ -569,7 +588,7 @@
Safefree(PL_nice_chunk);
PL_nice_chunk = Nullch;
PL_nice_chunk_size = 0;
- PL_sv_root = 0;
+ Parrot_unregister_pmc(PL_Parrot, PL_sv_pining);
}
/* ---------------------------------------------------------------------
@@ -9398,6 +9417,8 @@
Newz(0, tbl, 1, PTR_TBL_t);
tbl->tbl_max = 511;
tbl->tbl_items = 0;
+ tbl->iteration_nesting = 0;
+ tbl->pending_deletes = 0;
Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
return tbl;
}
@@ -9417,9 +9438,16 @@
PTR_TBL_ENT_t *current = *tblent;
if (current->oldval == sv) {
/* Found it. */
- *tblent = current->next;
- Safefree(current);
- --tbl->tbl_items;
+ if (tbl->iteration_nesting == 0) {
+ *tblent = current->next;
+ Safefree(current);
+ --tbl->tbl_items;
+ } else {
+ /* Someone is iterating over this ptr_table, so we can't
+ actually delete this entry right now. */
+ ++tbl->pending_deletes;
+ current->oldval = 0;
+ }
return;
}
tblent = &(current->next);
@@ -9470,7 +9498,7 @@
tblent->next = *otblent;
*otblent = tblent;
tbl->tbl_items++;
- if (!empty && tbl->tbl_items > tbl->tbl_max)
+ if (!empty && tbl->tbl_items > tbl->tbl_max && !tbl->iteration_nesting)
ptr_table_split(tbl);
}
@@ -9507,6 +9535,32 @@
}
+void
+Perl_ptr_table_cleanup(pTHX_ PTR_TBL_t *tbl)
+{
+ PTR_TBL_ENT_t **ary = tbl->tbl_ary;
+ UV i;
+
+ for (i=0; i <= tbl->tbl_max; i++, ary++) {
+ PTR_TBL_ENT_t **entp, *ent;
+ if (!*ary)
+ continue;
+ for (entp = ary, ent = *ary; ent; ent = *entp) {
+ if (!(ent->oldval)) {
+ *entp = ent->next;
+ Safefree(ent);
+ if(--tbl->pending_deletes == 0)
+ return;
+ continue;
+ }
+ else
+ entp = &ent->next;
+ }
+ }
+ croak("panic: ptr table %p size %u has %d pending_deletes missing",
+ tbl, tbl->tbl_max + 1, tbl->pending_deletes);
+}
+
/* remove all the entries from a ptr table */
void