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