autovivification.xs

   1 /* This file is part of the autovivification Perl module.
   2  * See http://search.cpan.org/dist/autovivification/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "autovivification"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 /* --- Compatibility wrappers ---------------------------------------------- */
  13
  14 #ifndef HvNAME_get
  15 # define HvNAME_get(H) HvNAME(H)
  16 #endif
  17
  18 #ifndef HvNAMELEN_get
  19 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  20 #endif
  21
  22 #define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  23
  24 #ifndef A_WORKAROUND_REQUIRE_PROPAGATION
  25 # define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1)
  26 #endif
  27
  28 #ifndef A_HAS_RPEEP
  29 # define A_HAS_RPEEP A_HAS_PERL(5, 13, 5)
  30 #endif
  31
  32 #ifndef A_HAS_MULTIDEREF
  33 # define A_HAS_MULTIDEREF A_HAS_PERL(5, 21, 7)
  34 #endif
  35
  36 #ifndef OpSIBLING
  37 # ifdef OP_SIBLING
  38 #  define OpSIBLING(O) OP_SIBLING(O)
  39 # else
  40 #  define OpSIBLING(O) ((O)->op_sibling)
  41 # endif
  42 #endif
  43
  44 /* ... Thread safety and multiplicity ...................................... */
  45
  46 /* Always safe when the workaround isn't needed */
  47 #if !A_WORKAROUND_REQUIRE_PROPAGATION
  48 # undef A_FORKSAFE
  49 # define A_FORKSAFE 1
  50 /* Otherwise, safe unless Makefile.PL says it's Win32 */
  51 #elif !defined(A_FORKSAFE)
  52 # define A_FORKSAFE 1
  53 #endif
  54
  55 #ifndef A_MULTIPLICITY
  56 # if defined(MULTIPLICITY)
  57 #  define A_MULTIPLICITY 1
  58 # else
  59 #  define A_MULTIPLICITY 0
  60 # endif
  61 #endif
  62 #if A_MULTIPLICITY
  63 # ifndef PERL_IMPLICIT_CONTEXT
  64 #  error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT
  65 # endif
  66 #endif
  67
  68 #ifndef tTHX
  69 # define tTHX PerlInterpreter*
  70 #endif
  71
  72 #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))
  73 # define A_THREADSAFE 1
  74 # ifndef MY_CXT_CLONE
  75 #  define MY_CXT_CLONE \
  76     dMY_CXT_SV;                                                      \
  77     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  78     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  79     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  80 # endif
  81 #else
  82 # define A_THREADSAFE 0
  83 # undef  dMY_CXT
  84 # define dMY_CXT      dNOOP
  85 # undef  MY_CXT
  86 # define MY_CXT       a_globaldata
  87 # undef  START_MY_CXT
  88 # define START_MY_CXT static my_cxt_t MY_CXT;
  89 # undef  MY_CXT_INIT
  90 # define MY_CXT_INIT  NOOP
  91 # undef  MY_CXT_CLONE
  92 # define MY_CXT_CLONE NOOP
  93 #endif
  94
  95 #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
  96 # define A_CHECK_MUTEX_LOCK   OP_CHECK_MUTEX_LOCK
  97 # define A_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK
  98 #else
  99 # define A_CHECK_MUTEX_LOCK   OP_REFCNT_LOCK
 100 # define A_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK
 101 #endif
 102
 103 typedef OP *(*a_ck_t)(pTHX_ OP *);
 104
 105 #ifdef wrap_op_checker
 106
 107 # define a_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
 108
 109 #else
 110
 111 static void a_ck_replace(pTHX_ OPCODE type, a_ck_t new_ck, a_ck_t *old_ck_p) {
 112 #define a_ck_replace(T, NC, OCP) a_ck_replace(aTHX_ (T), (NC), (OCP))
 113  A_CHECK_MUTEX_LOCK;
 114  if (!*old_ck_p) {
 115   *old_ck_p      = PL_check[type];
 116   PL_check[type] = new_ck;
 117  }
 118  A_CHECK_MUTEX_UNLOCK;
 119 }
 120
 121 #endif
 122
 123 static void a_ck_restore(pTHX_ OPCODE type, a_ck_t *old_ck_p) {
 124 #define a_ck_restore(T, OCP) a_ck_restore(aTHX_ (T), (OCP))
 125  A_CHECK_MUTEX_LOCK;
 126  if (*old_ck_p) {
 127   PL_check[type] = *old_ck_p;
 128   *old_ck_p      = 0;
 129  }
 130  A_CHECK_MUTEX_UNLOCK;
 131 }
 132
 133 /* --- Helpers ------------------------------------------------------------- */
 134
 135 /* ... Thread-safe hints ................................................... */
 136
 137 #if A_WORKAROUND_REQUIRE_PROPAGATION
 138
 139 typedef struct {
 140  U32 bits;
 141  IV  require_tag;
 142 } a_hint_t;
 143
 144 #define A_HINT_FREE(H) PerlMemShared_free(H)
 145
 146 #if A_THREADSAFE
 147
 148 #define PTABLE_NAME        ptable_hints
 149 #define PTABLE_VAL_FREE(V) A_HINT_FREE(V)
 150
 151 #define pPTBL  pTHX
 152 #define pPTBL_ pTHX_
 153 #define aPTBL  aTHX
 154 #define aPTBL_ aTHX_
 155
 156 #include "ptable.h"
 157
 158 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
 159 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
 160
 161 #endif /* A_THREADSAFE */
 162
 163 #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
 164
 165 #define PTABLE_NAME        ptable_seen
 166 #define PTABLE_VAL_FREE(V) NOOP
 167
 168 #include "ptable.h"
 169
 170 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 171 #define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
 172 #define ptable_seen_clear(T)       ptable_seen_clear(aPTBLMS_ (T))
 173 #define ptable_seen_free(T)        ptable_seen_free(aPTBLMS_ (T))
 174
 175 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 176
 177 typedef struct {
 178 #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
 179  ptable *tbl;   /* It really is a ptable_hints */
 180  tTHX    owner;
 181 #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
 182  ptable *seen;  /* It really is a ptable_seen */
 183 } my_cxt_t;
 184
 185 START_MY_CXT
 186
 187 #if A_THREADSAFE
 188
 189 #if A_WORKAROUND_REQUIRE_PROPAGATION
 190
 191 typedef struct {
 192  ptable       *tbl;
 193 #if A_HAS_PERL(5, 13, 2)
 194  CLONE_PARAMS *params;
 195 #else
 196  CLONE_PARAMS  params;
 197 #endif
 198 } a_ptable_clone_ud;
 199
 200 #if A_HAS_PERL(5, 13, 2)
 201 # define a_ptable_clone_ud_init(U, T, O) \
 202    (U).tbl    = (T); \
 203    (U).params = Perl_clone_params_new((O), aTHX)
 204 # define a_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
 205 # define a_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), (U)->params))
 206 #else
 207 # define a_ptable_clone_ud_init(U, T, O) \
 208    (U).tbl               = (T);     \
 209    (U).params.stashes    = newAV(); \
 210    (U).params.flags      = 0;       \
 211    (U).params.proto_perl = (O)
 212 # define a_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
 213 # define a_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), &((U)->params)))
 214 #endif
 215
 216 static void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 217  a_ptable_clone_ud *ud = ud_;
 218  a_hint_t *h1 = ent->val;
 219  a_hint_t *h2;
 220
 221  h2              = PerlMemShared_malloc(sizeof *h2);
 222  h2->bits        = h1->bits;
 223  h2->require_tag = PTR2IV(a_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
 224
 225  ptable_hints_store(ud->tbl, ent->key, h2);
 226 }
 227
 228 #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
 229
 230 static void a_thread_cleanup(pTHX_ void *ud) {
 231  dMY_CXT;
 232
 233 #if A_WORKAROUND_REQUIRE_PROPAGATION
 234  ptable_hints_free(MY_CXT.tbl);
 235  MY_CXT.tbl  = NULL;
 236 #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
 237  ptable_seen_free(MY_CXT.seen);
 238  MY_CXT.seen = NULL;
 239 }
 240
 241 static int a_endav_free(pTHX_ SV *sv, MAGIC *mg) {
 242  SAVEDESTRUCTOR_X(a_thread_cleanup, NULL);
 243
 244  return 0;
 245 }
 246
 247 static MGVTBL a_endav_vtbl = {
 248  0,
 249  0,
 250  0,
 251  0,
 252  a_endav_free
 253 #if MGf_COPY
 254  , 0
 255 #endif
 256 #if MGf_DUP
 257  , 0
 258 #endif
 259 #if MGf_LOCAL
 260  , 0
 261 #endif
 262 };
 263
 264 #endif /* A_THREADSAFE */
 265
 266 #if A_WORKAROUND_REQUIRE_PROPAGATION
 267
 268 static IV a_require_tag(pTHX) {
 269 #define a_require_tag() a_require_tag(aTHX)
 270  const CV *cv, *outside;
 271
 272  cv = PL_compcv;
 273
 274  if (!cv) {
 275   /* If for some reason the pragma is operational at run-time, try to discover
 276    * the current cv in use. */
 277   const PERL_SI *si;
 278
 279   for (si = PL_curstackinfo; si; si = si->si_prev) {
 280    I32 cxix;
 281
 282    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 283     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 284
 285     switch (CxTYPE(cx)) {
 286      case CXt_SUB:
 287      case CXt_FORMAT:
 288       /* The propagation workaround is only needed up to 5.10.0 and at that
 289        * time format and sub contexts were still identical. And even later the
 290        * cv members offsets should have been kept the same. */
 291       cv = cx->blk_sub.cv;
 292       goto get_enclosing_cv;
 293      case CXt_EVAL:
 294       cv = cx->blk_eval.cv;
 295       goto get_enclosing_cv;
 296      default:
 297       break;
 298     }
 299    }
 300   }
 301
 302   cv = PL_main_cv;
 303  }
 304
 305 get_enclosing_cv:
 306  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
 307   cv = outside;
 308
 309  return PTR2IV(cv);
 310 }
 311
 312 static SV *a_tag(pTHX_ UV bits) {
 313 #define a_tag(B) a_tag(aTHX_ (B))
 314  a_hint_t *h;
 315 #if A_THREADSAFE
 316  dMY_CXT;
 317
 318  if (!MY_CXT.tbl)
 319   return newSViv(0);
 320 #endif /* A_THREADSAFE */
 321
 322  h              = PerlMemShared_malloc(sizeof *h);
 323  h->bits        = bits;
 324  h->require_tag = a_require_tag();
 325
 326 #if A_THREADSAFE
 327  /* We only need for the key to be an unique tag for looking up the value later
 328   * Allocated memory provides convenient unique identifiers, so that's why we
 329   * use the hint as the key itself. */
 330  ptable_hints_store(MY_CXT.tbl, h, h);
 331 #endif /* A_THREADSAFE */
 332
 333  return newSViv(PTR2IV(h));
 334 }
 335
 336 static UV a_detag(pTHX_ const SV *hint) {
 337 #define a_detag(H) a_detag(aTHX_ (H))
 338  a_hint_t *h;
 339 #if A_THREADSAFE
 340  dMY_CXT;
 341
 342  if (!MY_CXT.tbl)
 343   return 0;
 344 #endif /* A_THREADSAFE */
 345
 346  if (!(hint && SvIOK(hint)))
 347   return 0;
 348
 349  h = INT2PTR(a_hint_t *, SvIVX(hint));
 350 #if A_THREADSAFE
 351  h = ptable_fetch(MY_CXT.tbl, h);
 352 #endif /* A_THREADSAFE */
 353
 354  if (a_require_tag() != h->require_tag)
 355   return 0;
 356
 357  return h->bits;
 358 }
 359
 360 #else /* A_WORKAROUND_REQUIRE_PROPAGATION */
 361
 362 #define a_tag(B)   newSVuv(B)
 363 /* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV
 364  * from a copy. */
 365 #define a_detag(H) \
 366  ((H)              \
 367   ? (SvIOK(H)      \
 368      ? SvUVX(H)    \
 369      : (SvPOK(H)   \
 370         ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
 371         : 0        \
 372        )           \
 373      )             \
 374   : 0)
 375
 376 #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
 377
 378 /* Used both for hints and op flags */
 379 #define A_HINT_STRICT 1
 380 #define A_HINT_WARN   2
 381 #define A_HINT_FETCH  4
 382 #define A_HINT_STORE  8
 383 #define A_HINT_EXISTS 16
 384 #define A_HINT_DELETE 32
 385 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
 386 #define A_HINT_DO     (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
 387 #define A_HINT_MASK   (A_HINT_NOTIFY|A_HINT_DO)
 388
 389 /* Only used in op flags */
 390 #define A_HINT_ROOT   64
 391 #define A_HINT_DEREF  128
 392
 393 static U32 a_hash = 0;
 394
 395 static UV a_hint(pTHX) {
 396 #define a_hint() a_hint(aTHX)
 397  SV *hint;
 398 #ifdef cop_hints_fetch_pvn
 399  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, a_hash, 0);
 400 #elif A_HAS_PERL(5, 9, 5)
 401  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 402                                        NULL,
 403                                        __PACKAGE__, __PACKAGE_LEN__,
 404                                        0,
 405                                        a_hash);
 406 #else
 407  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
 408  if (!val)
 409   return 0;
 410  hint = *val;
 411 #endif
 412  return a_detag(hint);
 413 }
 414
 415 /* ... op => info map ...................................................... */
 416
 417 typedef struct {
 418  OP   *(*old_pp)(pTHX);
 419  void   *next;
 420  UV      flags;
 421 } a_op_info;
 422
 423 #define PTABLE_NAME        ptable_map
 424 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 425
 426 #include "ptable.h"
 427
 428 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 429 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 430 #define ptable_map_delete(T, K)   ptable_map_delete(aPTBLMS_ (T), (K))
 431
 432 static ptable *a_op_map = NULL;
 433
 434 #ifdef USE_ITHREADS
 435
 436 #define dA_MAP_THX a_op_info a_op_map_tmp_oi
 437
 438 static perl_mutex a_op_map_mutex;
 439
 440 #define A_LOCK(M)   MUTEX_LOCK(M)
 441 #define A_UNLOCK(M) MUTEX_UNLOCK(M)
 442
 443 static const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
 444  const a_op_info *val;
 445
 446  A_LOCK(&a_op_map_mutex);
 447
 448  val = ptable_fetch(a_op_map, o);
 449  if (val) {
 450   *oi = *val;
 451   val = oi;
 452  }
 453
 454  A_UNLOCK(&a_op_map_mutex);
 455
 456  return val;
 457 }
 458
 459 #define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi)
 460
 461 #else /* USE_ITHREADS */
 462
 463 #define dA_MAP_THX dNOOP
 464
 465 #define A_LOCK(M)   NOOP
 466 #define A_UNLOCK(M) NOOP
 467
 468 #define a_map_fetch(O) ptable_fetch(a_op_map, (O))
 469
 470 #endif /* !USE_ITHREADS */
 471
 472 static const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
 473 #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F))
 474  a_op_info *oi;
 475
 476  if (!(oi = ptable_fetch(a_op_map, o))) {
 477   oi = PerlMemShared_malloc(sizeof *oi);
 478   ptable_map_store(a_op_map, o, oi);
 479  }
 480
 481  oi->old_pp = old_pp;
 482  oi->next   = next;
 483  oi->flags  = flags;
 484
 485  return oi;
 486 }
 487
 488 static void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
 489 #define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F))
 490  A_LOCK(&a_op_map_mutex);
 491
 492  a_map_store_locked(o, old_pp, next, flags);
 493
 494  A_UNLOCK(&a_op_map_mutex);
 495 }
 496
 497 static void a_map_delete(pTHX_ const OP *o) {
 498 #define a_map_delete(O) a_map_delete(aTHX_ (O))
 499  A_LOCK(&a_op_map_mutex);
 500
 501  ptable_map_delete(a_op_map, o);
 502
 503  A_UNLOCK(&a_op_map_mutex);
 504 }
 505
 506 static const OP *a_map_descend(const OP *o) {
 507  switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 508   case OA_BASEOP:
 509   case OA_UNOP:
 510   case OA_BINOP:
 511   case OA_BASEOP_OR_UNOP:
 512    return cUNOPo->op_first;
 513   case OA_LIST:
 514   case OA_LISTOP:
 515    return cLISTOPo->op_last;
 516  }
 517
 518  return NULL;
 519 }
 520
 521 static void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV flags) {
 522 #define a_map_store_root(R, PP, F) a_map_store_root(aPTBLMS_ (R), (PP), (F))
 523  const a_op_info *roi;
 524  a_op_info *oi;
 525  const OP *o = root;
 526
 527  A_LOCK(&a_op_map_mutex);
 528
 529  roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT);
 530
 531  while (o->op_flags & OPf_KIDS) {
 532   o = a_map_descend(o);
 533   if (!o)
 534    break;
 535   if ((oi = ptable_fetch(a_op_map, o))) {
 536    oi->flags &= ~A_HINT_ROOT;
 537    oi->next   = (a_op_info *) roi;
 538    break;
 539   }
 540  }
 541
 542  A_UNLOCK(&a_op_map_mutex);
 543
 544  return;
 545 }
 546
 547 static void a_map_update_flags_topdown(const OP *root, UV flags) {
 548  a_op_info *oi;
 549  const OP *o = root;
 550
 551  A_LOCK(&a_op_map_mutex);
 552
 553  flags &= ~A_HINT_ROOT;
 554
 555  do {
 556   if ((oi = ptable_fetch(a_op_map, o)))
 557    oi->flags = (oi->flags & A_HINT_ROOT) | flags;
 558   if (!(o->op_flags & OPf_KIDS))
 559    break;
 560   o = a_map_descend(o);
 561  } while (o);
 562
 563  A_UNLOCK(&a_op_map_mutex);
 564
 565  return;
 566 }
 567
 568 #define a_map_cancel(R) a_map_update_flags_topdown((R), 0)
 569
 570 static void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
 571  a_op_info *oi;
 572
 573  A_LOCK(&a_op_map_mutex);
 574
 575  flags  &= ~A_HINT_ROOT;
 576  rflags |=  A_HINT_ROOT;
 577
 578  oi = ptable_fetch(a_op_map, o);
 579  while (!(oi->flags & A_HINT_ROOT)) {
 580   oi->flags = flags;
 581   oi        = oi->next;
 582  }
 583  oi->flags = rflags;
 584
 585  A_UNLOCK(&a_op_map_mutex);
 586
 587  return;
 588 }
 589
 590 /* ... Decide whether this expression should be autovivified or not ........ */
 591
 592 static UV a_map_resolve(const OP *o, const a_op_info *oi) {
 593  UV flags = 0, rflags;
 594  const OP *root;
 595  const a_op_info *roi = oi;
 596
 597  while (!(roi->flags & A_HINT_ROOT))
 598   roi = roi->next;
 599  if (!roi)
 600   goto cancel;
 601
 602  rflags = roi->flags & ~A_HINT_ROOT;
 603  if (!rflags)
 604   goto cancel;
 605
 606  root = roi->next;
 607  if (root->op_flags & OPf_MOD) {
 608   if (rflags & A_HINT_STORE)
 609    flags = (A_HINT_STORE|A_HINT_DEREF);
 610  } else if (rflags & A_HINT_FETCH)
 611    flags = (A_HINT_FETCH|A_HINT_DEREF);
 612
 613  if (!flags) {
 614 cancel:
 615   a_map_update_flags_bottomup(o, 0, 0);
 616   return 0;
 617  }
 618
 619  flags |= (rflags & A_HINT_NOTIFY);
 620  a_map_update_flags_bottomup(o, flags, 0);
 621
 622  return oi->flags & A_HINT_ROOT ? 0 : flags;
 623 }
 624
 625 /* ... Inspired from pp_defined() .......................................... */
 626
 627 static int a_undef(pTHX_ SV *sv) {
 628 #define a_undef(S) a_undef(aTHX_ (S))
 629  switch (SvTYPE(sv)) {
 630   case SVt_NULL:
 631    return 1;
 632   case SVt_PVAV:
 633    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
 634                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 635     return 0;
 636    break;
 637   case SVt_PVHV:
 638    if (HvARRAY(sv) || SvGMAGICAL(sv)
 639                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 640     return 0;
 641    break;
 642   default:
 643    SvGETMAGIC(sv);
 644    if (SvOK(sv))
 645     return 0;
 646  }
 647
 648  return 1;
 649 }
 650
 651 /* --- PP functions -------------------------------------------------------- */
 652
 653 /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp
 654  * value, another extension might have saved our pp replacement as the ppaddr
 655  * for this op, so this doesn't ensure that our function will never be called
 656  * again. That's why we don't remove the op info from our map, so that it can
 657  * still run correctly if required. */
 658
 659 /* ... pp_rv2av ............................................................ */
 660
 661 static OP *a_pp_rv2av(pTHX) {
 662  dA_MAP_THX;
 663  const a_op_info *oi;
 664  dSP;
 665
 666  oi = a_map_fetch(PL_op);
 667
 668  if (oi->flags & A_HINT_DEREF) {
 669   if (a_undef(TOPs)) {
 670    /* We always need to push an empty array to fool the pp_aelem() that comes
 671     * later. */
 672    SV *av;
 673    (void) POPs;
 674    av = sv_2mortal((SV *) newAV());
 675    PUSHs(av);
 676    RETURN;
 677   }
 678  }
 679
 680  return oi->old_pp(aTHX);
 681 }
 682
 683 /* ... pp_rv2hv ............................................................ */
 684
 685 static OP *a_pp_rv2hv_simple(pTHX) {
 686  dA_MAP_THX;
 687  const a_op_info *oi;
 688  dSP;
 689
 690  oi = a_map_fetch(PL_op);
 691
 692  if (oi->flags & A_HINT_DEREF) {
 693   if (a_undef(TOPs))
 694    RETURN;
 695  }
 696
 697  return oi->old_pp(aTHX);
 698 }
 699
 700 static OP *a_pp_rv2hv(pTHX) {
 701  dA_MAP_THX;
 702  const a_op_info *oi;
 703  dSP;
 704
 705  oi = a_map_fetch(PL_op);
 706
 707  if (oi->flags & A_HINT_DEREF) {
 708   if (a_undef(TOPs)) {
 709    SV *hv;
 710    (void) POPs;
 711    hv = sv_2mortal((SV *) newHV());
 712    PUSHs(hv);
 713    RETURN;
 714   }
 715  }
 716
 717  return oi->old_pp(aTHX);
 718 }
 719
 720 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
 721
 722 static void a_cannot_vivify(pTHX_ UV flags) {
 723 #define a_cannot_vivify(F) a_cannot_vivify(aTHX_ (F))
 724  if (flags & A_HINT_STRICT)
 725   croak("Reference vivification forbidden");
 726  else if (flags & A_HINT_WARN)
 727   warn("Reference was vivified");
 728  else /* A_HINT_STORE */
 729   croak("Can't vivify reference");
 730 }
 731
 732 static OP *a_pp_deref(pTHX) {
 733  dA_MAP_THX;
 734  const a_op_info *oi;
 735  UV flags;
 736  dSP;
 737
 738  oi = a_map_fetch(PL_op);
 739
 740  flags = oi->flags;
 741  if (flags & A_HINT_DEREF) {
 742   OP *o;
 743
 744   o = oi->old_pp(aTHX);
 745
 746   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
 747    SPAGAIN;
 748    if (a_undef(TOPs))
 749     a_cannot_vivify(flags);
 750   }
 751
 752   return o;
 753  }
 754
 755  return oi->old_pp(aTHX);
 756 }
 757
 758 /* ... pp_root (exists,delete,keys,values) ................................. */
 759
 760 static OP *a_pp_root_unop(pTHX) {
 761  dSP;
 762
 763  if (a_undef(TOPs)) {
 764   (void) POPs;
 765   /* Can only be reached by keys or values */
 766   if (GIMME_V == G_SCALAR) {
 767    dTARGET;
 768    PUSHi(0);
 769   }
 770   RETURN;
 771  }
 772
 773  {
 774   dA_MAP_THX;
 775   const a_op_info *oi = a_map_fetch(PL_op);
 776   return oi->old_pp(aTHX);
 777  }
 778 }
 779
 780 static OP *a_pp_root_binop(pTHX) {
 781  dSP;
 782
 783  if (a_undef(TOPm1s)) {
 784   (void) POPs;
 785   (void) POPs;
 786   if (PL_op->op_type == OP_EXISTS)
 787    RETPUSHNO;
 788   else
 789    RETPUSHUNDEF;
 790  }
 791
 792  {
 793   dA_MAP_THX;
 794   const a_op_info *oi = a_map_fetch(PL_op);
 795   return oi->old_pp(aTHX);
 796  }
 797 }
 798
 799 #if A_HAS_MULTIDEREF
 800
 801 /* ... pp_multideref ....................................................... */
 802
 803 static UV a_do_multideref(const OP *o, UV flags) {
 804  UV isexdel, other_flags;
 805
 806  assert(o->op_type == OP_MULTIDEREF);
 807
 808  other_flags = flags & ~A_HINT_DO;
 809
 810  isexdel = o->op_private & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE);
 811  if (isexdel) {
 812   if (isexdel & OPpMULTIDEREF_EXISTS) {
 813    flags &= A_HINT_EXISTS;
 814   } else {
 815    flags &= A_HINT_DELETE;
 816   }
 817  } else {
 818   if (o->op_flags & OPf_MOD) {
 819    flags &= A_HINT_STORE;
 820   } else {
 821    flags &= A_HINT_FETCH;
 822   }
 823  }
 824
 825  return flags ? (flags | other_flags) : 0;
 826 }
 827
 828 static SV *a_do_fake_pp(pTHX_ OP *op) {
 829 #define a_do_fake_pp(O) a_do_fake_pp(aTHX_ (O))
 830  {
 831   OP *o = PL_op;
 832   ENTER;
 833   SAVEOP();
 834   PL_op = op;
 835   PL_op->op_ppaddr(aTHX);
 836   PL_op = o;
 837   LEAVE;
 838  }
 839
 840  {
 841   SV *ret;
 842   dSP;
 843   ret = POPs;
 844   PUTBACK;
 845   return ret;
 846  }
 847 }
 848
 849 static void a_do_fake_pp_unop_init(pTHX_ UNOP *unop, U32 type, U32 flags) {
 850 #define a_do_fake_pp_unop_init(O, T, F) a_do_fake_pp_unop_init(aTHX_ (O), (T), (F))
 851  unop->op_type    = type;
 852  unop->op_flags   = OPf_WANT_SCALAR | (~OPf_WANT & flags);
 853  unop->op_private = 0;
 854  unop->op_first   = NULL;
 855  unop->op_ppaddr  = PL_ppaddr[type];
 856 }
 857
 858 static SV *a_do_fake_pp_unop_arg1(pTHX_ U32 type, U32 flags, SV *arg) {
 859 #define a_do_fake_pp_unop_arg1(T, F, A) a_do_fake_pp_unop_arg1(aTHX_ (T), (F), (A))
 860  UNOP unop;
 861  dSP;
 862
 863  a_do_fake_pp_unop_init(&unop, type, flags);
 864
 865  EXTEND(SP, 1);
 866  PUSHs(arg);
 867  PUTBACK;
 868
 869  return a_do_fake_pp((OP *) &unop);
 870 }
 871
 872 static SV *a_do_fake_pp_unop_arg2(pTHX_ U32 type, U32 flags, SV *arg1, SV *arg2) {
 873 #define a_do_fake_pp_unop_arg2(T, F, A1, A2) a_do_fake_pp_unop_arg2(aTHX_ (T), (F), (A1), (A2))
 874  UNOP unop;
 875  dSP;
 876
 877  a_do_fake_pp_unop_init(&unop, type, flags);
 878
 879  EXTEND(SP, 2);
 880  PUSHs(arg1);
 881  PUSHs(arg2);
 882  PUTBACK;
 883
 884  return a_do_fake_pp((OP *) &unop);
 885 }
 886
 887 #define a_do_pp_rv2av(R)        a_do_fake_pp_unop_arg1(OP_RV2AV,  OPf_REF,     (R))
 888 #define a_do_pp_afetch(A, I)    a_do_fake_pp_unop_arg2(OP_AELEM,  0,           (A), (I))
 889 #define a_do_pp_afetch_lv(A, I) a_do_fake_pp_unop_arg2(OP_AELEM,  OPf_MOD,     (A), (I))
 890 #define a_do_pp_aexists(A, I)   a_do_fake_pp_unop_arg2(OP_EXISTS, OPf_SPECIAL, (A), (I))
 891 #define a_do_pp_adelete(A, I)   a_do_fake_pp_unop_arg2(OP_DELETE, OPf_SPECIAL, (A), (I))
 892
 893 #define a_do_pp_rv2hv(R)        a_do_fake_pp_unop_arg1(OP_RV2HV,  OPf_REF, (R))
 894 #define a_do_pp_hfetch(H, K)    a_do_fake_pp_unop_arg2(OP_HELEM,  0,       (H), (K))
 895 #define a_do_pp_hfetch_lv(H, K) a_do_fake_pp_unop_arg2(OP_HELEM,  OPf_MOD, (H), (K))
 896 #define a_do_pp_hexists(H, K)   a_do_fake_pp_unop_arg2(OP_EXISTS, 0,  (H), (K))
 897 #define a_do_pp_hdelete(H, K)   a_do_fake_pp_unop_arg2(OP_DELETE, 0,  (H), (K))
 898
 899 static OP *a_pp_multideref(pTHX) {
 900  UNOP_AUX_item *items;
 901  UV  actions;
 902  UV  flags = 0;
 903  SV *sv    = NULL;
 904  dSP;
 905
 906  {
 907   dA_MAP_THX;
 908   const a_op_info *oi = a_map_fetch(PL_op);
 909   assert(oi);
 910   flags = a_do_multideref(PL_op, oi->flags);
 911   if (!flags)
 912    return oi->old_pp(aTHX);
 913  }
 914
 915  items   = cUNOP_AUXx(PL_op)->op_aux;
 916  actions = items->uv;
 917
 918  PL_multideref_pc = items;
 919
 920  while (1) {
 921   switch (actions & MDEREF_ACTION_MASK) {
 922    case MDEREF_reload:
 923     actions = (++items)->uv;
 924     continue;
 925    case MDEREF_AV_padav_aelem: /* $lex[...] */
 926     sv = PAD_SVl((++items)->pad_offset);
 927     if (a_undef(sv))
 928      goto ret_undef;
 929     goto do_AV_aelem;
 930    case MDEREF_AV_gvav_aelem: /* $pkg[...] */
 931     sv = UNOP_AUX_item_sv(++items);
 932     assert(isGV_with_GP(sv));
 933     sv = (SV *) GvAVn((GV *) sv);
 934     if (a_undef(sv))
 935      goto ret_undef;
 936     goto do_AV_aelem;
 937    case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
 938     sv = POPs;
 939     if (a_undef(sv))
 940      goto ret_undef;
 941     goto do_AV_rv2av_aelem;
 942    case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
 943     sv = UNOP_AUX_item_sv(++items);
 944     assert(isGV_with_GP(sv));
 945     sv = GvSVn((GV *) sv);
 946     if (a_undef(sv))
 947      goto ret_undef;
 948     goto do_AV_vivify_rv2av_aelem;
 949    case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
 950     sv = PAD_SVl((++items)->pad_offset);
 951     /* FALLTHROUGH */
 952    case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
 953     if (a_undef(sv))
 954      goto ret_undef;
 955 do_AV_vivify_rv2av_aelem:
 956     sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_AV);
 957 do_AV_rv2av_aelem:
 958     sv = a_do_pp_rv2av(sv);
 959 do_AV_aelem:
 960     {
 961      SV *esv;
 962      assert(SvTYPE(sv) == SVt_PVAV);
 963      switch (actions & MDEREF_INDEX_MASK) {
 964       case MDEREF_INDEX_none:
 965        goto finish;
 966       case MDEREF_INDEX_const:
 967        esv = sv_2mortal(newSViv((++items)->iv));
 968        break;
 969       case MDEREF_INDEX_padsv:
 970        esv = PAD_SVl((++items)->pad_offset);
 971        goto check_elem;
 972       case MDEREF_INDEX_gvsv:
 973        esv = UNOP_AUX_item_sv(++items);
 974        assert(isGV_with_GP(esv));
 975        esv = GvSVn((GV *) esv);
 976 check_elem:
 977        if (UNLIKELY(SvROK(esv) && !SvGAMAGIC(esv) && ckWARN(WARN_MISC)))
 978         Perl_warner(aTHX_ packWARN(WARN_MISC),
 979                           "Use of reference \"%"SVf"\" as array index",
 980                           SVfARG(esv));
 981        break;
 982      }
 983      PL_multideref_pc = items;
 984      if (actions & MDEREF_FLAG_last) {
 985       switch (flags & A_HINT_DO) {
 986        case A_HINT_FETCH:
 987         sv = a_do_pp_afetch(sv, esv);
 988         break;
 989        case A_HINT_STORE:
 990         sv = a_do_pp_afetch_lv(sv, esv);
 991         break;
 992        case A_HINT_EXISTS:
 993         sv = a_do_pp_aexists(sv, esv);
 994         break;
 995        case A_HINT_DELETE:
 996         sv = a_do_pp_adelete(sv, esv);
 997         break;
 998       }
 999       goto finish;
1000      }
1001      sv = a_do_pp_afetch(sv, esv);
1002      break;
1003     }
1004    case MDEREF_HV_padhv_helem: /* $lex{...} */
1005     sv = PAD_SVl((++items)->pad_offset);
1006     if (a_undef(sv))
1007      goto ret_undef;
1008     goto do_HV_helem;
1009    case MDEREF_HV_gvhv_helem: /* $pkg{...} */
1010     sv = UNOP_AUX_item_sv(++items);
1011     assert(isGV_with_GP(sv));
1012     sv = (SV *) GvHVn((GV *) sv);
1013     if (a_undef(sv))
1014      goto ret_undef;
1015     goto do_HV_helem;
1016    case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
1017     sv = POPs;
1018     if (a_undef(sv))
1019      goto ret_undef;
1020     goto do_HV_rv2hv_helem;
1021    case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
1022     sv = UNOP_AUX_item_sv(++items);
1023     assert(isGV_with_GP(sv));
1024     sv = GvSVn((GV *) sv);
1025     if (a_undef(sv))
1026      goto ret_undef;
1027     goto do_HV_vivify_rv2hv_helem;
1028    case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
1029     sv = PAD_SVl((++items)->pad_offset);
1030     /* FALLTHROUGH */
1031    case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
1032     if (a_undef(sv))
1033      goto ret_undef;
1034 do_HV_vivify_rv2hv_helem:
1035     sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_HV);
1036 do_HV_rv2hv_helem:
1037     sv = a_do_pp_rv2hv(sv);
1038 do_HV_helem:
1039     {
1040      SV *key;
1041      assert(SvTYPE(sv) == SVt_PVHV);
1042      switch (actions & MDEREF_INDEX_MASK) {
1043       case MDEREF_INDEX_none:
1044        goto finish;
1045       case MDEREF_INDEX_const:
1046        key = UNOP_AUX_item_sv(++items);
1047        break;
1048       case MDEREF_INDEX_padsv:
1049        key = PAD_SVl((++items)->pad_offset);
1050        break;
1051       case MDEREF_INDEX_gvsv:
1052        key = UNOP_AUX_item_sv(++items);
1053        assert(isGV_with_GP(key));
1054        key = GvSVn((GV *) key);
1055        break;
1056      }
1057      PL_multideref_pc = items;
1058      if (actions & MDEREF_FLAG_last) {
1059       switch (flags & A_HINT_DO) {
1060        case A_HINT_FETCH:
1061         sv = a_do_pp_hfetch(sv, key);
1062         break;
1063        case A_HINT_STORE:
1064         sv = a_do_pp_hfetch_lv(sv, key);
1065         break;
1066        case A_HINT_EXISTS:
1067         sv = a_do_pp_hexists(sv, key);
1068         break;
1069        case A_HINT_DELETE:
1070         sv = a_do_pp_hdelete(sv, key);
1071         break;
1072        default:
1073         break;
1074       }
1075       goto finish;
1076      }
1077      sv = a_do_pp_hfetch(sv, key);
1078      break;
1079     }
1080   }
1081
1082   actions >>= MDEREF_SHIFT;
1083  }
1084
1085 ret_undef:
1086  if (flags & (A_HINT_NOTIFY|A_HINT_STORE))
1087   a_cannot_vivify(flags);
1088  if (flags & A_HINT_EXISTS)
1089   sv = &PL_sv_no;
1090  else
1091   sv = &PL_sv_undef;
1092 finish:
1093  XPUSHs(sv);
1094  RETURN;
1095 }
1096
1097 #endif /* A_HAS_MULTIDEREF */
1098
1099 /* --- Check functions ----------------------------------------------------- */
1100
1101 static void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
1102 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
1103
1104  if (o->op_type == type && o->op_ppaddr != new_pp
1105                         && cUNOPo->op_first->op_type != OP_GV) {
1106   dA_MAP_THX;
1107   const a_op_info *oi = a_map_fetch(o);
1108   if (oi) {
1109    a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1110    o->op_ppaddr = new_pp;
1111   }
1112  }
1113
1114  return;
1115 }
1116
1117 /* ... ck_pad{any,sv} ...................................................... */
1118
1119 /* Sadly, the padsv OPs we are interested in don't trigger the padsv check
1120  * function, but are instead manually mutated from a padany. So we store
1121  * the op entry in the op map in the padany check function, and we set their
1122  * op_ppaddr member in our peephole optimizer replacement below. */
1123
1124 static OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
1125
1126 static OP *a_ck_padany(pTHX_ OP *o) {
1127  UV hint;
1128
1129  o = a_old_ck_padany(aTHX_ o);
1130
1131  hint = a_hint();
1132  if (hint & A_HINT_DO)
1133   a_map_store_root(o, o->op_ppaddr, hint);
1134  else
1135   a_map_delete(o);
1136
1137  return o;
1138 }
1139
1140 static OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
1141
1142 static OP *a_ck_padsv(pTHX_ OP *o) {
1143  UV hint;
1144
1145  o = a_old_ck_padsv(aTHX_ o);
1146
1147  hint = a_hint();
1148  if (hint & A_HINT_DO) {
1149   a_map_store_root(o, o->op_ppaddr, hint);
1150   o->op_ppaddr = a_pp_deref;
1151  } else
1152   a_map_delete(o);
1153
1154  return o;
1155 }
1156
1157 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
1158
1159 /* Those ops appear both at the root and inside an expression but there's no
1160  * way to distinguish both situations. Worse, we can't even know if we are in a
1161  * modifying context, so the expression can't be resolved yet. It will be at the
1162  * first invocation of a_pp_deref() for this expression. */
1163
1164 static OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
1165 static OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
1166 static OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
1167
1168 static OP *a_ck_deref(pTHX_ OP *o) {
1169  OP * (*old_ck)(pTHX_ OP *o) = 0;
1170  UV hint = a_hint();
1171
1172  switch (o->op_type) {
1173   case OP_AELEM:
1174    old_ck = a_old_ck_aelem;
1175    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
1176     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
1177    break;
1178   case OP_HELEM:
1179    old_ck = a_old_ck_helem;
1180    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
1181     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
1182    break;
1183   case OP_RV2SV:
1184    old_ck = a_old_ck_rv2sv;
1185    break;
1186  }
1187  o = old_ck(aTHX_ o);
1188
1189  if (hint & A_HINT_DO) {
1190 #if A_HAS_MULTIDEREF
1191   if (old_ck == a_old_ck_rv2sv && o->op_flags & OPf_KIDS) {
1192    OP *kid = cUNOPo->op_first;
1193    if (kid && kid->op_type == OP_GV)
1194     a_map_store(kid, kid->op_ppaddr, NULL, hint);
1195   }
1196 #endif
1197   a_map_store_root(o, o->op_ppaddr, hint);
1198   o->op_ppaddr = a_pp_deref;
1199  } else
1200   a_map_delete(o);
1201
1202  return o;
1203 }
1204
1205 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
1206
1207 /* Those ops also appear both inisde and at the root, hence the caveats for
1208  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
1209  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
1210  * expression. */
1211
1212 static OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
1213 static OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
1214
1215 static OP *a_ck_rv2xv(pTHX_ OP *o) {
1216  OP * (*old_ck)(pTHX_ OP *o) = 0;
1217  OP * (*new_pp)(pTHX)        = 0;
1218  UV hint;
1219
1220  switch (o->op_type) {
1221   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
1222   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
1223  }
1224  o = old_ck(aTHX_ o);
1225
1226  if (cUNOPo->op_first->op_type == OP_GV)
1227   return o;
1228
1229  hint = a_hint();
1230  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
1231   a_map_store_root(o, o->op_ppaddr, hint);
1232   o->op_ppaddr = new_pp;
1233  } else
1234   a_map_delete(o);
1235
1236  return o;
1237 }
1238
1239 /* ... ck_xslice (aslice,hslice) ........................................... */
1240
1241 /* I think those are only found at the root, but there's nothing that really
1242  * prevent them to be inside the expression too. We only need to update the
1243  * root so that the rest of the expression will see the right context when
1244  * resolving. That's why we don't replace the ppaddr. */
1245
1246 static OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
1247 static OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
1248
1249 static OP *a_ck_xslice(pTHX_ OP *o) {
1250  OP * (*old_ck)(pTHX_ OP *o) = 0;
1251  UV hint = a_hint();
1252
1253  switch (o->op_type) {
1254   case OP_ASLICE:
1255    old_ck = a_old_ck_aslice;
1256    break;
1257   case OP_HSLICE:
1258    old_ck = a_old_ck_hslice;
1259    if (hint & A_HINT_DO)
1260     a_recheck_rv2xv(OpSIBLING(cUNOPo->op_first), OP_RV2HV, a_pp_rv2hv);
1261    break;
1262  }
1263  o = old_ck(aTHX_ o);
1264
1265  if (hint & A_HINT_DO) {
1266   a_map_store_root(o, 0, hint);
1267  } else
1268   a_map_delete(o);
1269
1270  return o;
1271 }
1272
1273 /* ... ck_root (exists,delete,keys,values) ................................. */
1274
1275 /* Those ops are only found at the root of a dereferencing expression. We can
1276  * then resolve at compile time if vivification must take place or not. */
1277
1278 static OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
1279 static OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
1280 static OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
1281 static OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
1282
1283 static OP *a_ck_root(pTHX_ OP *o) {
1284  OP * (*old_ck)(pTHX_ OP *o) = 0;
1285  OP * (*new_pp)(pTHX)        = 0;
1286  bool enabled = FALSE;
1287  UV hint = a_hint();
1288
1289  switch (o->op_type) {
1290   case OP_EXISTS:
1291    old_ck  = a_old_ck_exists;
1292    new_pp  = a_pp_root_binop;
1293    enabled = hint & A_HINT_EXISTS;
1294    break;
1295   case OP_DELETE:
1296    old_ck  = a_old_ck_delete;
1297    new_pp  = a_pp_root_binop;
1298    enabled = hint & A_HINT_DELETE;
1299    break;
1300   case OP_KEYS:
1301    old_ck  = a_old_ck_keys;
1302    new_pp  = a_pp_root_unop;
1303    enabled = hint & A_HINT_FETCH;
1304    break;
1305   case OP_VALUES:
1306    old_ck  = a_old_ck_values;
1307    new_pp  = a_pp_root_unop;
1308    enabled = hint & A_HINT_FETCH;
1309    break;
1310  }
1311  o = old_ck(aTHX_ o);
1312
1313  if (hint & A_HINT_DO) {
1314   if (enabled) {
1315    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
1316    a_map_store_root(o, o->op_ppaddr, hint);
1317    o->op_ppaddr = new_pp;
1318   } else {
1319    a_map_cancel(o);
1320   }
1321  } else
1322   a_map_delete(o);
1323
1324  return o;
1325 }
1326
1327 /* ... Our peephole optimizer .............................................. */
1328
1329 static peep_t a_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
1330
1331 static void a_peep_rec(pTHX_ OP *o, ptable *seen);
1332
1333 static void a_peep_rec(pTHX_ OP *o, ptable *seen) {
1334 #define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen)
1335  for (; o; o = o->op_next) {
1336   dA_MAP_THX;
1337   const a_op_info *oi = NULL;
1338   UV flags = 0;
1339
1340 #if !A_HAS_RPEEP
1341   if (ptable_fetch(seen, o))
1342    break;
1343   ptable_seen_store(seen, o, o);
1344 #endif
1345
1346   switch (o->op_type) {
1347 #if A_HAS_RPEEP
1348    case OP_NEXTSTATE:
1349    case OP_DBSTATE:
1350    case OP_STUB:
1351    case OP_UNSTACK:
1352     if (ptable_fetch(seen, o))
1353      return;
1354     ptable_seen_store(seen, o, o);
1355     break;
1356 #endif
1357    case OP_PADSV:
1358     if (o->op_ppaddr != a_pp_deref) {
1359      oi = a_map_fetch(o);
1360      if (oi && (oi->flags & A_HINT_DO)) {
1361       a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1362       o->op_ppaddr = a_pp_deref;
1363      }
1364     }
1365     /* FALLTHROUGH */
1366    case OP_AELEM:
1367    case OP_AELEMFAST:
1368    case OP_HELEM:
1369    case OP_RV2SV:
1370     if (o->op_ppaddr != a_pp_deref)
1371      break;
1372     oi = a_map_fetch(o);
1373     if (!oi)
1374      break;
1375     flags = oi->flags;
1376     if (!(flags & A_HINT_DEREF)
1377         && (flags & A_HINT_DO)
1378         && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
1379      /* Decide if the expression must autovivify or not. */
1380      flags = a_map_resolve(o, oi);
1381     }
1382     if (flags & A_HINT_DEREF)
1383      o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER);
1384     else
1385      o->op_ppaddr  = oi->old_pp;
1386     break;
1387    case OP_RV2AV:
1388    case OP_RV2HV:
1389     if (   o->op_ppaddr != a_pp_rv2av
1390         && o->op_ppaddr != a_pp_rv2hv
1391         && o->op_ppaddr != a_pp_rv2hv_simple)
1392      break;
1393     oi = a_map_fetch(o);
1394     if (!oi)
1395      break;
1396     if (!(oi->flags & A_HINT_DEREF))
1397      o->op_ppaddr  = oi->old_pp;
1398     break;
1399 #if A_HAS_MULTIDEREF
1400    case OP_MULTIDEREF:
1401     if (o->op_ppaddr != a_pp_multideref) {
1402      oi = a_map_fetch(cUNOPo->op_first);
1403      if (!oi)
1404       break;
1405      flags = oi->flags;
1406      if (a_do_multideref(o, flags)) {
1407       a_map_store_root(o, o->op_ppaddr, flags & ~A_HINT_DEREF);
1408       o->op_ppaddr = a_pp_multideref;
1409      }
1410     }
1411     break;
1412 #endif
1413 #if !A_HAS_RPEEP
1414    case OP_MAPWHILE:
1415    case OP_GREPWHILE:
1416    case OP_AND:
1417    case OP_OR:
1418    case OP_ANDASSIGN:
1419    case OP_ORASSIGN:
1420    case OP_COND_EXPR:
1421    case OP_RANGE:
1422 # if A_HAS_PERL(5, 10, 0)
1423    case OP_ONCE:
1424    case OP_DOR:
1425    case OP_DORASSIGN:
1426 # endif
1427     a_peep_rec(cLOGOPo->op_other);
1428     break;
1429    case OP_ENTERLOOP:
1430    case OP_ENTERITER:
1431     a_peep_rec(cLOOPo->op_redoop);
1432     a_peep_rec(cLOOPo->op_nextop);
1433     a_peep_rec(cLOOPo->op_lastop);
1434     break;
1435 # if A_HAS_PERL(5, 9, 5)
1436    case OP_SUBST:
1437     a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
1438     break;
1439 # else
1440    case OP_QR:
1441    case OP_MATCH:
1442    case OP_SUBST:
1443     a_peep_rec(cPMOPo->op_pmreplstart);
1444     break;
1445 # endif
1446 #endif /* !A_HAS_RPEEP */
1447    default:
1448     break;
1449   }
1450  }
1451 }
1452
1453 static void a_peep(pTHX_ OP *o) {
1454  dMY_CXT;
1455  ptable *seen = MY_CXT.seen;
1456
1457  a_old_peep(aTHX_ o);
1458
1459  if (seen) {
1460   ptable_seen_clear(seen);
1461   a_peep_rec(o);
1462   ptable_seen_clear(seen);
1463  }
1464 }
1465
1466 /* --- Interpreter setup/teardown ------------------------------------------ */
1467
1468 static U32 a_initialized = 0;
1469
1470 static void a_teardown(pTHX_ void *root) {
1471
1472  if (!a_initialized)
1473   return;
1474
1475 #if A_MULTIPLICITY
1476  if (aTHX != root)
1477   return;
1478 #endif
1479
1480  {
1481   dMY_CXT;
1482 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1483   ptable_hints_free(MY_CXT.tbl);
1484   MY_CXT.tbl  = NULL;
1485 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1486   ptable_seen_free(MY_CXT.seen);
1487   MY_CXT.seen = NULL;
1488  }
1489
1490  a_ck_restore(OP_PADANY, &a_old_ck_padany);
1491  a_ck_restore(OP_PADSV,  &a_old_ck_padsv);
1492
1493  a_ck_restore(OP_AELEM,  &a_old_ck_aelem);
1494  a_ck_restore(OP_HELEM,  &a_old_ck_helem);
1495  a_ck_restore(OP_RV2SV,  &a_old_ck_rv2sv);
1496
1497  a_ck_restore(OP_RV2AV,  &a_old_ck_rv2av);
1498  a_ck_restore(OP_RV2HV,  &a_old_ck_rv2hv);
1499
1500  a_ck_restore(OP_ASLICE, &a_old_ck_aslice);
1501  a_ck_restore(OP_HSLICE, &a_old_ck_hslice);
1502
1503  a_ck_restore(OP_EXISTS, &a_old_ck_exists);
1504  a_ck_restore(OP_DELETE, &a_old_ck_delete);
1505  a_ck_restore(OP_KEYS,   &a_old_ck_keys);
1506  a_ck_restore(OP_VALUES, &a_old_ck_values);
1507
1508 #if A_HAS_RPEEP
1509  PL_rpeepp  = a_old_peep;
1510 #else
1511  PL_peepp   = a_old_peep;
1512 #endif
1513  a_old_peep = 0;
1514
1515  a_initialized = 0;
1516 }
1517
1518 static void a_setup(pTHX) {
1519 #define a_setup() a_setup(aTHX)
1520  if (a_initialized)
1521   return;
1522
1523  {
1524   MY_CXT_INIT;
1525 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1526   MY_CXT.tbl   = ptable_new();
1527   MY_CXT.owner = aTHX;
1528 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1529   MY_CXT.seen  = ptable_new();
1530  }
1531
1532  a_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany);
1533  a_ck_replace(OP_PADSV,  a_ck_padsv,  &a_old_ck_padsv);
1534
1535  a_ck_replace(OP_AELEM,  a_ck_deref,  &a_old_ck_aelem);
1536  a_ck_replace(OP_HELEM,  a_ck_deref,  &a_old_ck_helem);
1537  a_ck_replace(OP_RV2SV,  a_ck_deref,  &a_old_ck_rv2sv);
1538
1539  a_ck_replace(OP_RV2AV,  a_ck_rv2xv,  &a_old_ck_rv2av);
1540  a_ck_replace(OP_RV2HV,  a_ck_rv2xv,  &a_old_ck_rv2hv);
1541
1542  a_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice);
1543  a_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice);
1544
1545  a_ck_replace(OP_EXISTS, a_ck_root,   &a_old_ck_exists);
1546  a_ck_replace(OP_DELETE, a_ck_root,   &a_old_ck_delete);
1547  a_ck_replace(OP_KEYS,   a_ck_root,   &a_old_ck_keys);
1548  a_ck_replace(OP_VALUES, a_ck_root,   &a_old_ck_values);
1549
1550 #if A_HAS_RPEEP
1551  a_old_peep = PL_rpeepp;
1552  PL_rpeepp  = a_peep;
1553 #else
1554  a_old_peep = PL_peepp;
1555  PL_peepp   = a_peep;
1556 #endif
1557
1558 #if A_MULTIPLICITY
1559  call_atexit(a_teardown, aTHX);
1560 #else
1561  call_atexit(a_teardown, NULL);
1562 #endif
1563
1564  a_initialized = 1;
1565 }
1566
1567 static U32 a_booted = 0;
1568
1569 /* --- XS ------------------------------------------------------------------ */
1570
1571 MODULE = autovivification      PACKAGE = autovivification
1572
1573 PROTOTYPES: ENABLE
1574
1575 BOOT:
1576 {
1577  if (!a_booted++) {
1578   HV *stash;
1579
1580   a_op_map = ptable_new();
1581 #ifdef USE_ITHREADS
1582   MUTEX_INIT(&a_op_map_mutex);
1583 #endif
1584
1585   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
1586
1587   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1588   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1589   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1590   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1591   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1592   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1593   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1594   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1595   newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(A_THREADSAFE));
1596   newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(A_FORKSAFE));
1597  }
1598
1599  a_setup();
1600 }
1601
1602 #if A_THREADSAFE
1603
1604 void
1605 CLONE(...)
1606 PROTOTYPE: DISABLE
1607 PREINIT:
1608 #if A_WORKAROUND_REQUIRE_PROPAGATION
1609  ptable *t;
1610 #endif
1611  ptable *s;
1612  GV     *gv;
1613 PPCODE:
1614  {
1615 #if A_WORKAROUND_REQUIRE_PROPAGATION
1616   dMY_CXT;
1617   {
1618    a_ptable_clone_ud ud;
1619
1620    t = ptable_new();
1621    a_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1622    ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1623    a_ptable_clone_ud_deinit(ud);
1624   }
1625 #endif
1626   s = ptable_new();
1627  }
1628  {
1629   MY_CXT_CLONE;
1630 #if A_WORKAROUND_REQUIRE_PROPAGATION
1631   MY_CXT.tbl   = t;
1632   MY_CXT.owner = aTHX;
1633 #endif
1634   MY_CXT.seen  = s;
1635  }
1636  gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
1637  if (gv) {
1638   CV *cv = GvCV(gv);
1639   if (!PL_endav)
1640    PL_endav = newAV();
1641   SvREFCNT_inc(cv);
1642   if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
1643    SvREFCNT_dec(cv);
1644   sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &a_endav_vtbl, NULL, 0);
1645  }
1646  XSRETURN(0);
1647
1648 void
1649 _THREAD_CLEANUP(...)
1650 PROTOTYPE: DISABLE
1651 PPCODE:
1652  a_thread_cleanup(aTHX_ NULL);
1653  XSRETURN(0);
1654
1655 #endif /* A_THREADSAFE */
1656
1657 SV *
1658 _tag(SV *hint)
1659 PROTOTYPE: $
1660 CODE:
1661  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1662 OUTPUT:
1663  RETVAL
1664
1665 SV *
1666 _detag(SV *tag)
1667 PROTOTYPE: $
1668 CODE:
1669  if (!SvOK(tag))
1670   XSRETURN_UNDEF;
1671  RETVAL = newSVuv(a_detag(tag));
1672 OUTPUT:
1673  RETVAL