]> git.vpit.fr Git - perl/modules/autovivification.git/blob - autovivification.xs
828ea9a91c2389d0acf6ce8f191dbc45be4a1677
[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 #ifndef A_HAS_MULTIDEREF
33 # define A_HAS_MULTIDEREF A_HAS_PERL(5, 21, 7)
34 #endif
35
36 #ifndef OpSIBLING
37 # ifdef OP_SIBLING
38 #  define OpSIBLING(O) OP_SIBLING(O)
39 # else
40 #  define OpSIBLING(O) ((O)->op_sibling)
41 # endif
42 #endif
43
44 /* ... Our vivify_ref() .................................................... */
45
46 /* Perl_vivify_ref() is not exported, so we have to reimplement it. */
47
48 #if A_HAS_MULTIDEREF
49
50 static SV *a_vivify_ref(pTHX_ SV *sv, int to_hash) {
51 #define a_vivify_ref(S, TH) a_vivify_ref(aTHX_ (S), (TH))
52  SvGETMAGIC(sv);
53
54  if (!SvOK(sv)) {
55   SV *val;
56
57   if (SvREADONLY(sv))
58    Perl_croak_no_modify();
59
60   /* Inlined prepare_SV_for_RV() */
61   if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV) {
62    sv_upgrade(sv, SVt_IV);
63   } else if (SvTYPE(sv) >= SVt_PV) {
64    SvPV_free(sv);
65    SvLEN_set(sv, 0);
66    SvCUR_set(sv, 0);
67   }
68
69   val = to_hash ? MUTABLE_SV(newHV()) : MUTABLE_SV(newAV());
70   SvRV_set(sv, val);
71   SvROK_on(sv);
72   SvSETMAGIC(sv);
73   SvGETMAGIC(sv);
74  }
75
76  if (SvGMAGICAL(sv)) {
77   SV *msv = sv_newmortal();
78   sv_setsv_nomg(msv, sv);
79   return msv;
80  }
81
82  return sv;
83 }
84
85 #endif /* A_HAS_MULTIDEREF */
86
87 /* ... Thread safety and multiplicity ...................................... */
88
89 /* Always safe when the workaround isn't needed */
90 #if !A_WORKAROUND_REQUIRE_PROPAGATION
91 # undef A_FORKSAFE
92 # define A_FORKSAFE 1
93 /* Otherwise, safe unless Makefile.PL says it's Win32 */
94 #elif !defined(A_FORKSAFE)
95 # define A_FORKSAFE 1
96 #endif
97
98 #ifndef A_MULTIPLICITY
99 # if defined(MULTIPLICITY)
100 #  define A_MULTIPLICITY 1
101 # else
102 #  define A_MULTIPLICITY 0
103 # endif
104 #endif
105 #if A_MULTIPLICITY
106 # ifndef PERL_IMPLICIT_CONTEXT
107 #  error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT
108 # endif
109 #endif
110
111 #ifndef tTHX
112 # define tTHX PerlInterpreter*
113 #endif
114
115 #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))
116 # define A_THREADSAFE 1
117 # ifndef MY_CXT_CLONE
118 #  define MY_CXT_CLONE \
119     dMY_CXT_SV;                                                      \
120     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
121     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
122     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
123 # endif
124 #else
125 # define A_THREADSAFE 0
126 # undef  dMY_CXT
127 # define dMY_CXT      dNOOP
128 # undef  MY_CXT
129 # define MY_CXT       a_globaldata
130 # undef  START_MY_CXT
131 # define START_MY_CXT static my_cxt_t MY_CXT;
132 # undef  MY_CXT_INIT
133 # define MY_CXT_INIT  NOOP
134 # undef  MY_CXT_CLONE
135 # define MY_CXT_CLONE NOOP
136 #endif
137
138 #if A_THREADSAFE
139 /* We must use preexistent global mutexes or we will never be able to destroy
140  * them. */
141 # if A_HAS_PERL(5, 9, 3)
142 #  define A_LOADED_LOCK   MUTEX_LOCK(&PL_my_ctx_mutex)
143 #  define A_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex)
144 # else
145 #  define A_LOADED_LOCK   OP_REFCNT_LOCK
146 #  define A_LOADED_UNLOCK OP_REFCNT_UNLOCK
147 # endif
148 #else
149 # define A_LOADED_LOCK   NOOP
150 # define A_LOADED_UNLOCK NOOP
151 #endif
152
153 #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
154 # define A_CHECK_LOCK   OP_CHECK_MUTEX_LOCK
155 # define A_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK
156 #elif A_HAS_PERL(5, 9, 3)
157 # define A_CHECK_LOCK   OP_REFCNT_LOCK
158 # define A_CHECK_UNLOCK OP_REFCNT_UNLOCK
159 #else
160 /* Before perl 5.9.3, indirect_ck_*() calls are already protected by the
161  * A_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't
162  * lock it twice. */
163 # define A_CHECK_LOCK   NOOP
164 # define A_CHECK_UNLOCK NOOP
165 #endif
166
167 typedef OP *(*a_ck_t)(pTHX_ OP *);
168
169 #ifdef wrap_op_checker
170
171 # define a_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
172
173 #else
174
175 static void a_ck_replace(pTHX_ OPCODE type, a_ck_t new_ck, a_ck_t *old_ck_p) {
176 #define a_ck_replace(T, NC, OCP) a_ck_replace(aTHX_ (T), (NC), (OCP))
177  A_CHECK_LOCK;
178  if (!*old_ck_p) {
179   *old_ck_p      = PL_check[type];
180   PL_check[type] = new_ck;
181  }
182  A_CHECK_UNLOCK;
183 }
184
185 #endif
186
187 static void a_ck_restore(pTHX_ OPCODE type, a_ck_t *old_ck_p) {
188 #define a_ck_restore(T, OCP) a_ck_restore(aTHX_ (T), (OCP))
189  A_CHECK_LOCK;
190  if (*old_ck_p) {
191   PL_check[type] = *old_ck_p;
192   *old_ck_p      = 0;
193  }
194  A_CHECK_UNLOCK;
195 }
196
197 /* --- Helpers ------------------------------------------------------------- */
198
199 /* ... Check if the module is loaded ....................................... */
200
201 static I32 a_loaded = 0;
202
203 #if A_THREADSAFE
204
205 #define PTABLE_NAME        ptable_loaded
206 #define PTABLE_NEED_DELETE 1
207 #define PTABLE_NEED_WALK   0
208
209 #include "ptable.h"
210
211 #define ptable_loaded_store(T, K, V) ptable_loaded_store(aPTBLMS_ (T), (K), (V))
212 #define ptable_loaded_delete(T, K)   ptable_loaded_delete(aPTBLMS_ (T), (K))
213 #define ptable_loaded_free(T)        ptable_loaded_free(aPTBLMS_ (T))
214
215 static ptable *a_loaded_cxts = NULL;
216
217 static int a_is_loaded(pTHX_ void *cxt) {
218 #define a_is_loaded(C) a_is_loaded(aTHX_ (C))
219  int res = 0;
220
221  A_LOADED_LOCK;
222  if (a_loaded_cxts && ptable_fetch(a_loaded_cxts, cxt))
223   res = 1;
224  A_LOADED_UNLOCK;
225
226  return res;
227 }
228
229 static int a_set_loaded_locked(pTHX_ void *cxt) {
230 #define a_set_loaded_locked(C) a_set_loaded_locked(aTHX_ (C))
231  int global_setup = 0;
232
233  if (a_loaded <= 0) {
234   assert(a_loaded == 0);
235   assert(!a_loaded_cxts);
236   a_loaded_cxts = ptable_new();
237   global_setup  = 1;
238  }
239  ++a_loaded;
240  assert(a_loaded_cxts);
241  ptable_loaded_store(a_loaded_cxts, cxt, cxt);
242
243  return global_setup;
244 }
245
246 static int a_clear_loaded_locked(pTHX_ void *cxt) {
247 #define a_clear_loaded_locked(C) a_clear_loaded_locked(aTHX_ (C))
248  int global_teardown = 0;
249
250  if (a_loaded > 1) {
251   assert(a_loaded_cxts);
252   ptable_loaded_delete(a_loaded_cxts, cxt);
253   --a_loaded;
254  } else if (a_loaded_cxts) {
255   assert(a_loaded == 1);
256   ptable_loaded_free(a_loaded_cxts);
257   a_loaded_cxts   = NULL;
258   a_loaded        = 0;
259   global_teardown = 1;
260  }
261
262  return global_teardown;
263 }
264
265 #else
266
267 #define a_is_loaded(C)           (a_loaded > 0)
268 #define a_set_loaded_locked(C)   ((a_loaded++ <= 0) ? 1 : 0)
269 #define a_clear_loaded_locked(C) ((--a_loaded <= 0) ? 1 : 0)
270
271 #endif
272
273 /* ... Thread-safe hints ................................................... */
274
275 #if A_WORKAROUND_REQUIRE_PROPAGATION
276
277 typedef struct {
278  U32 bits;
279  IV  require_tag;
280 } a_hint_t;
281
282 #define A_HINT_FREE(H) PerlMemShared_free(H)
283
284 #if A_THREADSAFE
285
286 #define PTABLE_NAME        ptable_hints
287 #define PTABLE_VAL_FREE(V) A_HINT_FREE(V)
288 #define PTABLE_NEED_DELETE 0
289 #define PTABLE_NEED_WALK   1
290
291 #define pPTBL  pTHX
292 #define pPTBL_ pTHX_
293 #define aPTBL  aTHX
294 #define aPTBL_ aTHX_
295
296 #include "ptable.h"
297
298 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
299 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
300
301 #endif /* A_THREADSAFE */
302
303 #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
304
305 #define PTABLE_NAME        ptable_seen
306 #define PTABLE_NEED_DELETE 0
307 #define PTABLE_NEED_WALK   0
308
309 #include "ptable.h"
310
311 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
312 #define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
313 #define ptable_seen_clear(T)       ptable_seen_clear(aPTBLMS_ (T))
314 #define ptable_seen_free(T)        ptable_seen_free(aPTBLMS_ (T))
315
316 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
317
318 typedef struct {
319  peep_t  old_peep; /* This is actually the rpeep past 5.13.5 */
320  ptable *seen;     /* It really is a ptable_seen */
321 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
322  ptable *tbl;      /* It really is a ptable_hints */
323  tTHX    owner;
324 #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
325 } my_cxt_t;
326
327 START_MY_CXT
328
329 #if A_WORKAROUND_REQUIRE_PROPAGATION
330
331 #if A_THREADSAFE
332
333 typedef struct {
334  ptable       *tbl;
335 #if A_HAS_PERL(5, 13, 2)
336  CLONE_PARAMS *params;
337 #else
338  CLONE_PARAMS  params;
339 #endif
340 } a_ptable_clone_ud;
341
342 #if A_HAS_PERL(5, 13, 2)
343 # define a_ptable_clone_ud_init(U, T, O) \
344    (U).tbl    = (T); \
345    (U).params = Perl_clone_params_new((O), aTHX)
346 # define a_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
347 # define a_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), (U)->params))
348 #else
349 # define a_ptable_clone_ud_init(U, T, O) \
350    (U).tbl               = (T);     \
351    (U).params.stashes    = newAV(); \
352    (U).params.flags      = 0;       \
353    (U).params.proto_perl = (O)
354 # define a_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
355 # define a_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), &((U)->params)))
356 #endif
357
358 static void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
359  a_ptable_clone_ud *ud = ud_;
360  a_hint_t *h1 = ent->val;
361  a_hint_t *h2;
362
363  h2              = PerlMemShared_malloc(sizeof *h2);
364  h2->bits        = h1->bits;
365  h2->require_tag = PTR2IV(a_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
366
367  ptable_hints_store(ud->tbl, ent->key, h2);
368 }
369
370 #endif /* A_THREADSAFE */
371
372 static IV a_require_tag(pTHX) {
373 #define a_require_tag() a_require_tag(aTHX)
374  const CV *cv, *outside;
375
376  cv = PL_compcv;
377
378  if (!cv) {
379   /* If for some reason the pragma is operational at run-time, try to discover
380    * the current cv in use. */
381   const PERL_SI *si;
382
383   for (si = PL_curstackinfo; si; si = si->si_prev) {
384    I32 cxix;
385
386    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
387     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
388
389     switch (CxTYPE(cx)) {
390      case CXt_SUB:
391      case CXt_FORMAT:
392       /* The propagation workaround is only needed up to 5.10.0 and at that
393        * time format and sub contexts were still identical. And even later the
394        * cv members offsets should have been kept the same. */
395       cv = cx->blk_sub.cv;
396       goto get_enclosing_cv;
397      case CXt_EVAL:
398       cv = cx->blk_eval.cv;
399       goto get_enclosing_cv;
400      default:
401       break;
402     }
403    }
404   }
405
406   cv = PL_main_cv;
407  }
408
409 get_enclosing_cv:
410  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
411   cv = outside;
412
413  return PTR2IV(cv);
414 }
415
416 static SV *a_tag(pTHX_ UV bits) {
417 #define a_tag(B) a_tag(aTHX_ (B))
418  a_hint_t *h;
419 #if A_THREADSAFE
420  dMY_CXT;
421
422  if (!MY_CXT.tbl)
423   return newSViv(0);
424 #endif /* A_THREADSAFE */
425
426  h              = PerlMemShared_malloc(sizeof *h);
427  h->bits        = bits;
428  h->require_tag = a_require_tag();
429
430 #if A_THREADSAFE
431  /* We only need for the key to be an unique tag for looking up the value later
432   * Allocated memory provides convenient unique identifiers, so that's why we
433   * use the hint as the key itself. */
434  ptable_hints_store(MY_CXT.tbl, h, h);
435 #endif /* A_THREADSAFE */
436
437  return newSViv(PTR2IV(h));
438 }
439
440 static UV a_detag(pTHX_ const SV *hint) {
441 #define a_detag(H) a_detag(aTHX_ (H))
442  a_hint_t *h;
443 #if A_THREADSAFE
444  dMY_CXT;
445
446  if (!MY_CXT.tbl)
447   return 0;
448 #endif /* A_THREADSAFE */
449
450  if (!(hint && SvIOK(hint)))
451   return 0;
452
453  h = INT2PTR(a_hint_t *, SvIVX(hint));
454 #if A_THREADSAFE
455  h = ptable_fetch(MY_CXT.tbl, h);
456 #endif /* A_THREADSAFE */
457
458  if (a_require_tag() != h->require_tag)
459   return 0;
460
461  return h->bits;
462 }
463
464 #else /* A_WORKAROUND_REQUIRE_PROPAGATION */
465
466 #define a_tag(B)   newSVuv(B)
467 /* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV
468  * from a copy. */
469 #define a_detag(H) \
470  ((H)              \
471   ? (SvIOK(H)      \
472      ? SvUVX(H)    \
473      : (SvPOK(H)   \
474         ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
475         : 0        \
476        )           \
477      )             \
478   : 0)
479
480 #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
481
482 /* Used both for hints and op flags */
483 #define A_HINT_STRICT 1
484 #define A_HINT_WARN   2
485 #define A_HINT_FETCH  4
486 #define A_HINT_STORE  8
487 #define A_HINT_EXISTS 16
488 #define A_HINT_DELETE 32
489 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
490 #define A_HINT_DO     (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
491 #define A_HINT_MASK   (A_HINT_NOTIFY|A_HINT_DO)
492
493 /* Only used in op flags */
494 #define A_HINT_ROOT   64
495 #define A_HINT_DEREF  128
496
497 static VOL U32 a_hash = 0;
498
499 static UV a_hint(pTHX) {
500 #define a_hint() a_hint(aTHX)
501  SV *hint;
502 #ifdef cop_hints_fetch_pvn
503  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, a_hash, 0);
504 #elif A_HAS_PERL(5, 9, 5)
505  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
506                                        NULL,
507                                        __PACKAGE__, __PACKAGE_LEN__,
508                                        0,
509                                        a_hash);
510 #else
511  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
512  if (!val)
513   return 0;
514  hint = *val;
515 #endif
516  return a_detag(hint);
517 }
518
519 /* ... op => info map ...................................................... */
520
521 typedef struct {
522  OP   *(*old_pp)(pTHX);
523  void   *next;
524  UV      flags;
525 } a_op_info;
526
527 #define PTABLE_NAME        ptable_map
528 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
529 #define PTABLE_NEED_DELETE 1
530 #define PTABLE_NEED_WALK   0
531
532 #include "ptable.h"
533
534 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
535 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
536 #define ptable_map_delete(T, K)   ptable_map_delete(aPTBLMS_ (T), (K))
537 #define ptable_map_free(T)        ptable_map_free(aPTBLMS_ (T))
538
539 static ptable *a_op_map = NULL;
540
541 #ifdef USE_ITHREADS
542
543 #define dA_MAP_THX a_op_info a_op_map_tmp_oi
544
545 static perl_mutex a_op_map_mutex;
546
547 #define A_LOCK(M)   MUTEX_LOCK(M)
548 #define A_UNLOCK(M) MUTEX_UNLOCK(M)
549
550 static const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
551  const a_op_info *val;
552
553  A_LOCK(&a_op_map_mutex);
554
555  val = ptable_fetch(a_op_map, o);
556  if (val) {
557   *oi = *val;
558   val = oi;
559  }
560
561  A_UNLOCK(&a_op_map_mutex);
562
563  return val;
564 }
565
566 #define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi)
567
568 #else /* USE_ITHREADS */
569
570 #define dA_MAP_THX dNOOP
571
572 #define A_LOCK(M)   NOOP
573 #define A_UNLOCK(M) NOOP
574
575 #define a_map_fetch(O) ptable_fetch(a_op_map, (O))
576
577 #endif /* !USE_ITHREADS */
578
579 static const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
580 #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F))
581  a_op_info *oi;
582
583  if (!(oi = ptable_fetch(a_op_map, o))) {
584   oi = PerlMemShared_malloc(sizeof *oi);
585   ptable_map_store(a_op_map, o, oi);
586  }
587
588  oi->old_pp = old_pp;
589  oi->next   = next;
590  oi->flags  = flags;
591
592  return oi;
593 }
594
595 static void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
596 #define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F))
597  A_LOCK(&a_op_map_mutex);
598
599  a_map_store_locked(o, old_pp, next, flags);
600
601  A_UNLOCK(&a_op_map_mutex);
602 }
603
604 static void a_map_delete(pTHX_ const OP *o) {
605 #define a_map_delete(O) a_map_delete(aTHX_ (O))
606  A_LOCK(&a_op_map_mutex);
607
608  ptable_map_delete(a_op_map, o);
609
610  A_UNLOCK(&a_op_map_mutex);
611 }
612
613 static const OP *a_map_descend(const OP *o) {
614  switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
615   case OA_BASEOP:
616   case OA_UNOP:
617   case OA_BINOP:
618   case OA_BASEOP_OR_UNOP:
619    return cUNOPo->op_first;
620   case OA_LIST:
621   case OA_LISTOP:
622    return cLISTOPo->op_last;
623  }
624
625  return NULL;
626 }
627
628 static void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV flags) {
629 #define a_map_store_root(R, PP, F) a_map_store_root(aPTBLMS_ (R), (PP), (F))
630  const a_op_info *roi;
631  a_op_info *oi;
632  const OP *o = root;
633
634  A_LOCK(&a_op_map_mutex);
635
636  roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT);
637
638  while (o->op_flags & OPf_KIDS) {
639   o = a_map_descend(o);
640   if (!o)
641    break;
642   if ((oi = ptable_fetch(a_op_map, o))) {
643    oi->flags &= ~A_HINT_ROOT;
644    oi->next   = (a_op_info *) roi;
645    break;
646   }
647  }
648
649  A_UNLOCK(&a_op_map_mutex);
650
651  return;
652 }
653
654 static void a_map_update_flags_topdown(const OP *root, UV flags) {
655  a_op_info *oi;
656  const OP *o = root;
657
658  A_LOCK(&a_op_map_mutex);
659
660  flags &= ~A_HINT_ROOT;
661
662  do {
663   if ((oi = ptable_fetch(a_op_map, o)))
664    oi->flags = (oi->flags & A_HINT_ROOT) | flags;
665   if (!(o->op_flags & OPf_KIDS))
666    break;
667   o = a_map_descend(o);
668  } while (o);
669
670  A_UNLOCK(&a_op_map_mutex);
671
672  return;
673 }
674
675 #define a_map_cancel(R) a_map_update_flags_topdown((R), 0)
676
677 static void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
678  a_op_info *oi;
679
680  A_LOCK(&a_op_map_mutex);
681
682  flags  &= ~A_HINT_ROOT;
683  rflags |=  A_HINT_ROOT;
684
685  oi = ptable_fetch(a_op_map, o);
686  while (!(oi->flags & A_HINT_ROOT)) {
687   oi->flags = flags;
688   oi        = oi->next;
689  }
690  oi->flags = rflags;
691
692  A_UNLOCK(&a_op_map_mutex);
693
694  return;
695 }
696
697 /* ... Decide whether this expression should be autovivified or not ........ */
698
699 static UV a_map_resolve(const OP *o, const a_op_info *oi) {
700  UV flags = 0, rflags;
701  const OP *root;
702  const a_op_info *roi = oi;
703
704  while (!(roi->flags & A_HINT_ROOT))
705   roi = roi->next;
706  if (!roi)
707   goto cancel;
708
709  rflags = roi->flags & ~A_HINT_ROOT;
710  if (!rflags)
711   goto cancel;
712
713  root = roi->next;
714  if (root->op_flags & OPf_MOD) {
715   if (rflags & A_HINT_STORE)
716    flags = (A_HINT_STORE|A_HINT_DEREF);
717  } else if (rflags & A_HINT_FETCH)
718    flags = (A_HINT_FETCH|A_HINT_DEREF);
719
720  if (!flags) {
721 cancel:
722   a_map_update_flags_bottomup(o, 0, 0);
723   return 0;
724  }
725
726  flags |= (rflags & A_HINT_NOTIFY);
727  a_map_update_flags_bottomup(o, flags, 0);
728
729  return oi->flags & A_HINT_ROOT ? 0 : flags;
730 }
731
732 /* ... Inspired from pp_defined() .......................................... */
733
734 static int a_undef(pTHX_ SV *sv) {
735 #define a_undef(S) a_undef(aTHX_ (S))
736  switch (SvTYPE(sv)) {
737   case SVt_NULL:
738    return 1;
739   case SVt_PVAV:
740    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
741                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
742     return 0;
743    break;
744   case SVt_PVHV:
745    if (HvARRAY(sv) || SvGMAGICAL(sv)
746                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
747     return 0;
748    break;
749   default:
750    SvGETMAGIC(sv);
751    if (SvOK(sv))
752     return 0;
753  }
754
755  return 1;
756 }
757
758 /* --- PP functions -------------------------------------------------------- */
759
760 /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp
761  * value, another extension might have saved our pp replacement as the ppaddr
762  * for this op, so this doesn't ensure that our function will never be called
763  * again. That's why we don't remove the op info from our map, so that it can
764  * still run correctly if required. */
765
766 /* ... pp_rv2av ............................................................ */
767
768 static OP *a_pp_rv2av(pTHX) {
769  dA_MAP_THX;
770  const a_op_info *oi;
771  dSP;
772
773  oi = a_map_fetch(PL_op);
774
775  if (oi->flags & A_HINT_DEREF) {
776   if (a_undef(TOPs)) {
777    /* We always need to push an empty array to fool the pp_aelem() that comes
778     * later. */
779    SV *av;
780    (void) POPs;
781    av = sv_2mortal((SV *) newAV());
782    PUSHs(av);
783    RETURN;
784   }
785  }
786
787  return oi->old_pp(aTHX);
788 }
789
790 /* ... pp_rv2hv ............................................................ */
791
792 static OP *a_pp_rv2hv_simple(pTHX) {
793  dA_MAP_THX;
794  const a_op_info *oi;
795  dSP;
796
797  oi = a_map_fetch(PL_op);
798
799  if (oi->flags & A_HINT_DEREF) {
800   if (a_undef(TOPs))
801    RETURN;
802  }
803
804  return oi->old_pp(aTHX);
805 }
806
807 static OP *a_pp_rv2hv(pTHX) {
808  dA_MAP_THX;
809  const a_op_info *oi;
810  dSP;
811
812  oi = a_map_fetch(PL_op);
813
814  if (oi->flags & A_HINT_DEREF) {
815   if (a_undef(TOPs)) {
816    SV *hv;
817    (void) POPs;
818    hv = sv_2mortal((SV *) newHV());
819    PUSHs(hv);
820    RETURN;
821   }
822  }
823
824  return oi->old_pp(aTHX);
825 }
826
827 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
828
829 static void a_cannot_vivify(pTHX_ UV flags) {
830 #define a_cannot_vivify(F) a_cannot_vivify(aTHX_ (F))
831  if (flags & A_HINT_STRICT)
832   croak("Reference vivification forbidden");
833  else if (flags & A_HINT_WARN)
834   warn("Reference was vivified");
835  else /* A_HINT_STORE */
836   croak("Can't vivify reference");
837 }
838
839 static OP *a_pp_deref(pTHX) {
840  dA_MAP_THX;
841  const a_op_info *oi;
842  UV flags;
843  dSP;
844
845  oi = a_map_fetch(PL_op);
846
847  flags = oi->flags;
848  if (flags & A_HINT_DEREF) {
849   OP *o;
850
851   o = oi->old_pp(aTHX);
852
853   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
854    SPAGAIN;
855    if (a_undef(TOPs))
856     a_cannot_vivify(flags);
857   }
858
859   return o;
860  }
861
862  return oi->old_pp(aTHX);
863 }
864
865 /* ... pp_root (exists,delete,keys,values) ................................. */
866
867 static OP *a_pp_root_unop(pTHX) {
868  dSP;
869
870  if (a_undef(TOPs)) {
871   (void) POPs;
872   /* Can only be reached by keys or values */
873   if (GIMME_V == G_SCALAR) {
874    dTARGET;
875    PUSHi(0);
876   }
877   RETURN;
878  }
879
880  {
881   dA_MAP_THX;
882   const a_op_info *oi = a_map_fetch(PL_op);
883   return oi->old_pp(aTHX);
884  }
885 }
886
887 static OP *a_pp_root_binop(pTHX) {
888  dSP;
889
890  if (a_undef(TOPm1s)) {
891   (void) POPs;
892   (void) POPs;
893   if (PL_op->op_type == OP_EXISTS)
894    RETPUSHNO;
895   else
896    RETPUSHUNDEF;
897  }
898
899  {
900   dA_MAP_THX;
901   const a_op_info *oi = a_map_fetch(PL_op);
902   return oi->old_pp(aTHX);
903  }
904 }
905
906 #if A_HAS_MULTIDEREF
907
908 /* ... pp_multideref ....................................................... */
909
910 /* This pp replacement is actually only called for topmost exists/delete ops,
911  * because we hijack the [ah]elem check functions and this disables the
912  * optimization for lvalue and rvalue dereferencing. In particular, the
913  * OPf_MOD branches should never be covered. In the future, the multideref
914  * optimization might also be disabled for custom exists/delete check functions,
915  * which will make this section unnecessary. However, the code tries to be as
916  * general as possible in case I think of a way to reenable the multideref
917  * optimization even when this module is in use. */
918
919 static UV a_do_multideref(const OP *o, UV flags) {
920  UV isexdel, other_flags;
921
922  assert(o->op_type == OP_MULTIDEREF);
923
924  other_flags = flags & ~A_HINT_DO;
925
926  isexdel = o->op_private & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE);
927  if (isexdel) {
928   if (isexdel & OPpMULTIDEREF_EXISTS) {
929    flags &= A_HINT_EXISTS;
930   } else {
931    flags &= A_HINT_DELETE;
932   }
933  } else {
934   if (o->op_flags & OPf_MOD) {
935    flags &= A_HINT_STORE;
936   } else {
937    flags &= A_HINT_FETCH;
938   }
939  }
940
941  return flags ? (flags | other_flags) : 0;
942 }
943
944 static SV *a_do_fake_pp(pTHX_ OP *op) {
945 #define a_do_fake_pp(O) a_do_fake_pp(aTHX_ (O))
946  {
947   OP *o = PL_op;
948   ENTER;
949   SAVEOP();
950   PL_op = op;
951   PL_op->op_ppaddr(aTHX);
952   PL_op = o;
953   LEAVE;
954  }
955
956  {
957   SV *ret;
958   dSP;
959   ret = POPs;
960   PUTBACK;
961   return ret;
962  }
963 }
964
965 static void a_do_fake_pp_unop_init(pTHX_ UNOP *unop, U32 type, U32 flags) {
966 #define a_do_fake_pp_unop_init(O, T, F) a_do_fake_pp_unop_init(aTHX_ (O), (T), (F))
967  unop->op_type    = type;
968  unop->op_flags   = OPf_WANT_SCALAR | (~OPf_WANT & flags);
969  unop->op_private = 0;
970  unop->op_first   = NULL;
971  unop->op_ppaddr  = PL_ppaddr[type];
972 }
973
974 static SV *a_do_fake_pp_unop_arg1(pTHX_ U32 type, U32 flags, SV *arg) {
975 #define a_do_fake_pp_unop_arg1(T, F, A) a_do_fake_pp_unop_arg1(aTHX_ (T), (F), (A))
976  UNOP unop;
977  dSP;
978
979  a_do_fake_pp_unop_init(&unop, type, flags);
980
981  EXTEND(SP, 1);
982  PUSHs(arg);
983  PUTBACK;
984
985  return a_do_fake_pp((OP *) &unop);
986 }
987
988 static SV *a_do_fake_pp_unop_arg2(pTHX_ U32 type, U32 flags, SV *arg1, SV *arg2) {
989 #define a_do_fake_pp_unop_arg2(T, F, A1, A2) a_do_fake_pp_unop_arg2(aTHX_ (T), (F), (A1), (A2))
990  UNOP unop;
991  dSP;
992
993  a_do_fake_pp_unop_init(&unop, type, flags);
994
995  EXTEND(SP, 2);
996  PUSHs(arg1);
997  PUSHs(arg2);
998  PUTBACK;
999
1000  return a_do_fake_pp((OP *) &unop);
1001 }
1002
1003 #define a_do_pp_rv2av(R)        a_do_fake_pp_unop_arg1(OP_RV2AV,  OPf_REF,     (R))
1004 #define a_do_pp_afetch(A, I)    a_do_fake_pp_unop_arg2(OP_AELEM,  0,           (A), (I))
1005 #define a_do_pp_afetch_lv(A, I) a_do_fake_pp_unop_arg2(OP_AELEM,  OPf_MOD,     (A), (I))
1006 #define a_do_pp_aexists(A, I)   a_do_fake_pp_unop_arg2(OP_EXISTS, OPf_SPECIAL, (A), (I))
1007 #define a_do_pp_adelete(A, I)   a_do_fake_pp_unop_arg2(OP_DELETE, OPf_SPECIAL, (A), (I))
1008
1009 #define a_do_pp_rv2hv(R)        a_do_fake_pp_unop_arg1(OP_RV2HV,  OPf_REF, (R))
1010 #define a_do_pp_hfetch(H, K)    a_do_fake_pp_unop_arg2(OP_HELEM,  0,       (H), (K))
1011 #define a_do_pp_hfetch_lv(H, K) a_do_fake_pp_unop_arg2(OP_HELEM,  OPf_MOD, (H), (K))
1012 #define a_do_pp_hexists(H, K)   a_do_fake_pp_unop_arg2(OP_EXISTS, 0,  (H), (K))
1013 #define a_do_pp_hdelete(H, K)   a_do_fake_pp_unop_arg2(OP_DELETE, 0,  (H), (K))
1014
1015 static OP *a_pp_multideref(pTHX) {
1016  UNOP_AUX_item *items;
1017  UV  actions;
1018  UV  flags = 0;
1019  SV *sv    = NULL;
1020  dSP;
1021
1022  {
1023   dA_MAP_THX;
1024   const a_op_info *oi = a_map_fetch(PL_op);
1025   assert(oi);
1026   flags = a_do_multideref(PL_op, oi->flags);
1027   if (!flags)
1028    return oi->old_pp(aTHX);
1029  }
1030
1031  items   = cUNOP_AUXx(PL_op)->op_aux;
1032  actions = items->uv;
1033
1034  PL_multideref_pc = items;
1035
1036  while (1) {
1037   switch (actions & MDEREF_ACTION_MASK) {
1038    case MDEREF_reload:
1039     actions = (++items)->uv;
1040     continue;
1041    case MDEREF_AV_padav_aelem: /* $lex[...] */
1042     sv = PAD_SVl((++items)->pad_offset);
1043     if (a_undef(sv))
1044      goto ret_undef;
1045     goto do_AV_aelem;
1046    case MDEREF_AV_gvav_aelem: /* $pkg[...] */
1047     sv = UNOP_AUX_item_sv(++items);
1048     assert(isGV_with_GP(sv));
1049     sv = (SV *) GvAVn((GV *) sv);
1050     if (a_undef(sv))
1051      goto ret_undef;
1052     goto do_AV_aelem;
1053    case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
1054     sv = POPs;
1055     if (a_undef(sv))
1056      goto ret_undef;
1057     goto do_AV_rv2av_aelem;
1058    case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
1059     sv = UNOP_AUX_item_sv(++items);
1060     assert(isGV_with_GP(sv));
1061     sv = GvSVn((GV *) sv);
1062     if (a_undef(sv))
1063      goto ret_undef;
1064     goto do_AV_vivify_rv2av_aelem;
1065    case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
1066     sv = PAD_SVl((++items)->pad_offset);
1067     /* FALLTHROUGH */
1068    case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
1069     if (a_undef(sv))
1070      goto ret_undef;
1071 do_AV_vivify_rv2av_aelem:
1072     sv = a_vivify_ref(sv, 0);
1073 do_AV_rv2av_aelem:
1074     sv = a_do_pp_rv2av(sv);
1075 do_AV_aelem:
1076     {
1077      SV *esv;
1078      assert(SvTYPE(sv) == SVt_PVAV);
1079      switch (actions & MDEREF_INDEX_MASK) {
1080       case MDEREF_INDEX_none:
1081        goto finish;
1082       case MDEREF_INDEX_const:
1083        esv = sv_2mortal(newSViv((++items)->iv));
1084        break;
1085       case MDEREF_INDEX_padsv:
1086        esv = PAD_SVl((++items)->pad_offset);
1087        goto check_elem;
1088       case MDEREF_INDEX_gvsv:
1089        esv = UNOP_AUX_item_sv(++items);
1090        assert(isGV_with_GP(esv));
1091        esv = GvSVn((GV *) esv);
1092 check_elem:
1093        if (UNLIKELY(SvROK(esv) && !SvGAMAGIC(esv) && ckWARN(WARN_MISC)))
1094         Perl_warner(aTHX_ packWARN(WARN_MISC),
1095                           "Use of reference \"%"SVf"\" as array index",
1096                           SVfARG(esv));
1097        break;
1098      }
1099      PL_multideref_pc = items;
1100      if (actions & MDEREF_FLAG_last) {
1101       switch (flags & A_HINT_DO) {
1102        case A_HINT_FETCH:
1103         sv = a_do_pp_afetch(sv, esv);
1104         break;
1105        case A_HINT_STORE:
1106         sv = a_do_pp_afetch_lv(sv, esv);
1107         break;
1108        case A_HINT_EXISTS:
1109         sv = a_do_pp_aexists(sv, esv);
1110         break;
1111        case A_HINT_DELETE:
1112         sv = a_do_pp_adelete(sv, esv);
1113         break;
1114       }
1115       goto finish;
1116      }
1117      sv = a_do_pp_afetch(sv, esv);
1118      break;
1119     }
1120    case MDEREF_HV_padhv_helem: /* $lex{...} */
1121     sv = PAD_SVl((++items)->pad_offset);
1122     if (a_undef(sv))
1123      goto ret_undef;
1124     goto do_HV_helem;
1125    case MDEREF_HV_gvhv_helem: /* $pkg{...} */
1126     sv = UNOP_AUX_item_sv(++items);
1127     assert(isGV_with_GP(sv));
1128     sv = (SV *) GvHVn((GV *) sv);
1129     if (a_undef(sv))
1130      goto ret_undef;
1131     goto do_HV_helem;
1132    case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
1133     sv = POPs;
1134     if (a_undef(sv))
1135      goto ret_undef;
1136     goto do_HV_rv2hv_helem;
1137    case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
1138     sv = UNOP_AUX_item_sv(++items);
1139     assert(isGV_with_GP(sv));
1140     sv = GvSVn((GV *) sv);
1141     if (a_undef(sv))
1142      goto ret_undef;
1143     goto do_HV_vivify_rv2hv_helem;
1144    case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
1145     sv = PAD_SVl((++items)->pad_offset);
1146     /* FALLTHROUGH */
1147    case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
1148     if (a_undef(sv))
1149      goto ret_undef;
1150 do_HV_vivify_rv2hv_helem:
1151     sv = a_vivify_ref(sv, 1);
1152 do_HV_rv2hv_helem:
1153     sv = a_do_pp_rv2hv(sv);
1154 do_HV_helem:
1155     {
1156      SV *key;
1157      assert(SvTYPE(sv) == SVt_PVHV);
1158      switch (actions & MDEREF_INDEX_MASK) {
1159       case MDEREF_INDEX_none:
1160        goto finish;
1161       case MDEREF_INDEX_const:
1162        key = UNOP_AUX_item_sv(++items);
1163        break;
1164       case MDEREF_INDEX_padsv:
1165        key = PAD_SVl((++items)->pad_offset);
1166        break;
1167       case MDEREF_INDEX_gvsv:
1168        key = UNOP_AUX_item_sv(++items);
1169        assert(isGV_with_GP(key));
1170        key = GvSVn((GV *) key);
1171        break;
1172      }
1173      PL_multideref_pc = items;
1174      if (actions & MDEREF_FLAG_last) {
1175       switch (flags & A_HINT_DO) {
1176        case A_HINT_FETCH:
1177         sv = a_do_pp_hfetch(sv, key);
1178         break;
1179        case A_HINT_STORE:
1180         sv = a_do_pp_hfetch_lv(sv, key);
1181         break;
1182        case A_HINT_EXISTS:
1183         sv = a_do_pp_hexists(sv, key);
1184         break;
1185        case A_HINT_DELETE:
1186         sv = a_do_pp_hdelete(sv, key);
1187         break;
1188        default:
1189         break;
1190       }
1191       goto finish;
1192      }
1193      sv = a_do_pp_hfetch(sv, key);
1194      break;
1195     }
1196   }
1197
1198   actions >>= MDEREF_SHIFT;
1199  }
1200
1201 ret_undef:
1202  if (flags & (A_HINT_NOTIFY|A_HINT_STORE))
1203   a_cannot_vivify(flags);
1204  if (flags & A_HINT_EXISTS)
1205   sv = &PL_sv_no;
1206  else
1207   sv = &PL_sv_undef;
1208 finish:
1209  XPUSHs(sv);
1210  RETURN;
1211 }
1212
1213 #endif /* A_HAS_MULTIDEREF */
1214
1215 /* --- Check functions ----------------------------------------------------- */
1216
1217 static void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
1218 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
1219
1220  if (o->op_type == type && o->op_ppaddr != new_pp
1221                         && cUNOPo->op_first->op_type != OP_GV) {
1222   dA_MAP_THX;
1223   const a_op_info *oi = a_map_fetch(o);
1224   if (oi) {
1225    a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1226    o->op_ppaddr = new_pp;
1227   }
1228  }
1229
1230  return;
1231 }
1232
1233 /* ... ck_pad{any,sv} ...................................................... */
1234
1235 /* Sadly, the padsv OPs we are interested in don't trigger the padsv check
1236  * function, but are instead manually mutated from a padany. So we store
1237  * the op entry in the op map in the padany check function, and we set their
1238  * op_ppaddr member in our peephole optimizer replacement below. */
1239
1240 static OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
1241
1242 static OP *a_ck_padany(pTHX_ OP *o) {
1243  UV hint;
1244
1245  o = a_old_ck_padany(aTHX_ o);
1246
1247  hint = a_hint();
1248  if (hint & A_HINT_DO)
1249   a_map_store_root(o, o->op_ppaddr, hint);
1250  else
1251   a_map_delete(o);
1252
1253  return o;
1254 }
1255
1256 static OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
1257
1258 static OP *a_ck_padsv(pTHX_ OP *o) {
1259  UV hint;
1260
1261  o = a_old_ck_padsv(aTHX_ o);
1262
1263  hint = a_hint();
1264  if (hint & A_HINT_DO) {
1265   a_map_store_root(o, o->op_ppaddr, hint);
1266   o->op_ppaddr = a_pp_deref;
1267  } else
1268   a_map_delete(o);
1269
1270  return o;
1271 }
1272
1273 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
1274
1275 /* Those ops appear both at the root and inside an expression but there's no
1276  * way to distinguish both situations. Worse, we can't even know if we are in a
1277  * modifying context, so the expression can't be resolved yet. It will be at the
1278  * first invocation of a_pp_deref() for this expression. */
1279
1280 static OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
1281 static OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
1282 static OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
1283
1284 static OP *a_ck_deref(pTHX_ OP *o) {
1285  OP * (*old_ck)(pTHX_ OP *o) = 0;
1286  UV hint = a_hint();
1287
1288  switch (o->op_type) {
1289   case OP_AELEM:
1290    old_ck = a_old_ck_aelem;
1291    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
1292     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
1293    break;
1294   case OP_HELEM:
1295    old_ck = a_old_ck_helem;
1296    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
1297     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
1298    break;
1299   case OP_RV2SV:
1300    old_ck = a_old_ck_rv2sv;
1301    break;
1302  }
1303  o = old_ck(aTHX_ o);
1304
1305 #if A_HAS_MULTIDEREF
1306  if (old_ck == a_old_ck_rv2sv && o->op_flags & OPf_KIDS) {
1307   OP *kid = cUNOPo->op_first;
1308   if (kid && kid->op_type == OP_GV) {
1309    if (hint & A_HINT_DO)
1310     a_map_store(kid, kid->op_ppaddr, NULL, hint);
1311    else
1312     a_map_delete(kid);
1313   }
1314  }
1315 #endif
1316
1317  if (hint & A_HINT_DO) {
1318   a_map_store_root(o, o->op_ppaddr, hint);
1319   o->op_ppaddr = a_pp_deref;
1320  } else
1321   a_map_delete(o);
1322
1323  return o;
1324 }
1325
1326 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
1327
1328 /* Those ops also appear both inisde and at the root, hence the caveats for
1329  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
1330  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
1331  * expression. */
1332
1333 static OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
1334 static OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
1335
1336 static OP *a_ck_rv2xv(pTHX_ OP *o) {
1337  OP * (*old_ck)(pTHX_ OP *o) = 0;
1338  OP * (*new_pp)(pTHX)        = 0;
1339  UV hint;
1340
1341  switch (o->op_type) {
1342   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
1343   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
1344  }
1345  o = old_ck(aTHX_ o);
1346
1347  if (cUNOPo->op_first->op_type == OP_GV)
1348   return o;
1349
1350  hint = a_hint();
1351  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
1352   a_map_store_root(o, o->op_ppaddr, hint);
1353   o->op_ppaddr = new_pp;
1354  } else
1355   a_map_delete(o);
1356
1357  return o;
1358 }
1359
1360 /* ... ck_xslice (aslice,hslice) ........................................... */
1361
1362 /* I think those are only found at the root, but there's nothing that really
1363  * prevent them to be inside the expression too. We only need to update the
1364  * root so that the rest of the expression will see the right context when
1365  * resolving. That's why we don't replace the ppaddr. */
1366
1367 static OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
1368 static OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
1369
1370 static OP *a_ck_xslice(pTHX_ OP *o) {
1371  OP * (*old_ck)(pTHX_ OP *o) = 0;
1372  UV hint = a_hint();
1373
1374  switch (o->op_type) {
1375   case OP_ASLICE:
1376    old_ck = a_old_ck_aslice;
1377    break;
1378   case OP_HSLICE:
1379    old_ck = a_old_ck_hslice;
1380    if (hint & A_HINT_DO)
1381     a_recheck_rv2xv(OpSIBLING(cUNOPo->op_first), OP_RV2HV, a_pp_rv2hv);
1382    break;
1383  }
1384  o = old_ck(aTHX_ o);
1385
1386  if (hint & A_HINT_DO) {
1387   a_map_store_root(o, 0, hint);
1388  } else
1389   a_map_delete(o);
1390
1391  return o;
1392 }
1393
1394 /* ... ck_root (exists,delete,keys,values) ................................. */
1395
1396 /* Those ops are only found at the root of a dereferencing expression. We can
1397  * then resolve at compile time if vivification must take place or not. */
1398
1399 static OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
1400 static OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
1401 static OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
1402 static OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
1403
1404 static OP *a_ck_root(pTHX_ OP *o) {
1405  OP * (*old_ck)(pTHX_ OP *o) = 0;
1406  OP * (*new_pp)(pTHX)        = 0;
1407  bool enabled = FALSE;
1408  UV hint = a_hint();
1409
1410  switch (o->op_type) {
1411   case OP_EXISTS:
1412    old_ck  = a_old_ck_exists;
1413    new_pp  = a_pp_root_binop;
1414    enabled = hint & A_HINT_EXISTS;
1415    break;
1416   case OP_DELETE:
1417    old_ck  = a_old_ck_delete;
1418    new_pp  = a_pp_root_binop;
1419    enabled = hint & A_HINT_DELETE;
1420    break;
1421   case OP_KEYS:
1422    old_ck  = a_old_ck_keys;
1423    new_pp  = a_pp_root_unop;
1424    enabled = hint & A_HINT_FETCH;
1425    break;
1426   case OP_VALUES:
1427    old_ck  = a_old_ck_values;
1428    new_pp  = a_pp_root_unop;
1429    enabled = hint & A_HINT_FETCH;
1430    break;
1431  }
1432  o = old_ck(aTHX_ o);
1433
1434  if (hint & A_HINT_DO) {
1435   if (enabled) {
1436    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
1437    a_map_store_root(o, o->op_ppaddr, hint);
1438    o->op_ppaddr = new_pp;
1439   } else {
1440    a_map_cancel(o);
1441   }
1442  } else
1443   a_map_delete(o);
1444
1445  return o;
1446 }
1447
1448 /* ... Our peephole optimizer .............................................. */
1449
1450 static void a_peep_rec(pTHX_ OP *o, ptable *seen);
1451
1452 static void a_peep_rec(pTHX_ OP *o, ptable *seen) {
1453 #define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen)
1454  for (; o; o = o->op_next) {
1455   dA_MAP_THX;
1456   const a_op_info *oi = NULL;
1457   UV flags = 0;
1458
1459 #if !A_HAS_RPEEP
1460   if (ptable_fetch(seen, o))
1461    break;
1462   ptable_seen_store(seen, o, o);
1463 #endif
1464
1465   switch (o->op_type) {
1466 #if A_HAS_RPEEP
1467    case OP_NEXTSTATE:
1468    case OP_DBSTATE:
1469    case OP_STUB:
1470    case OP_UNSTACK:
1471     if (ptable_fetch(seen, o))
1472      return;
1473     ptable_seen_store(seen, o, o);
1474     break;
1475 #endif
1476    case OP_PADSV:
1477     if (o->op_ppaddr != a_pp_deref) {
1478      oi = a_map_fetch(o);
1479      if (oi && (oi->flags & A_HINT_DO)) {
1480       a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1481       o->op_ppaddr = a_pp_deref;
1482      }
1483     }
1484     /* FALLTHROUGH */
1485    case OP_AELEM:
1486    case OP_AELEMFAST:
1487    case OP_HELEM:
1488    case OP_RV2SV:
1489     if (o->op_ppaddr != a_pp_deref)
1490      break;
1491     oi = a_map_fetch(o);
1492     if (!oi)
1493      break;
1494     flags = oi->flags;
1495     if (!(flags & A_HINT_DEREF)
1496         && (flags & A_HINT_DO)
1497         && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
1498      /* Decide if the expression must autovivify or not. */
1499      flags = a_map_resolve(o, oi);
1500     }
1501     if (flags & A_HINT_DEREF)
1502      o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER);
1503     else
1504      o->op_ppaddr  = oi->old_pp;
1505     break;
1506    case OP_RV2AV:
1507    case OP_RV2HV:
1508     if (   o->op_ppaddr != a_pp_rv2av
1509         && o->op_ppaddr != a_pp_rv2hv
1510         && o->op_ppaddr != a_pp_rv2hv_simple)
1511      break;
1512     oi = a_map_fetch(o);
1513     if (!oi)
1514      break;
1515     if (!(oi->flags & A_HINT_DEREF))
1516      o->op_ppaddr  = oi->old_pp;
1517     break;
1518 #if A_HAS_MULTIDEREF
1519    case OP_MULTIDEREF:
1520     if (o->op_ppaddr != a_pp_multideref) {
1521      oi = a_map_fetch(cUNOPo->op_first);
1522      if (!oi)
1523       break;
1524      flags = oi->flags;
1525      if (a_do_multideref(o, flags)) {
1526       a_map_store_root(o, o->op_ppaddr, flags & ~A_HINT_DEREF);
1527       o->op_ppaddr = a_pp_multideref;
1528      }
1529     }
1530     break;
1531 #endif
1532 #if !A_HAS_RPEEP
1533    case OP_MAPWHILE:
1534    case OP_GREPWHILE:
1535    case OP_AND:
1536    case OP_OR:
1537    case OP_ANDASSIGN:
1538    case OP_ORASSIGN:
1539    case OP_COND_EXPR:
1540    case OP_RANGE:
1541 # if A_HAS_PERL(5, 10, 0)
1542    case OP_ONCE:
1543    case OP_DOR:
1544    case OP_DORASSIGN:
1545 # endif
1546     a_peep_rec(cLOGOPo->op_other);
1547     break;
1548    case OP_ENTERLOOP:
1549    case OP_ENTERITER:
1550     a_peep_rec(cLOOPo->op_redoop);
1551     a_peep_rec(cLOOPo->op_nextop);
1552     a_peep_rec(cLOOPo->op_lastop);
1553     break;
1554 # if A_HAS_PERL(5, 9, 5)
1555    case OP_SUBST:
1556     a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
1557     break;
1558 # else
1559    case OP_QR:
1560    case OP_MATCH:
1561    case OP_SUBST:
1562     a_peep_rec(cPMOPo->op_pmreplstart);
1563     break;
1564 # endif
1565 #endif /* !A_HAS_RPEEP */
1566    default:
1567     break;
1568   }
1569  }
1570 }
1571
1572 static void a_peep(pTHX_ OP *o) {
1573  ptable *seen;
1574  dMY_CXT;
1575
1576  assert(a_is_loaded(&MY_CXT));
1577
1578  MY_CXT.old_peep(aTHX_ o);
1579
1580  seen = MY_CXT.seen;
1581  if (seen) {
1582   ptable_seen_clear(seen);
1583   a_peep_rec(o);
1584   ptable_seen_clear(seen);
1585  }
1586 }
1587
1588 /* --- Module setup/teardown ----------------------------------------------- */
1589
1590 static void a_teardown(pTHX_ void *root) {
1591  dMY_CXT;
1592
1593  A_LOADED_LOCK;
1594
1595  if (a_clear_loaded_locked(&MY_CXT)) {
1596   a_ck_restore(OP_PADANY, &a_old_ck_padany);
1597   a_ck_restore(OP_PADSV,  &a_old_ck_padsv);
1598
1599   a_ck_restore(OP_AELEM,  &a_old_ck_aelem);
1600   a_ck_restore(OP_HELEM,  &a_old_ck_helem);
1601   a_ck_restore(OP_RV2SV,  &a_old_ck_rv2sv);
1602
1603   a_ck_restore(OP_RV2AV,  &a_old_ck_rv2av);
1604   a_ck_restore(OP_RV2HV,  &a_old_ck_rv2hv);
1605
1606   a_ck_restore(OP_ASLICE, &a_old_ck_aslice);
1607   a_ck_restore(OP_HSLICE, &a_old_ck_hslice);
1608
1609   a_ck_restore(OP_EXISTS, &a_old_ck_exists);
1610   a_ck_restore(OP_DELETE, &a_old_ck_delete);
1611   a_ck_restore(OP_KEYS,   &a_old_ck_keys);
1612   a_ck_restore(OP_VALUES, &a_old_ck_values);
1613
1614   ptable_map_free(a_op_map);
1615   a_op_map = NULL;
1616
1617 #ifdef USE_ITHREADS
1618   MUTEX_DESTROY(&a_op_map_mutex);
1619 #endif
1620  }
1621
1622  A_LOADED_UNLOCK;
1623
1624  if (MY_CXT.old_peep) {
1625 #if A_HAS_RPEEP
1626   PL_rpeepp = MY_CXT.old_peep;
1627 #else
1628   PL_peepp  = MY_CXT.old_peep;
1629 #endif
1630   MY_CXT.old_peep = 0;
1631  }
1632
1633  ptable_seen_free(MY_CXT.seen);
1634  MY_CXT.seen = NULL;
1635
1636 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1637  ptable_hints_free(MY_CXT.tbl);
1638  MY_CXT.tbl  = NULL;
1639 #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1640
1641  return;
1642 }
1643
1644 static void a_setup(pTHX) {
1645 #define a_setup() a_setup(aTHX)
1646  MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */
1647
1648  A_LOADED_LOCK;
1649
1650  if (a_set_loaded_locked(&MY_CXT)) {
1651   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
1652
1653   a_op_map = ptable_new();
1654
1655 #ifdef USE_ITHREADS
1656   MUTEX_INIT(&a_op_map_mutex);
1657 #endif
1658
1659   a_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany);
1660   a_ck_replace(OP_PADSV,  a_ck_padsv,  &a_old_ck_padsv);
1661
1662   a_ck_replace(OP_AELEM,  a_ck_deref,  &a_old_ck_aelem);
1663   a_ck_replace(OP_HELEM,  a_ck_deref,  &a_old_ck_helem);
1664   a_ck_replace(OP_RV2SV,  a_ck_deref,  &a_old_ck_rv2sv);
1665
1666   a_ck_replace(OP_RV2AV,  a_ck_rv2xv,  &a_old_ck_rv2av);
1667   a_ck_replace(OP_RV2HV,  a_ck_rv2xv,  &a_old_ck_rv2hv);
1668
1669   a_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice);
1670   a_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice);
1671
1672   a_ck_replace(OP_EXISTS, a_ck_root,   &a_old_ck_exists);
1673   a_ck_replace(OP_DELETE, a_ck_root,   &a_old_ck_delete);
1674   a_ck_replace(OP_KEYS,   a_ck_root,   &a_old_ck_keys);
1675   a_ck_replace(OP_VALUES, a_ck_root,   &a_old_ck_values);
1676  }
1677
1678  A_LOADED_UNLOCK;
1679
1680  {
1681   HV *stash;
1682
1683   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1684   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1685   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1686   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1687   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1688   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1689   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1690   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1691   newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(A_THREADSAFE));
1692   newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(A_FORKSAFE));
1693  }
1694
1695 #if A_HAS_RPEEP
1696  if (PL_rpeepp != a_peep) {
1697   MY_CXT.old_peep = PL_rpeepp;
1698   PL_rpeepp       = a_peep;
1699  }
1700 #else
1701  if (PL_peepp != a_peep) {
1702   MY_CXT.old_peep = PL_peepp;
1703   PL_peepp        = a_peep;
1704  }
1705 #endif
1706  else {
1707   MY_CXT.old_peep = 0;
1708  }
1709
1710  MY_CXT.seen = ptable_new();
1711
1712 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1713  MY_CXT.tbl   = ptable_new();
1714  MY_CXT.owner = aTHX;
1715 #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1716
1717  call_atexit(a_teardown, NULL);
1718
1719  return;
1720 }
1721
1722 /* --- XS ------------------------------------------------------------------ */
1723
1724 MODULE = autovivification      PACKAGE = autovivification
1725
1726 PROTOTYPES: ENABLE
1727
1728 BOOT:
1729 {
1730  a_setup();
1731 }
1732
1733 #if A_THREADSAFE
1734
1735 void
1736 CLONE(...)
1737 PROTOTYPE: DISABLE
1738 PREINIT:
1739 #if A_WORKAROUND_REQUIRE_PROPAGATION
1740  ptable *t;
1741 #endif
1742 PPCODE:
1743 #if A_WORKAROUND_REQUIRE_PROPAGATION
1744  {
1745   a_ptable_clone_ud ud;
1746   dMY_CXT;
1747   t = ptable_new();
1748   a_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1749   ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1750   a_ptable_clone_ud_deinit(ud);
1751  }
1752 #endif
1753  {
1754   MY_CXT_CLONE;
1755 #if A_WORKAROUND_REQUIRE_PROPAGATION
1756   MY_CXT.tbl   = t;
1757   MY_CXT.owner = aTHX;
1758 #endif
1759   MY_CXT.seen  = ptable_new();
1760   {
1761    int global_setup;
1762    A_LOADED_LOCK;
1763    global_setup = a_set_loaded_locked(&MY_CXT);
1764    assert(!global_setup);
1765    A_LOADED_UNLOCK;
1766   }
1767  }
1768  XSRETURN(0);
1769
1770 #endif /* A_THREADSAFE */
1771
1772 SV *
1773 _tag(SV *hint)
1774 PROTOTYPE: $
1775 CODE:
1776  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1777 OUTPUT:
1778  RETVAL
1779
1780 SV *
1781 _detag(SV *tag)
1782 PROTOTYPE: $
1783 CODE:
1784  if (!SvOK(tag))
1785   XSRETURN_UNDEF;
1786  RETVAL = newSVuv(a_detag(tag));
1787 OUTPUT:
1788  RETVAL