Track the mapping between source shared hash keys and target shared

hash keys to save repeated lookups during cloning.

p4raw-id: //depot/perl@24574

diff --git a/embed.fnc b/embed.fnc
index 2ae37bb..a1ce117 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -993,7 +993,7 @@ s   |void   |del_he         |HE *p
 s      |HEK*   |save_hek_flags |const char *str|I32 len|U32 hash|int flags
 s      |void   |hv_magic_check |HV *hv|bool *needs_copy|bool *needs_store
 s      |void   |unshare_hek_or_pvn|HEK* hek|const char* sv|I32 len|U32 hash
-s      |HEK*   |share_hek_flags|const char* sv|I32 len|U32 hash|int flags
+s      |HE*    |share_hek_flags|const char* sv|I32 len|U32 hash|int flags
 rs     |void   |hv_notallowed  |int flags|const char *key|I32 klen|const char *msg
 #endif
 

diff --git a/embedvar.h b/embedvar.h
index d0c3a46..ea68e16 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -377,6 +377,7 @@
 #define PL_savebegin           (vTHX->Isavebegin)
 #define PL_sawampersand                (vTHX->Isawampersand)
 #define PL_sh_path_compat      (vTHX->Ish_path_compat)
+#define PL_shared_hek_table    (vTHX->Ishared_hek_table)
 #define PL_sharehook           (vTHX->Isharehook)
 #define PL_sig_pending         (vTHX->Isig_pending)
 #define PL_sighandlerp         (vTHX->Isighandlerp)
@@ -681,6 +682,7 @@
 #define PL_Isavebegin          PL_savebegin
 #define PL_Isawampersand       PL_sawampersand
 #define PL_Ish_path_compat     PL_sh_path_compat
+#define PL_Ishared_hek_table   PL_shared_hek_table
 #define PL_Isharehook          PL_sharehook
 #define PL_Isig_pending                PL_sig_pending
 #define PL_Isighandlerp                PL_sighandlerp

diff --git a/ext/threads/threads.xs b/ext/threads/threads.xs
index 03cb590..f6b57d6 100755 (executable)
--- a/ext/threads/threads.xs
+++ b/ext/threads/threads.xs
@@ -615,6 +615,7 @@ Perl_ithread_join(pTHX_ SV *obj)
          clone_params.stashes = newAV();
          clone_params.flags |= CLONEf_JOIN_IN;
          PL_ptr_table = ptr_table_new();
+         PL_shared_hek_table = ptr_table_new();
          current_thread = Perl_ithread_get(aTHX);
          Perl_ithread_set(aTHX_ thread);
          /* ensure 'meaningful' addresses retain their meaning */
@@ -646,6 +647,8 @@ Perl_ithread_join(pTHX_ SV *obj)
          SvREFCNT_inc(retparam);
          ptr_table_free(PL_ptr_table);
          PL_ptr_table = NULL;
+         ptr_table_free(PL_shared_hek_table);
+         PL_shared_hek_table = NULL;
 
        }
        /* We are finished with it */

diff --git a/hv.c b/hv.c
index 5443771..919f3f6 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -146,9 +146,21 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
        HeKEY_hek(ret) = (HEK*)k;
        HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
     }
-    else if (shared)
-       HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
-                                         HeKFLAGS(e));
+    else if (shared) {
+       HEK *source = HeKEY_hek(e);
+       HE *shared = (HE*)ptr_table_fetch(PL_shared_hek_table, source);
+
+       if (shared) {
+           /* We already shared this hash key.  */
+           ++HeVAL(shared);
+       }
+       else {
+           shared = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
+                                    HEK_HASH(source), HEK_FLAGS(source));
+           ptr_table_store(PL_shared_hek_table, source, shared);
+       }
+       HeKEY_hek(ret) = HeKEY_hek(shared);
+    }
     else
        HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
                                         HeKFLAGS(e));
@@ -652,8 +664,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
                    /* Need to swap the key we have for a key with the flags we
                       need. As keys are shared we can't just write to the
                       flag, so we share the new one, unshare the old one.  */
-                   HEK *new_hek = share_hek_flags(key, klen, hash,
-                                                  masked_flags);
+                   HEK *new_hek = HeKEY_hek(share_hek_flags(key, klen, hash,
+                                                            masked_flags));
                    unshare_hek (HeKEY_hek(entry));
                    HeKEY_hek(entry) = new_hek;
                }
@@ -755,7 +767,7 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
     /* share_hek_flags will do the free for us.  This might be considered
        bad API design.  */
     if (HvSHAREKEYS(hv))
-       HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
+       HeKEY_hek(entry) = HeKEY_hek(share_hek_flags(key, klen, hash, flags));
     else                                       /* gotta do the real thing */
        HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
     HeVAL(entry) = val;
@@ -1348,7 +1360,7 @@ Perl_newHVhv(pTHX_ HV *ohv)
                ent = new_HE();
                HeVAL(ent)     = newSVsv(HeVAL(oent));
                HeKEY_hek(ent)
-                    = shared ? share_hek_flags(key, len, hash, flags)
+                    = shared ? HeKEY_hek(share_hek_flags(key, len, hash, flags))
                              :  save_hek_flags(key, len, hash, flags);
                if (prev)
                    HeNEXT(prev) = ent;
@@ -2206,10 +2218,10 @@ Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
           flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
     }
 
-    return share_hek_flags (str, len, hash, flags);
+    return HeKEY_hek(share_hek_flags (str, len, hash, flags));
 }
 
-STATIC HEK *
+STATIC HE *
 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
 {
     register XPVHV* xhv;
@@ -2263,7 +2275,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
     if (flags & HVhek_FREEKEY)
        Safefree(str);
 
-    return HeKEY_hek(entry);
+    return entry;
 }
 
 I32 *

diff --git a/intrpvar.h b/intrpvar.h
index 3fd201d..ae4850c 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -425,6 +425,7 @@ PERLVAR(IProc,              struct IPerlProc*)
 
 #if defined(USE_ITHREADS)
 PERLVAR(Iptr_table,    PTR_TBL_t*)
+PERLVAR(Ishared_hek_table, PTR_TBL_t*)
 #endif
 PERLVARI(Ibeginav_save, AV*, Nullav)   /* save BEGIN{}s when compiling */
 

diff --git a/perl.c b/perl.c
index babaaed..a7ed27e 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -834,9 +834,11 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_strtab);
 
 #ifdef USE_ITHREADS
-    /* free the pointer table used for cloning */
+    /* free the pointer tables used for cloning */
     ptr_table_free(PL_ptr_table);
     PL_ptr_table = (PTR_TBL_t*)NULL;
+    ptr_table_free(PL_shared_hek_table);
+    PL_shared_hek_table = (PTR_TBL_t*)NULL;
 #endif
 
     /* free special SVs */

diff --git a/perlapi.h b/perlapi.h
index 1702029..39d516e 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -533,6 +533,8 @@ END_EXTERN_C
 #define PL_sawampersand                (*Perl_Isawampersand_ptr(aTHX))
 #undef  PL_sh_path_compat
 #define PL_sh_path_compat      (*Perl_Ish_path_compat_ptr(aTHX))
+#undef  PL_shared_hek_table
+#define PL_shared_hek_table    (*Perl_Ishared_hek_table_ptr(aTHX))
 #undef  PL_sharehook
 #define PL_sharehook           (*Perl_Isharehook_ptr(aTHX))
 #undef  PL_sig_pending

diff --git a/proto.h b/proto.h
index 3408671..d816332 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1816,7 +1816,7 @@ STATIC void       S_del_he(pTHX_ HE *p);
 STATIC HEK*    S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags);
 STATIC void    S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store);
 STATIC void    S_unshare_hek_or_pvn(pTHX_ HEK* hek, const char* sv, I32 len, U32 hash);
-STATIC HEK*    S_share_hek_flags(pTHX_ const char* sv, I32 len, U32 hash, int flags);
+STATIC HE*     S_share_hek_flags(pTHX_ const char* sv, I32 len, U32 hash, int flags);
 STATIC void    S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, const char *msg)
                        __attribute__noreturn__;
 

diff --git a/sv.c b/sv.c
index 3e87962..b0571d8 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -11668,6 +11668,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* create SV map for pointer relocation */
     PL_ptr_table = ptr_table_new();
+    /* and one for finding shared hash keys quickly */
+    PL_shared_hek_table = ptr_table_new();
 
     /* initialize these special pointers as early as possible */
     SvANY(&PL_sv_undef)                = NULL;
@@ -12296,6 +12298,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
         ptr_table_free(PL_ptr_table);
         PL_ptr_table = NULL;
+        ptr_table_free(PL_shared_hek_table);
+        PL_shared_hek_table = NULL;
     }
 
     /* Call the ->CLONE method, if it exists, for each of the stashes