Track the mapping between source shared hash keys and target shared

hash keys to save repeated lookups during cloning.

p4raw-id: //depot/perl@24574

9 files changed, 39 insertions, 13 deletions

diff --git a/embed.fnc b/embed.fnc
index 2ae37bb73e..a1ce11747e 100644
--- 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 d0c3a466bb..ea68e16392 100644
--- 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 03cb590b13..f6b57d636c 100755
--- 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 5443771fea..919f3f60bd 100644
--- 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 3fd201d101..ae4850c27e 100644
--- 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 babaaed3b1..a7ed27e51b 100644
--- 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 17020299ff..39d516e12a 100644
--- 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 3408671aea..d81633203d 100644
--- 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 3e87962c43..b0571d81f2 100644
--- 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