autovivification.xs

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