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