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