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