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

p4raw-id: //depot/perl@24404

diff --git a/embedvar.h b/embedvar.h
index b7ce358..dad8a80 100644 (file)
--- 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 3fe5adb..2125acf 100644 (file)
--- 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 c9ccd69..662ecdf 100644 (file)
--- 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 f9858e8..cdcbd6c 100644 (file)
--- 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;