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 STATIC SV *a_clone(pTHX_ SV *sv, tTHX owner) {
 125 #define a_clone(S, O) a_clone(aTHX_ (S), (O))
 126  CLONE_PARAMS  param;
 127  AV           *stashes = NULL;
 128  SV           *dupsv;
 129
 130  if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
 131   stashes = newAV();
 132
 133  param.stashes    = stashes;
 134  param.flags      = 0;
 135  param.proto_perl = owner;
 136
 137  dupsv = sv_dup(sv, &param);
 138
 139  if (stashes) {
 140   av_undef(stashes);
 141   SvREFCNT_dec(stashes);
 142  }
 143
 144  return SvREFCNT_inc(dupsv);
 145 }
 146
 147 STATIC void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 148  my_cxt_t *ud = ud_;
 149  a_hint_t *h1 = ent->val;
 150  a_hint_t *h2;
 151
 152  if (ud->owner == aTHX)
 153   return;
 154
 155  h2              = PerlMemShared_malloc(sizeof *h2);
 156  h2->bits        = h1->bits;
 157  h2->require_tag = PTR2IV(a_clone(INT2PTR(SV *, h1->require_tag), ud->owner));
 158
 159  ptable_hints_store(ud->tbl, ent->key, h2);
 160 }
 161
 162 STATIC void a_thread_cleanup(pTHX_ void *);
 163
 164 STATIC void a_thread_cleanup(pTHX_ void *ud) {
 165  int *level = ud;
 166
 167  if (*level) {
 168   *level = 0;
 169   LEAVE;
 170   SAVEDESTRUCTOR_X(a_thread_cleanup, level);
 171   ENTER;
 172  } else {
 173   dMY_CXT;
 174   PerlMemShared_free(level);
 175   ptable_hints_free(MY_CXT.tbl);
 176  }
 177 }
 178
 179 #endif /* A_THREADSAFE */
 180
 181 STATIC IV a_require_tag(pTHX) {
 182 #define a_require_tag() a_require_tag(aTHX)
 183  const CV *cv, *outside;
 184
 185  cv = PL_compcv;
 186
 187  if (!cv) {
 188   /* If for some reason the pragma is operational at run-time, try to discover
 189    * the current cv in use. */
 190   const PERL_SI *si;
 191
 192   for (si = PL_curstackinfo; si; si = si->si_prev) {
 193    I32 cxix;
 194
 195    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 196     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 197
 198     switch (CxTYPE(cx)) {
 199      case CXt_SUB:
 200      case CXt_FORMAT:
 201       /* The propagation workaround is only needed up to 5.10.0 and at that
 202        * time format and sub contexts were still identical. And even later the
 203        * cv members offsets should have been kept the same. */
 204       cv = cx->blk_sub.cv;
 205       goto get_enclosing_cv;
 206      case CXt_EVAL:
 207       cv = cx->blk_eval.cv;
 208       goto get_enclosing_cv;
 209      default:
 210       break;
 211     }
 212    }
 213   }
 214
 215   cv = PL_main_cv;
 216  }
 217
 218 get_enclosing_cv:
 219  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
 220   cv = outside;
 221
 222  return PTR2IV(cv);
 223 }
 224
 225 STATIC SV *a_tag(pTHX_ UV bits) {
 226 #define a_tag(B) a_tag(aTHX_ (B))
 227  a_hint_t *h;
 228  dMY_CXT;
 229
 230  h              = PerlMemShared_malloc(sizeof *h);
 231  h->bits        = bits;
 232  h->require_tag = a_require_tag();
 233
 234 #if A_THREADSAFE
 235  /* We only need for the key to be an unique tag for looking up the value later.
 236   * Allocated memory provides convenient unique identifiers, so that's why we
 237   * use the hint as the key itself. */
 238  ptable_hints_store(MY_CXT.tbl, h, h);
 239 #endif /* A_THREADSAFE */
 240
 241  return newSViv(PTR2IV(h));
 242 }
 243
 244 STATIC UV a_detag(pTHX_ const SV *hint) {
 245 #define a_detag(H) a_detag(aTHX_ (H))
 246  a_hint_t *h;
 247  dMY_CXT;
 248
 249  if (!(hint && SvIOK(hint)))
 250   return 0;
 251
 252  h = INT2PTR(a_hint_t *, SvIVX(hint));
 253 #if A_THREADSAFE
 254  h = ptable_fetch(MY_CXT.tbl, h);
 255 #endif /* A_THREADSAFE */
 256
 257  if (a_require_tag() != h->require_tag)
 258   return 0;
 259
 260  return h->bits;
 261 }
 262
 263 #else /* A_WORKAROUND_REQUIRE_PROPAGATION */
 264
 265 #define a_tag(B)   newSVuv(B)
 266 /* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV
 267  * from a copy. */
 268 #define a_detag(H) \
 269  ((H)              \
 270   ? (SvIOK(H)      \
 271      ? SvUVX(H)    \
 272      : (SvPOK(H)   \
 273         ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
 274         : 0        \
 275        )           \
 276      )             \
 277   : 0)
 278
 279 #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
 280
 281 /* Used both for hints and op flags */
 282 #define A_HINT_STRICT 1
 283 #define A_HINT_WARN   2
 284 #define A_HINT_FETCH  4
 285 #define A_HINT_STORE  8
 286 #define A_HINT_EXISTS 16
 287 #define A_HINT_DELETE 32
 288 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
 289 #define A_HINT_DO     (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
 290 #define A_HINT_MASK   (A_HINT_NOTIFY|A_HINT_DO)
 291
 292 /* Only used in op flags */
 293 #define A_HINT_ROOT   64
 294 #define A_HINT_DEREF  128
 295
 296 STATIC U32 a_hash = 0;
 297
 298 STATIC UV a_hint(pTHX) {
 299 #define a_hint() a_hint(aTHX)
 300  SV *hint;
 301 #if A_HAS_PERL(5, 9, 5)
 302  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 303                                        NULL,
 304                                        __PACKAGE__, __PACKAGE_LEN__,
 305                                        0,
 306                                        a_hash);
 307 #else
 308  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, a_hash);
 309  if (!val)
 310   return 0;
 311  hint = *val;
 312 #endif
 313  return a_detag(hint);
 314 }
 315
 316 /* ... op => info map ...................................................... */
 317
 318 typedef struct {
 319  OP *(*old_pp)(pTHX);
 320  UV flags;
 321  void *next;
 322 } a_op_info;
 323
 324 #define PTABLE_NAME        ptable_map
 325 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 326
 327 #include "ptable.h"
 328
 329 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 330 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 331
 332 STATIC ptable *a_op_map = NULL;
 333
 334 #ifdef USE_ITHREADS
 335 STATIC perl_mutex a_op_map_mutex;
 336 #endif
 337
 338 STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
 339  const a_op_info *val;
 340
 341 #ifdef USE_ITHREADS
 342  MUTEX_LOCK(&a_op_map_mutex);
 343 #endif
 344
 345  val = ptable_fetch(a_op_map, o);
 346  if (val) {
 347   *oi = *val;
 348   val = oi;
 349  }
 350
 351 #ifdef USE_ITHREADS
 352  MUTEX_UNLOCK(&a_op_map_mutex);
 353 #endif
 354
 355  return val;
 356 }
 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_store(a_op_map, o, NULL);
 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, a_op_info *oi) {
 500  UV flags = 0, rflags;
 501  const OP *root;
 502  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 /* ... Lightweight pp_defined() ............................................ */
 533
 534 STATIC bool a_defined(pTHX_ SV *sv) {
 535 #define a_defined(S) a_defined(aTHX_ (S))
 536  bool defined = FALSE;
 537
 538  switch (SvTYPE(sv)) {
 539   case SVt_PVAV:
 540    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
 541                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 542     defined = TRUE;
 543    break;
 544   case SVt_PVHV:
 545    if (HvARRAY(sv) || SvGMAGICAL(sv)
 546                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 547     defined = TRUE;
 548    break;
 549   default:
 550    SvGETMAGIC(sv);
 551    if (SvOK(sv))
 552     defined = TRUE;
 553  }
 554
 555  return defined;
 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  a_op_info oi;
 570  UV flags;
 571  dSP;
 572
 573  a_map_fetch(PL_op, &oi);
 574  flags = oi.flags;
 575
 576  if (flags & A_HINT_DEREF) {
 577   if (!a_defined(TOPs)) {
 578    /* We always need to push an empty array to fool the pp_aelem() that comes
 579     * later. */
 580    SV *av;
 581    POPs;
 582    av = sv_2mortal((SV *) newAV());
 583    PUSHs(av);
 584    RETURN;
 585   }
 586  } else {
 587   PL_op->op_ppaddr = oi.old_pp;
 588  }
 589
 590  return CALL_FPTR(oi.old_pp)(aTHX);
 591 }
 592
 593 /* ... pp_rv2hv ............................................................ */
 594
 595 STATIC OP *a_pp_rv2hv_simple(pTHX) {
 596  a_op_info oi;
 597  UV flags;
 598  dSP;
 599
 600  a_map_fetch(PL_op, &oi);
 601  flags = oi.flags;
 602
 603  if (flags & A_HINT_DEREF) {
 604   if (!a_defined(TOPs))
 605    RETURN;
 606  } else {
 607   PL_op->op_ppaddr = oi.old_pp;
 608  }
 609
 610  return CALL_FPTR(oi.old_pp)(aTHX);
 611 }
 612
 613 STATIC OP *a_pp_rv2hv(pTHX) {
 614  a_op_info oi;
 615  UV flags;
 616  dSP;
 617
 618  a_map_fetch(PL_op, &oi);
 619  flags = oi.flags;
 620
 621  if (flags & A_HINT_DEREF) {
 622   if (!a_defined(TOPs)) {
 623    SV *hv;
 624    POPs;
 625    hv = sv_2mortal((SV *) newHV());
 626    PUSHs(hv);
 627    RETURN;
 628   }
 629  } else {
 630   PL_op->op_ppaddr = oi.old_pp;
 631  }
 632
 633  return CALL_FPTR(oi.old_pp)(aTHX);
 634 }
 635
 636 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
 637
 638 STATIC OP *a_pp_deref(pTHX) {
 639  a_op_info oi;
 640  UV flags;
 641  dSP;
 642
 643  a_map_fetch(PL_op, &oi);
 644  flags = oi.flags;
 645
 646  if (flags & A_HINT_DEREF) {
 647   OP *o;
 648   U8 old_private;
 649
 650 deref:
 651   old_private       = PL_op->op_private;
 652   PL_op->op_private = ((old_private & ~OPpDEREF) | OPpLVAL_DEFER);
 653   o = CALL_FPTR(oi.old_pp)(aTHX);
 654   PL_op->op_private = old_private;
 655
 656   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
 657    SPAGAIN;
 658    if (!a_defined(TOPs)) {
 659     if (flags & A_HINT_STRICT)
 660      croak("Reference vivification forbidden");
 661     else if (flags & A_HINT_WARN)
 662       warn("Reference was vivified");
 663     else /* A_HINT_STORE */
 664      croak("Can't vivify reference");
 665    }
 666   }
 667
 668   return o;
 669  } else if ((flags & ~A_HINT_ROOT)
 670                     && (PL_op->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
 671   /* Decide if the expression must autovivify or not.
 672    * This branch should be called only once by expression. */
 673   flags = a_map_resolve(PL_op, &oi);
 674
 675   /* We need the updated flags value in the deref branch. */
 676   if (flags & A_HINT_DEREF)
 677    goto deref;
 678  }
 679
 680  /* This op doesn't need to skip autovivification, so restore the original
 681   * state. */
 682  PL_op->op_ppaddr = oi.old_pp;
 683
 684  return CALL_FPTR(oi.old_pp)(aTHX);
 685 }
 686
 687 /* ... pp_root (exists,delete,keys,values) ................................. */
 688
 689 STATIC OP *a_pp_root_unop(pTHX) {
 690  a_op_info oi;
 691  dSP;
 692
 693  if (!a_defined(TOPs)) {
 694   POPs;
 695   /* Can only be reached by keys or values */
 696   if (GIMME_V == G_SCALAR) {
 697    dTARGET;
 698    PUSHi(0);
 699   }
 700   RETURN;
 701  }
 702
 703  a_map_fetch(PL_op, &oi);
 704
 705  return CALL_FPTR(oi.old_pp)(aTHX);
 706 }
 707
 708 STATIC OP *a_pp_root_binop(pTHX) {
 709  a_op_info oi;
 710  dSP;
 711
 712  if (!a_defined(TOPm1s)) {
 713   POPs;
 714   POPs;
 715   if (PL_op->op_type == OP_EXISTS)
 716    RETPUSHNO;
 717   else
 718    RETPUSHUNDEF;
 719  }
 720
 721  a_map_fetch(PL_op, &oi);
 722
 723  return CALL_FPTR(oi.old_pp)(aTHX);
 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  a_op_info oi;
 731
 732  if (o->op_type == type && o->op_ppaddr != new_pp
 733                         && cUNOPo->op_first->op_type != OP_GV
 734                         && a_map_fetch(o, &oi)) {
 735   a_map_store(o, o->op_ppaddr, oi.next, oi.flags);
 736   o->op_ppaddr = new_pp;
 737  }
 738
 739  return;
 740 }
 741
 742 /* ... ck_pad{any,sv} ...................................................... */
 743
 744 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 745  * function, but are instead manually mutated from a PADANY. This is why we set
 746  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 747  * their op_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 748  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 749  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 750  * globally. */
 751
 752 STATIC OP *(*a_pp_padsv_saved)(pTHX) = 0;
 753
 754 STATIC void a_pp_padsv_save(void) {
 755  if (a_pp_padsv_saved)
 756   return;
 757
 758  a_pp_padsv_saved    = PL_ppaddr[OP_PADSV];
 759  PL_ppaddr[OP_PADSV] = a_pp_deref;
 760 }
 761
 762 STATIC void a_pp_padsv_restore(OP *o) {
 763  if (!a_pp_padsv_saved)
 764   return;
 765
 766  if (o->op_ppaddr == a_pp_deref)
 767   o->op_ppaddr = a_pp_padsv_saved;
 768
 769  PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
 770  a_pp_padsv_saved    = 0;
 771 }
 772
 773 STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
 774
 775 STATIC OP *a_ck_padany(pTHX_ OP *o) {
 776  UV hint;
 777
 778  a_pp_padsv_restore(o);
 779
 780  o = CALL_FPTR(a_old_ck_padany)(aTHX_ o);
 781
 782  hint = a_hint();
 783  if (hint & A_HINT_DO) {
 784   a_pp_padsv_save();
 785   a_map_store_root(o, a_pp_padsv_saved, hint);
 786  } else
 787   a_map_delete(o);
 788
 789  return o;
 790 }
 791
 792 STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
 793
 794 STATIC OP *a_ck_padsv(pTHX_ OP *o) {
 795  UV hint;
 796
 797  a_pp_padsv_restore(o);
 798
 799  o = CALL_FPTR(a_old_ck_padsv)(aTHX_ o);
 800
 801  hint = a_hint();
 802  if (hint & A_HINT_DO) {
 803   a_map_store_root(o, o->op_ppaddr, hint);
 804   o->op_ppaddr = a_pp_deref;
 805  } else
 806   a_map_delete(o);
 807
 808  return o;
 809 }
 810
 811 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
 812
 813 /* Those ops appear both at the root and inside an expression but there's no
 814  * way to distinguish both situations. Worse, we can't even know if we are in a
 815  * modifying context, so the expression can't be resolved yet. It will be at the
 816  * first invocation of a_pp_deref() for this expression. */
 817
 818 STATIC OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
 819 STATIC OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
 820 STATIC OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
 821
 822 STATIC OP *a_ck_deref(pTHX_ OP *o) {
 823  OP * (*old_ck)(pTHX_ OP *o) = 0;
 824  UV hint = a_hint();
 825
 826  switch (o->op_type) {
 827   case OP_AELEM:
 828    old_ck = a_old_ck_aelem;
 829    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 830     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
 831    break;
 832   case OP_HELEM:
 833    old_ck = a_old_ck_helem;
 834    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 835     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
 836    break;
 837   case OP_RV2SV:
 838    old_ck = a_old_ck_rv2sv;
 839    break;
 840  }
 841  o = CALL_FPTR(old_ck)(aTHX_ o);
 842
 843  if (hint & A_HINT_DO) {
 844   a_map_store_root(o, o->op_ppaddr, hint);
 845   o->op_ppaddr = a_pp_deref;
 846  } else
 847   a_map_delete(o);
 848
 849  return o;
 850 }
 851
 852 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
 853
 854 /* Those ops also appear both inisde and at the root, hence the caveats for
 855  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
 856  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
 857  * expression. */
 858
 859 STATIC OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
 860 STATIC OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
 861
 862 STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
 863  OP * (*old_ck)(pTHX_ OP *o) = 0;
 864  OP * (*new_pp)(pTHX)        = 0;
 865  UV hint;
 866
 867  switch (o->op_type) {
 868   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
 869   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
 870  }
 871  o = CALL_FPTR(old_ck)(aTHX_ o);
 872
 873  if (cUNOPo->op_first->op_type == OP_GV)
 874   return o;
 875
 876  hint = a_hint();
 877  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
 878   a_map_store_root(o, o->op_ppaddr, hint);
 879   o->op_ppaddr = new_pp;
 880  } else
 881   a_map_delete(o);
 882
 883  return o;
 884 }
 885
 886 /* ... ck_xslice (aslice,hslice) ........................................... */
 887
 888 /* I think those are only found at the root, but there's nothing that really
 889  * prevent them to be inside the expression too. We only need to update the
 890  * root so that the rest of the expression will see the right context when
 891  * resolving. That's why we don't replace the ppaddr. */
 892
 893 STATIC OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
 894 STATIC OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
 895
 896 STATIC OP *a_ck_xslice(pTHX_ OP *o) {
 897  OP * (*old_ck)(pTHX_ OP *o) = 0;
 898  UV hint = a_hint();
 899
 900  switch (o->op_type) {
 901   case OP_ASLICE:
 902    old_ck = a_old_ck_aslice;
 903    break;
 904   case OP_HSLICE:
 905    old_ck = a_old_ck_hslice;
 906    if (hint & A_HINT_DO)
 907     a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv);
 908    break;
 909  }
 910  o = CALL_FPTR(old_ck)(aTHX_ o);
 911
 912  if (hint & A_HINT_DO) {
 913   a_map_store_root(o, 0, hint);
 914  } else
 915   a_map_delete(o);
 916
 917  return o;
 918 }
 919
 920 /* ... ck_root (exists,delete,keys,values) ................................. */
 921
 922 /* Those ops are only found at the root of a dereferencing expression. We can
 923  * then resolve at compile time if vivification must take place or not. */
 924
 925 STATIC OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
 926 STATIC OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
 927 STATIC OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
 928 STATIC OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
 929
 930 STATIC OP *a_ck_root(pTHX_ OP *o) {
 931  OP * (*old_ck)(pTHX_ OP *o) = 0;
 932  OP * (*new_pp)(pTHX)        = 0;
 933  bool enabled = FALSE;
 934  UV hint = a_hint();
 935
 936  switch (o->op_type) {
 937   case OP_EXISTS:
 938    old_ck  = a_old_ck_exists;
 939    new_pp  = a_pp_root_binop;
 940    enabled = hint & A_HINT_EXISTS;
 941    break;
 942   case OP_DELETE:
 943    old_ck  = a_old_ck_delete;
 944    new_pp  = a_pp_root_binop;
 945    enabled = hint & A_HINT_DELETE;
 946    break;
 947   case OP_KEYS:
 948    old_ck  = a_old_ck_keys;
 949    new_pp  = a_pp_root_unop;
 950    enabled = hint & A_HINT_FETCH;
 951    break;
 952   case OP_VALUES:
 953    old_ck  = a_old_ck_values;
 954    new_pp  = a_pp_root_unop;
 955    enabled = hint & A_HINT_FETCH;
 956    break;
 957  }
 958  o = CALL_FPTR(old_ck)(aTHX_ o);
 959
 960  if (hint & A_HINT_DO) {
 961   if (enabled) {
 962    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
 963    a_map_store_root(o, o->op_ppaddr, hint);
 964    o->op_ppaddr = new_pp;
 965   } else {
 966    a_map_cancel(o);
 967   }
 968  } else
 969   a_map_delete(o);
 970
 971  return o;
 972 }
 973
 974 STATIC U32 a_initialized = 0;
 975
 976 STATIC void a_teardown(pTHX_ void *root) {
 977
 978  if (!a_initialized)
 979   return;
 980
 981 #if A_MULTIPLICITY
 982  if (aTHX != root)
 983   return;
 984 #endif
 985
 986 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
 987  {
 988   dMY_CXT;
 989   ptable_hints_free(MY_CXT.tbl);
 990  }
 991 #endif
 992
 993  PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_old_ck_padany);
 994  a_old_ck_padany     = 0;
 995  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_old_ck_padsv);
 996  a_old_ck_padsv      = 0;
 997
 998  PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_old_ck_aelem);
 999  a_old_ck_aelem      = 0;
1000  PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_old_ck_helem);
1001  a_old_ck_helem      = 0;
1002  PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_old_ck_rv2sv);
1003  a_old_ck_rv2sv      = 0;
1004
1005  PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_old_ck_rv2av);
1006  a_old_ck_rv2av      = 0;
1007  PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_old_ck_rv2hv);
1008  a_old_ck_rv2hv      = 0;
1009
1010  PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_old_ck_aslice);
1011  a_old_ck_aslice     = 0;
1012  PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_old_ck_hslice);
1013  a_old_ck_hslice     = 0;
1014
1015  PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_old_ck_exists);
1016  a_old_ck_exists     = 0;
1017  PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_old_ck_delete);
1018  a_old_ck_delete     = 0;
1019  PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_old_ck_keys);
1020  a_old_ck_keys       = 0;
1021  PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_old_ck_values);
1022  a_old_ck_values     = 0;
1023
1024  if (a_pp_padsv_saved) {
1025   PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
1026   a_pp_padsv_saved    = 0;
1027  }
1028
1029  a_initialized = 0;
1030 }
1031
1032 STATIC void a_setup(pTHX) {
1033 #define a_setup() a_setup(aTHX)
1034  if (a_initialized)
1035   return;
1036
1037 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1038  {
1039   MY_CXT_INIT;
1040   MY_CXT.tbl   = ptable_new();
1041   MY_CXT.owner = aTHX;
1042  }
1043 #endif
1044
1045  a_old_ck_padany     = PL_check[OP_PADANY];
1046  PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_ck_padany);
1047  a_old_ck_padsv      = PL_check[OP_PADSV];
1048  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_ck_padsv);
1049
1050  a_old_ck_aelem      = PL_check[OP_AELEM];
1051  PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_ck_deref);
1052  a_old_ck_helem      = PL_check[OP_HELEM];
1053  PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_ck_deref);
1054  a_old_ck_rv2sv      = PL_check[OP_RV2SV];
1055  PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_ck_deref);
1056
1057  a_old_ck_rv2av      = PL_check[OP_RV2AV];
1058  PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
1059  a_old_ck_rv2hv      = PL_check[OP_RV2HV];
1060  PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
1061
1062  a_old_ck_aslice     = PL_check[OP_ASLICE];
1063  PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1064  a_old_ck_hslice     = PL_check[OP_HSLICE];
1065  PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_ck_xslice);
1066
1067  a_old_ck_exists     = PL_check[OP_EXISTS];
1068  PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
1069  a_old_ck_delete     = PL_check[OP_DELETE];
1070  PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_ck_root);
1071  a_old_ck_keys       = PL_check[OP_KEYS];
1072  PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_ck_root);
1073  a_old_ck_values     = PL_check[OP_VALUES];
1074  PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_ck_root);
1075
1076 #if A_MULTIPLICITY
1077  call_atexit(a_teardown, aTHX);
1078 #else
1079  call_atexit(a_teardown, NULL);
1080 #endif
1081
1082  a_initialized = 1;
1083 }
1084
1085 STATIC U32 a_booted = 0;
1086
1087 /* --- XS ------------------------------------------------------------------ */
1088
1089 MODULE = autovivification      PACKAGE = autovivification
1090
1091 PROTOTYPES: ENABLE
1092
1093 BOOT:
1094 {
1095  if (!a_booted++) {
1096   HV *stash;
1097
1098   a_op_map = ptable_new();
1099 #ifdef USE_ITHREADS
1100   MUTEX_INIT(&a_op_map_mutex);
1101 #endif
1102
1103   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
1104
1105   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1106   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1107   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1108   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1109   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1110   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1111   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1112   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1113   newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(A_THREADSAFE));
1114   newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(A_FORKSAFE));
1115  }
1116
1117  a_setup();
1118 }
1119
1120 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1121
1122 void
1123 CLONE(...)
1124 PROTOTYPE: DISABLE
1125 PREINIT:
1126  ptable *t;
1127  int    *level;
1128 PPCODE:
1129  {
1130   my_cxt_t ud;
1131   dMY_CXT;
1132   ud.tbl   = t = ptable_new();
1133   ud.owner = MY_CXT.owner;
1134   ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1135  }
1136  {
1137   MY_CXT_CLONE;
1138   MY_CXT.tbl   = t;
1139   MY_CXT.owner = aTHX;
1140  }
1141  {
1142   level = PerlMemShared_malloc(sizeof *level);
1143   *level = 1;
1144   LEAVEn("sub");
1145   SAVEDESTRUCTOR_X(a_thread_cleanup, level);
1146   ENTERn("sub");
1147  }
1148  XSRETURN(0);
1149
1150 #endif
1151
1152 SV *
1153 _tag(SV *hint)
1154 PROTOTYPE: $
1155 CODE:
1156  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1157 OUTPUT:
1158  RETVAL
1159
1160 SV *
1161 _detag(SV *tag)
1162 PROTOTYPE: $
1163 CODE:
1164  if (!SvOK(tag))
1165   XSRETURN_UNDEF;
1166  RETVAL = newSVuv(a_detag(tag));
1167 OUTPUT:
1168  RETVAL