1 /* This file is part of the autovivification Perl module.
2 * See http://search.cpan.org/dist/autovivification/ */
4 #define PERL_NO_GET_CONTEXT
9 #define __PACKAGE__ "autovivification"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
12 /* --- Compatibility wrappers ---------------------------------------------- */
15 # define HvNAME_get(H) HvNAME(H)
19 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
22 #define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
25 #if defined(ENTER_with_name) && !A_HAS_PERL(5, 11, 4)
26 # define ENTERn(N) ENTER_with_name(N)
28 # define ENTERn(N) ENTER
32 #if defined(LEAVE_with_name) && !A_HAS_PERL(5, 11, 4)
33 # define LEAVEn(N) LEAVE_with_name(N)
35 # define LEAVEn(N) LEAVE
38 #ifndef A_WORKAROUND_REQUIRE_PROPAGATION
39 # define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1)
42 /* ... Thread safety and multiplicity ...................................... */
44 #ifndef A_MULTIPLICITY
45 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
46 # define A_MULTIPLICITY 1
48 # define A_MULTIPLICITY 0
51 #if A_MULTIPLICITY && !defined(tTHX)
52 # define tTHX PerlInterpreter*
55 #if A_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
56 # define A_THREADSAFE 1
58 # define MY_CXT_CLONE \
60 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
61 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
62 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
65 # define A_THREADSAFE 0
67 # define dMY_CXT dNOOP
69 # define MY_CXT a_globaldata
71 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
73 # define MY_CXT_INIT NOOP
75 # define MY_CXT_CLONE NOOP
78 /* --- Helpers ------------------------------------------------------------- */
80 /* ... Thread-safe hints ................................................... */
82 #if A_WORKAROUND_REQUIRE_PROPAGATION
89 #define A_HINT_BITS(H) ((H)->bits)
91 #define A_HINT_FREE(H) PerlMemShared_free(H)
95 #define PTABLE_NAME ptable_hints
96 #define PTABLE_VAL_FREE(V) A_HINT_FREE(V)
105 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
106 #define ptable_hints_free(T) ptable_hints_free(aTHX_ (T))
108 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
111 ptable *tbl; /* It really is a ptable_hints */
117 STATIC SV *a_clone(pTHX_ SV *sv, tTHX owner) {
118 #define a_clone(S, O) a_clone(aTHX_ (S), (O))
123 if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
126 param.stashes = stashes;
128 param.proto_perl = owner;
130 dupsv = sv_dup(sv, ¶m);
134 SvREFCNT_dec(stashes);
137 return SvREFCNT_inc(dupsv);
140 STATIC void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
142 a_hint_t *h1 = ent->val;
145 if (ud->owner == aTHX)
148 h2 = PerlMemShared_malloc(sizeof *h2);
149 h2->require_tag = PTR2IV(a_clone(INT2PTR(SV *, h1->require_tag), ud->owner));
151 ptable_hints_store(ud->tbl, ent->key, h2);
154 STATIC void a_thread_cleanup(pTHX_ void *);
156 STATIC void a_thread_cleanup(pTHX_ void *ud) {
162 SAVEDESTRUCTOR_X(a_thread_cleanup, level);
166 PerlMemShared_free(level);
167 ptable_hints_free(MY_CXT.tbl);
171 #endif /* A_THREADSAFE */
173 STATIC IV a_require_tag(pTHX) {
174 #define a_require_tag() a_require_tag(aTHX)
175 const CV *cv, *outside;
180 /* If for some reason the pragma is operational at run-time, try to discover
181 * the current cv in use. */
184 for (si = PL_curstackinfo; si; si = si->si_prev) {
187 for (cxix = si->si_cxix; cxix >= 0; --cxix) {
188 const PERL_CONTEXT *cx = si->si_cxstack + cxix;
190 switch (CxTYPE(cx)) {
193 /* The propagation workaround is only needed up to 5.10.0 and at that
194 * time format and sub contexts were still identical. And even later the
195 * cv members offsets should have been kept the same. */
197 goto get_enclosing_cv;
199 cv = cx->blk_eval.cv;
200 goto get_enclosing_cv;
211 for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
217 STATIC SV *a_tag(pTHX_ UV bits) {
218 #define a_tag(B) a_tag(aTHX_ (B))
222 h = PerlMemShared_malloc(sizeof *h);
224 h->require_tag = a_require_tag();
227 /* We only need for the key to be an unique tag for looking up the value later.
228 * Allocated memory provides convenient unique identifiers, so that's why we
229 * use the hint as the key itself. */
230 ptable_hints_store(MY_CXT.tbl, h, h);
231 #endif /* A_THREADSAFE */
233 return newSViv(PTR2IV(h));
236 STATIC UV a_detag(pTHX_ const SV *hint) {
237 #define a_detag(H) a_detag(aTHX_ (H))
241 if (!(hint && SvIOK(hint)))
244 h = INT2PTR(a_hint_t *, SvIVX(hint));
246 h = ptable_fetch(MY_CXT.tbl, h);
247 #endif /* A_THREADSAFE */
249 if (a_require_tag() != h->require_tag)
252 return A_HINT_BITS(h);
255 #else /* A_WORKAROUND_REQUIRE_PROPAGATION */
257 #define a_tag(B) newSVuv(B)
258 /* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV
265 ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
271 #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
273 /* Used both for hints and op flags */
274 #define A_HINT_STRICT 1
275 #define A_HINT_WARN 2
276 #define A_HINT_FETCH 4
277 #define A_HINT_STORE 8
278 #define A_HINT_EXISTS 16
279 #define A_HINT_DELETE 32
280 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
281 #define A_HINT_DO (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
282 #define A_HINT_MASK (A_HINT_NOTIFY|A_HINT_DO)
284 /* Only used in op flags */
285 #define A_HINT_ROOT 64
286 #define A_HINT_DEREF 128
288 STATIC U32 a_hash = 0;
290 STATIC UV a_hint(pTHX) {
291 #define a_hint() a_hint(aTHX)
293 #if A_HAS_PERL(5, 9, 5)
294 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
296 __PACKAGE__, __PACKAGE_LEN__,
300 SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, a_hash);
305 return a_detag(hint);
308 /* ... op => info map ...................................................... */
316 #define PTABLE_NAME ptable_map
317 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
321 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
322 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
324 STATIC ptable *a_op_map = NULL;
327 STATIC perl_mutex a_op_map_mutex;
330 STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
331 const a_op_info *val;
334 MUTEX_LOCK(&a_op_map_mutex);
337 val = ptable_fetch(a_op_map, o);
344 MUTEX_UNLOCK(&a_op_map_mutex);
350 STATIC const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
351 #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F))
354 if (!(oi = ptable_fetch(a_op_map, o))) {
355 oi = PerlMemShared_malloc(sizeof *oi);
356 ptable_map_store(a_op_map, o, oi);
366 STATIC void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
367 #define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F))
370 MUTEX_LOCK(&a_op_map_mutex);
373 a_map_store_locked(o, old_pp, next, flags);
376 MUTEX_UNLOCK(&a_op_map_mutex);
380 STATIC void a_map_delete(pTHX_ const OP *o) {
381 #define a_map_delete(O) a_map_delete(aTHX_ (O))
383 MUTEX_LOCK(&a_op_map_mutex);
386 ptable_map_store(a_op_map, o, NULL);
389 MUTEX_UNLOCK(&a_op_map_mutex);
393 STATIC const OP *a_map_descend(const OP *o) {
394 switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
398 case OA_BASEOP_OR_UNOP:
399 return cUNOPo->op_first;
402 return cLISTOPo->op_last;
408 STATIC void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV flags) {
409 #define a_map_store_root(R, PP, F) a_map_store_root(aPTBLMS_ (R), (PP), (F))
410 const a_op_info *roi;
415 MUTEX_LOCK(&a_op_map_mutex);
418 roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT);
420 while (o->op_flags & OPf_KIDS) {
421 o = a_map_descend(o);
424 if ((oi = ptable_fetch(a_op_map, o))) {
425 oi->flags &= ~A_HINT_ROOT;
426 oi->next = (a_op_info *) roi;
432 MUTEX_UNLOCK(&a_op_map_mutex);
438 STATIC void a_map_update_flags_topdown(const OP *root, UV flags) {
443 MUTEX_LOCK(&a_op_map_mutex);
446 flags &= ~A_HINT_ROOT;
449 if ((oi = ptable_fetch(a_op_map, o)))
450 oi->flags = (oi->flags & A_HINT_ROOT) | flags;
451 if (!(o->op_flags & OPf_KIDS))
453 o = a_map_descend(o);
457 MUTEX_UNLOCK(&a_op_map_mutex);
463 #define a_map_cancel(R) a_map_update_flags_topdown((R), 0)
465 STATIC void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
469 MUTEX_LOCK(&a_op_map_mutex);
472 flags &= ~A_HINT_ROOT;
473 rflags |= A_HINT_ROOT;
475 oi = ptable_fetch(a_op_map, o);
476 while (!(oi->flags & A_HINT_ROOT)) {
483 MUTEX_UNLOCK(&a_op_map_mutex);
489 /* ... Decide whether this expression should be autovivified or not ........ */
491 STATIC UV a_map_resolve(const OP *o, a_op_info *oi) {
492 UV flags = 0, rflags;
496 while (!(roi->flags & A_HINT_ROOT))
501 rflags = roi->flags & ~A_HINT_ROOT;
506 if (root->op_flags & OPf_MOD) {
507 if (rflags & A_HINT_STORE)
508 flags = (A_HINT_STORE|A_HINT_DEREF);
509 } else if (rflags & A_HINT_FETCH)
510 flags = (A_HINT_FETCH|A_HINT_DEREF);
514 a_map_update_flags_bottomup(o, 0, 0);
518 flags |= (rflags & A_HINT_NOTIFY);
519 a_map_update_flags_bottomup(o, flags, 0);
521 return oi->flags & A_HINT_ROOT ? 0 : flags;
524 /* ... Lightweight pp_defined() ............................................ */
526 STATIC bool a_defined(pTHX_ SV *sv) {
527 #define a_defined(S) a_defined(aTHX_ (S))
528 bool defined = FALSE;
530 switch (SvTYPE(sv)) {
532 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
533 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
537 if (HvARRAY(sv) || SvGMAGICAL(sv)
538 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
550 /* --- PP functions -------------------------------------------------------- */
552 /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp
553 * value, another extension might have saved our pp replacement as the ppaddr
554 * for this op, so this doesn't ensure that our function will never be called
555 * again. That's why we don't remove the op info from our map, so that it can
556 * still run correctly if required. */
558 /* ... pp_rv2av ............................................................ */
560 STATIC OP *a_pp_rv2av(pTHX) {
565 a_map_fetch(PL_op, &oi);
568 if (flags & A_HINT_DEREF) {
569 if (!a_defined(TOPs)) {
570 /* We always need to push an empty array to fool the pp_aelem() that comes
574 av = sv_2mortal((SV *) newAV());
579 PL_op->op_ppaddr = oi.old_pp;
582 return CALL_FPTR(oi.old_pp)(aTHX);
585 /* ... pp_rv2hv ............................................................ */
587 STATIC OP *a_pp_rv2hv_simple(pTHX) {
592 a_map_fetch(PL_op, &oi);
595 if (flags & A_HINT_DEREF) {
596 if (!a_defined(TOPs))
599 PL_op->op_ppaddr = oi.old_pp;
602 return CALL_FPTR(oi.old_pp)(aTHX);
605 STATIC OP *a_pp_rv2hv(pTHX) {
610 a_map_fetch(PL_op, &oi);
613 if (flags & A_HINT_DEREF) {
614 if (!a_defined(TOPs)) {
617 hv = sv_2mortal((SV *) newHV());
622 PL_op->op_ppaddr = oi.old_pp;
625 return CALL_FPTR(oi.old_pp)(aTHX);
628 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
630 STATIC OP *a_pp_deref(pTHX) {
635 a_map_fetch(PL_op, &oi);
638 if (flags & A_HINT_DEREF) {
643 old_private = PL_op->op_private;
644 PL_op->op_private = ((old_private & ~OPpDEREF) | OPpLVAL_DEFER);
645 o = CALL_FPTR(oi.old_pp)(aTHX);
646 PL_op->op_private = old_private;
648 if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
650 if (!a_defined(TOPs)) {
651 if (flags & A_HINT_STRICT)
652 croak("Reference vivification forbidden");
653 else if (flags & A_HINT_WARN)
654 warn("Reference was vivified");
655 else /* A_HINT_STORE */
656 croak("Can't vivify reference");
661 } else if ((flags & ~A_HINT_ROOT)
662 && (PL_op->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
663 /* Decide if the expression must autovivify or not.
664 * This branch should be called only once by expression. */
665 flags = a_map_resolve(PL_op, &oi);
667 /* We need the updated flags value in the deref branch. */
668 if (flags & A_HINT_DEREF)
672 /* This op doesn't need to skip autovivification, so restore the original
674 PL_op->op_ppaddr = oi.old_pp;
676 return CALL_FPTR(oi.old_pp)(aTHX);
679 /* ... pp_root (exists,delete,keys,values) ................................. */
681 STATIC OP *a_pp_root_unop(pTHX) {
685 if (!a_defined(TOPs)) {
687 /* Can only be reached by keys or values */
688 if (GIMME_V == G_SCALAR) {
695 a_map_fetch(PL_op, &oi);
697 return CALL_FPTR(oi.old_pp)(aTHX);
700 STATIC OP *a_pp_root_binop(pTHX) {
704 if (!a_defined(TOPm1s)) {
707 if (PL_op->op_type == OP_EXISTS)
713 a_map_fetch(PL_op, &oi);
715 return CALL_FPTR(oi.old_pp)(aTHX);
718 /* --- Check functions ----------------------------------------------------- */
720 STATIC void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
721 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
724 if (o->op_type == type && o->op_ppaddr != new_pp
725 && cUNOPo->op_first->op_type != OP_GV
726 && a_map_fetch(o, &oi)) {
727 a_map_store(o, o->op_ppaddr, oi.next, oi.flags);
728 o->op_ppaddr = new_pp;
734 /* ... ck_pad{any,sv} ...................................................... */
736 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
737 * function, but are instead manually mutated from a PADANY. This is why we set
738 * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
739 * their op_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
740 * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
741 * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
744 STATIC OP *(*a_pp_padsv_saved)(pTHX) = 0;
746 STATIC void a_pp_padsv_save(void) {
747 if (a_pp_padsv_saved)
750 a_pp_padsv_saved = PL_ppaddr[OP_PADSV];
751 PL_ppaddr[OP_PADSV] = a_pp_deref;
754 STATIC void a_pp_padsv_restore(OP *o) {
755 if (!a_pp_padsv_saved)
758 if (o->op_ppaddr == a_pp_deref)
759 o->op_ppaddr = a_pp_padsv_saved;
761 PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
762 a_pp_padsv_saved = 0;
765 STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
767 STATIC OP *a_ck_padany(pTHX_ OP *o) {
770 a_pp_padsv_restore(o);
772 o = CALL_FPTR(a_old_ck_padany)(aTHX_ o);
775 if (hint & A_HINT_DO) {
777 a_map_store_root(o, a_pp_padsv_saved, hint);
784 STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
786 STATIC OP *a_ck_padsv(pTHX_ OP *o) {
789 a_pp_padsv_restore(o);
791 o = CALL_FPTR(a_old_ck_padsv)(aTHX_ o);
794 if (hint & A_HINT_DO) {
795 a_map_store_root(o, o->op_ppaddr, hint);
796 o->op_ppaddr = a_pp_deref;
803 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
805 /* Those ops appear both at the root and inside an expression but there's no
806 * way to distinguish both situations. Worse, we can't even know if we are in a
807 * modifying context, so the expression can't be resolved yet. It will be at the
808 * first invocation of a_pp_deref() for this expression. */
810 STATIC OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
811 STATIC OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
812 STATIC OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
814 STATIC OP *a_ck_deref(pTHX_ OP *o) {
815 OP * (*old_ck)(pTHX_ OP *o) = 0;
818 switch (o->op_type) {
820 old_ck = a_old_ck_aelem;
821 if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
822 a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
825 old_ck = a_old_ck_helem;
826 if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
827 a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
830 old_ck = a_old_ck_rv2sv;
833 o = CALL_FPTR(old_ck)(aTHX_ o);
835 if (hint & A_HINT_DO) {
836 a_map_store_root(o, o->op_ppaddr, hint);
837 o->op_ppaddr = a_pp_deref;
844 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
846 /* Those ops also appear both inisde and at the root, hence the caveats for
847 * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
848 * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
851 STATIC OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
852 STATIC OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
854 STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
855 OP * (*old_ck)(pTHX_ OP *o) = 0;
856 OP * (*new_pp)(pTHX) = 0;
859 switch (o->op_type) {
860 case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
861 case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
863 o = CALL_FPTR(old_ck)(aTHX_ o);
865 if (cUNOPo->op_first->op_type == OP_GV)
869 if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
870 a_map_store_root(o, o->op_ppaddr, hint);
871 o->op_ppaddr = new_pp;
878 /* ... ck_xslice (aslice,hslice) ........................................... */
880 /* I think those are only found at the root, but there's nothing that really
881 * prevent them to be inside the expression too. We only need to update the
882 * root so that the rest of the expression will see the right context when
883 * resolving. That's why we don't replace the ppaddr. */
885 STATIC OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
886 STATIC OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
888 STATIC OP *a_ck_xslice(pTHX_ OP *o) {
889 OP * (*old_ck)(pTHX_ OP *o) = 0;
892 switch (o->op_type) {
894 old_ck = a_old_ck_aslice;
897 old_ck = a_old_ck_hslice;
898 if (hint & A_HINT_DO)
899 a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv);
902 o = CALL_FPTR(old_ck)(aTHX_ o);
904 if (hint & A_HINT_DO) {
905 a_map_store_root(o, 0, hint);
912 /* ... ck_root (exists,delete,keys,values) ................................. */
914 /* Those ops are only found at the root of a dereferencing expression. We can
915 * then resolve at compile time if vivification must take place or not. */
917 STATIC OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
918 STATIC OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
919 STATIC OP *(*a_old_ck_keys) (pTHX_ OP *) = 0;
920 STATIC OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
922 STATIC OP *a_ck_root(pTHX_ OP *o) {
923 OP * (*old_ck)(pTHX_ OP *o) = 0;
924 OP * (*new_pp)(pTHX) = 0;
925 bool enabled = FALSE;
928 switch (o->op_type) {
930 old_ck = a_old_ck_exists;
931 new_pp = a_pp_root_binop;
932 enabled = hint & A_HINT_EXISTS;
935 old_ck = a_old_ck_delete;
936 new_pp = a_pp_root_binop;
937 enabled = hint & A_HINT_DELETE;
940 old_ck = a_old_ck_keys;
941 new_pp = a_pp_root_unop;
942 enabled = hint & A_HINT_FETCH;
945 old_ck = a_old_ck_values;
946 new_pp = a_pp_root_unop;
947 enabled = hint & A_HINT_FETCH;
950 o = CALL_FPTR(old_ck)(aTHX_ o);
952 if (hint & A_HINT_DO) {
954 a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
955 a_map_store_root(o, o->op_ppaddr, hint);
956 o->op_ppaddr = new_pp;
966 STATIC U32 a_initialized = 0;
968 /* --- XS ------------------------------------------------------------------ */
970 MODULE = autovivification PACKAGE = autovivification
976 if (!a_initialized++) {
978 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
980 MY_CXT.tbl = ptable_new();
984 a_op_map = ptable_new();
986 MUTEX_INIT(&a_op_map_mutex);
989 PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
991 a_old_ck_padany = PL_check[OP_PADANY];
992 PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_ck_padany);
993 a_old_ck_padsv = PL_check[OP_PADSV];
994 PL_check[OP_PADSV] = MEMBER_TO_FPTR(a_ck_padsv);
996 a_old_ck_aelem = PL_check[OP_AELEM];
997 PL_check[OP_AELEM] = MEMBER_TO_FPTR(a_ck_deref);
998 a_old_ck_helem = PL_check[OP_HELEM];
999 PL_check[OP_HELEM] = MEMBER_TO_FPTR(a_ck_deref);
1000 a_old_ck_rv2sv = PL_check[OP_RV2SV];
1001 PL_check[OP_RV2SV] = MEMBER_TO_FPTR(a_ck_deref);
1003 a_old_ck_rv2av = PL_check[OP_RV2AV];
1004 PL_check[OP_RV2AV] = MEMBER_TO_FPTR(a_ck_rv2xv);
1005 a_old_ck_rv2hv = PL_check[OP_RV2HV];
1006 PL_check[OP_RV2HV] = MEMBER_TO_FPTR(a_ck_rv2xv);
1008 a_old_ck_aslice = PL_check[OP_ASLICE];
1009 PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1010 a_old_ck_hslice = PL_check[OP_HSLICE];
1011 PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1013 a_old_ck_exists = PL_check[OP_EXISTS];
1014 PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
1015 a_old_ck_delete = PL_check[OP_DELETE];
1016 PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_ck_root);
1017 a_old_ck_keys = PL_check[OP_KEYS];
1018 PL_check[OP_KEYS] = MEMBER_TO_FPTR(a_ck_root);
1019 a_old_ck_values = PL_check[OP_VALUES];
1020 PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_ck_root);
1022 stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1023 newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1024 newCONSTSUB(stash, "A_HINT_WARN", newSVuv(A_HINT_WARN));
1025 newCONSTSUB(stash, "A_HINT_FETCH", newSVuv(A_HINT_FETCH));
1026 newCONSTSUB(stash, "A_HINT_STORE", newSVuv(A_HINT_STORE));
1027 newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1028 newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1029 newCONSTSUB(stash, "A_HINT_MASK", newSVuv(A_HINT_MASK));
1033 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1045 ud.tbl = t = ptable_new();
1046 ud.owner = MY_CXT.owner;
1047 ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1052 MY_CXT.owner = aTHX;
1055 level = PerlMemShared_malloc(sizeof *level);
1058 SAVEDESTRUCTOR_X(a_thread_cleanup, level);
1068 RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1078 RETVAL = newSVuv(a_detag(tag));