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