Allocate pointer table entries (for ithread cloning) from an arena

p4raw-id: //depot/perl@24404

4 files changed, 61 insertions, 2 deletions

diff --git a/embedvar.h b/embedvar.h
index b7ce358354..dad8a80db0 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -358,6 +358,8 @@
 #define PL_psig_name		(vTHX->Ipsig_name)
 #define PL_psig_pend		(vTHX->Ipsig_pend)
 #define PL_psig_ptr		(vTHX->Ipsig_ptr)
+#define PL_pte_arenaroot	(vTHX->Ipte_arenaroot)
+#define PL_pte_root		(vTHX->Ipte_root)
 #define PL_ptr_table		(vTHX->Iptr_table)
 #define PL_reentrant_buffer	(vTHX->Ireentrant_buffer)
 #define PL_reentrant_retint	(vTHX->Ireentrant_retint)
@@ -661,6 +663,8 @@
 #define PL_Ipsig_name		PL_psig_name
 #define PL_Ipsig_pend		PL_psig_pend
 #define PL_Ipsig_ptr		PL_psig_ptr
+#define PL_Ipte_arenaroot	PL_pte_arenaroot
+#define PL_Ipte_root		PL_pte_root
 #define PL_Iptr_table		PL_ptr_table
 #define PL_Ireentrant_buffer	PL_reentrant_buffer
 #define PL_Ireentrant_retint	PL_reentrant_retint
diff --git a/intrpvar.h b/intrpvar.h
index 3fe5adb736..2125acf180 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -261,6 +261,7 @@ PERLVAR(Ixpvmg_root,	XPVMG *)	/* free xpvmg list */
 PERLVAR(Ixpvlv_root,	XPVLV *)	/* free xpvlv list */
 PERLVAR(Ixpvbm_root,	XPVBM *)	/* free xpvbm list */
 PERLVAR(Ihe_root,	HE *)		/* free he list */
+PERLVAR(Ipte_root,	struct ptr_tbl_ent *)	/* free ptr_tbl_ent list */
 PERLVAR(Inice_chunk,	char *)		/* a nice chunk of memory to reuse */
 PERLVAR(Inice_chunk_size,	U32)	/* how nice the chunk of memory is */
 
@@ -437,6 +438,7 @@ PERLVAR(Ixpvmg_arenaroot,XPVMG*)	/* list of allocated xpvmg areas */
 PERLVAR(Ixpvlv_arenaroot,XPVLV*)	/* list of allocated xpvlv areas */
 PERLVAR(Ixpvbm_arenaroot,XPVBM*)	/* list of allocated xpvbm areas */
 PERLVAR(Ihe_arenaroot,	XPV*)		/* list of allocated he areas */
+PERLVAR(Ipte_arenaroot,	XPV*)		/* list of allocated he areas */
 
      /* 5.6.0 stopped here */
 
diff --git a/perlapi.h b/perlapi.h
index c9ccd690b9..662ecdfbc0 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -496,6 +496,10 @@ END_EXTERN_C
 #define PL_psig_pend		(*Perl_Ipsig_pend_ptr(aTHX))
 #undef  PL_psig_ptr
 #define PL_psig_ptr		(*Perl_Ipsig_ptr_ptr(aTHX))
+#undef  PL_pte_arenaroot
+#define PL_pte_arenaroot	(*Perl_Ipte_arenaroot_ptr(aTHX))
+#undef  PL_pte_root
+#define PL_pte_root		(*Perl_Ipte_root_ptr(aTHX))
 #undef  PL_ptr_table
 #define PL_ptr_table		(*Perl_Iptr_table_ptr(aTHX))
 #undef  PL_reentrant_buffer
diff --git a/sv.c b/sv.c
index f9858e889f..cdcbd6c507 100644
--- a/sv.c
+++ b/sv.c
@@ -621,6 +621,13 @@ Perl_sv_free_arenas(pTHX)
     PL_he_arenaroot = 0;
     PL_he_root = 0;
 
+    for (arena = (XPV*)PL_pte_arenaroot; arena; arena = arenanext) {
+	arenanext = (XPV*)arena->xpv_pv;
+	Safefree(arena);
+    }
+    PL_pte_arenaroot = 0;
+    PL_pte_root = 0;
+
     if (PL_nice_chunk)
 	Safefree(PL_nice_chunk);
     PL_nice_chunk = Nullch;
@@ -10412,6 +10419,46 @@ Perl_ptr_table_new(pTHX)
 #  define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
 #endif
 
+
+
+STATIC void
+S_more_pte(pTHX)
+{
+    register struct ptr_tbl_ent* pte;
+    register struct ptr_tbl_ent* pteend;
+    XPV *ptr;
+    New(54, ptr, 1008/sizeof(XPV), XPV);
+    ptr->xpv_pv = (char*)PL_pte_arenaroot;
+    PL_pte_arenaroot = ptr;
+
+    pte = (struct ptr_tbl_ent*)ptr;
+    pteend = &pte[1008 / sizeof(struct ptr_tbl_ent) - 1];
+    PL_pte_root = ++pte;
+    while (pte < pteend) {
+	pte->next = pte + 1;
+	pte++;
+    }
+    pte->next = 0;
+}
+
+STATIC struct ptr_tbl_ent*
+S_new_pte(pTHX)
+{
+    struct ptr_tbl_ent* pte;
+    if (!PL_pte_root)
+	S_more_pte(aTHX);
+    pte = PL_pte_root;
+    PL_pte_root = pte->next;
+    return pte;
+}
+
+STATIC void
+S_del_pte(pTHX_ struct ptr_tbl_ent*p)
+{
+    p->next = PL_pte_root;
+    PL_pte_root = p;
+}
+
 /* map an existing pointer using a table */
 
 void *
@@ -10448,7 +10495,7 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
 	    return;
 	}
     }
-    Newz(0, tblent, 1, PTR_TBL_ENT_t);
+    tblent = S_new_pte(aTHX);
     tblent->oldval = oldv;
     tblent->newval = newv;
     tblent->next = *otblent;
@@ -10513,7 +10560,7 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
         if (entry) {
             oentry = entry;
             entry = entry->next;
-            Safefree(oentry);
+            S_del_pte(aTHX_ oentry);
         }
         if (!entry) {
             if (++riter > max) {
@@ -11627,6 +11674,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_xpvbm_root	= NULL;
     PL_he_arenaroot	= NULL;
     PL_he_root		= NULL;
+    PL_pte_arenaroot	= NULL;
+    PL_pte_root		= NULL;
     PL_nice_chunk	= NULL;
     PL_nice_chunk_size	= 0;
     PL_sv_count		= 0;