# endif
#endif
+#ifdef DEBUGGING
+# define A_ASSERT(C) assert(C)
+#else
+# define A_ASSERT(C)
+#endif
+
+/* ... Our vivify_ref() .................................................... */
+
+/* Perl_vivify_ref() is not exported, so we have to reimplement it. */
+
+#if A_HAS_MULTIDEREF
+
+static SV *a_vivify_ref(pTHX_ SV *sv, int to_hash) {
+#define a_vivify_ref(S, TH) a_vivify_ref(aTHX_ (S), (TH))
+ SvGETMAGIC(sv);
+
+ if (!SvOK(sv)) {
+ SV *val;
+
+ if (SvREADONLY(sv))
+ Perl_croak_no_modify();
+
+ /* Inlined prepare_SV_for_RV() */
+ if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV) {
+ sv_upgrade(sv, SVt_IV);
+ } else if (SvTYPE(sv) >= SVt_PV) {
+ SvPV_free(sv);
+ SvLEN_set(sv, 0);
+ SvCUR_set(sv, 0);
+ }
+
+ val = to_hash ? MUTABLE_SV(newHV()) : MUTABLE_SV(newAV());
+ SvRV_set(sv, val);
+ SvROK_on(sv);
+ SvSETMAGIC(sv);
+ SvGETMAGIC(sv);
+ }
+
+ if (SvGMAGICAL(sv)) {
+ SV *msv = sv_newmortal();
+ sv_setsv_nomg(msv, sv);
+ return msv;
+ }
+
+ return sv;
+}
+
+#endif /* A_HAS_MULTIDEREF */
+
/* ... Thread safety and multiplicity ...................................... */
/* Always safe when the workaround isn't needed */
# define A_CHECK_LOCK OP_REFCNT_LOCK
# define A_CHECK_UNLOCK OP_REFCNT_UNLOCK
#else
-/* Before perl 5.9.3, indirect_ck_*() calls are already protected by the
- * A_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't
- * lock it twice. */
+/* Before perl 5.9.3, a_ck_*() calls are already protected by the A_LOADED
+ * mutex, which falls back to the OP_REFCNT mutex. Make sure we don't lock it
+ * twice. */
# define A_CHECK_LOCK NOOP
# define A_CHECK_UNLOCK NOOP
#endif
#if A_THREADSAFE
#define PTABLE_NAME ptable_loaded
-#define PTABLE_VAL_FREE(V) NOOP
+#define PTABLE_NEED_DELETE 1
+#define PTABLE_NEED_WALK 0
#include "ptable.h"
int global_setup = 0;
if (a_loaded <= 0) {
- assert(a_loaded == 0);
- assert(!a_loaded_cxts);
+ A_ASSERT(a_loaded == 0);
+ A_ASSERT(!a_loaded_cxts);
a_loaded_cxts = ptable_new();
global_setup = 1;
}
++a_loaded;
- assert(a_loaded_cxts);
+ A_ASSERT(a_loaded_cxts);
ptable_loaded_store(a_loaded_cxts, cxt, cxt);
return global_setup;
int global_teardown = 0;
if (a_loaded > 1) {
- assert(a_loaded_cxts);
+ A_ASSERT(a_loaded_cxts);
ptable_loaded_delete(a_loaded_cxts, cxt);
--a_loaded;
} else if (a_loaded_cxts) {
- assert(a_loaded == 1);
+ A_ASSERT(a_loaded == 1);
ptable_loaded_free(a_loaded_cxts);
a_loaded_cxts = NULL;
a_loaded = 0;
#define PTABLE_NAME ptable_hints
#define PTABLE_VAL_FREE(V) A_HINT_FREE(V)
+#define PTABLE_NEED_DELETE 0
+#define PTABLE_NEED_WALK 1
#define pPTBL pTHX
#define pPTBL_ pTHX_
#endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
#define PTABLE_NAME ptable_seen
-#define PTABLE_VAL_FREE(V) NOOP
+#define PTABLE_NEED_DELETE 0
+#define PTABLE_NEED_WALK 0
#include "ptable.h"
#define PTABLE_NAME ptable_map
#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
+#define PTABLE_NEED_DELETE 1
+#define PTABLE_NEED_WALK 0
#include "ptable.h"
/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
#define ptable_map_delete(T, K) ptable_map_delete(aPTBLMS_ (T), (K))
+#define ptable_map_free(T) ptable_map_free(aPTBLMS_ (T))
static ptable *a_op_map = NULL;
static UV a_do_multideref(const OP *o, UV flags) {
UV isexdel, other_flags;
- assert(o->op_type == OP_MULTIDEREF);
+ A_ASSERT(o->op_type == OP_MULTIDEREF);
other_flags = flags & ~A_HINT_DO;
{
dA_MAP_THX;
const a_op_info *oi = a_map_fetch(PL_op);
- assert(oi);
+ A_ASSERT(oi);
flags = a_do_multideref(PL_op, oi->flags);
if (!flags)
return oi->old_pp(aTHX);
goto do_AV_aelem;
case MDEREF_AV_gvav_aelem: /* $pkg[...] */
sv = UNOP_AUX_item_sv(++items);
- assert(isGV_with_GP(sv));
+ A_ASSERT(isGV_with_GP(sv));
sv = (SV *) GvAVn((GV *) sv);
if (a_undef(sv))
goto ret_undef;
goto do_AV_rv2av_aelem;
case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
sv = UNOP_AUX_item_sv(++items);
- assert(isGV_with_GP(sv));
+ A_ASSERT(isGV_with_GP(sv));
sv = GvSVn((GV *) sv);
if (a_undef(sv))
goto ret_undef;
if (a_undef(sv))
goto ret_undef;
do_AV_vivify_rv2av_aelem:
- sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_AV);
+ sv = a_vivify_ref(sv, 0);
do_AV_rv2av_aelem:
sv = a_do_pp_rv2av(sv);
do_AV_aelem:
{
SV *esv;
- assert(SvTYPE(sv) == SVt_PVAV);
+ A_ASSERT(SvTYPE(sv) == SVt_PVAV);
switch (actions & MDEREF_INDEX_MASK) {
case MDEREF_INDEX_none:
goto finish;
goto check_elem;
case MDEREF_INDEX_gvsv:
esv = UNOP_AUX_item_sv(++items);
- assert(isGV_with_GP(esv));
+ A_ASSERT(isGV_with_GP(esv));
esv = GvSVn((GV *) esv);
check_elem:
if (UNLIKELY(SvROK(esv) && !SvGAMAGIC(esv) && ckWARN(WARN_MISC)))
goto do_HV_helem;
case MDEREF_HV_gvhv_helem: /* $pkg{...} */
sv = UNOP_AUX_item_sv(++items);
- assert(isGV_with_GP(sv));
+ A_ASSERT(isGV_with_GP(sv));
sv = (SV *) GvHVn((GV *) sv);
if (a_undef(sv))
goto ret_undef;
goto do_HV_rv2hv_helem;
case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
sv = UNOP_AUX_item_sv(++items);
- assert(isGV_with_GP(sv));
+ A_ASSERT(isGV_with_GP(sv));
sv = GvSVn((GV *) sv);
if (a_undef(sv))
goto ret_undef;
if (a_undef(sv))
goto ret_undef;
do_HV_vivify_rv2hv_helem:
- sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_HV);
+ sv = a_vivify_ref(sv, 1);
do_HV_rv2hv_helem:
sv = a_do_pp_rv2hv(sv);
do_HV_helem:
{
SV *key;
- assert(SvTYPE(sv) == SVt_PVHV);
+ A_ASSERT(SvTYPE(sv) == SVt_PVHV);
switch (actions & MDEREF_INDEX_MASK) {
case MDEREF_INDEX_none:
goto finish;
break;
case MDEREF_INDEX_gvsv:
key = UNOP_AUX_item_sv(++items);
- assert(isGV_with_GP(key));
+ A_ASSERT(isGV_with_GP(key));
key = GvSVn((GV *) key);
break;
}
break;
case A_HINT_STORE:
sv = a_do_pp_hfetch_lv(sv, key);
- break;
+ break;
case A_HINT_EXISTS:
sv = a_do_pp_hexists(sv, key);
break;
}
o = old_ck(aTHX_ o);
- if (hint & A_HINT_DO) {
#if A_HAS_MULTIDEREF
- if (old_ck == a_old_ck_rv2sv && o->op_flags & OPf_KIDS) {
- OP *kid = cUNOPo->op_first;
- if (kid && kid->op_type == OP_GV)
+ if (old_ck == a_old_ck_rv2sv && o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
+ if (kid && kid->op_type == OP_GV) {
+ if (hint & A_HINT_DO)
a_map_store(kid, kid->op_ppaddr, NULL, hint);
+ else
+ a_map_delete(kid);
}
+ }
#endif
+
+ if (hint & A_HINT_DO) {
a_map_store_root(o, o->op_ppaddr, hint);
o->op_ppaddr = a_pp_deref;
} else
ptable *seen;
dMY_CXT;
- assert(a_is_loaded(&MY_CXT));
+ A_ASSERT(a_is_loaded(&MY_CXT));
MY_CXT.old_peep(aTHX_ o);
ptable_map_free(a_op_map);
a_op_map = NULL;
+
+#ifdef USE_ITHREADS
+ MUTEX_DESTROY(&a_op_map_mutex);
+#endif
}
A_LOADED_UNLOCK;
PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
a_op_map = ptable_new();
+
#ifdef USE_ITHREADS
MUTEX_INIT(&a_op_map_mutex);
#endif
int global_setup;
A_LOADED_LOCK;
global_setup = a_set_loaded_locked(&MY_CXT);
- assert(!global_setup);
+ A_ASSERT(!global_setup);
A_LOADED_UNLOCK;
}
}