]> git.vpit.fr Git - perl/modules/autovivification.git/blob - autovivification.xs
Quote version numbers in Makefile.PL
[perl/modules/autovivification.git] / autovivification.xs
1 /* This file is part of the autovivification Perl module.
2  * See http://search.cpan.org/dist/autovivification/ */
3
4 #define PERL_NO_GET_CONTEXT
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8
9 #define __PACKAGE__     "autovivification"
10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
11
12 /* --- Compatibility wrappers ---------------------------------------------- */
13
14 #ifndef HvNAME_get
15 # define HvNAME_get(H) HvNAME(H)
16 #endif
17
18 #ifndef HvNAMELEN_get
19 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
20 #endif
21
22 #define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
23
24 #ifndef A_WORKAROUND_REQUIRE_PROPAGATION
25 # define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1)
26 #endif
27
28 #ifndef A_HAS_RPEEP
29 # define A_HAS_RPEEP A_HAS_PERL(5, 13, 5)
30 #endif
31
32 /* ... Thread safety and multiplicity ...................................... */
33
34 /* Always safe when the workaround isn't needed */
35 #if !A_WORKAROUND_REQUIRE_PROPAGATION
36 # undef A_FORKSAFE
37 # define A_FORKSAFE 1
38 /* Otherwise, safe unless Makefile.PL says it's Win32 */
39 #elif !defined(A_FORKSAFE)
40 # define A_FORKSAFE 1
41 #endif
42
43 #ifndef A_MULTIPLICITY
44 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
45 #  define A_MULTIPLICITY 1
46 # else
47 #  define A_MULTIPLICITY 0
48 # endif
49 #endif
50
51 #ifndef tTHX
52 # define tTHX PerlInterpreter*
53 #endif
54
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
57 # ifndef MY_CXT_CLONE
58 #  define MY_CXT_CLONE \
59     dMY_CXT_SV;                                                      \
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))
63 # endif
64 #else
65 # define A_THREADSAFE 0
66 # undef  dMY_CXT
67 # define dMY_CXT      dNOOP
68 # undef  MY_CXT
69 # define MY_CXT       a_globaldata
70 # undef  START_MY_CXT
71 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
72 # undef  MY_CXT_INIT
73 # define MY_CXT_INIT  NOOP
74 # undef  MY_CXT_CLONE
75 # define MY_CXT_CLONE NOOP
76 #endif
77
78 /* --- Helpers ------------------------------------------------------------- */
79
80 /* ... Thread-safe hints ................................................... */
81
82 #if A_WORKAROUND_REQUIRE_PROPAGATION
83
84 typedef struct {
85  U32 bits;
86  IV  require_tag;
87 } a_hint_t;
88
89 #define A_HINT_FREE(H) PerlMemShared_free(H)
90
91 #if A_THREADSAFE
92
93 #define PTABLE_NAME        ptable_hints
94 #define PTABLE_VAL_FREE(V) A_HINT_FREE(V)
95
96 #define pPTBL  pTHX
97 #define pPTBL_ pTHX_
98 #define aPTBL  aTHX
99 #define aPTBL_ aTHX_
100
101 #include "ptable.h"
102
103 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
104 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
105
106 #endif /* A_THREADSAFE */
107
108 #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
109
110 #define PTABLE_NAME        ptable_seen
111 #define PTABLE_VAL_FREE(V) NOOP
112
113 #include "ptable.h"
114
115 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
116 #define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
117 #define ptable_seen_clear(T)       ptable_seen_clear(aPTBLMS_ (T))
118 #define ptable_seen_free(T)        ptable_seen_free(aPTBLMS_ (T))
119
120 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
121
122 typedef struct {
123 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
124  ptable *tbl;   /* It really is a ptable_hints */
125  tTHX    owner;
126 #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
127  ptable *seen;  /* It really is a ptable_seen */
128 } my_cxt_t;
129
130 START_MY_CXT
131
132 #if A_THREADSAFE
133
134 #if A_WORKAROUND_REQUIRE_PROPAGATION
135
136 typedef struct {
137  ptable       *tbl;
138 #if A_HAS_PERL(5, 13, 2)
139  CLONE_PARAMS *params;
140 #else
141  CLONE_PARAMS  params;
142 #endif
143 } a_ptable_clone_ud;
144
145 #if A_HAS_PERL(5, 13, 2)
146 # define a_ptable_clone_ud_init(U, T, O) \
147    (U).tbl    = (T); \
148    (U).params = Perl_clone_params_new((O), aTHX)
149 # define a_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
150 # define a_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), (U)->params))
151 #else
152 # define a_ptable_clone_ud_init(U, T, O) \
153    (U).tbl               = (T);     \
154    (U).params.stashes    = newAV(); \
155    (U).params.flags      = 0;       \
156    (U).params.proto_perl = (O)
157 # define a_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
158 # define a_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), &((U)->params)))
159 #endif
160
161 STATIC void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
162  a_ptable_clone_ud *ud = ud_;
163  a_hint_t *h1 = ent->val;
164  a_hint_t *h2;
165
166  h2              = PerlMemShared_malloc(sizeof *h2);
167  h2->bits        = h1->bits;
168  h2->require_tag = PTR2IV(a_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
169
170  ptable_hints_store(ud->tbl, ent->key, h2);
171 }
172
173 #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
174
175 #include "reap.h"
176
177 STATIC void a_thread_cleanup(pTHX_ void *ud) {
178  dMY_CXT;
179
180 #if A_WORKAROUND_REQUIRE_PROPAGATION
181  ptable_hints_free(MY_CXT.tbl);
182 #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
183  ptable_seen_free(MY_CXT.seen);
184 }
185
186 #endif /* A_THREADSAFE */
187
188 #if A_WORKAROUND_REQUIRE_PROPAGATION
189
190 STATIC IV a_require_tag(pTHX) {
191 #define a_require_tag() a_require_tag(aTHX)
192  const CV *cv, *outside;
193
194  cv = PL_compcv;
195
196  if (!cv) {
197   /* If for some reason the pragma is operational at run-time, try to discover
198    * the current cv in use. */
199   const PERL_SI *si;
200
201   for (si = PL_curstackinfo; si; si = si->si_prev) {
202    I32 cxix;
203
204    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
205     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
206
207     switch (CxTYPE(cx)) {
208      case CXt_SUB:
209      case CXt_FORMAT:
210       /* The propagation workaround is only needed up to 5.10.0 and at that
211        * time format and sub contexts were still identical. And even later the
212        * cv members offsets should have been kept the same. */
213       cv = cx->blk_sub.cv;
214       goto get_enclosing_cv;
215      case CXt_EVAL:
216       cv = cx->blk_eval.cv;
217       goto get_enclosing_cv;
218      default:
219       break;
220     }
221    }
222   }
223
224   cv = PL_main_cv;
225  }
226
227 get_enclosing_cv:
228  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
229   cv = outside;
230
231  return PTR2IV(cv);
232 }
233
234 STATIC SV *a_tag(pTHX_ UV bits) {
235 #define a_tag(B) a_tag(aTHX_ (B))
236  a_hint_t *h;
237
238  h              = PerlMemShared_malloc(sizeof *h);
239  h->bits        = bits;
240  h->require_tag = a_require_tag();
241
242 #if A_THREADSAFE
243  {
244   dMY_CXT;
245   /* We only need for the key to be an unique tag for looking up the value later
246    * Allocated memory provides convenient unique identifiers, so that's why we
247    * use the hint as the key itself. */
248   ptable_hints_store(MY_CXT.tbl, h, h);
249  }
250 #endif /* A_THREADSAFE */
251
252  return newSViv(PTR2IV(h));
253 }
254
255 STATIC UV a_detag(pTHX_ const SV *hint) {
256 #define a_detag(H) a_detag(aTHX_ (H))
257  a_hint_t *h;
258
259  if (!(hint && SvIOK(hint)))
260   return 0;
261
262  h = INT2PTR(a_hint_t *, SvIVX(hint));
263 #if A_THREADSAFE
264  {
265   dMY_CXT;
266   h = ptable_fetch(MY_CXT.tbl, h);
267  }
268 #endif /* A_THREADSAFE */
269
270  if (a_require_tag() != h->require_tag)
271   return 0;
272
273  return h->bits;
274 }
275
276 #else /* A_WORKAROUND_REQUIRE_PROPAGATION */
277
278 #define a_tag(B)   newSVuv(B)
279 /* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV
280  * from a copy. */
281 #define a_detag(H) \
282  ((H)              \
283   ? (SvIOK(H)      \
284      ? SvUVX(H)    \
285      : (SvPOK(H)   \
286         ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
287         : 0        \
288        )           \
289      )             \
290   : 0)
291
292 #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
293
294 /* Used both for hints and op flags */
295 #define A_HINT_STRICT 1
296 #define A_HINT_WARN   2
297 #define A_HINT_FETCH  4
298 #define A_HINT_STORE  8
299 #define A_HINT_EXISTS 16
300 #define A_HINT_DELETE 32
301 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
302 #define A_HINT_DO     (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
303 #define A_HINT_MASK   (A_HINT_NOTIFY|A_HINT_DO)
304
305 /* Only used in op flags */
306 #define A_HINT_ROOT   64
307 #define A_HINT_DEREF  128
308
309 STATIC U32 a_hash = 0;
310
311 STATIC UV a_hint(pTHX) {
312 #define a_hint() a_hint(aTHX)
313  SV *hint;
314 #ifdef cop_hints_fetch_pvn
315  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, a_hash, 0);
316 #elif A_HAS_PERL(5, 9, 5)
317  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
318                                        NULL,
319                                        __PACKAGE__, __PACKAGE_LEN__,
320                                        0,
321                                        a_hash);
322 #else
323  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
324  if (!val)
325   return 0;
326  hint = *val;
327 #endif
328  return a_detag(hint);
329 }
330
331 /* ... op => info map ...................................................... */
332
333 typedef struct {
334  OP   *(*old_pp)(pTHX);
335  void   *next;
336  UV      flags;
337 } a_op_info;
338
339 #define PTABLE_NAME        ptable_map
340 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
341
342 #include "ptable.h"
343
344 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
345 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
346 #define ptable_map_delete(T, K)   ptable_map_delete(aPTBLMS_ (T), (K))
347
348 STATIC ptable *a_op_map = NULL;
349
350 #ifdef USE_ITHREADS
351
352 #define dA_MAP_THX a_op_info a_op_map_tmp_oi
353
354 STATIC perl_mutex a_op_map_mutex;
355
356 #define A_LOCK(M)   MUTEX_LOCK(M)
357 #define A_UNLOCK(M) MUTEX_UNLOCK(M)
358
359 STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
360  const a_op_info *val;
361
362  A_LOCK(&a_op_map_mutex);
363
364  val = ptable_fetch(a_op_map, o);
365  if (val) {
366   *oi = *val;
367   val = oi;
368  }
369
370  A_UNLOCK(&a_op_map_mutex);
371
372  return val;
373 }
374
375 #define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi)
376
377 #else /* USE_ITHREADS */
378
379 #define dA_MAP_THX dNOOP
380
381 #define A_LOCK(M)   NOOP
382 #define A_UNLOCK(M) NOOP
383
384 #define a_map_fetch(O) ptable_fetch(a_op_map, (O))
385
386 #endif /* !USE_ITHREADS */
387
388 STATIC const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
389 #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F))
390  a_op_info *oi;
391
392  if (!(oi = ptable_fetch(a_op_map, o))) {
393   oi = PerlMemShared_malloc(sizeof *oi);
394   ptable_map_store(a_op_map, o, oi);
395  }
396
397  oi->old_pp = old_pp;
398  oi->next   = next;
399  oi->flags  = flags;
400
401  return oi;
402 }
403
404 STATIC void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
405 #define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F))
406  A_LOCK(&a_op_map_mutex);
407
408  a_map_store_locked(o, old_pp, next, flags);
409
410  A_UNLOCK(&a_op_map_mutex);
411 }
412
413 STATIC void a_map_delete(pTHX_ const OP *o) {
414 #define a_map_delete(O) a_map_delete(aTHX_ (O))
415  A_LOCK(&a_op_map_mutex);
416
417  ptable_map_delete(a_op_map, o);
418
419  A_UNLOCK(&a_op_map_mutex);
420 }
421
422 STATIC const OP *a_map_descend(const OP *o) {
423  switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
424   case OA_BASEOP:
425   case OA_UNOP:
426   case OA_BINOP:
427   case OA_BASEOP_OR_UNOP:
428    return cUNOPo->op_first;
429   case OA_LIST:
430   case OA_LISTOP:
431    return cLISTOPo->op_last;
432  }
433
434  return NULL;
435 }
436
437 STATIC void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV flags) {
438 #define a_map_store_root(R, PP, F) a_map_store_root(aPTBLMS_ (R), (PP), (F))
439  const a_op_info *roi;
440  a_op_info *oi;
441  const OP *o = root;
442
443  A_LOCK(&a_op_map_mutex);
444
445  roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT);
446
447  while (o->op_flags & OPf_KIDS) {
448   o = a_map_descend(o);
449   if (!o)
450    break;
451   if ((oi = ptable_fetch(a_op_map, o))) {
452    oi->flags &= ~A_HINT_ROOT;
453    oi->next   = (a_op_info *) roi;
454    break;
455   }
456  }
457
458  A_UNLOCK(&a_op_map_mutex);
459
460  return;
461 }
462
463 STATIC void a_map_update_flags_topdown(const OP *root, UV flags) {
464  a_op_info *oi;
465  const OP *o = root;
466
467  A_LOCK(&a_op_map_mutex);
468
469  flags &= ~A_HINT_ROOT;
470
471  do {
472   if ((oi = ptable_fetch(a_op_map, o)))
473    oi->flags = (oi->flags & A_HINT_ROOT) | flags;
474   if (!(o->op_flags & OPf_KIDS))
475    break;
476   o = a_map_descend(o);
477  } while (o);
478
479  A_UNLOCK(&a_op_map_mutex);
480
481  return;
482 }
483
484 #define a_map_cancel(R) a_map_update_flags_topdown((R), 0)
485
486 STATIC void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
487  a_op_info *oi;
488
489  A_LOCK(&a_op_map_mutex);
490
491  flags  &= ~A_HINT_ROOT;
492  rflags |=  A_HINT_ROOT;
493
494  oi = ptable_fetch(a_op_map, o);
495  while (!(oi->flags & A_HINT_ROOT)) {
496   oi->flags = flags;
497   oi        = oi->next;
498  }
499  oi->flags = rflags;
500
501  A_UNLOCK(&a_op_map_mutex);
502
503  return;
504 }
505
506 /* ... Decide whether this expression should be autovivified or not ........ */
507
508 STATIC UV a_map_resolve(const OP *o, const a_op_info *oi) {
509  UV flags = 0, rflags;
510  const OP *root;
511  const a_op_info *roi = oi;
512
513  while (!(roi->flags & A_HINT_ROOT))
514   roi = roi->next;
515  if (!roi)
516   goto cancel;
517
518  rflags = roi->flags & ~A_HINT_ROOT;
519  if (!rflags)
520   goto cancel;
521
522  root = roi->next;
523  if (root->op_flags & OPf_MOD) {
524   if (rflags & A_HINT_STORE)
525    flags = (A_HINT_STORE|A_HINT_DEREF);
526  } else if (rflags & A_HINT_FETCH)
527    flags = (A_HINT_FETCH|A_HINT_DEREF);
528
529  if (!flags) {
530 cancel:
531   a_map_update_flags_bottomup(o, 0, 0);
532   return 0;
533  }
534
535  flags |= (rflags & A_HINT_NOTIFY);
536  a_map_update_flags_bottomup(o, flags, 0);
537
538  return oi->flags & A_HINT_ROOT ? 0 : flags;
539 }
540
541 /* ... Inspired from pp_defined() .......................................... */
542
543 STATIC int a_undef(pTHX_ SV *sv) {
544 #define a_undef(S) a_undef(aTHX_ (S))
545  switch (SvTYPE(sv)) {
546   case SVt_NULL:
547    return 1;
548   case SVt_PVAV:
549    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
550                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
551     return 0;
552    break;
553   case SVt_PVHV:
554    if (HvARRAY(sv) || SvGMAGICAL(sv)
555                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
556     return 0;
557    break;
558   default:
559    SvGETMAGIC(sv);
560    if (SvOK(sv))
561     return 0;
562  }
563
564  return 1;
565 }
566
567 /* --- PP functions -------------------------------------------------------- */
568
569 /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp
570  * value, another extension might have saved our pp replacement as the ppaddr
571  * for this op, so this doesn't ensure that our function will never be called
572  * again. That's why we don't remove the op info from our map, so that it can
573  * still run correctly if required. */
574
575 /* ... pp_rv2av ............................................................ */
576
577 STATIC OP *a_pp_rv2av(pTHX) {
578  dA_MAP_THX;
579  const a_op_info *oi;
580  dSP;
581
582  oi = a_map_fetch(PL_op);
583
584  if (oi->flags & A_HINT_DEREF) {
585   if (a_undef(TOPs)) {
586    /* We always need to push an empty array to fool the pp_aelem() that comes
587     * later. */
588    SV *av;
589    POPs;
590    av = sv_2mortal((SV *) newAV());
591    PUSHs(av);
592    RETURN;
593   }
594  }
595
596  return oi->old_pp(aTHX);
597 }
598
599 /* ... pp_rv2hv ............................................................ */
600
601 STATIC OP *a_pp_rv2hv_simple(pTHX) {
602  dA_MAP_THX;
603  const a_op_info *oi;
604  dSP;
605
606  oi = a_map_fetch(PL_op);
607
608  if (oi->flags & A_HINT_DEREF) {
609   if (a_undef(TOPs))
610    RETURN;
611  }
612
613  return oi->old_pp(aTHX);
614 }
615
616 STATIC OP *a_pp_rv2hv(pTHX) {
617  dA_MAP_THX;
618  const a_op_info *oi;
619  dSP;
620
621  oi = a_map_fetch(PL_op);
622
623  if (oi->flags & A_HINT_DEREF) {
624   if (a_undef(TOPs)) {
625    SV *hv;
626    POPs;
627    hv = sv_2mortal((SV *) newHV());
628    PUSHs(hv);
629    RETURN;
630   }
631  }
632
633  return oi->old_pp(aTHX);
634 }
635
636 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
637
638 STATIC OP *a_pp_deref(pTHX) {
639  dA_MAP_THX;
640  const a_op_info *oi;
641  UV flags;
642  dSP;
643
644  oi = a_map_fetch(PL_op);
645
646  flags = oi->flags;
647  if (flags & A_HINT_DEREF) {
648   OP *o;
649
650   o = oi->old_pp(aTHX);
651
652   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
653    SPAGAIN;
654    if (a_undef(TOPs)) {
655     if (flags & A_HINT_STRICT)
656      croak("Reference vivification forbidden");
657     else if (flags & A_HINT_WARN)
658       warn("Reference was vivified");
659     else /* A_HINT_STORE */
660      croak("Can't vivify reference");
661    }
662   }
663
664   return o;
665  }
666
667  return oi->old_pp(aTHX);
668 }
669
670 /* ... pp_root (exists,delete,keys,values) ................................. */
671
672 STATIC OP *a_pp_root_unop(pTHX) {
673  dSP;
674
675  if (a_undef(TOPs)) {
676   POPs;
677   /* Can only be reached by keys or values */
678   if (GIMME_V == G_SCALAR) {
679    dTARGET;
680    PUSHi(0);
681   }
682   RETURN;
683  }
684
685  {
686   dA_MAP_THX;
687   const a_op_info *oi = a_map_fetch(PL_op);
688   return oi->old_pp(aTHX);
689  }
690 }
691
692 STATIC OP *a_pp_root_binop(pTHX) {
693  dSP;
694
695  if (a_undef(TOPm1s)) {
696   POPs;
697   POPs;
698   if (PL_op->op_type == OP_EXISTS)
699    RETPUSHNO;
700   else
701    RETPUSHUNDEF;
702  }
703
704  {
705   dA_MAP_THX;
706   const a_op_info *oi = a_map_fetch(PL_op);
707   return oi->old_pp(aTHX);
708  }
709 }
710
711 /* --- Check functions ----------------------------------------------------- */
712
713 STATIC void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
714 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
715
716  if (o->op_type == type && o->op_ppaddr != new_pp
717                         && cUNOPo->op_first->op_type != OP_GV) {
718   dA_MAP_THX;
719   const a_op_info *oi = a_map_fetch(o);
720   if (oi) {
721    a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
722    o->op_ppaddr = new_pp;
723   }
724  }
725
726  return;
727 }
728
729 /* ... ck_pad{any,sv} ...................................................... */
730
731 /* Sadly, the padsv OPs we are interested in don't trigger the padsv check
732  * function, but are instead manually mutated from a padany. So we store
733  * the op entry in the op map in the padany check function, and we set their
734  * op_ppaddr member in our peephole optimizer replacement below. */
735
736 STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
737
738 STATIC OP *a_ck_padany(pTHX_ OP *o) {
739  UV hint;
740
741  o = a_old_ck_padany(aTHX_ o);
742
743  hint = a_hint();
744  if (hint & A_HINT_DO)
745   a_map_store_root(o, o->op_ppaddr, hint);
746  else
747   a_map_delete(o);
748
749  return o;
750 }
751
752 STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
753
754 STATIC OP *a_ck_padsv(pTHX_ OP *o) {
755  UV hint;
756
757  o = a_old_ck_padsv(aTHX_ o);
758
759  hint = a_hint();
760  if (hint & A_HINT_DO) {
761   a_map_store_root(o, o->op_ppaddr, hint);
762   o->op_ppaddr = a_pp_deref;
763  } else
764   a_map_delete(o);
765
766  return o;
767 }
768
769 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
770
771 /* Those ops appear both at the root and inside an expression but there's no
772  * way to distinguish both situations. Worse, we can't even know if we are in a
773  * modifying context, so the expression can't be resolved yet. It will be at the
774  * first invocation of a_pp_deref() for this expression. */
775
776 STATIC OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
777 STATIC OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
778 STATIC OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
779
780 STATIC OP *a_ck_deref(pTHX_ OP *o) {
781  OP * (*old_ck)(pTHX_ OP *o) = 0;
782  UV hint = a_hint();
783
784  switch (o->op_type) {
785   case OP_AELEM:
786    old_ck = a_old_ck_aelem;
787    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
788     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
789    break;
790   case OP_HELEM:
791    old_ck = a_old_ck_helem;
792    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
793     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
794    break;
795   case OP_RV2SV:
796    old_ck = a_old_ck_rv2sv;
797    break;
798  }
799  o = old_ck(aTHX_ o);
800
801  if (hint & A_HINT_DO) {
802   a_map_store_root(o, o->op_ppaddr, hint);
803   o->op_ppaddr = a_pp_deref;
804  } else
805   a_map_delete(o);
806
807  return o;
808 }
809
810 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
811
812 /* Those ops also appear both inisde and at the root, hence the caveats for
813  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
814  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
815  * expression. */
816
817 STATIC OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
818 STATIC OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
819
820 STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
821  OP * (*old_ck)(pTHX_ OP *o) = 0;
822  OP * (*new_pp)(pTHX)        = 0;
823  UV hint;
824
825  switch (o->op_type) {
826   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
827   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
828  }
829  o = old_ck(aTHX_ o);
830
831  if (cUNOPo->op_first->op_type == OP_GV)
832   return o;
833
834  hint = a_hint();
835  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
836   a_map_store_root(o, o->op_ppaddr, hint);
837   o->op_ppaddr = new_pp;
838  } else
839   a_map_delete(o);
840
841  return o;
842 }
843
844 /* ... ck_xslice (aslice,hslice) ........................................... */
845
846 /* I think those are only found at the root, but there's nothing that really
847  * prevent them to be inside the expression too. We only need to update the
848  * root so that the rest of the expression will see the right context when
849  * resolving. That's why we don't replace the ppaddr. */
850
851 STATIC OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
852 STATIC OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
853
854 STATIC OP *a_ck_xslice(pTHX_ OP *o) {
855  OP * (*old_ck)(pTHX_ OP *o) = 0;
856  UV hint = a_hint();
857
858  switch (o->op_type) {
859   case OP_ASLICE:
860    old_ck = a_old_ck_aslice;
861    break;
862   case OP_HSLICE:
863    old_ck = a_old_ck_hslice;
864    if (hint & A_HINT_DO)
865     a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv);
866    break;
867  }
868  o = old_ck(aTHX_ o);
869
870  if (hint & A_HINT_DO) {
871   a_map_store_root(o, 0, hint);
872  } else
873   a_map_delete(o);
874
875  return o;
876 }
877
878 /* ... ck_root (exists,delete,keys,values) ................................. */
879
880 /* Those ops are only found at the root of a dereferencing expression. We can
881  * then resolve at compile time if vivification must take place or not. */
882
883 STATIC OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
884 STATIC OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
885 STATIC OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
886 STATIC OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
887
888 STATIC OP *a_ck_root(pTHX_ OP *o) {
889  OP * (*old_ck)(pTHX_ OP *o) = 0;
890  OP * (*new_pp)(pTHX)        = 0;
891  bool enabled = FALSE;
892  UV hint = a_hint();
893
894  switch (o->op_type) {
895   case OP_EXISTS:
896    old_ck  = a_old_ck_exists;
897    new_pp  = a_pp_root_binop;
898    enabled = hint & A_HINT_EXISTS;
899    break;
900   case OP_DELETE:
901    old_ck  = a_old_ck_delete;
902    new_pp  = a_pp_root_binop;
903    enabled = hint & A_HINT_DELETE;
904    break;
905   case OP_KEYS:
906    old_ck  = a_old_ck_keys;
907    new_pp  = a_pp_root_unop;
908    enabled = hint & A_HINT_FETCH;
909    break;
910   case OP_VALUES:
911    old_ck  = a_old_ck_values;
912    new_pp  = a_pp_root_unop;
913    enabled = hint & A_HINT_FETCH;
914    break;
915  }
916  o = old_ck(aTHX_ o);
917
918  if (hint & A_HINT_DO) {
919   if (enabled) {
920    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
921    a_map_store_root(o, o->op_ppaddr, hint);
922    o->op_ppaddr = new_pp;
923   } else {
924    a_map_cancel(o);
925   }
926  } else
927   a_map_delete(o);
928
929  return o;
930 }
931
932 /* ... Our peephole optimizer .............................................. */
933
934 STATIC peep_t a_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
935
936 STATIC void a_peep_rec(pTHX_ OP *o, ptable *seen);
937
938 STATIC void a_peep_rec(pTHX_ OP *o, ptable *seen) {
939 #define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen)
940  for (; o; o = o->op_next) {
941   dA_MAP_THX;
942   const a_op_info *oi = NULL;
943   UV flags = 0;
944
945   if (ptable_fetch(seen, o))
946    break;
947   ptable_seen_store(seen, o, o);
948
949   switch (o->op_type) {
950    case OP_PADSV:
951     if (o->op_ppaddr != a_pp_deref) {
952      oi = a_map_fetch(o);
953      if (oi && (oi->flags & A_HINT_DO)) {
954       a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
955       o->op_ppaddr = a_pp_deref;
956      }
957     }
958     /* FALLTHROUGH */
959    case OP_AELEM:
960    case OP_AELEMFAST:
961    case OP_HELEM:
962    case OP_RV2SV:
963     if (o->op_ppaddr != a_pp_deref)
964      break;
965     oi = a_map_fetch(o);
966     if (!oi)
967      break;
968     flags = oi->flags;
969     if (!(flags & A_HINT_DEREF)
970         && (flags & A_HINT_DO)
971         && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
972      /* Decide if the expression must autovivify or not. */
973      flags = a_map_resolve(o, oi);
974     }
975     if (flags & A_HINT_DEREF)
976      o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER);
977     else
978      o->op_ppaddr  = oi->old_pp;
979     break;
980    case OP_RV2AV:
981    case OP_RV2HV:
982     if (   o->op_ppaddr != a_pp_rv2av
983         && o->op_ppaddr != a_pp_rv2hv
984         && o->op_ppaddr != a_pp_rv2hv_simple)
985      break;
986     oi = a_map_fetch(o);
987     if (!oi)
988      break;
989     if (!(oi->flags & A_HINT_DEREF))
990      o->op_ppaddr  = oi->old_pp;
991     break;
992 #if !A_HAS_RPEEP
993    case OP_MAPWHILE:
994    case OP_GREPWHILE:
995    case OP_AND:
996    case OP_OR:
997    case OP_ANDASSIGN:
998    case OP_ORASSIGN:
999    case OP_COND_EXPR:
1000    case OP_RANGE:
1001 # if A_HAS_PERL(5, 10, 0)
1002    case OP_ONCE:
1003    case OP_DOR:
1004    case OP_DORASSIGN:
1005 # endif
1006     a_peep_rec(cLOGOPo->op_other);
1007     break;
1008    case OP_ENTERLOOP:
1009    case OP_ENTERITER:
1010     a_peep_rec(cLOOPo->op_redoop);
1011     a_peep_rec(cLOOPo->op_nextop);
1012     a_peep_rec(cLOOPo->op_lastop);
1013     break;
1014 # if A_HAS_PERL(5, 9, 5)
1015    case OP_SUBST:
1016     a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
1017     break;
1018 # else
1019    case OP_QR:
1020    case OP_MATCH:
1021    case OP_SUBST:
1022     a_peep_rec(cPMOPo->op_pmreplstart);
1023     break;
1024 # endif
1025 #endif /* !A_HAS_RPEEP */
1026    default:
1027     break;
1028   }
1029  }
1030 }
1031
1032 STATIC void a_peep(pTHX_ OP *o) {
1033  dMY_CXT;
1034  ptable *seen = MY_CXT.seen;
1035
1036  a_old_peep(aTHX_ o);
1037
1038  ptable_seen_clear(seen);
1039  a_peep_rec(o);
1040  ptable_seen_clear(seen);
1041 }
1042
1043 /* --- Interpreter setup/teardown ------------------------------------------ */
1044
1045 STATIC U32 a_initialized = 0;
1046
1047 STATIC void a_teardown(pTHX_ void *root) {
1048
1049  if (!a_initialized)
1050   return;
1051
1052 #if A_MULTIPLICITY
1053  if (aTHX != root)
1054   return;
1055 #endif
1056
1057  {
1058   dMY_CXT;
1059 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1060   ptable_hints_free(MY_CXT.tbl);
1061 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1062   ptable_seen_free(MY_CXT.seen);
1063  }
1064
1065  PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_old_ck_padany);
1066  a_old_ck_padany     = 0;
1067  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_old_ck_padsv);
1068  a_old_ck_padsv      = 0;
1069
1070  PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_old_ck_aelem);
1071  a_old_ck_aelem      = 0;
1072  PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_old_ck_helem);
1073  a_old_ck_helem      = 0;
1074  PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_old_ck_rv2sv);
1075  a_old_ck_rv2sv      = 0;
1076
1077  PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_old_ck_rv2av);
1078  a_old_ck_rv2av      = 0;
1079  PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_old_ck_rv2hv);
1080  a_old_ck_rv2hv      = 0;
1081
1082  PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_old_ck_aslice);
1083  a_old_ck_aslice     = 0;
1084  PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_old_ck_hslice);
1085  a_old_ck_hslice     = 0;
1086
1087  PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_old_ck_exists);
1088  a_old_ck_exists     = 0;
1089  PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_old_ck_delete);
1090  a_old_ck_delete     = 0;
1091  PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_old_ck_keys);
1092  a_old_ck_keys       = 0;
1093  PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_old_ck_values);
1094  a_old_ck_values     = 0;
1095
1096 #if A_HAS_RPEEP
1097  PL_rpeepp  = a_old_peep;
1098 #else
1099  PL_peepp   = a_old_peep;
1100 #endif
1101  a_old_peep = 0;
1102
1103  a_initialized = 0;
1104 }
1105
1106 STATIC void a_setup(pTHX) {
1107 #define a_setup() a_setup(aTHX)
1108  if (a_initialized)
1109   return;
1110
1111  {
1112   MY_CXT_INIT;
1113 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1114   MY_CXT.tbl   = ptable_new();
1115   MY_CXT.owner = aTHX;
1116 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1117   MY_CXT.seen  = ptable_new();
1118  }
1119
1120  a_old_ck_padany     = PL_check[OP_PADANY];
1121  PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_ck_padany);
1122  a_old_ck_padsv      = PL_check[OP_PADSV];
1123  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_ck_padsv);
1124
1125  a_old_ck_aelem      = PL_check[OP_AELEM];
1126  PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_ck_deref);
1127  a_old_ck_helem      = PL_check[OP_HELEM];
1128  PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_ck_deref);
1129  a_old_ck_rv2sv      = PL_check[OP_RV2SV];
1130  PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_ck_deref);
1131
1132  a_old_ck_rv2av      = PL_check[OP_RV2AV];
1133  PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
1134  a_old_ck_rv2hv      = PL_check[OP_RV2HV];
1135  PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
1136
1137  a_old_ck_aslice     = PL_check[OP_ASLICE];
1138  PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1139  a_old_ck_hslice     = PL_check[OP_HSLICE];
1140  PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1141
1142  a_old_ck_exists     = PL_check[OP_EXISTS];
1143  PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
1144  a_old_ck_delete     = PL_check[OP_DELETE];
1145  PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_ck_root);
1146  a_old_ck_keys       = PL_check[OP_KEYS];
1147  PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_ck_root);
1148  a_old_ck_values     = PL_check[OP_VALUES];
1149  PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_ck_root);
1150
1151 #if A_HAS_RPEEP
1152  a_old_peep = PL_rpeepp;
1153  PL_rpeepp  = a_peep;
1154 #else
1155  a_old_peep = PL_peepp;
1156  PL_peepp   = a_peep;
1157 #endif
1158
1159 #if A_MULTIPLICITY
1160  call_atexit(a_teardown, aTHX);
1161 #else
1162  call_atexit(a_teardown, NULL);
1163 #endif
1164
1165  a_initialized = 1;
1166 }
1167
1168 STATIC U32 a_booted = 0;
1169
1170 /* --- XS ------------------------------------------------------------------ */
1171
1172 MODULE = autovivification      PACKAGE = autovivification
1173
1174 PROTOTYPES: ENABLE
1175
1176 BOOT:
1177 {
1178  if (!a_booted++) {
1179   HV *stash;
1180
1181   a_op_map = ptable_new();
1182 #ifdef USE_ITHREADS
1183   MUTEX_INIT(&a_op_map_mutex);
1184 #endif
1185
1186   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
1187
1188   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1189   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1190   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1191   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1192   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1193   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1194   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1195   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1196   newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(A_THREADSAFE));
1197   newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(A_FORKSAFE));
1198  }
1199
1200  a_setup();
1201 }
1202
1203 #if A_THREADSAFE
1204
1205 void
1206 CLONE(...)
1207 PROTOTYPE: DISABLE
1208 PREINIT:
1209 #if A_WORKAROUND_REQUIRE_PROPAGATION
1210  ptable *t;
1211 #endif
1212  ptable *s;
1213 PPCODE:
1214  {
1215   dMY_CXT;
1216 #if A_WORKAROUND_REQUIRE_PROPAGATION
1217   {
1218    a_ptable_clone_ud ud;
1219
1220    t = ptable_new();
1221    a_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1222    ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1223    a_ptable_clone_ud_deinit(ud);
1224   }
1225 #endif
1226   s = ptable_new();
1227  }
1228  {
1229   MY_CXT_CLONE;
1230 #if A_WORKAROUND_REQUIRE_PROPAGATION
1231   MY_CXT.tbl   = t;
1232   MY_CXT.owner = aTHX;
1233 #endif
1234   MY_CXT.seen  = s;
1235  }
1236  reap(3, a_thread_cleanup, NULL);
1237  XSRETURN(0);
1238
1239 #endif /* A_THREADSAFE */
1240
1241 SV *
1242 _tag(SV *hint)
1243 PROTOTYPE: $
1244 CODE:
1245  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1246 OUTPUT:
1247  RETVAL
1248
1249 SV *
1250 _detag(SV *tag)
1251 PROTOTYPE: $
1252 CODE:
1253  if (!SvOK(tag))
1254   XSRETURN_UNDEF;
1255  RETVAL = newSVuv(a_detag(tag));
1256 OUTPUT:
1257  RETVAL