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