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