autovivification.xs

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