cvs commit: ponie/src/pmc perl5cargo_cult.pmc
[email protected] (Nicholas Clark) 4 May 2005 09:44:03 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
cvsuser 05/05/04 02:44:02
Modified: perl embed.fnc embed.h embedvar.h global.sym perlapi.h
proto.h sv.c
src/pmc perl5cargo_cult.pmc
Log:
Move all the code from S_del_SV into the PMC internals. S_del_SV becomes a
PMC set call.
Revision Changes Path
1.44 +1 -0 ponie/perl/embed.fnc
Index: embed.fnc
===================================================================
RCS file: /cvs/public/ponie/perl/embed.fnc,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- embed.fnc 1 May 2005 18:34:07 -0000 1.43
+++ embed.fnc 4 May 2005 09:44:01 -0000 1.44
@@ -941,6 +941,7 @@
#endif
#endif
Ap |PTR_TBL_t*|ptr_table_new
+Ap |void* |ptr_table_delete|PTR_TBL_t *tbl|void *sv
Ap |void* |ptr_table_fetch|PTR_TBL_t *tbl|void *sv
Ap |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv
Ap |void |ptr_table_split|PTR_TBL_t *tbl
1.34 +2 -0 ponie/perl/embed.h
Index: embed.h
===================================================================
RCS file: /cvs/public/ponie/perl/embed.h,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- embed.h 1 May 2005 18:34:07 -0000 1.33
+++ embed.h 4 May 2005 09:44:01 -0000 1.34
@@ -1223,6 +1223,7 @@
#endif
#endif
#define ptr_table_new Perl_ptr_table_new
+#define ptr_table_delete Perl_ptr_table_delete
#define ptr_table_fetch Perl_ptr_table_fetch
#define ptr_table_store Perl_ptr_table_store
#define ptr_table_split Perl_ptr_table_split
@@ -3708,6 +3709,7 @@
#endif
#endif
#define ptr_table_new() Perl_ptr_table_new(aTHX)
+#define ptr_table_delete(a,b) Perl_ptr_table_delete(aTHX_ a,b)
#define ptr_table_fetch(a,b) Perl_ptr_table_fetch(aTHX_ a,b)
#define ptr_table_store(a,b,c) Perl_ptr_table_store(aTHX_ a,b,c)
#define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a)
1.14 +0 -2 ponie/perl/embedvar.h
Index: embedvar.h
===================================================================
RCS file: /cvs/public/ponie/perl/embedvar.h,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- embedvar.h 3 May 2005 22:16:29 -0000 1.13
+++ embedvar.h 4 May 2005 09:44:01 -0000 1.14
@@ -394,7 +394,6 @@
#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)
@@ -698,7 +697,6 @@
#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.27 +1 -0 ponie/perl/global.sym
Index: global.sym
===================================================================
RCS file: /cvs/public/ponie/perl/global.sym,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -r1.26 -r1.27
--- global.sym 1 May 2005 18:34:07 -0000 1.26
+++ global.sym 4 May 2005 09:44:01 -0000 1.27
@@ -619,6 +619,7 @@
Perl_sv_dup
Perl_sys_intern_dup
Perl_ptr_table_new
+Perl_ptr_table_delete
Perl_ptr_table_fetch
Perl_ptr_table_store
Perl_ptr_table_split
1.14 +0 -2 ponie/perl/perlapi.h
Index: perlapi.h
===================================================================
RCS file: /cvs/public/ponie/perl/perlapi.h,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- perlapi.h 3 May 2005 22:16:30 -0000 1.13
+++ perlapi.h 4 May 2005 09:44:01 -0000 1.14
@@ -553,8 +553,6 @@
#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.44 +1 -0 ponie/perl/proto.h
Index: proto.h
===================================================================
RCS file: /cvs/public/ponie/perl/proto.h,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -r1.43 -r1.44
--- proto.h 1 May 2005 18:34:08 -0000 1.43
+++ proto.h 4 May 2005 09:44:01 -0000 1.44
@@ -901,6 +901,7 @@
#endif
#endif
PERL_CALLCONV PTR_TBL_t* Perl_ptr_table_new(pTHX);
+PERL_CALLCONV void* Perl_ptr_table_delete(pTHX_ PTR_TBL_t *tbl, void *sv);
PERL_CALLCONV void* Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv);
PERL_CALLCONV void Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldsv, void *newsv);
PERL_CALLCONV void Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl);
1.82 +18 -49 ponie/perl/sv.c
Index: sv.c
===================================================================
RCS file: /cvs/public/ponie/perl/sv.c,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -r1.81 -r1.82
--- sv.c 3 May 2005 22:16:30 -0000 1.81
+++ sv.c 4 May 2005 09:44:01 -0000 1.82
@@ -165,16 +165,6 @@
* "A time to plant, and a time to uproot what was planted..."
*/
-#ifdef DEBUG_LEAKING_SCALARS
-# ifdef NETWARE
-# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
-# else
-# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
-# endif
-#else
-# define FREE_SV_DEBUG_FILE(sv)
-#endif
-
/* new_SV(): return a new, empty SV head */
/* provide a real function for a debugger to play with */
@@ -210,39 +200,10 @@
}
# 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_ptr_table_cleanup(pTHX_ PTR_TBL_t *tbl);
-STATIC void
-S_del_SV(pTHX_ SV *p)
-{
- if (!ptr_table_fetch(PL_sv_arenatable, p)) {
- Perl_croak("Attempt to free non-arena SV: 0x%"UVxf
- pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
- return;
- }
- LOCK_SV_MUTEX;
- --PL_sv_count;
- if (!PL_in_clean_all) {
- Perl_ptr_table_delete(PL_sv_arenatable, p);
- }
- UNLOCK_SV_MUTEX;
-
- Parrot_PMC_set_intval_intkey(PL_Parrot,MUMBLE(p),
- Ponie_I_SV_ZERO_FLAGS_SET_TYPE,
- SVTYPEMASK);
-
- if (!PL_in_clean_all) {
- FREE_SV_DEBUG_FILE(p);
- Parrot_PMC_set_pointer_intkey(PL_Parrot, MUMBLE(p),
- Ponie_P_PINE_FOR_FJORDS,
- 0);
- Parrot_PMC_push_pmc(PL_Parrot, PL_sv_pining, MUMBLE(p));
- Parrot_unregister_pmc(PL_Parrot, MUMBLE(p));
- }
-}
-
-# define del_SV(p) S_del_SV(aTHX_ p)
+#define del_SV(p) Parrot_PMC_set_pointer_intkey(PL_Parrot, MUMBLE(p), \
+ Ponie_P_PINE_FOR_FJORDS, 0)
/*
@@ -342,7 +303,7 @@
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);
+ S_ptr_table_cleanup(aTHX_ PL_sv_arenatable);
}
return visited;
}
@@ -478,7 +439,10 @@
static void
do_free_heads(pTHX_ SV *sv)
{
- Perl_ptr_table_delete(PL_sv_arenatable, sv);
+ if (!Perl_ptr_table_delete(PL_sv_arenatable, sv)) {
+ croak("Could not find pointer %p in ptr table %p", sv,
+ PL_sv_arenatable);
+ }
Parrot_unregister_pmc(PL_Parrot, MUMBLE(sv));
}
/*
@@ -9427,7 +9391,10 @@
/* delete */
-void
+/* Return the pointer "newval" for this entry. Or NULL for not found.
+ Given that it's a pointer table map, we assume that no-one ever puts
+ NULL in as their newval */
+void *
Perl_ptr_table_delete(pTHX_ PTR_TBL_t *tbl, void *sv)
{
PTR_TBL_ENT_t **tblent;
@@ -9438,6 +9405,7 @@
PTR_TBL_ENT_t *current = *tblent;
if (current->oldval == sv) {
/* Found it. */
+ void *result = current->newval;
if (tbl->iteration_nesting == 0) {
*tblent = current->next;
Safefree(current);
@@ -9447,13 +9415,14 @@
actually delete this entry right now. */
++tbl->pending_deletes;
current->oldval = 0;
+ current->newval = 0;
}
- return;
+ return result;
}
tblent = &(current->next);
}
/* Failed to find it. */
- croak("Could not find pointer %p in ptr table %p", sv, tbl);
+ return NULL;
}
/* map an existing pointer using a table */
@@ -9535,8 +9504,8 @@
}
-void
-Perl_ptr_table_cleanup(pTHX_ PTR_TBL_t *tbl)
+STATIC void
+S_ptr_table_cleanup(pTHX_ PTR_TBL_t *tbl)
{
PTR_TBL_ENT_t **ary = tbl->tbl_ary;
UV i;
1.60 +25 -3 ponie/src/pmc/perl5cargo_cult.pmc
Index: perl5cargo_cult.pmc
===================================================================
RCS file: /cvs/public/ponie/src/pmc/perl5cargo_cult.pmc,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -r1.59 -r1.60
--- perl5cargo_cult.pmc 2 May 2005 20:27:07 -0000 1.59
+++ perl5cargo_cult.pmc 4 May 2005 09:44:02 -0000 1.60
@@ -48,6 +48,16 @@
SvREFCNT_dec(SvSTASH(sv));
}
+#ifdef DEBUG_LEAKING_SCALARS
+# ifdef NETWARE
+# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
+# else
+# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
+# endif
+#else
+# define FREE_SV_DEBUG_FILE(sv)
+#endif
+
pmclass Perl5cargo_cult dynpmc {
void init () {
@@ -557,7 +567,13 @@
break;
case Ponie_P_PINE_FOR_FJORDS:
{
- U32 flags = PERL5_FLAGS(SELF);
+ --PL_sv_count;
+
+ if (!Perl_ptr_table_delete(PL_sv_arenatable, MUMBLE(SELF))) {
+ Perl_croak("Attempt to free non-arena SV: 0x%"UVxf
+ pTHX__FORMAT, PTR2UV(MUMBLE(SELF)) pTHX__VALUE);
+ return;
+ }
assert(PMC_struct_val(SELF));
assert(!PERL5_REFCNT(SELF));
@@ -573,7 +589,13 @@
Not convinced that I want to give it a public way to set
the flags, as after creation they should be read only. */
PObj_bufstart(pmc) = value;
- PObj_buflen(pmc) = flags;
+ PObj_buflen(pmc) = SVTYPEMASK;;
+
+ if (!PL_in_clean_all) {
+ FREE_SV_DEBUG_FILE(p);
+ Parrot_PMC_push_pmc(INTERP, PL_sv_pining, SELF);
+ Parrot_unregister_pmc(INTERP, SELF);
+ }
break;
}
default: