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 void a_cannot_vivify(pTHX_ UV flags) {
 714 #define a_cannot_vivify(F) a_cannot_vivify(aTHX_ (F))
 715  if (flags & A_HINT_STRICT)
 716   croak("Reference vivification forbidden");
 717  else if (flags & A_HINT_WARN)
 718   warn("Reference was vivified");
 719  else /* A_HINT_STORE */
 720   croak("Can't vivify reference");
 721 }
 722
 723 static OP *a_pp_deref(pTHX) {
 724  dA_MAP_THX;
 725  const a_op_info *oi;
 726  UV flags;
 727  dSP;
 728
 729  oi = a_map_fetch(PL_op);
 730
 731  flags = oi->flags;
 732  if (flags & A_HINT_DEREF) {
 733   OP *o;
 734
 735   o = oi->old_pp(aTHX);
 736
 737   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
 738    SPAGAIN;
 739    if (a_undef(TOPs))
 740     a_cannot_vivify(flags);
 741   }
 742
 743   return o;
 744  }
 745
 746  return oi->old_pp(aTHX);
 747 }
 748
 749 /* ... pp_root (exists,delete,keys,values) ................................. */
 750
 751 static OP *a_pp_root_unop(pTHX) {
 752  dSP;
 753
 754  if (a_undef(TOPs)) {
 755   (void) POPs;
 756   /* Can only be reached by keys or values */
 757   if (GIMME_V == G_SCALAR) {
 758    dTARGET;
 759    PUSHi(0);
 760   }
 761   RETURN;
 762  }
 763
 764  {
 765   dA_MAP_THX;
 766   const a_op_info *oi = a_map_fetch(PL_op);
 767   return oi->old_pp(aTHX);
 768  }
 769 }
 770
 771 static OP *a_pp_root_binop(pTHX) {
 772  dSP;
 773
 774  if (a_undef(TOPm1s)) {
 775   (void) POPs;
 776   (void) POPs;
 777   if (PL_op->op_type == OP_EXISTS)
 778    RETPUSHNO;
 779   else
 780    RETPUSHUNDEF;
 781  }
 782
 783  {
 784   dA_MAP_THX;
 785   const a_op_info *oi = a_map_fetch(PL_op);
 786   return oi->old_pp(aTHX);
 787  }
 788 }
 789
 790 /* --- Check functions ----------------------------------------------------- */
 791
 792 static void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
 793 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
 794
 795  if (o->op_type == type && o->op_ppaddr != new_pp
 796                         && cUNOPo->op_first->op_type != OP_GV) {
 797   dA_MAP_THX;
 798   const a_op_info *oi = a_map_fetch(o);
 799   if (oi) {
 800    a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
 801    o->op_ppaddr = new_pp;
 802   }
 803  }
 804
 805  return;
 806 }
 807
 808 /* ... ck_pad{any,sv} ...................................................... */
 809
 810 /* Sadly, the padsv OPs we are interested in don't trigger the padsv check
 811  * function, but are instead manually mutated from a padany. So we store
 812  * the op entry in the op map in the padany check function, and we set their
 813  * op_ppaddr member in our peephole optimizer replacement below. */
 814
 815 static OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
 816
 817 static OP *a_ck_padany(pTHX_ OP *o) {
 818  UV hint;
 819
 820  o = a_old_ck_padany(aTHX_ o);
 821
 822  hint = a_hint();
 823  if (hint & A_HINT_DO)
 824   a_map_store_root(o, o->op_ppaddr, hint);
 825  else
 826   a_map_delete(o);
 827
 828  return o;
 829 }
 830
 831 static OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
 832
 833 static OP *a_ck_padsv(pTHX_ OP *o) {
 834  UV hint;
 835
 836  o = a_old_ck_padsv(aTHX_ o);
 837
 838  hint = a_hint();
 839  if (hint & A_HINT_DO) {
 840   a_map_store_root(o, o->op_ppaddr, hint);
 841   o->op_ppaddr = a_pp_deref;
 842  } else
 843   a_map_delete(o);
 844
 845  return o;
 846 }
 847
 848 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
 849
 850 /* Those ops appear both at the root and inside an expression but there's no
 851  * way to distinguish both situations. Worse, we can't even know if we are in a
 852  * modifying context, so the expression can't be resolved yet. It will be at the
 853  * first invocation of a_pp_deref() for this expression. */
 854
 855 static OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
 856 static OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
 857 static OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
 858
 859 static OP *a_ck_deref(pTHX_ OP *o) {
 860  OP * (*old_ck)(pTHX_ OP *o) = 0;
 861  UV hint = a_hint();
 862
 863  switch (o->op_type) {
 864   case OP_AELEM:
 865    old_ck = a_old_ck_aelem;
 866    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 867     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
 868    break;
 869   case OP_HELEM:
 870    old_ck = a_old_ck_helem;
 871    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 872     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
 873    break;
 874   case OP_RV2SV:
 875    old_ck = a_old_ck_rv2sv;
 876    break;
 877  }
 878  o = old_ck(aTHX_ o);
 879
 880  if (hint & A_HINT_DO) {
 881   a_map_store_root(o, o->op_ppaddr, hint);
 882   o->op_ppaddr = a_pp_deref;
 883  } else
 884   a_map_delete(o);
 885
 886  return o;
 887 }
 888
 889 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
 890
 891 /* Those ops also appear both inisde and at the root, hence the caveats for
 892  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
 893  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
 894  * expression. */
 895
 896 static OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
 897 static OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
 898
 899 static OP *a_ck_rv2xv(pTHX_ OP *o) {
 900  OP * (*old_ck)(pTHX_ OP *o) = 0;
 901  OP * (*new_pp)(pTHX)        = 0;
 902  UV hint;
 903
 904  switch (o->op_type) {
 905   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
 906   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
 907  }
 908  o = old_ck(aTHX_ o);
 909
 910  if (cUNOPo->op_first->op_type == OP_GV)
 911   return o;
 912
 913  hint = a_hint();
 914  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
 915   a_map_store_root(o, o->op_ppaddr, hint);
 916   o->op_ppaddr = new_pp;
 917  } else
 918   a_map_delete(o);
 919
 920  return o;
 921 }
 922
 923 /* ... ck_xslice (aslice,hslice) ........................................... */
 924
 925 /* I think those are only found at the root, but there's nothing that really
 926  * prevent them to be inside the expression too. We only need to update the
 927  * root so that the rest of the expression will see the right context when
 928  * resolving. That's why we don't replace the ppaddr. */
 929
 930 static OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
 931 static OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
 932
 933 static OP *a_ck_xslice(pTHX_ OP *o) {
 934  OP * (*old_ck)(pTHX_ OP *o) = 0;
 935  UV hint = a_hint();
 936
 937  switch (o->op_type) {
 938   case OP_ASLICE:
 939    old_ck = a_old_ck_aslice;
 940    break;
 941   case OP_HSLICE:
 942    old_ck = a_old_ck_hslice;
 943    if (hint & A_HINT_DO)
 944     a_recheck_rv2xv(OpSIBLING(cUNOPo->op_first), OP_RV2HV, a_pp_rv2hv);
 945    break;
 946  }
 947  o = old_ck(aTHX_ o);
 948
 949  if (hint & A_HINT_DO) {
 950   a_map_store_root(o, 0, hint);
 951  } else
 952   a_map_delete(o);
 953
 954  return o;
 955 }
 956
 957 /* ... ck_root (exists,delete,keys,values) ................................. */
 958
 959 /* Those ops are only found at the root of a dereferencing expression. We can
 960  * then resolve at compile time if vivification must take place or not. */
 961
 962 static OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
 963 static OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
 964 static OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
 965 static OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
 966
 967 static OP *a_ck_root(pTHX_ OP *o) {
 968  OP * (*old_ck)(pTHX_ OP *o) = 0;
 969  OP * (*new_pp)(pTHX)        = 0;
 970  bool enabled = FALSE;
 971  UV hint = a_hint();
 972
 973  switch (o->op_type) {
 974   case OP_EXISTS:
 975    old_ck  = a_old_ck_exists;
 976    new_pp  = a_pp_root_binop;
 977    enabled = hint & A_HINT_EXISTS;
 978    break;
 979   case OP_DELETE:
 980    old_ck  = a_old_ck_delete;
 981    new_pp  = a_pp_root_binop;
 982    enabled = hint & A_HINT_DELETE;
 983    break;
 984   case OP_KEYS:
 985    old_ck  = a_old_ck_keys;
 986    new_pp  = a_pp_root_unop;
 987    enabled = hint & A_HINT_FETCH;
 988    break;
 989   case OP_VALUES:
 990    old_ck  = a_old_ck_values;
 991    new_pp  = a_pp_root_unop;
 992    enabled = hint & A_HINT_FETCH;
 993    break;
 994  }
 995  o = old_ck(aTHX_ o);
 996
 997  if (hint & A_HINT_DO) {
 998   if (enabled) {
 999    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
1000    a_map_store_root(o, o->op_ppaddr, hint);
1001    o->op_ppaddr = new_pp;
1002   } else {
1003    a_map_cancel(o);
1004   }
1005  } else
1006   a_map_delete(o);
1007
1008  return o;
1009 }
1010
1011 /* ... Our peephole optimizer .............................................. */
1012
1013 static peep_t a_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
1014
1015 static void a_peep_rec(pTHX_ OP *o, ptable *seen);
1016
1017 static void a_peep_rec(pTHX_ OP *o, ptable *seen) {
1018 #define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen)
1019  for (; o; o = o->op_next) {
1020   dA_MAP_THX;
1021   const a_op_info *oi = NULL;
1022   UV flags = 0;
1023
1024 #if !A_HAS_RPEEP
1025   if (ptable_fetch(seen, o))
1026    break;
1027   ptable_seen_store(seen, o, o);
1028 #endif
1029
1030   switch (o->op_type) {
1031 #if A_HAS_RPEEP
1032    case OP_NEXTSTATE:
1033    case OP_DBSTATE:
1034    case OP_STUB:
1035    case OP_UNSTACK:
1036     if (ptable_fetch(seen, o))
1037      return;
1038     ptable_seen_store(seen, o, o);
1039     break;
1040 #endif
1041    case OP_PADSV:
1042     if (o->op_ppaddr != a_pp_deref) {
1043      oi = a_map_fetch(o);
1044      if (oi && (oi->flags & A_HINT_DO)) {
1045       a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1046       o->op_ppaddr = a_pp_deref;
1047      }
1048     }
1049     /* FALLTHROUGH */
1050    case OP_AELEM:
1051    case OP_AELEMFAST:
1052    case OP_HELEM:
1053    case OP_RV2SV:
1054     if (o->op_ppaddr != a_pp_deref)
1055      break;
1056     oi = a_map_fetch(o);
1057     if (!oi)
1058      break;
1059     flags = oi->flags;
1060     if (!(flags & A_HINT_DEREF)
1061         && (flags & A_HINT_DO)
1062         && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
1063      /* Decide if the expression must autovivify or not. */
1064      flags = a_map_resolve(o, oi);
1065     }
1066     if (flags & A_HINT_DEREF)
1067      o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER);
1068     else
1069      o->op_ppaddr  = oi->old_pp;
1070     break;
1071    case OP_RV2AV:
1072    case OP_RV2HV:
1073     if (   o->op_ppaddr != a_pp_rv2av
1074         && o->op_ppaddr != a_pp_rv2hv
1075         && o->op_ppaddr != a_pp_rv2hv_simple)
1076      break;
1077     oi = a_map_fetch(o);
1078     if (!oi)
1079      break;
1080     if (!(oi->flags & A_HINT_DEREF))
1081      o->op_ppaddr  = oi->old_pp;
1082     break;
1083 #if !A_HAS_RPEEP
1084    case OP_MAPWHILE:
1085    case OP_GREPWHILE:
1086    case OP_AND:
1087    case OP_OR:
1088    case OP_ANDASSIGN:
1089    case OP_ORASSIGN:
1090    case OP_COND_EXPR:
1091    case OP_RANGE:
1092 # if A_HAS_PERL(5, 10, 0)
1093    case OP_ONCE:
1094    case OP_DOR:
1095    case OP_DORASSIGN:
1096 # endif
1097     a_peep_rec(cLOGOPo->op_other);
1098     break;
1099    case OP_ENTERLOOP:
1100    case OP_ENTERITER:
1101     a_peep_rec(cLOOPo->op_redoop);
1102     a_peep_rec(cLOOPo->op_nextop);
1103     a_peep_rec(cLOOPo->op_lastop);
1104     break;
1105 # if A_HAS_PERL(5, 9, 5)
1106    case OP_SUBST:
1107     a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
1108     break;
1109 # else
1110    case OP_QR:
1111    case OP_MATCH:
1112    case OP_SUBST:
1113     a_peep_rec(cPMOPo->op_pmreplstart);
1114     break;
1115 # endif
1116 #endif /* !A_HAS_RPEEP */
1117    default:
1118     break;
1119   }
1120  }
1121 }
1122
1123 static void a_peep(pTHX_ OP *o) {
1124  dMY_CXT;
1125  ptable *seen = MY_CXT.seen;
1126
1127  a_old_peep(aTHX_ o);
1128
1129  if (seen) {
1130   ptable_seen_clear(seen);
1131   a_peep_rec(o);
1132   ptable_seen_clear(seen);
1133  }
1134 }
1135
1136 /* --- Interpreter setup/teardown ------------------------------------------ */
1137
1138 static U32 a_initialized = 0;
1139
1140 static void a_teardown(pTHX_ void *root) {
1141
1142  if (!a_initialized)
1143   return;
1144
1145 #if A_MULTIPLICITY
1146  if (aTHX != root)
1147   return;
1148 #endif
1149
1150  {
1151   dMY_CXT;
1152 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1153   ptable_hints_free(MY_CXT.tbl);
1154   MY_CXT.tbl  = NULL;
1155 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1156   ptable_seen_free(MY_CXT.seen);
1157   MY_CXT.seen = NULL;
1158  }
1159
1160  a_ck_restore(OP_PADANY, &a_old_ck_padany);
1161  a_ck_restore(OP_PADSV,  &a_old_ck_padsv);
1162
1163  a_ck_restore(OP_AELEM,  &a_old_ck_aelem);
1164  a_ck_restore(OP_HELEM,  &a_old_ck_helem);
1165  a_ck_restore(OP_RV2SV,  &a_old_ck_rv2sv);
1166
1167  a_ck_restore(OP_RV2AV,  &a_old_ck_rv2av);
1168  a_ck_restore(OP_RV2HV,  &a_old_ck_rv2hv);
1169
1170  a_ck_restore(OP_ASLICE, &a_old_ck_aslice);
1171  a_ck_restore(OP_HSLICE, &a_old_ck_hslice);
1172
1173  a_ck_restore(OP_EXISTS, &a_old_ck_exists);
1174  a_ck_restore(OP_DELETE, &a_old_ck_delete);
1175  a_ck_restore(OP_KEYS,   &a_old_ck_keys);
1176  a_ck_restore(OP_VALUES, &a_old_ck_values);
1177
1178 #if A_HAS_RPEEP
1179  PL_rpeepp  = a_old_peep;
1180 #else
1181  PL_peepp   = a_old_peep;
1182 #endif
1183  a_old_peep = 0;
1184
1185  a_initialized = 0;
1186 }
1187
1188 static void a_setup(pTHX) {
1189 #define a_setup() a_setup(aTHX)
1190  if (a_initialized)
1191   return;
1192
1193  {
1194   MY_CXT_INIT;
1195 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1196   MY_CXT.tbl   = ptable_new();
1197   MY_CXT.owner = aTHX;
1198 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1199   MY_CXT.seen  = ptable_new();
1200  }
1201
1202  a_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany);
1203  a_ck_replace(OP_PADSV,  a_ck_padsv,  &a_old_ck_padsv);
1204
1205  a_ck_replace(OP_AELEM,  a_ck_deref,  &a_old_ck_aelem);
1206  a_ck_replace(OP_HELEM,  a_ck_deref,  &a_old_ck_helem);
1207  a_ck_replace(OP_RV2SV,  a_ck_deref,  &a_old_ck_rv2sv);
1208
1209  a_ck_replace(OP_RV2AV,  a_ck_rv2xv,  &a_old_ck_rv2av);
1210  a_ck_replace(OP_RV2HV,  a_ck_rv2xv,  &a_old_ck_rv2hv);
1211
1212  a_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice);
1213  a_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice);
1214
1215  a_ck_replace(OP_EXISTS, a_ck_root,   &a_old_ck_exists);
1216  a_ck_replace(OP_DELETE, a_ck_root,   &a_old_ck_delete);
1217  a_ck_replace(OP_KEYS,   a_ck_root,   &a_old_ck_keys);
1218  a_ck_replace(OP_VALUES, a_ck_root,   &a_old_ck_values);
1219
1220 #if A_HAS_RPEEP
1221  a_old_peep = PL_rpeepp;
1222  PL_rpeepp  = a_peep;
1223 #else
1224  a_old_peep = PL_peepp;
1225  PL_peepp   = a_peep;
1226 #endif
1227
1228 #if A_MULTIPLICITY
1229  call_atexit(a_teardown, aTHX);
1230 #else
1231  call_atexit(a_teardown, NULL);
1232 #endif
1233
1234  a_initialized = 1;
1235 }
1236
1237 static U32 a_booted = 0;
1238
1239 /* --- XS ------------------------------------------------------------------ */
1240
1241 MODULE = autovivification      PACKAGE = autovivification
1242
1243 PROTOTYPES: ENABLE
1244
1245 BOOT:
1246 {
1247  if (!a_booted++) {
1248   HV *stash;
1249
1250   a_op_map = ptable_new();
1251 #ifdef USE_ITHREADS
1252   MUTEX_INIT(&a_op_map_mutex);
1253 #endif
1254
1255   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
1256
1257   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1258   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1259   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1260   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1261   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1262   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1263   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1264   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1265   newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(A_THREADSAFE));
1266   newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(A_FORKSAFE));
1267  }
1268
1269  a_setup();
1270 }
1271
1272 #if A_THREADSAFE
1273
1274 void
1275 CLONE(...)
1276 PROTOTYPE: DISABLE
1277 PREINIT:
1278 #if A_WORKAROUND_REQUIRE_PROPAGATION
1279  ptable *t;
1280 #endif
1281  ptable *s;
1282  GV     *gv;
1283 PPCODE:
1284  {
1285 #if A_WORKAROUND_REQUIRE_PROPAGATION
1286   dMY_CXT;
1287   {
1288    a_ptable_clone_ud ud;
1289
1290    t = ptable_new();
1291    a_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1292    ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1293    a_ptable_clone_ud_deinit(ud);
1294   }
1295 #endif
1296   s = ptable_new();
1297  }
1298  {
1299   MY_CXT_CLONE;
1300 #if A_WORKAROUND_REQUIRE_PROPAGATION
1301   MY_CXT.tbl   = t;
1302   MY_CXT.owner = aTHX;
1303 #endif
1304   MY_CXT.seen  = s;
1305  }
1306  gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
1307  if (gv) {
1308   CV *cv = GvCV(gv);
1309   if (!PL_endav)
1310    PL_endav = newAV();
1311   SvREFCNT_inc(cv);
1312   if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
1313    SvREFCNT_dec(cv);
1314   sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &a_endav_vtbl, NULL, 0);
1315  }
1316  XSRETURN(0);
1317
1318 void
1319 _THREAD_CLEANUP(...)
1320 PROTOTYPE: DISABLE
1321 PPCODE:
1322  a_thread_cleanup(aTHX_ NULL);
1323  XSRETURN(0);
1324
1325 #endif /* A_THREADSAFE */
1326
1327 SV *
1328 _tag(SV *hint)
1329 PROTOTYPE: $
1330 CODE:
1331  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1332 OUTPUT:
1333  RETVAL
1334
1335 SV *
1336 _detag(SV *tag)
1337 PROTOTYPE: $
1338 CODE:
1339  if (!SvOK(tag))
1340   XSRETURN_UNDEF;
1341  RETVAL = newSVuv(a_detag(tag));
1342 OUTPUT:
1343  RETVAL