#if A_WORKAROUND_REQUIRE_PROPAGATION
-typedef struct {
- UV bits;
- I32 requires;
-} a_hint_t;
+#define A_ENCODE_UV(B, U) \
+ len = 0; \
+ while (len < sizeof(UV)) { \
+ (B)[len++] = (U) & 0xFF; \
+ (U) >>= 8; \
+ }
+
+#define A_DECODE_UV(U, B) \
+ len = sizeof(UV); \
+ while (len > 0) \
+ (U) = ((U) << 8) | (B)[--len];
STATIC SV *a_tag(pTHX_ UV bits) {
#define a_tag(B) a_tag(aTHX_ (B))
- SV *tag;
- a_hint_t h;
-
- h.bits = bits;
+ SV *hint;
+ const PERL_SI *si;
+ UV requires = 0;
+ unsigned char buf[sizeof(UV) * 2];
+ STRLEN len;
- {
- const PERL_SI *si;
- I32 requires = 0;
+ for (si = PL_curstackinfo; si; si = si->si_prev) {
+ I32 cxix;
- for (si = PL_curstackinfo; si; si = si->si_prev) {
- I32 cxix;
+ for (cxix = si->si_cxix; cxix >= 0; --cxix) {
+ const PERL_CONTEXT *cx = si->si_cxstack + cxix;
- for (cxix = si->si_cxix; cxix >= 0; --cxix) {
- const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
- ++requires;
- }
+ if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
+ ++requires;
}
-
- h.requires = requires;
}
- return newSVpvn((const char *) &h, sizeof h);
+ A_ENCODE_UV(buf, requires);
+ A_ENCODE_UV(buf + sizeof(UV), bits);
+ hint = newSVpvn(buf, sizeof buf);
+ SvREADONLY_on(hint);
+
+ return hint;
}
STATIC UV a_detag(pTHX_ const SV *hint) {
#define a_detag(H) a_detag(aTHX_ (H))
- const a_hint_t *h;
+ const PERL_SI *si;
+ UV requires = 0, requires_max = 0, bits = 0;
+ unsigned char *buf;
+ STRLEN len;
if (!(hint && SvOK(hint)))
return 0;
- h = (const a_hint_t *) SvPVX(hint);
+ buf = SvPVX(hint);
+ A_DECODE_UV(requires_max, buf);
- {
- const PERL_SI *si;
- I32 requires = 0;
+ for (si = PL_curstackinfo; si; si = si->si_prev) {
+ I32 cxix;
- for (si = PL_curstackinfo; si; si = si->si_prev) {
- I32 cxix;
+ for (cxix = si->si_cxix; cxix >= 0; --cxix) {
+ const PERL_CONTEXT *cx = si->si_cxstack + cxix;
- for (cxix = si->si_cxix; cxix >= 0; --cxix) {
- const PERL_CONTEXT *cx = si->si_cxstack + cxix;
-
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
- && ++requires > h->requires)
- return 0;
- }
+ if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
+ && ++requires > requires_max)
+ return 0;
}
}
- return h->bits;
+ A_DECODE_UV(bits, buf + sizeof(UV));
+
+ return bits;
}
#else /* A_WORKAROUND_REQUIRE_PROPAGATION */
STATIC UV a_hint(pTHX) {
#define a_hint() a_hint(aTHX)
- const SV *hint;
+ SV *hint;
#if A_HAS_PERL(5, 9, 5)
hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
NULL,
if (val) {
*oi = *val;
val = oi;
- } else
- oi->old_pp = 0;
+ }
#ifdef USE_ITHREADS
MUTEX_UNLOCK(&a_op_map_mutex);
a_map_fetch(PL_op, &oi);
- if (PL_op != oi.root && !SvOK(TOPs)) {
+ if (PL_op == oi.root) { /* This means "@$arrayref" */
+ PL_op->op_ppaddr = oi.old_pp;
+ } else if (!SvOK(TOPs)) {
/* We always need to push an empty array to fool the pp_aelem() that comes
* later. */
SV *av;
a_map_fetch(PL_op, &oi);
- if (PL_op != oi.root && !SvOK(TOPs)) {
- if (oi.root->op_flags & OPf_MOD) {
- SV *hv;
- POPs;
- hv = sv_2mortal((SV *) newHV());
- PUSHs(hv);
- }
+ if (PL_op == oi.root) { /* This means "%$hashref" */
+ PL_op->op_ppaddr = oi.old_pp;
+ } else if (!SvOK(TOPs)) {
RETURN;
}
/* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
-STATIC const char a_msg_forbidden[] = "Reference vivification forbidden";
-STATIC const char a_msg_impossible[] = "Can't vivify reference";
-
STATIC OP *a_pp_deref(pTHX) {
a_op_info oi;
UV flags;
SPAGAIN;
if (!SvOK(TOPs)) {
if (flags & A_HINT_STRICT)
- croak(a_msg_forbidden);
+ croak("Reference vivification forbidden");
else if (flags & A_HINT_WARN)
- warn(a_msg_forbidden);
+ warn("Reference was vivified");
else /* A_HINT_STORE */
- croak(a_msg_impossible);
+ croak("Can't vivify reference");
}
}
} else if (flags && (PL_op->op_private & OPpDEREF || PL_op == oi.root)) {
oi.flags = flags & A_HINT_NOTIFY;
- if ((oi.root->op_flags & (OPf_MOD|OPf_REF)) != (OPf_MOD|OPf_REF)) {
- if (flags & A_HINT_FETCH)
- oi.flags |= (A_HINT_FETCH|A_HINT_DEREF);
- } else if (flags & A_HINT_STORE)
+ if (oi.root->op_flags & OPf_MOD) {
+ if (flags & A_HINT_STORE)
oi.flags |= (A_HINT_STORE|A_HINT_DEREF);
+ } else if (flags & A_HINT_FETCH)
+ oi.flags |= (A_HINT_FETCH|A_HINT_DEREF);
if (PL_op == oi.root)
oi.flags &= ~A_HINT_DEREF;
STATIC OP *a_ck_deref(pTHX_ OP *o) {
OP * (*old_ck)(pTHX_ OP *o) = 0;
- UV hint;
+ UV hint = a_hint();
switch (o->op_type) {
- case OP_AELEM: old_ck = a_old_ck_aelem; break;
- case OP_HELEM: old_ck = a_old_ck_helem; break;
- case OP_RV2SV: old_ck = a_old_ck_rv2sv; break;
+ case OP_AELEM:
+ old_ck = a_old_ck_aelem;
+ if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) {
+ OP *kid = cUNOPo->op_first;
+ a_op_info oi;
+ if (kid->op_type == OP_RV2AV && kid->op_ppaddr != a_pp_rv2av
+ && kUNOP->op_first->op_type != OP_GV
+ && a_map_fetch(kid, &oi)) {
+ a_map_store(kid, kid->op_ppaddr, hint);
+ kid->op_ppaddr = a_pp_rv2av;
+ }
+ }
+ break;
+ case OP_HELEM:
+ old_ck = a_old_ck_helem;
+ if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) {
+ OP *kid = cUNOPo->op_first;
+ a_op_info oi;
+ if (kid->op_type == OP_RV2HV && kid->op_ppaddr != a_pp_rv2hv
+ && kUNOP->op_first->op_type != OP_GV
+ && a_map_fetch(kid, &oi)) {
+ a_map_store(kid, kid->op_ppaddr, hint);
+ kid->op_ppaddr = a_pp_rv2hv;
+ }
+ }
+ break;
+ case OP_RV2SV:
+ old_ck = a_old_ck_rv2sv;
+ break;
}
o = CALL_FPTR(old_ck)(aTHX_ o);
- hint = a_hint();
if (hint & A_HINT_DO) {
a_map_store(o, o->op_ppaddr, hint);
o->op_ppaddr = a_pp_deref;
}
o = CALL_FPTR(old_ck)(aTHX_ o);
+ if (cUNOPo->op_first->op_type == OP_GV)
+ return o;
+
hint = a_hint();
if (hint & A_HINT_DO) {
if (!(hint & A_HINT_STRICT)) {
projects / perl / modules / autovivification.git / blobdiff