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