Serialise changes to %^H onto the current COP. Return the compile time

state of %^H as an eleventh value from caller. This allows users to
write pragmas.

p4raw-id: //depot/perl@27643

20 files changed, 510 insertions, 11 deletions

diff --git a/cop.h b/cop.h
index 81712fac59..8ce6b3ebae 100644
--- a/cop.h
+++ b/cop.h
@@ -148,6 +148,9 @@ struct cop {
     line_t      cop_line;       /* line # of this command */
     SV *	cop_warnings;	/* lexical warnings bitmask */
     SV *	cop_io;		/* lexical IO defaults */
+    /* compile time state of %^H.  See the comment in op.c for how this is
+       used to recreate a hash to return from caller.  */
+    struct refcounted_he * cop_hints;
 };
 
 #ifdef USE_ITHREADS
@@ -805,3 +808,13 @@ See L<perlcall/Lightweight Callbacks>.
 	CATCH_SET(multicall_oldcatch);					\
 	LEAVE;								\
     } STMT_END
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
diff --git a/dump.c b/dump.c
index c86d3e5dec..c8406a1deb 100644
--- a/dump.c
+++ b/dump.c
@@ -959,6 +959,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
 	{ PERL_MAGIC_bm,             "bm(B)" },
 	{ PERL_MAGIC_regdata,        "regdata(D)" },
 	{ PERL_MAGIC_env,            "env(E)" },
+	{ PERL_MAGIC_hints,          "hints(H)" },
 	{ PERL_MAGIC_isa,            "isa(I)" },
 	{ PERL_MAGIC_dbfile,         "dbfile(L)" },
 	{ PERL_MAGIC_shared,         "shared(N)" },
@@ -971,6 +972,7 @@ static const struct { const char type; const char *name; } magic_names[] = {
 	{ PERL_MAGIC_envelem,        "envelem(e)" },
 	{ PERL_MAGIC_fm,             "fm(f)" },
 	{ PERL_MAGIC_regex_global,   "regex_global(g)" },
+	{ PERL_MAGIC_hintselem,      "hintselem(h)" },
 	{ PERL_MAGIC_isaelem,        "isaelem(i)" },
 	{ PERL_MAGIC_nkeys,          "nkeys(k)" },
 	{ PERL_MAGIC_dbline,         "dbline(l)" },
@@ -1030,6 +1032,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
 	    else if (v == &PL_vtbl_backref)    s = "backref";
 	    else if (v == &PL_vtbl_utf8)       s = "utf8";
             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
+            else if (v == &PL_vtbl_hintselem)  s = "hintselem";
 	    if (s)
 	        Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
 	    else
diff --git a/embed.fnc b/embed.fnc
index 0fdbf20ba4..dfd3d5abab 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -302,6 +302,16 @@ ApMdR	|HE*	|hv_iternext_flags|NN HV* tb|I32 flags
 ApdR	|SV*	|hv_iterval	|NN HV* tb|NN HE* entry
 Ap	|void	|hv_ksplit	|NN HV* hv|IV newmax
 Apdbm	|void	|hv_magic	|NN HV* hv|NULLOK GV* gv|int how
+#ifdef USE_ITHREADS
+dpoM|struct refcounted_he *|refcounted_he_dup \
+				|NULLOK const struct refcounted_he *const he \
+				|NN CLONE_PARAMS* param
+#endif
+dpoM	|HV *	|refcounted_he_chain_2hv|NULLOK const struct refcounted_he *c
+dpoM	|void	|refcounted_he_free|NULLOK struct refcounted_he *he
+dpoM	|struct refcounted_he *|refcounted_he_new \
+				|NULLOK struct refcounted_he *parent \
+				|NULLOK SV *key|NULLOK SV *value
 Apd	|SV**	|hv_store	|NULLOK HV* tb|NULLOK const char* key|I32 klen|NULLOK SV* val \
 				|U32 hash
 Apd	|HE*	|hv_store_ent	|NULLOK HV* tb|NULLOK SV* key|NULLOK SV* val|U32 hash
@@ -401,6 +411,7 @@ ApdR	|bool	|grok_numeric_radix|NN const char **sp|NN const char *send
 Apd	|UV	|grok_oct	|NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
 p	|int	|magic_clearenv	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clear_all_env|NN SV* sv|NN MAGIC* mg
+dp	|int	|magic_clearhint|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clearpack|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clearsig	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_existspack|NN SV* sv|NN MAGIC* mg
@@ -431,6 +442,7 @@ p	|int	|magic_setdbline|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setdefelem|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setenv	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setfm	|NN SV* sv|NN MAGIC* mg
+dp	|int	|magic_sethint	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setisa	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setglob	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setmglob	|NN SV* sv|NN MAGIC* mg
@@ -1075,6 +1087,7 @@ sM	|SV*	|hv_delete_common|NULLOK HV* tb|NULLOK SV* keysv|NULLOK const char* key
 		|STRLEN klen|int k_flags|I32 d_flags|U32 hash
 sM	|HE*	|hv_fetch_common|NULLOK HV* tb|NULLOK SV* keysv|NULLOK const char* key \
 		|STRLEN klen|int flags|int action|NULLOK SV* val|U32 hash
+sM	|void	|clear_placeholders	|NN HV* hb|U32 items
 #endif
 
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index 53d6043d5e..b8c279ffc2 100644
--- a/embed.h
+++ b/embed.h
@@ -287,6 +287,8 @@
 #define hv_iternext_flags	Perl_hv_iternext_flags
 #define hv_iterval		Perl_hv_iterval
 #define hv_ksplit		Perl_hv_ksplit
+#ifdef USE_ITHREADS
+#endif
 #define hv_store		Perl_hv_store
 #define hv_store_ent		Perl_hv_store_ent
 #define hv_store_flags		Perl_hv_store_flags
@@ -399,6 +401,7 @@
 #ifdef PERL_CORE
 #define magic_clearenv		Perl_magic_clearenv
 #define magic_clear_all_env	Perl_magic_clear_all_env
+#define magic_clearhint		Perl_magic_clearhint
 #define magic_clearpack		Perl_magic_clearpack
 #define magic_clearsig		Perl_magic_clearsig
 #define magic_existspack	Perl_magic_existspack
@@ -429,6 +432,7 @@
 #define magic_setdefelem	Perl_magic_setdefelem
 #define magic_setenv		Perl_magic_setenv
 #define magic_setfm		Perl_magic_setfm
+#define magic_sethint		Perl_magic_sethint
 #define magic_setisa		Perl_magic_setisa
 #define magic_setglob		Perl_magic_setglob
 #define magic_setmglob		Perl_magic_setmglob
@@ -1091,6 +1095,7 @@
 #define hv_auxinit		S_hv_auxinit
 #define hv_delete_common	S_hv_delete_common
 #define hv_fetch_common		S_hv_fetch_common
+#define clear_placeholders	S_clear_placeholders
 #endif
 #endif
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
@@ -2448,6 +2453,12 @@
 #define hv_iternext_flags(a,b)	Perl_hv_iternext_flags(aTHX_ a,b)
 #define hv_iterval(a,b)		Perl_hv_iterval(aTHX_ a,b)
 #define hv_ksplit(a,b)		Perl_hv_ksplit(aTHX_ a,b)
+#ifdef USE_ITHREADS
+#ifdef PERL_CORE
+#endif
+#endif
+#ifdef PERL_CORE
+#endif
 #define hv_store(a,b,c,d,e)	Perl_hv_store(aTHX_ a,b,c,d,e)
 #define hv_store_ent(a,b,c,d)	Perl_hv_store_ent(aTHX_ a,b,c,d)
 #define hv_store_flags(a,b,c,d,e,f)	Perl_hv_store_flags(aTHX_ a,b,c,d,e,f)
@@ -2559,6 +2570,7 @@
 #ifdef PERL_CORE
 #define magic_clearenv(a,b)	Perl_magic_clearenv(aTHX_ a,b)
 #define magic_clear_all_env(a,b)	Perl_magic_clear_all_env(aTHX_ a,b)
+#define magic_clearhint(a,b)	Perl_magic_clearhint(aTHX_ a,b)
 #define magic_clearpack(a,b)	Perl_magic_clearpack(aTHX_ a,b)
 #define magic_clearsig(a,b)	Perl_magic_clearsig(aTHX_ a,b)
 #define magic_existspack(a,b)	Perl_magic_existspack(aTHX_ a,b)
@@ -2589,6 +2601,7 @@
 #define magic_setdefelem(a,b)	Perl_magic_setdefelem(aTHX_ a,b)
 #define magic_setenv(a,b)	Perl_magic_setenv(aTHX_ a,b)
 #define magic_setfm(a,b)	Perl_magic_setfm(aTHX_ a,b)
+#define magic_sethint(a,b)	Perl_magic_sethint(aTHX_ a,b)
 #define magic_setisa(a,b)	Perl_magic_setisa(aTHX_ a,b)
 #define magic_setglob(a,b)	Perl_magic_setglob(aTHX_ a,b)
 #define magic_setmglob(a,b)	Perl_magic_setmglob(aTHX_ a,b)
@@ -3241,6 +3254,7 @@
 #define hv_auxinit		S_hv_auxinit
 #define hv_delete_common(a,b,c,d,e,f,g)	S_hv_delete_common(aTHX_ a,b,c,d,e,f,g)
 #define hv_fetch_common(a,b,c,d,e,f,g,h)	S_hv_fetch_common(aTHX_ a,b,c,d,e,f,g,h)
+#define clear_placeholders(a,b)	S_clear_placeholders(aTHX_ a,b)
 #endif
 #endif
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
diff --git a/gv.c b/gv.c
index 090d667fbe..83f3ed885b 100644
--- a/gv.c
+++ b/gv.c
@@ -1156,6 +1156,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	    sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 	    goto magicalize;
 
+	case '\010':	/* $^H */
+	    {
+		HV *const hv = GvHVn(gv);
+		hv_magic(hv, NULL, PERL_MAGIC_hints);
+	    }
+	    goto magicalize;
+
 	case '+':
 	{
 	    AV* const av = GvAVn(gv);
@@ -1194,7 +1201,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	case '\004':	/* $^D */
 	case '\005':	/* $^E */
 	case '\006':	/* $^F */
-	case '\010':	/* $^H */
 	case '\011':	/* $^I, NOT \t in EBCDIC */
 	case '\016':	/* $^N */
 	case '\017':	/* $^O */
diff --git a/hv.c b/hv.c
index fab0e6a299..8227eca203 100644
--- a/hv.c
+++ b/hv.c
@@ -1606,7 +1606,16 @@ void
 Perl_hv_clear_placeholders(pTHX_ HV *hv)
 {
     dVAR;
-    I32 items = (I32)HvPLACEHOLDERS_get(hv);
+    const U32 items = (U32)HvPLACEHOLDERS_get(hv);
+
+    if (items)
+	clear_placeholders(hv, items);
+}
+
+static void
+S_clear_placeholders(pTHX_ HV *hv, U32 items)
+{
+    dVAR;
     I32 i;
 
     if (items == 0)
@@ -2515,6 +2524,180 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
 }
 
 /*
+=for apidoc refcounted_he_chain_2hv
+
+Generates an returns a C<HV *> by walking up the tree starting at the passed
+in C<struct refcounted_he *>.
+
+=cut
+*/
+HV *
+Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain)
+{
+    HV *hv = newHV();
+    U32 placeholders = 0;
+    /* We could chase the chain once to get an idea of the number of keys,
+       and call ksplit.  But for now we'll make a potentially inefficient
+       hash with only 8 entries in its array.  */
+    const U32 max = HvMAX(hv);
+
+    if (!HvARRAY(hv)) {
+	char *array;
+	Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
+	HvARRAY(hv) = (HE**)array;
+    }
+
+    while (chain) {
+	const U32 hash = HEK_HASH(chain->refcounted_he_he.hent_hek);
+	HE **oentry = &((HvARRAY(hv))[hash & max]);
+	HE *entry = *oentry;
+
+	for (; entry; entry = HeNEXT(entry)) {
+	    if (HeHASH(entry) == hash) {
+		goto next_please;
+	    }
+	}
+	assert (!entry);
+	entry = new_HE();
+
+	HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_he.hent_hek);
+
+	HeVAL(entry) = chain->refcounted_he_he.he_valu.hent_val;
+	if (HeVAL(entry) == &PL_sv_placeholder)
+	    placeholders++;
+	SvREFCNT_inc_void_NN(HeVAL(entry));
+
+	/* Link it into the chain.  */
+	HeNEXT(entry) = *oentry;
+	if (!HeNEXT(entry)) {
+	    /* initial entry.   */
+	    HvFILL(hv)++;
+	}
+	*oentry = entry;
+
+	HvTOTALKEYS(hv)++;
+
+    next_please:
+	chain = (struct refcounted_he *) chain->refcounted_he_he.hent_next;
+    }
+
+    if (placeholders) {
+	clear_placeholders(hv, placeholders);
+	HvTOTALKEYS(hv) -= placeholders;
+    }
+
+    /* We could check in the loop to see if we encounter any keys with key
+       flags, but it's probably not worth it, as this per-hash flag is only
+       really meant as an optimisation for things like Storable.  */
+    HvHASKFLAGS_on(hv);
+#ifdef DEBUGGING
+    Perl_hv_assert(aTHX_ hv);
+#endif
+
+    return hv;
+}
+
+/*
+=for apidoc refcounted_he_new
+
+Creates a new C<struct refcounted_he>. Assumes ownership of one reference
+to I<value>. As S<key> is copied into a shared hash key, all references remain
+the property of the caller. The C<struct refcounted_he> is returned with a
+reference count of 1.
+
+=cut
+*/
+
+struct refcounted_he *
+Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
+		       SV *const key, SV *const value) {
+    struct refcounted_he *he;
+    U32 hash;
+    STRLEN len;
+    const char *p = SvPV_const(key, len);
+
+    PERL_HASH(hash, p, len);
+
+    Newx(he, 1, struct refcounted_he);
+
+    he->refcounted_he_he.hent_next = (HE *)parent;
+    he->refcounted_he_he.he_valu.hent_val = value;
+    he->refcounted_he_he.hent_hek
+	= share_hek(p, SvUTF8(key) ? -(I32)len : len, hash);
+    he->refcounted_he_refcnt = 1;
+
+    return he;
+}
+
+/*
+=for apidoc refcounted_he_free
+
+Decrements the reference count of the passed in C<struct refcounted_he *>
+by one. If the reference count reaches zero the structure's memory is freed,
+and C<refcounted_he_free> iterates onto the parent node.
+
+=cut
+*/
+
+void
+Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+    while (he) {
+	struct refcounted_he *copy;
+
+	if (--he->refcounted_he_refcnt)
+	    return;
+
+	unshare_hek_or_pvn (he->refcounted_he_he.hent_hek, 0, 0, 0);
+	SvREFCNT_dec(he->refcounted_he_he.he_valu.hent_val);
+	copy = he;
+	he = (struct refcounted_he *) he->refcounted_he_he.hent_next;
+	Safefree(copy);
+    }
+}
+
+
+/*
+=for apidoc refcounted_he_dup
+
+Duplicates the C<struct refcounted_he *> for a new thread.
+
+=cut
+*/
+
+#if defined(USE_ITHREADS)
+struct refcounted_he *
+Perl_refcounted_he_dup(pTHX_ const struct refcounted_he *const he,
+			CLONE_PARAMS* param)
+{
+    struct refcounted_he *copy;
+
+    if (!he)
+	return NULL;
+
+    /* look for it in the table first */
+    copy = (struct refcounted_he *)ptr_table_fetch(PL_ptr_table, he);
+    if (copy)
+	return copy;
+
+    /* create anew and remember what it is */
+    Newx(copy, 1, struct refcounted_he);
+    ptr_table_store(PL_ptr_table, he, copy);
+
+    copy->refcounted_he_he.hent_next
+	= (HE *)Perl_refcounted_he_dup(aTHX_
+				       (struct refcounted_he *)
+				       he->refcounted_he_he.hent_next,
+				       param);
+    copy->refcounted_he_he.he_valu.hent_val
+	= SvREFCNT_inc(sv_dup(he->refcounted_he_he.he_valu.hent_val, param));
+    copy->refcounted_he_he.hent_hek
+	= hek_dup(he->refcounted_he_he.hent_hek, param);
+    copy->refcounted_he_refcnt = he->refcounted_he_refcnt;
+    return copy;
+}
+#endif
+
+/*
 =for apidoc hv_assert
 
 Check that a hash is in an internally consistent state.
diff --git a/hv.h b/hv.h
index efba2b98bd..dfb0d25162 100644
--- a/hv.h
+++ b/hv.h
@@ -36,6 +36,11 @@ struct shared_he {
     struct hek shared_he_hek;
 };
 
+struct refcounted_he {
+    struct he refcounted_he_he;
+    U32 refcounted_he_refcnt;
+};
+
 /* Subject to change.
    Don't access this directly.
 */
diff --git a/makedef.pl b/makedef.pl
index 3745e19143..f2036011ea 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -747,6 +747,7 @@ unless ($define{'USE_ITHREADS'}) {
 		    Perl_sharedsv_thrcnt_inc
 		    Perl_sharedsv_unlock
 		    Perl_stashpv_hvname_match
+		    Perl_refcounted_he_dup
 		    )];
 }
 
diff --git a/mg.c b/mg.c
index 210d681dd7..b7e2e56c08 100644
--- a/mg.c
+++ b/mg.c
@@ -2838,6 +2838,46 @@ S_unwind_handler_stack(pTHX_ const void *p)
 }
 
 /*
+=for apidoc magic_sethint
+
+Triggered by a store to %^H, records the key/value pair to
+C<PL_compiling.cop_hints>.  It is assumed that hints aren't storing anything
+that would need a deep copy.  Maybe we should warn if we find a reference.
+
+=cut
+*/
+int
+Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+    assert(mg->mg_len == HEf_SVKEY);
+
+    PL_compiling.cop_hints
+	= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
+				 (SV *)mg->mg_ptr, newSVsv(sv));
+    return 0;
+}
+
+/*
+=for apidoc magic_sethint
+
+Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
+
+=cut
+*/
+int
+Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+    assert(mg->mg_len == HEf_SVKEY);
+
+    PL_compiling.cop_hints
+	= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
+				 (SV *)mg->mg_ptr, &PL_sv_placeholder);
+    return 0;
+}
+
+/*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
diff --git a/op.c b/op.c
index 5187f3b1a3..bc49fb52c3 100644
--- a/op.c
+++ b/op.c
@@ -73,6 +73,28 @@ into peep() to do that code's portion of the 3rd pass.  It has to be
 recursive, but it's recursive on basic blocks, not on tree nodes.
 */
 
+/* To implement user lexical pragams, there needs to be a way at run time to
+   get the compile time state of %^H for that block.  Storing %^H in every
+   block (or even COP) would be very expensive, so a different approach is
+   taken.  The (running) state of %^H is serialised into a tree of HE-like
+   structs.  Stores into %^H are chained onto the current leaf as a struct
+   refcounted_he * with the key and the value.  Deletes from %^H are saved
+   with a value of PL_sv_placeholder.  The state of %^H at any point can be
+   turned back into a regular HV by walking back up the tree from that point's
+   leaf, ignoring any key you've already seen (placeholder or now), storing
+   the rest into the HV structure, then removing the placeholders. Hence
+   memory is only used to store the %^H deltas from the enclosing COP, rather
+   than the entire %^H on each COP.
+
+   To cause actions on %^H to write out the serialisation records, it has
+   magic type 'H'. This magic (itself) does nothing, but its presence causes
+   the values to gain magic type 'h', which has entries for set and clear.
+   C<Perl_magic_sethint> updates C<PL_compiling.cop_hints> with a store
+   record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+   saves the current C<PL_compiling.cop_hints> on the save stack, so that it
+   will be correctly restored when any inner compiling scope is exited.
+*/
+
 #include "EXTERN.h"
 #define PERL_IN_OP_C
 #include "perl.h"
@@ -492,6 +514,7 @@ S_cop_free(pTHX_ COP* cop)
 	SvREFCNT_dec(cop->cop_io);
 #endif
     }
+    Perl_refcounted_he_free(aTHX_ cop->cop_hints);
 }
 
 void
@@ -3928,7 +3951,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
         cop->cop_io = PL_curcop->cop_io;
     else
         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
-
+    cop->cop_hints = PL_curcop->cop_hints;
+    if (cop->cop_hints) {
+	cop->cop_hints->refcounted_he_refcnt++;
+    }
 
     if (PL_copline == NOLINE)
         CopLINE_set(cop, CopLINE(PL_curcop));
diff --git a/perl.c b/perl.c
index 2b4d1b22e9..15fc64b0ac 100644
--- a/perl.c
+++ b/perl.c
@@ -1039,6 +1039,8 @@ perl_destruct(pTHXx)
     if (!specialCopIO(PL_compiling.cop_io))
 	SvREFCNT_dec(PL_compiling.cop_io);
     PL_compiling.cop_io = NULL;
+    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
+    PL_compiling.cop_hints = NULL;
     CopFILE_free(&PL_compiling);
     CopSTASH_free(&PL_compiling);
 
diff --git a/perl.h b/perl.h
index 27d01ede0d..1e83f50328 100644
--- a/perl.h
+++ b/perl.h
@@ -3105,9 +3105,9 @@ struct nexttoken {
 #include "cv.h"
 #include "opnames.h"
 #include "op.h"
+#include "hv.h"
 #include "cop.h"
 #include "av.h"
-#include "hv.h"
 #include "mg.h"
 #include "scope.h"
 #include "warnings.h"
@@ -3509,6 +3509,8 @@ Gid_t getegid (void);
 #define PERL_MAGIC_envelem	  'e' /* %ENV hash element */
 #define PERL_MAGIC_fm		  'f' /* Formline ('compiled' format) */
 #define PERL_MAGIC_regex_global	  'g' /* m//g target / study()ed string */
+#define PERL_MAGIC_hints	  'H' /* %^H hash */
+#define PERL_MAGIC_hintselem	  'h' /* %^H hash element */
 #define PERL_MAGIC_isa		  'I' /* @ISA array */
 #define PERL_MAGIC_isaelem	  'i' /* @ISA array element */
 #define PERL_MAGIC_nkeys	  'k' /* scalar(keys()) lvalue */
@@ -4161,7 +4163,8 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_backref,
     want_vtbl_utf8,
     want_vtbl_symtab,
-    want_vtbl_arylen_p
+    want_vtbl_arylen_p,
+    want_vtbl_hintselem
 };
 
 				/* Note: the lowest 8 bits are reserved for
@@ -4441,6 +4444,7 @@ MGVTBL_SET(
     NULL
 );
 
+/* For now, hints magic will also use vtbl_sig, because it is all NULL  */
 MGVTBL_SET(
     PL_vtbl_sig,
     NULL,
@@ -4793,6 +4797,18 @@ MGVTBL_SET(
 );
 #endif
 
+MGVTBL_SET(
+    PL_vtbl_hintselem,
+    NULL,
+    MEMBER_TO_FPTR(Perl_magic_sethint),
+    NULL,
+    MEMBER_TO_FPTR(Perl_magic_clearhint),
+    NULL,
+    NULL,
+    NULL,
+    NULL
+);
+
 
 enum {
   fallback_amg,        abs_amg,
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index e9e22fa6b9..d638cc14f2 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -623,7 +623,8 @@ print a stack trace.  The value of EXPR indicates how many call frames
 to go back before the current one.
 
     ($package, $filename, $line, $subroutine, $hasargs,
-    $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($i);
+    $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash)
+	 = caller($i);
 
 Here $subroutine may be C<(eval)> if the frame is not a subroutine
 call, but an C<eval>.  In such a case additional elements $evaltext and
@@ -639,6 +640,10 @@ C<$hints> and C<$bitmask> contain pragmatic hints that the caller was
 compiled with.  The C<$hints> and C<$bitmask> values are subject to change
 between versions of Perl, and are not meant for external use.
 
+C<$hinthash> is a reference to a hash containing the value of C<%^H> when the
+caller was compiled, or C<undef> if C<%^H> was empty. Do not modify the values
+of this hash, as they are the actual values stored in the optree.
+
 Furthermore, when called from within the DB package, caller returns more
 detailed information: it sets the list variable C<@DB::args> to be the
 arguments with which the subroutine was invoked.
diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index 2cc6868c9a..6c82701995 100644
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -470,6 +470,59 @@ Found in file gv.c
 
 =back
 
+=head1 Hash Manipulation Functions
+
+=over 8
+
+=item refcounted_he_chain_2hv
+X<refcounted_he_chain_2hv>
+
+Generates an returns a C<HV *> by walking up the tree starting at the passed
+in C<struct refcounted_he *>.
+
+	HV *	refcounted_he_chain_2hv(const struct refcounted_he *c)
+
+=for hackers
+Found in file hv.c
+
+=item refcounted_he_dup
+X<refcounted_he_dup>
+
+Duplicates the C<struct refcounted_he *> for a new thread.
+
+	struct refcounted_he *	refcounted_he_dup(const struct refcounted_he *const he, CLONE_PARAMS* param)
+
+=for hackers
+Found in file hv.c
+
+=item refcounted_he_free
+X<refcounted_he_free>
+
+Decrements the reference count of the passed in C<struct refcounted_he *>
+by one. If the reference count reaches zero the structure's memory is freed,
+and C<refcounted_he_free> iterates onto the parent node.
+
+	void	refcounted_he_free(struct refcounted_he *he)
+
+=for hackers
+Found in file hv.c
+
+=item refcounted_he_new
+X<refcounted_he_new>
+
+Creates a new C<struct refcounted_he>. Assumes ownership of one reference
+to I<value>. As S<key> is copied into a shared hash key, all references remain
+the property of the caller. The C<struct refcounted_he> is returned with a
+reference count of 1.
+
+	struct refcounted_he *	refcounted_he_new(struct refcounted_he *parent, SV *key, SV *value)
+
+=for hackers
+Found in file hv.c
+
+
+=back
+
 =head1 IO Functions
 
 =over 8
@@ -494,6 +547,16 @@ Found in file doio.c
 
 =over 8
 
+=item magic_sethint
+X<magic_sethint>
+
+Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
+
+	int	magic_sethint(SV* sv, MAGIC* mg)
+
+=for hackers
+Found in file mg.c
+
 =item mg_localize
 X<mg_localize>
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 3844331e03..72caef3d67 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1620,7 +1620,7 @@ PP(pp_caller)
 	RETURN;
     }
 
-    EXTEND(SP, 10);
+    EXTEND(SP, 11);
 
     if (!stashname)
 	PUSHs(&PL_sv_undef);
@@ -1721,6 +1721,12 @@ PP(pp_caller)
             mask = newSVsv(old_warnings);
         PUSHs(sv_2mortal(mask));
     }
+
+    PUSHs(cx->blk_oldcop->cop_hints ?
+	  sv_2mortal(newRV_noinc(
+		(SV*)Perl_refcounted_he_chain_2hv(aTHX_
+						  cx->blk_oldcop->cop_hints)))
+	  : &PL_sv_undef);
     RETURN;
 }
 
diff --git a/proto.h b/proto.h
index 3f3d526715..5bbd521a2e 100644
--- a/proto.h
+++ b/proto.h
@@ -720,6 +720,14 @@ PERL_CALLCONV void	Perl_hv_ksplit(pTHX_ HV* hv, IV newmax)
 /* PERL_CALLCONV void	Perl_hv_magic(pTHX_ HV* hv, GV* gv, int how)
 			__attribute__nonnull__(pTHX_1); */
 
+#ifdef USE_ITHREADS
+PERL_CALLCONV struct refcounted_he *	Perl_refcounted_he_dup(pTHX_ const struct refcounted_he *const he, CLONE_PARAMS* param)
+			__attribute__nonnull__(pTHX_2);
+
+#endif
+PERL_CALLCONV HV *	Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *c);
+PERL_CALLCONV void	Perl_refcounted_he_free(pTHX_ struct refcounted_he *he);
+PERL_CALLCONV struct refcounted_he *	Perl_refcounted_he_new(pTHX_ struct refcounted_he *parent, SV *key, SV *value);
 PERL_CALLCONV SV**	Perl_hv_store(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash);
 PERL_CALLCONV HE*	Perl_hv_store_ent(pTHX_ HV* tb, SV* key, SV* val, U32 hash);
 PERL_CALLCONV SV**	Perl_hv_store_flags(pTHX_ HV* tb, const char* key, I32 klen, SV* val, U32 hash, int flags);
@@ -1054,6 +1062,10 @@ PERL_CALLCONV int	Perl_magic_clear_all_env(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
 
+PERL_CALLCONV int	Perl_magic_clearhint(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+
 PERL_CALLCONV int	Perl_magic_clearpack(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
@@ -1176,6 +1188,10 @@ PERL_CALLCONV int	Perl_magic_setfm(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
 
+PERL_CALLCONV int	Perl_magic_sethint(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+
 PERL_CALLCONV int	Perl_magic_setisa(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
@@ -2921,6 +2937,9 @@ STATIC struct xpvhv_aux*	S_hv_auxinit(HV *hv)
 
 STATIC SV*	S_hv_delete_common(pTHX_ HV* tb, SV* keysv, const char* key, STRLEN klen, int k_flags, I32 d_flags, U32 hash);
 STATIC HE*	S_hv_fetch_common(pTHX_ HV* tb, SV* keysv, const char* key, STRLEN klen, int flags, int action, SV* val, U32 hash);
+STATIC void	S_clear_placeholders(pTHX_ HV* hb, U32 items)
+			__attribute__nonnull__(pTHX_1);
+
 #endif
 
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
diff --git a/scope.c b/scope.c
index 7b7682388a..5e4193ac17 100644
--- a/scope.c
+++ b/scope.c
@@ -890,6 +890,8 @@ Perl_leave_scope(pTHX_ I32 base)
 		GvHV(PL_hintgv) = NULL;
 	    }
 	    *(I32*)&PL_hints = (I32)SSPOPINT;
+	    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
+	    PL_compiling.cop_hints = (struct refcounted_he *) SSPOPPTR;
 	    if (PL_hints & HINT_LOCALIZE_HH) {
 		SvREFCNT_dec((SV*)GvHV(PL_hintgv));
 		GvHV(PL_hintgv) = (HV*)SSPOPPTR;
diff --git a/scope.h b/scope.h
index cace24689d..debae280db 100644
--- a/scope.h
+++ b/scope.h
@@ -150,11 +150,15 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 
 #define SAVEHINTS() \
     STMT_START {					\
-	SSCHECK(3);					\
+	SSCHECK(4);					\
 	if (PL_hints & HINT_LOCALIZE_HH) {		\
 	    SSPUSHPTR(GvHV(PL_hintgv));			\
 	    GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));	\
 	}						\
+	if (PL_compiling.cop_hints) {			\
+	    PL_compiling.cop_hints->refcounted_he_refcnt++;	\
+	}						\
+	SSPUSHPTR(PL_compiling.cop_hints);		\
 	SSPUSHINT(PL_hints);				\
 	SSPUSHINT(SAVEt_HINTS);				\
     } STMT_END
diff --git a/sv.c b/sv.c
index ded27c951d..d5cc44d190 100644
--- a/sv.c
+++ b/sv.c
@@ -4489,6 +4489,8 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_qr:
 	vtable = &PL_vtbl_regexp;
 	break;
+    case PERL_MAGIC_hints:
+	/* As this vtable is all NULL, we can reuse it.  */
     case PERL_MAGIC_sig:
 	vtable = &PL_vtbl_sig;
 	break;
@@ -4528,6 +4530,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_backref:
 	vtable = &PL_vtbl_backref;
 	break;
+    case PERL_MAGIC_hintselem:
+	vtable = &PL_vtbl_hintselem;
+	break;
     case PERL_MAGIC_ext:
 	/* Reserved for use by extensions not perl internals.	        */
 	/* Useful for attaching extension internal data to perl vars.	*/
@@ -10573,6 +10578,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 	case SAVEt_HINTS:
 	    i = POPINT(ss,ix);
 	    TOPINT(nss,ix) = i;
+	    ptr = POPPTR(ss,ix);
+	    TOPPTR(nss,ix) = Perl_refcounted_he_dup(aTHX_ ptr, param);
+	    /* FIXME - either dup the conditionally saved HV, or eliminate
+	       it by recreating eval's %^H from the cop  */
 	    break;
 	case SAVEt_COMPPAD:
 	    av = (AV*)POPPTR(ss,ix);
@@ -10857,6 +10866,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 	PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
     if (!specialCopIO(PL_compiling.cop_io))
 	PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
+    PL_compiling.cop_hints
+	= Perl_refcounted_he_dup(aTHX_ PL_compiling.cop_hints, proto_perl);
     PL_curcop		= (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
 
     /* pseudo environmental stuff */
diff --git a/t/op/caller.t b/t/op/caller.t
index 578aaaf0d8..1bbd2621fb 100644
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 31 );
+    plan( tests => 48 );
 }
 
 my @c;
@@ -104,7 +104,7 @@ my $debugger_test =  q<
 sub pb { return (caller(0))[3] }
 
 my $i = eval $debugger_test;
-is( $i, 10, "do not skip over eval (and caller returns 10 elements)" );
+is( $i, 11, "do not skip over eval (and caller returns 10 elements)" );
 
 is( eval 'pb()', 'main::pb', "actually return the right function name" );
 
@@ -113,6 +113,73 @@ $^P = 16;
 $^P = $saved_perldb;
 
 $i = eval $debugger_test;
-is( $i, 10, 'do not skip over eval even if $^P had been on at some point' );
+is( $i, 11, 'do not skip over eval even if $^P had been on at some point' );
 is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
 
+# caller can now return the compile time state of %^H
+sub get_dooot {
+    my $level = shift;
+    my @results = caller($level||0);
+    $results[10]->{dooot};
+}
+sub get_hash {
+    my $level = shift;
+    my @results = caller($level||0);
+    $results[10];
+}
+sub dooot {
+    is(get_dooot(), undef);
+    my $hash = get_hash();
+    ok(!exists $hash->{dooot});
+    is(get_dooot(1), 54);
+    BEGIN {
+	$^H{dooot} = 42;
+    }
+    is(get_dooot(), 6 * 7);
+    is(get_dooot(1), 54);
+
+    BEGIN {
+	$^H{dooot} = undef;
+    }
+    is(get_dooot(), undef);
+    $hash = get_hash();
+    ok(exists $hash->{dooot});
+
+    BEGIN {
+	delete $^H{dooot};
+    }
+    is(get_dooot(), undef);
+    $hash = get_hash();
+    ok(!exists $hash->{dooot});
+    is(get_dooot(1), 54);
+}
+{
+    is(get_dooot(), undef);
+    BEGIN {
+	$^H{dooot} = 1;
+    }
+	is(get_dooot(), 1);
+
+    BEGIN {
+	$^H{dooot} = 42;
+    }
+    {
+	{
+	    BEGIN {
+		$^H{dooot} = 6 * 9;
+	    }
+	    is(get_dooot(), 54);
+	    {
+		BEGIN {
+		    delete $^H{dooot};
+		}
+		is(get_dooot(), undef);
+		my $hash = get_hash();
+		ok(!exists $hash->{dooot});
+	    }
+	    dooot();
+	}
+	is(get_dooot(), 6 * 7);
+    }
+    is(get_dooot(), 6 * 7);
+}