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 STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
 333  const a_op_info *val;
 334
 335  MUTEX_LOCK(&a_op_map_mutex);
 336
 337  val = ptable_fetch(a_op_map, o);
 338  if (val) {
 339   *oi = *val;
 340   val = oi;
 341  }
 342
 343  MUTEX_UNLOCK(&a_op_map_mutex);
 344
 345  return val;
 346 }
 347
 348 #define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi)
 349
 350 #else /* USE_ITHREADS */
 351
 352 #define dA_MAP_THX dNOOP
 353
 354 #define a_map_fetch(O) ptable_fetch(a_op_map, (O))
 355
 356 #endif /* !USE_ITHREADS */
 357
 358 STATIC const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
 359 #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F))
 360  a_op_info *oi;
 361
 362  if (!(oi = ptable_fetch(a_op_map, o))) {
 363   oi = PerlMemShared_malloc(sizeof *oi);
 364   ptable_map_store(a_op_map, o, oi);
 365  }
 366
 367  oi->old_pp = old_pp;
 368  oi->next   = next;
 369  oi->flags  = flags;
 370
 371  return oi;
 372 }
 373
 374 STATIC void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
 375 #define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F))
 376
 377 #ifdef USE_ITHREADS
 378  MUTEX_LOCK(&a_op_map_mutex);
 379 #endif
 380
 381  a_map_store_locked(o, old_pp, next, flags);
 382
 383 #ifdef USE_ITHREADS
 384  MUTEX_UNLOCK(&a_op_map_mutex);
 385 #endif
 386 }
 387
 388 STATIC void a_map_delete(pTHX_ const OP *o) {
 389 #define a_map_delete(O) a_map_delete(aTHX_ (O))
 390 #ifdef USE_ITHREADS
 391  MUTEX_LOCK(&a_op_map_mutex);
 392 #endif
 393
 394  ptable_map_delete(a_op_map, o);
 395
 396 #ifdef USE_ITHREADS
 397  MUTEX_UNLOCK(&a_op_map_mutex);
 398 #endif
 399 }
 400
 401 STATIC const OP *a_map_descend(const OP *o) {
 402  switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 403   case OA_BASEOP:
 404   case OA_UNOP:
 405   case OA_BINOP:
 406   case OA_BASEOP_OR_UNOP:
 407    return cUNOPo->op_first;
 408   case OA_LIST:
 409   case OA_LISTOP:
 410    return cLISTOPo->op_last;
 411  }
 412
 413  return NULL;
 414 }
 415
 416 STATIC void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV flags) {
 417 #define a_map_store_root(R, PP, F) a_map_store_root(aPTBLMS_ (R), (PP), (F))
 418  const a_op_info *roi;
 419  a_op_info *oi;
 420  const OP *o = root;
 421
 422 #ifdef USE_ITHREADS
 423  MUTEX_LOCK(&a_op_map_mutex);
 424 #endif
 425
 426  roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT);
 427
 428  while (o->op_flags & OPf_KIDS) {
 429   o = a_map_descend(o);
 430   if (!o)
 431    break;
 432   if ((oi = ptable_fetch(a_op_map, o))) {
 433    oi->flags &= ~A_HINT_ROOT;
 434    oi->next   = (a_op_info *) roi;
 435    break;
 436   }
 437  }
 438
 439 #ifdef USE_ITHREADS
 440  MUTEX_UNLOCK(&a_op_map_mutex);
 441 #endif
 442
 443  return;
 444 }
 445
 446 STATIC void a_map_update_flags_topdown(const OP *root, UV flags) {
 447  a_op_info *oi;
 448  const OP *o = root;
 449
 450 #ifdef USE_ITHREADS
 451  MUTEX_LOCK(&a_op_map_mutex);
 452 #endif
 453
 454  flags &= ~A_HINT_ROOT;
 455
 456  do {
 457   if ((oi = ptable_fetch(a_op_map, o)))
 458    oi->flags = (oi->flags & A_HINT_ROOT) | flags;
 459   if (!(o->op_flags & OPf_KIDS))
 460    break;
 461   o = a_map_descend(o);
 462  } while (o);
 463
 464 #ifdef USE_ITHREADS
 465  MUTEX_UNLOCK(&a_op_map_mutex);
 466 #endif
 467
 468  return;
 469 }
 470
 471 #define a_map_cancel(R) a_map_update_flags_topdown((R), 0)
 472
 473 STATIC void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
 474  a_op_info *oi;
 475
 476 #ifdef USE_ITHREADS
 477  MUTEX_LOCK(&a_op_map_mutex);
 478 #endif
 479
 480  flags  &= ~A_HINT_ROOT;
 481  rflags |=  A_HINT_ROOT;
 482
 483  oi = ptable_fetch(a_op_map, o);
 484  while (!(oi->flags & A_HINT_ROOT)) {
 485   oi->flags = flags;
 486   oi        = oi->next;
 487  }
 488  oi->flags = rflags;
 489
 490 #ifdef USE_ITHREADS
 491  MUTEX_UNLOCK(&a_op_map_mutex);
 492 #endif
 493
 494  return;
 495 }
 496
 497 /* ... Decide whether this expression should be autovivified or not ........ */
 498
 499 STATIC UV a_map_resolve(const OP *o, const a_op_info *oi) {
 500  UV flags = 0, rflags;
 501  const OP *root;
 502  const a_op_info *roi = oi;
 503
 504  while (!(roi->flags & A_HINT_ROOT))
 505   roi = roi->next;
 506  if (!roi)
 507   goto cancel;
 508
 509  rflags = roi->flags & ~A_HINT_ROOT;
 510  if (!rflags)
 511   goto cancel;
 512
 513  root = roi->next;
 514  if (root->op_flags & OPf_MOD) {
 515   if (rflags & A_HINT_STORE)
 516    flags = (A_HINT_STORE|A_HINT_DEREF);
 517  } else if (rflags & A_HINT_FETCH)
 518    flags = (A_HINT_FETCH|A_HINT_DEREF);
 519
 520  if (!flags) {
 521 cancel:
 522   a_map_update_flags_bottomup(o, 0, 0);
 523   return 0;
 524  }
 525
 526  flags |= (rflags & A_HINT_NOTIFY);
 527  a_map_update_flags_bottomup(o, flags, 0);
 528
 529  return oi->flags & A_HINT_ROOT ? 0 : flags;
 530 }
 531
 532 /* ... Inspired from pp_defined() .......................................... */
 533
 534 STATIC int a_undef(pTHX_ SV *sv) {
 535 #define a_undef(S) a_undef(aTHX_ (S))
 536  switch (SvTYPE(sv)) {
 537   case SVt_NULL:
 538    return 1;
 539   case SVt_PVAV:
 540    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
 541                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 542     return 0;
 543    break;
 544   case SVt_PVHV:
 545    if (HvARRAY(sv) || SvGMAGICAL(sv)
 546                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 547     return 0;
 548    break;
 549   default:
 550    SvGETMAGIC(sv);
 551    if (SvOK(sv))
 552     return 0;
 553  }
 554
 555  return 1;
 556 }
 557
 558 /* --- PP functions -------------------------------------------------------- */
 559
 560 /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp
 561  * value, another extension might have saved our pp replacement as the ppaddr
 562  * for this op, so this doesn't ensure that our function will never be called
 563  * again. That's why we don't remove the op info from our map, so that it can
 564  * still run correctly if required. */
 565
 566 /* ... pp_rv2av ............................................................ */
 567
 568 STATIC OP *a_pp_rv2av(pTHX) {
 569  dA_MAP_THX;
 570  const a_op_info *oi;
 571  dSP;
 572
 573  oi = a_map_fetch(PL_op);
 574
 575  if (oi->flags & A_HINT_DEREF) {
 576   if (a_undef(TOPs)) {
 577    /* We always need to push an empty array to fool the pp_aelem() that comes
 578     * later. */
 579    SV *av;
 580    POPs;
 581    av = sv_2mortal((SV *) newAV());
 582    PUSHs(av);
 583    RETURN;
 584   }
 585  } else {
 586   PL_op->op_ppaddr = oi->old_pp;
 587  }
 588
 589  return oi->old_pp(aTHX);
 590 }
 591
 592 /* ... pp_rv2hv ............................................................ */
 593
 594 STATIC OP *a_pp_rv2hv_simple(pTHX) {
 595  dA_MAP_THX;
 596  const a_op_info *oi;
 597  dSP;
 598
 599  oi = a_map_fetch(PL_op);
 600
 601  if (oi->flags & A_HINT_DEREF) {
 602   if (a_undef(TOPs))
 603    RETURN;
 604  } else {
 605   PL_op->op_ppaddr = oi->old_pp;
 606  }
 607
 608  return oi->old_pp(aTHX);
 609 }
 610
 611 STATIC OP *a_pp_rv2hv(pTHX) {
 612  dA_MAP_THX;
 613  const a_op_info *oi;
 614  dSP;
 615
 616  oi = a_map_fetch(PL_op);
 617
 618  if (oi->flags & A_HINT_DEREF) {
 619   if (a_undef(TOPs)) {
 620    SV *hv;
 621    POPs;
 622    hv = sv_2mortal((SV *) newHV());
 623    PUSHs(hv);
 624    RETURN;
 625   }
 626  } else {
 627   PL_op->op_ppaddr = oi->old_pp;
 628  }
 629
 630  return oi->old_pp(aTHX);
 631 }
 632
 633 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
 634
 635 STATIC OP *a_pp_deref(pTHX) {
 636  dA_MAP_THX;
 637  const a_op_info *oi;
 638  UV flags;
 639  dSP;
 640
 641  oi = a_map_fetch(PL_op);
 642  flags = oi->flags;
 643
 644  if (flags & A_HINT_DEREF) {
 645   OP *o;
 646   U8 old_private;
 647
 648 deref:
 649   old_private       = PL_op->op_private;
 650   PL_op->op_private = ((old_private & ~OPpDEREF) | OPpLVAL_DEFER);
 651   o = oi->old_pp(aTHX);
 652   PL_op->op_private = old_private;
 653
 654   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
 655    SPAGAIN;
 656    if (a_undef(TOPs)) {
 657     if (flags & A_HINT_STRICT)
 658      croak("Reference vivification forbidden");
 659     else if (flags & A_HINT_WARN)
 660       warn("Reference was vivified");
 661     else /* A_HINT_STORE */
 662      croak("Can't vivify reference");
 663    }
 664   }
 665
 666   return o;
 667  } else if ((flags & ~A_HINT_ROOT)
 668                     && (PL_op->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
 669   /* Decide if the expression must autovivify or not.
 670    * This branch should be called only once by expression. */
 671   flags = a_map_resolve(PL_op, oi);
 672
 673   /* We need the updated flags value in the deref branch. */
 674   if (flags & A_HINT_DEREF)
 675    goto deref;
 676  }
 677
 678  /* This op doesn't need to skip autovivification, so restore the original
 679   * state. */
 680  PL_op->op_ppaddr = oi->old_pp;
 681
 682  return oi->old_pp(aTHX);
 683 }
 684
 685 /* ... pp_root (exists,delete,keys,values) ................................. */
 686
 687 STATIC OP *a_pp_root_unop(pTHX) {
 688  dSP;
 689
 690  if (a_undef(TOPs)) {
 691   POPs;
 692   /* Can only be reached by keys or values */
 693   if (GIMME_V == G_SCALAR) {
 694    dTARGET;
 695    PUSHi(0);
 696   }
 697   RETURN;
 698  }
 699
 700  {
 701   dA_MAP_THX;
 702   const a_op_info *oi = a_map_fetch(PL_op);
 703   return oi->old_pp(aTHX);
 704  }
 705 }
 706
 707 STATIC OP *a_pp_root_binop(pTHX) {
 708  dSP;
 709
 710  if (a_undef(TOPm1s)) {
 711   POPs;
 712   POPs;
 713   if (PL_op->op_type == OP_EXISTS)
 714    RETPUSHNO;
 715   else
 716    RETPUSHUNDEF;
 717  }
 718
 719  {
 720   dA_MAP_THX;
 721   const a_op_info *oi = a_map_fetch(PL_op);
 722   return oi->old_pp(aTHX);
 723  }
 724 }
 725
 726 /* --- Check functions ----------------------------------------------------- */
 727
 728 STATIC void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
 729 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
 730
 731  if (o->op_type == type && o->op_ppaddr != new_pp
 732                         && cUNOPo->op_first->op_type != OP_GV) {
 733   dA_MAP_THX;
 734   const a_op_info *oi = a_map_fetch(o);
 735   if (oi) {
 736    a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
 737    o->op_ppaddr = new_pp;
 738   }
 739  }
 740
 741  return;
 742 }
 743
 744 /* ... ck_pad{any,sv} ...................................................... */
 745
 746 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 747  * function, but are instead manually mutated from a PADANY. This is why we set
 748  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 749  * their op_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 750  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 751  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 752  * globally. */
 753
 754 STATIC OP *(*a_pp_padsv_saved)(pTHX) = 0;
 755
 756 STATIC void a_pp_padsv_save(void) {
 757  if (a_pp_padsv_saved)
 758   return;
 759
 760  a_pp_padsv_saved    = PL_ppaddr[OP_PADSV];
 761  PL_ppaddr[OP_PADSV] = a_pp_deref;
 762 }
 763
 764 STATIC void a_pp_padsv_restore(OP *o) {
 765  if (!a_pp_padsv_saved)
 766   return;
 767
 768  if (o->op_ppaddr == a_pp_deref)
 769   o->op_ppaddr = a_pp_padsv_saved;
 770
 771  PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
 772  a_pp_padsv_saved    = 0;
 773 }
 774
 775 STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
 776
 777 STATIC OP *a_ck_padany(pTHX_ OP *o) {
 778  UV hint;
 779
 780  a_pp_padsv_restore(o);
 781
 782  o = a_old_ck_padany(aTHX_ o);
 783
 784  hint = a_hint();
 785  if (hint & A_HINT_DO) {
 786   a_pp_padsv_save();
 787   a_map_store_root(o, a_pp_padsv_saved, hint);
 788  } else
 789   a_map_delete(o);
 790
 791  return o;
 792 }
 793
 794 STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
 795
 796 STATIC OP *a_ck_padsv(pTHX_ OP *o) {
 797  UV hint;
 798
 799  a_pp_padsv_restore(o);
 800
 801  o = a_old_ck_padsv(aTHX_ o);
 802
 803  hint = a_hint();
 804  if (hint & A_HINT_DO) {
 805   a_map_store_root(o, o->op_ppaddr, hint);
 806   o->op_ppaddr = a_pp_deref;
 807  } else
 808   a_map_delete(o);
 809
 810  return o;
 811 }
 812
 813 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
 814
 815 /* Those ops appear both at the root and inside an expression but there's no
 816  * way to distinguish both situations. Worse, we can't even know if we are in a
 817  * modifying context, so the expression can't be resolved yet. It will be at the
 818  * first invocation of a_pp_deref() for this expression. */
 819
 820 STATIC OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
 821 STATIC OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
 822 STATIC OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
 823
 824 STATIC OP *a_ck_deref(pTHX_ OP *o) {
 825  OP * (*old_ck)(pTHX_ OP *o) = 0;
 826  UV hint = a_hint();
 827
 828  switch (o->op_type) {
 829   case OP_AELEM:
 830    old_ck = a_old_ck_aelem;
 831    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 832     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
 833    break;
 834   case OP_HELEM:
 835    old_ck = a_old_ck_helem;
 836    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 837     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
 838    break;
 839   case OP_RV2SV:
 840    old_ck = a_old_ck_rv2sv;
 841    break;
 842  }
 843  o = old_ck(aTHX_ o);
 844
 845  if (hint & A_HINT_DO) {
 846   a_map_store_root(o, o->op_ppaddr, hint);
 847   o->op_ppaddr = a_pp_deref;
 848  } else
 849   a_map_delete(o);
 850
 851  return o;
 852 }
 853
 854 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
 855
 856 /* Those ops also appear both inisde and at the root, hence the caveats for
 857  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
 858  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
 859  * expression. */
 860
 861 STATIC OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
 862 STATIC OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
 863
 864 STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
 865  OP * (*old_ck)(pTHX_ OP *o) = 0;
 866  OP * (*new_pp)(pTHX)        = 0;
 867  UV hint;
 868
 869  switch (o->op_type) {
 870   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
 871   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
 872  }
 873  o = old_ck(aTHX_ o);
 874
 875  if (cUNOPo->op_first->op_type == OP_GV)
 876   return o;
 877
 878  hint = a_hint();
 879  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
 880   a_map_store_root(o, o->op_ppaddr, hint);
 881   o->op_ppaddr = new_pp;
 882  } else
 883   a_map_delete(o);
 884
 885  return o;
 886 }
 887
 888 /* ... ck_xslice (aslice,hslice) ........................................... */
 889
 890 /* I think those are only found at the root, but there's nothing that really
 891  * prevent them to be inside the expression too. We only need to update the
 892  * root so that the rest of the expression will see the right context when
 893  * resolving. That's why we don't replace the ppaddr. */
 894
 895 STATIC OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
 896 STATIC OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
 897
 898 STATIC OP *a_ck_xslice(pTHX_ OP *o) {
 899  OP * (*old_ck)(pTHX_ OP *o) = 0;
 900  UV hint = a_hint();
 901
 902  switch (o->op_type) {
 903   case OP_ASLICE:
 904    old_ck = a_old_ck_aslice;
 905    break;
 906   case OP_HSLICE:
 907    old_ck = a_old_ck_hslice;
 908    if (hint & A_HINT_DO)
 909     a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv);
 910    break;
 911  }
 912  o = old_ck(aTHX_ o);
 913
 914  if (hint & A_HINT_DO) {
 915   a_map_store_root(o, 0, hint);
 916  } else
 917   a_map_delete(o);
 918
 919  return o;
 920 }
 921
 922 /* ... ck_root (exists,delete,keys,values) ................................. */
 923
 924 /* Those ops are only found at the root of a dereferencing expression. We can
 925  * then resolve at compile time if vivification must take place or not. */
 926
 927 STATIC OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
 928 STATIC OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
 929 STATIC OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
 930 STATIC OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
 931
 932 STATIC OP *a_ck_root(pTHX_ OP *o) {
 933  OP * (*old_ck)(pTHX_ OP *o) = 0;
 934  OP * (*new_pp)(pTHX)        = 0;
 935  bool enabled = FALSE;
 936  UV hint = a_hint();
 937
 938  switch (o->op_type) {
 939   case OP_EXISTS:
 940    old_ck  = a_old_ck_exists;
 941    new_pp  = a_pp_root_binop;
 942    enabled = hint & A_HINT_EXISTS;
 943    break;
 944   case OP_DELETE:
 945    old_ck  = a_old_ck_delete;
 946    new_pp  = a_pp_root_binop;
 947    enabled = hint & A_HINT_DELETE;
 948    break;
 949   case OP_KEYS:
 950    old_ck  = a_old_ck_keys;
 951    new_pp  = a_pp_root_unop;
 952    enabled = hint & A_HINT_FETCH;
 953    break;
 954   case OP_VALUES:
 955    old_ck  = a_old_ck_values;
 956    new_pp  = a_pp_root_unop;
 957    enabled = hint & A_HINT_FETCH;
 958    break;
 959  }
 960  o = old_ck(aTHX_ o);
 961
 962  if (hint & A_HINT_DO) {
 963   if (enabled) {
 964    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
 965    a_map_store_root(o, o->op_ppaddr, hint);
 966    o->op_ppaddr = new_pp;
 967   } else {
 968    a_map_cancel(o);
 969   }
 970  } else
 971   a_map_delete(o);
 972
 973  return o;
 974 }
 975
 976 STATIC U32 a_initialized = 0;
 977
 978 STATIC void a_teardown(pTHX_ void *root) {
 979
 980  if (!a_initialized)
 981   return;
 982
 983 #if A_MULTIPLICITY
 984  if (aTHX != root)
 985   return;
 986 #endif
 987
 988 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
 989  {
 990   dMY_CXT;
 991   ptable_hints_free(MY_CXT.tbl);
 992  }
 993 #endif
 994
 995  PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_old_ck_padany);
 996  a_old_ck_padany     = 0;
 997  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_old_ck_padsv);
 998  a_old_ck_padsv      = 0;
 999
1000  PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_old_ck_aelem);
1001  a_old_ck_aelem      = 0;
1002  PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_old_ck_helem);
1003  a_old_ck_helem      = 0;
1004  PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_old_ck_rv2sv);
1005  a_old_ck_rv2sv      = 0;
1006
1007  PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_old_ck_rv2av);
1008  a_old_ck_rv2av      = 0;
1009  PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_old_ck_rv2hv);
1010  a_old_ck_rv2hv      = 0;
1011
1012  PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_old_ck_aslice);
1013  a_old_ck_aslice     = 0;
1014  PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_old_ck_hslice);
1015  a_old_ck_hslice     = 0;
1016
1017  PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_old_ck_exists);
1018  a_old_ck_exists     = 0;
1019  PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_old_ck_delete);
1020  a_old_ck_delete     = 0;
1021  PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_old_ck_keys);
1022  a_old_ck_keys       = 0;
1023  PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_old_ck_values);
1024  a_old_ck_values     = 0;
1025
1026  if (a_pp_padsv_saved) {
1027   PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
1028   a_pp_padsv_saved    = 0;
1029  }
1030
1031  a_initialized = 0;
1032 }
1033
1034 STATIC void a_setup(pTHX) {
1035 #define a_setup() a_setup(aTHX)
1036  if (a_initialized)
1037   return;
1038
1039 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1040  {
1041   MY_CXT_INIT;
1042   MY_CXT.tbl   = ptable_new();
1043   MY_CXT.owner = aTHX;
1044  }
1045 #endif
1046
1047  a_old_ck_padany     = PL_check[OP_PADANY];
1048  PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_ck_padany);
1049  a_old_ck_padsv      = PL_check[OP_PADSV];
1050  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_ck_padsv);
1051
1052  a_old_ck_aelem      = PL_check[OP_AELEM];
1053  PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_ck_deref);
1054  a_old_ck_helem      = PL_check[OP_HELEM];
1055  PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_ck_deref);
1056  a_old_ck_rv2sv      = PL_check[OP_RV2SV];
1057  PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_ck_deref);
1058
1059  a_old_ck_rv2av      = PL_check[OP_RV2AV];
1060  PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
1061  a_old_ck_rv2hv      = PL_check[OP_RV2HV];
1062  PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
1063
1064  a_old_ck_aslice     = PL_check[OP_ASLICE];
1065  PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1066  a_old_ck_hslice     = PL_check[OP_HSLICE];
1067  PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1068
1069  a_old_ck_exists     = PL_check[OP_EXISTS];
1070  PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
1071  a_old_ck_delete     = PL_check[OP_DELETE];
1072  PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_ck_root);
1073  a_old_ck_keys       = PL_check[OP_KEYS];
1074  PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_ck_root);
1075  a_old_ck_values     = PL_check[OP_VALUES];
1076  PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_ck_root);
1077
1078 #if A_MULTIPLICITY
1079  call_atexit(a_teardown, aTHX);
1080 #else
1081  call_atexit(a_teardown, NULL);
1082 #endif
1083
1084  a_initialized = 1;
1085 }
1086
1087 STATIC U32 a_booted = 0;
1088
1089 /* --- XS ------------------------------------------------------------------ */
1090
1091 MODULE = autovivification      PACKAGE = autovivification
1092
1093 PROTOTYPES: ENABLE
1094
1095 BOOT:
1096 {
1097  if (!a_booted++) {
1098   HV *stash;
1099
1100   a_op_map = ptable_new();
1101 #ifdef USE_ITHREADS
1102   MUTEX_INIT(&a_op_map_mutex);
1103 #endif
1104
1105   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
1106
1107   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1108   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1109   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1110   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1111   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1112   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1113   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1114   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1115   newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(A_THREADSAFE));
1116   newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(A_FORKSAFE));
1117  }
1118
1119  a_setup();
1120 }
1121
1122 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1123
1124 void
1125 CLONE(...)
1126 PROTOTYPE: DISABLE
1127 PREINIT:
1128  ptable *t;
1129 PPCODE:
1130  {
1131   a_ptable_clone_ud ud;
1132   dMY_CXT;
1133
1134   t = ptable_new();
1135   a_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1136   ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1137   a_ptable_clone_ud_deinit(ud);
1138  }
1139  {
1140   MY_CXT_CLONE;
1141   MY_CXT.tbl   = t;
1142   MY_CXT.owner = aTHX;
1143  }
1144  reap(3, a_thread_cleanup, NULL);
1145  XSRETURN(0);
1146
1147 #endif
1148
1149 SV *
1150 _tag(SV *hint)
1151 PROTOTYPE: $
1152 CODE:
1153  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1154 OUTPUT:
1155  RETVAL
1156
1157 SV *
1158 _detag(SV *tag)
1159 PROTOTYPE: $
1160 CODE:
1161  if (!SvOK(tag))
1162   XSRETURN_UNDEF;
1163  RETVAL = newSVuv(a_detag(tag));
1164 OUTPUT:
1165  RETVAL