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