autovivification.xs

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