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;
 805
 806  assert(o->op_type == OP_MULTIDEREF);
 807
 808  isexdel = o->op_private & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE);
 809
 810  if (isexdel) {
 811   if (isexdel & OPpMULTIDEREF_EXISTS) {
 812    if (flags & A_HINT_EXISTS)
 813     return A_HINT_EXISTS;
 814   } else {
 815    if (flags & A_HINT_DELETE)
 816     return A_HINT_DELETE;
 817   }
 818  } else {
 819   if (o->op_flags & OPf_MOD) {
 820    if (flags & A_HINT_STORE)
 821     return A_HINT_STORE;
 822   } else {
 823    if (flags & A_HINT_FETCH)
 824     return A_HINT_FETCH;
 825   }
 826  }
 827
 828  return 0;
 829 }
 830
 831 static SV *a_do_fake_pp(pTHX_ OP *op) {
 832 #define a_do_fake_pp(O) a_do_fake_pp(aTHX_ (O))
 833  {
 834   OP *o = PL_op;
 835   ENTER;
 836   SAVEOP();
 837   PL_op = op;
 838   PL_op->op_ppaddr(aTHX);
 839   PL_op = o;
 840   LEAVE;
 841  }
 842
 843  {
 844   SV *ret;
 845   dSP;
 846   ret = POPs;
 847   PUTBACK;
 848   return ret;
 849  }
 850 }
 851
 852 static void a_do_fake_pp_unop_init(pTHX_ UNOP *unop, U32 type, U32 flags) {
 853 #define a_do_fake_pp_unop_init(O, T, F) a_do_fake_pp_unop_init(aTHX_ (O), (T), (F))
 854  unop->op_type    = type;
 855  unop->op_flags   = OPf_WANT_SCALAR | (~OPf_WANT & flags);
 856  unop->op_private = 0;
 857  unop->op_first   = NULL;
 858  unop->op_ppaddr  = PL_ppaddr[type];
 859 }
 860
 861 static SV *a_do_fake_pp_unop_arg1(pTHX_ U32 type, U32 flags, SV *arg) {
 862 #define a_do_fake_pp_unop_arg1(T, F, A) a_do_fake_pp_unop_arg1(aTHX_ (T), (F), (A))
 863  UNOP unop;
 864  dSP;
 865
 866  a_do_fake_pp_unop_init(&unop, type, flags);
 867
 868  EXTEND(SP, 1);
 869  PUSHs(arg);
 870  PUTBACK;
 871
 872  return a_do_fake_pp((OP *) &unop);
 873 }
 874
 875 static SV *a_do_fake_pp_unop_arg2(pTHX_ U32 type, U32 flags, SV *arg1, SV *arg2) {
 876 #define a_do_fake_pp_unop_arg2(T, F, A1, A2) a_do_fake_pp_unop_arg2(aTHX_ (T), (F), (A1), (A2))
 877  UNOP unop;
 878  dSP;
 879
 880  a_do_fake_pp_unop_init(&unop, type, flags);
 881
 882  EXTEND(SP, 2);
 883  PUSHs(arg1);
 884  PUSHs(arg2);
 885  PUTBACK;
 886
 887  return a_do_fake_pp((OP *) &unop);
 888 }
 889
 890 #define a_do_pp_rv2av(R)        a_do_fake_pp_unop_arg1(OP_RV2AV,  OPf_REF,     (R))
 891 #define a_do_pp_afetch(A, I)    a_do_fake_pp_unop_arg2(OP_AELEM,  0,           (A), (I))
 892 #define a_do_pp_afetch_lv(A, I) a_do_fake_pp_unop_arg2(OP_AELEM,  OPf_MOD,     (A), (I))
 893 #define a_do_pp_aexists(A, I)   a_do_fake_pp_unop_arg2(OP_EXISTS, OPf_SPECIAL, (A), (I))
 894 #define a_do_pp_adelete(A, I)   a_do_fake_pp_unop_arg2(OP_DELETE, OPf_SPECIAL, (A), (I))
 895
 896 #define a_do_pp_rv2hv(R)        a_do_fake_pp_unop_arg1(OP_RV2HV,  OPf_REF, (R))
 897 #define a_do_pp_hfetch(H, K)    a_do_fake_pp_unop_arg2(OP_HELEM,  0,       (H), (K))
 898 #define a_do_pp_hfetch_lv(H, K) a_do_fake_pp_unop_arg2(OP_HELEM,  OPf_MOD, (H), (K))
 899 #define a_do_pp_hexists(H, K)   a_do_fake_pp_unop_arg2(OP_EXISTS, 0,  (H), (K))
 900 #define a_do_pp_hdelete(H, K)   a_do_fake_pp_unop_arg2(OP_DELETE, 0,  (H), (K))
 901
 902 static OP *a_pp_multideref(pTHX) {
 903  UNOP_AUX_item *items;
 904  UV  actions;
 905  UV  flags = 0;
 906  UV  deref = 0;
 907  SV *sv    = NULL;
 908  dSP;
 909
 910  {
 911   dA_MAP_THX;
 912   const a_op_info *oi = a_map_fetch(PL_op);
 913   assert(oi);
 914   flags = oi->flags;
 915   deref = a_do_multideref(PL_op, flags);
 916   if (!deref)
 917    return oi->old_pp(aTHX);
 918  }
 919
 920  items   = cUNOP_AUXx(PL_op)->op_aux;
 921  actions = items->uv;
 922
 923  PL_multideref_pc = items;
 924
 925  while (1) {
 926   switch (actions & MDEREF_ACTION_MASK) {
 927    case MDEREF_reload:
 928     actions = (++items)->uv;
 929     continue;
 930    case MDEREF_AV_padav_aelem: /* $lex[...] */
 931     sv = PAD_SVl((++items)->pad_offset);
 932     if (a_undef(sv))
 933      goto ret_undef;
 934     goto do_AV_aelem;
 935    case MDEREF_AV_gvav_aelem: /* $pkg[...] */
 936     sv = UNOP_AUX_item_sv(++items);
 937     assert(isGV_with_GP(sv));
 938     sv = (SV *) GvAVn((GV *) sv);
 939     if (a_undef(sv))
 940      goto ret_undef;
 941     goto do_AV_aelem;
 942    case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
 943     sv = POPs;
 944     if (a_undef(sv))
 945      goto ret_undef;
 946     goto do_AV_rv2av_aelem;
 947    case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
 948     sv = UNOP_AUX_item_sv(++items);
 949     assert(isGV_with_GP(sv));
 950     sv = GvSVn((GV *) sv);
 951     if (a_undef(sv))
 952      goto ret_undef;
 953     goto do_AV_vivify_rv2av_aelem;
 954    case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
 955     sv = PAD_SVl((++items)->pad_offset);
 956     /* FALLTHROUGH */
 957    case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
 958     if (a_undef(sv))
 959      goto ret_undef;
 960 do_AV_vivify_rv2av_aelem:
 961     sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_AV);
 962 do_AV_rv2av_aelem:
 963     sv = a_do_pp_rv2av(sv);
 964 do_AV_aelem:
 965     {
 966      SV *esv;
 967      assert(SvTYPE(sv) == SVt_PVAV);
 968      switch (actions & MDEREF_INDEX_MASK) {
 969       case MDEREF_INDEX_none:
 970        goto finish;
 971       case MDEREF_INDEX_const:
 972        esv = sv_2mortal(newSViv((++items)->iv));
 973        break;
 974       case MDEREF_INDEX_padsv:
 975        esv = PAD_SVl((++items)->pad_offset);
 976        goto check_elem;
 977       case MDEREF_INDEX_gvsv:
 978        esv = UNOP_AUX_item_sv(++items);
 979        assert(isGV_with_GP(esv));
 980        esv = GvSVn((GV *) esv);
 981 check_elem:
 982        if (UNLIKELY(SvROK(esv) && !SvGAMAGIC(esv) && ckWARN(WARN_MISC)))
 983         Perl_warner(aTHX_ packWARN(WARN_MISC),
 984                           "Use of reference \"%"SVf"\" as array index",
 985                           SVfARG(esv));
 986        break;
 987      }
 988      PL_multideref_pc = items;
 989      if (actions & MDEREF_FLAG_last) {
 990       switch (deref) {
 991        case A_HINT_FETCH:
 992         sv = a_do_pp_afetch(sv, esv);
 993         break;
 994        case A_HINT_STORE:
 995         sv = a_do_pp_afetch_lv(sv, esv);
 996         break;
 997        case A_HINT_EXISTS:
 998         sv = a_do_pp_aexists(sv, esv);
 999         break;
1000        case A_HINT_DELETE:
1001         sv = a_do_pp_adelete(sv, esv);
1002         break;
1003       }
1004       goto finish;
1005      }
1006      sv = a_do_pp_afetch(sv, esv);
1007      break;
1008     }
1009    case MDEREF_HV_padhv_helem: /* $lex{...} */
1010     sv = PAD_SVl((++items)->pad_offset);
1011     if (a_undef(sv))
1012      goto ret_undef;
1013     goto do_HV_helem;
1014    case MDEREF_HV_gvhv_helem: /* $pkg{...} */
1015     sv = UNOP_AUX_item_sv(++items);
1016     assert(isGV_with_GP(sv));
1017     sv = (SV *) GvHVn((GV *) sv);
1018     if (a_undef(sv))
1019      goto ret_undef;
1020     goto do_HV_helem;
1021    case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
1022     sv = POPs;
1023     if (a_undef(sv))
1024      goto ret_undef;
1025     goto do_HV_rv2hv_helem;
1026    case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
1027     sv = UNOP_AUX_item_sv(++items);
1028     assert(isGV_with_GP(sv));
1029     sv = GvSVn((GV *) sv);
1030     if (a_undef(sv))
1031      goto ret_undef;
1032     goto do_HV_vivify_rv2hv_helem;
1033    case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
1034     sv = PAD_SVl((++items)->pad_offset);
1035     /* FALLTHROUGH */
1036    case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
1037     if (a_undef(sv))
1038      goto ret_undef;
1039 do_HV_vivify_rv2hv_helem:
1040     sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_HV);
1041 do_HV_rv2hv_helem:
1042     sv = a_do_pp_rv2hv(sv);
1043 do_HV_helem:
1044     {
1045      SV *key;
1046      assert(SvTYPE(sv) == SVt_PVHV);
1047      switch (actions & MDEREF_INDEX_MASK) {
1048       case MDEREF_INDEX_none:
1049        goto finish;
1050       case MDEREF_INDEX_const:
1051        key = UNOP_AUX_item_sv(++items);
1052        break;
1053       case MDEREF_INDEX_padsv:
1054        key = PAD_SVl((++items)->pad_offset);
1055        break;
1056       case MDEREF_INDEX_gvsv:
1057        key = UNOP_AUX_item_sv(++items);
1058        assert(isGV_with_GP(key));
1059        key = GvSVn((GV *) key);
1060        break;
1061      }
1062      PL_multideref_pc = items;
1063      if (actions & MDEREF_FLAG_last) {
1064       switch (deref) {
1065        case A_HINT_FETCH:
1066         sv = a_do_pp_hfetch(sv, key);
1067         break;
1068        case A_HINT_STORE:
1069         sv = a_do_pp_hfetch_lv(sv, key);
1070         break;
1071        case A_HINT_EXISTS:
1072         sv = a_do_pp_hexists(sv, key);
1073         break;
1074        case A_HINT_DELETE:
1075         sv = a_do_pp_hdelete(sv, key);
1076         break;
1077        default:
1078         break;
1079       }
1080       goto finish;
1081      }
1082      sv = a_do_pp_hfetch(sv, key);
1083      break;
1084     }
1085   }
1086
1087   actions >>= MDEREF_SHIFT;
1088  }
1089
1090 ret_undef:
1091  if ((flags & A_HINT_NOTIFY) || (deref == A_HINT_STORE))
1092   a_cannot_vivify(flags);
1093  if (deref == A_HINT_EXISTS)
1094   sv = &PL_sv_no;
1095  else
1096   sv = &PL_sv_undef;
1097 finish:
1098  XPUSHs(sv);
1099  RETURN;
1100 }
1101
1102 #endif /* A_HAS_MULTIDEREF */
1103
1104 /* --- Check functions ----------------------------------------------------- */
1105
1106 static void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
1107 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
1108
1109  if (o->op_type == type && o->op_ppaddr != new_pp
1110                         && cUNOPo->op_first->op_type != OP_GV) {
1111   dA_MAP_THX;
1112   const a_op_info *oi = a_map_fetch(o);
1113   if (oi) {
1114    a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1115    o->op_ppaddr = new_pp;
1116   }
1117  }
1118
1119  return;
1120 }
1121
1122 /* ... ck_pad{any,sv} ...................................................... */
1123
1124 /* Sadly, the padsv OPs we are interested in don't trigger the padsv check
1125  * function, but are instead manually mutated from a padany. So we store
1126  * the op entry in the op map in the padany check function, and we set their
1127  * op_ppaddr member in our peephole optimizer replacement below. */
1128
1129 static OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
1130
1131 static OP *a_ck_padany(pTHX_ OP *o) {
1132  UV hint;
1133
1134  o = a_old_ck_padany(aTHX_ o);
1135
1136  hint = a_hint();
1137  if (hint & A_HINT_DO)
1138   a_map_store_root(o, o->op_ppaddr, hint);
1139  else
1140   a_map_delete(o);
1141
1142  return o;
1143 }
1144
1145 static OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
1146
1147 static OP *a_ck_padsv(pTHX_ OP *o) {
1148  UV hint;
1149
1150  o = a_old_ck_padsv(aTHX_ o);
1151
1152  hint = a_hint();
1153  if (hint & A_HINT_DO) {
1154   a_map_store_root(o, o->op_ppaddr, hint);
1155   o->op_ppaddr = a_pp_deref;
1156  } else
1157   a_map_delete(o);
1158
1159  return o;
1160 }
1161
1162 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
1163
1164 /* Those ops appear both at the root and inside an expression but there's no
1165  * way to distinguish both situations. Worse, we can't even know if we are in a
1166  * modifying context, so the expression can't be resolved yet. It will be at the
1167  * first invocation of a_pp_deref() for this expression. */
1168
1169 static OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
1170 static OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
1171 static OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
1172
1173 static OP *a_ck_deref(pTHX_ OP *o) {
1174  OP * (*old_ck)(pTHX_ OP *o) = 0;
1175  UV hint = a_hint();
1176
1177  switch (o->op_type) {
1178   case OP_AELEM:
1179    old_ck = a_old_ck_aelem;
1180    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
1181     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
1182    break;
1183   case OP_HELEM:
1184    old_ck = a_old_ck_helem;
1185    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
1186     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
1187    break;
1188   case OP_RV2SV:
1189    old_ck = a_old_ck_rv2sv;
1190    break;
1191  }
1192  o = old_ck(aTHX_ o);
1193
1194  if (hint & A_HINT_DO) {
1195 #if A_HAS_MULTIDEREF
1196   if (old_ck == a_old_ck_rv2sv && o->op_flags & OPf_KIDS) {
1197    OP *kid = cUNOPo->op_first;
1198    if (kid && kid->op_type == OP_GV)
1199     a_map_store(kid, kid->op_ppaddr, NULL, hint);
1200   }
1201 #endif
1202   a_map_store_root(o, o->op_ppaddr, hint);
1203   o->op_ppaddr = a_pp_deref;
1204  } else
1205   a_map_delete(o);
1206
1207  return o;
1208 }
1209
1210 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
1211
1212 /* Those ops also appear both inisde and at the root, hence the caveats for
1213  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
1214  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
1215  * expression. */
1216
1217 static OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
1218 static OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
1219
1220 static OP *a_ck_rv2xv(pTHX_ OP *o) {
1221  OP * (*old_ck)(pTHX_ OP *o) = 0;
1222  OP * (*new_pp)(pTHX)        = 0;
1223  UV hint;
1224
1225  switch (o->op_type) {
1226   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
1227   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
1228  }
1229  o = old_ck(aTHX_ o);
1230
1231  if (cUNOPo->op_first->op_type == OP_GV)
1232   return o;
1233
1234  hint = a_hint();
1235  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
1236   a_map_store_root(o, o->op_ppaddr, hint);
1237   o->op_ppaddr = new_pp;
1238  } else
1239   a_map_delete(o);
1240
1241  return o;
1242 }
1243
1244 /* ... ck_xslice (aslice,hslice) ........................................... */
1245
1246 /* I think those are only found at the root, but there's nothing that really
1247  * prevent them to be inside the expression too. We only need to update the
1248  * root so that the rest of the expression will see the right context when
1249  * resolving. That's why we don't replace the ppaddr. */
1250
1251 static OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
1252 static OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
1253
1254 static OP *a_ck_xslice(pTHX_ OP *o) {
1255  OP * (*old_ck)(pTHX_ OP *o) = 0;
1256  UV hint = a_hint();
1257
1258  switch (o->op_type) {
1259   case OP_ASLICE:
1260    old_ck = a_old_ck_aslice;
1261    break;
1262   case OP_HSLICE:
1263    old_ck = a_old_ck_hslice;
1264    if (hint & A_HINT_DO)
1265     a_recheck_rv2xv(OpSIBLING(cUNOPo->op_first), OP_RV2HV, a_pp_rv2hv);
1266    break;
1267  }
1268  o = old_ck(aTHX_ o);
1269
1270  if (hint & A_HINT_DO) {
1271   a_map_store_root(o, 0, hint);
1272  } else
1273   a_map_delete(o);
1274
1275  return o;
1276 }
1277
1278 /* ... ck_root (exists,delete,keys,values) ................................. */
1279
1280 /* Those ops are only found at the root of a dereferencing expression. We can
1281  * then resolve at compile time if vivification must take place or not. */
1282
1283 static OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
1284 static OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
1285 static OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
1286 static OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
1287
1288 static OP *a_ck_root(pTHX_ OP *o) {
1289  OP * (*old_ck)(pTHX_ OP *o) = 0;
1290  OP * (*new_pp)(pTHX)        = 0;
1291  bool enabled = FALSE;
1292  UV hint = a_hint();
1293
1294  switch (o->op_type) {
1295   case OP_EXISTS:
1296    old_ck  = a_old_ck_exists;
1297    new_pp  = a_pp_root_binop;
1298    enabled = hint & A_HINT_EXISTS;
1299    break;
1300   case OP_DELETE:
1301    old_ck  = a_old_ck_delete;
1302    new_pp  = a_pp_root_binop;
1303    enabled = hint & A_HINT_DELETE;
1304    break;
1305   case OP_KEYS:
1306    old_ck  = a_old_ck_keys;
1307    new_pp  = a_pp_root_unop;
1308    enabled = hint & A_HINT_FETCH;
1309    break;
1310   case OP_VALUES:
1311    old_ck  = a_old_ck_values;
1312    new_pp  = a_pp_root_unop;
1313    enabled = hint & A_HINT_FETCH;
1314    break;
1315  }
1316  o = old_ck(aTHX_ o);
1317
1318  if (hint & A_HINT_DO) {
1319   if (enabled) {
1320    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
1321    a_map_store_root(o, o->op_ppaddr, hint);
1322    o->op_ppaddr = new_pp;
1323   } else {
1324    a_map_cancel(o);
1325   }
1326  } else
1327   a_map_delete(o);
1328
1329  return o;
1330 }
1331
1332 /* ... Our peephole optimizer .............................................. */
1333
1334 static peep_t a_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
1335
1336 static void a_peep_rec(pTHX_ OP *o, ptable *seen);
1337
1338 static void a_peep_rec(pTHX_ OP *o, ptable *seen) {
1339 #define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen)
1340  for (; o; o = o->op_next) {
1341   dA_MAP_THX;
1342   const a_op_info *oi = NULL;
1343   UV flags = 0;
1344
1345 #if !A_HAS_RPEEP
1346   if (ptable_fetch(seen, o))
1347    break;
1348   ptable_seen_store(seen, o, o);
1349 #endif
1350
1351   switch (o->op_type) {
1352 #if A_HAS_RPEEP
1353    case OP_NEXTSTATE:
1354    case OP_DBSTATE:
1355    case OP_STUB:
1356    case OP_UNSTACK:
1357     if (ptable_fetch(seen, o))
1358      return;
1359     ptable_seen_store(seen, o, o);
1360     break;
1361 #endif
1362    case OP_PADSV:
1363     if (o->op_ppaddr != a_pp_deref) {
1364      oi = a_map_fetch(o);
1365      if (oi && (oi->flags & A_HINT_DO)) {
1366       a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1367       o->op_ppaddr = a_pp_deref;
1368      }
1369     }
1370     /* FALLTHROUGH */
1371    case OP_AELEM:
1372    case OP_AELEMFAST:
1373    case OP_HELEM:
1374    case OP_RV2SV:
1375     if (o->op_ppaddr != a_pp_deref)
1376      break;
1377     oi = a_map_fetch(o);
1378     if (!oi)
1379      break;
1380     flags = oi->flags;
1381     if (!(flags & A_HINT_DEREF)
1382         && (flags & A_HINT_DO)
1383         && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
1384      /* Decide if the expression must autovivify or not. */
1385      flags = a_map_resolve(o, oi);
1386     }
1387     if (flags & A_HINT_DEREF)
1388      o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER);
1389     else
1390      o->op_ppaddr  = oi->old_pp;
1391     break;
1392    case OP_RV2AV:
1393    case OP_RV2HV:
1394     if (   o->op_ppaddr != a_pp_rv2av
1395         && o->op_ppaddr != a_pp_rv2hv
1396         && o->op_ppaddr != a_pp_rv2hv_simple)
1397      break;
1398     oi = a_map_fetch(o);
1399     if (!oi)
1400      break;
1401     if (!(oi->flags & A_HINT_DEREF))
1402      o->op_ppaddr  = oi->old_pp;
1403     break;
1404 #if A_HAS_MULTIDEREF
1405    case OP_MULTIDEREF:
1406     if (o->op_ppaddr != a_pp_multideref) {
1407      oi = a_map_fetch(cUNOPo->op_first);
1408      if (!oi)
1409       break;
1410      flags = oi->flags;
1411      if (a_do_multideref(o, flags)) {
1412       a_map_store_root(o, o->op_ppaddr, flags & ~A_HINT_DEREF);
1413       o->op_ppaddr = a_pp_multideref;
1414      }
1415     }
1416     break;
1417 #endif
1418 #if !A_HAS_RPEEP
1419    case OP_MAPWHILE:
1420    case OP_GREPWHILE:
1421    case OP_AND:
1422    case OP_OR:
1423    case OP_ANDASSIGN:
1424    case OP_ORASSIGN:
1425    case OP_COND_EXPR:
1426    case OP_RANGE:
1427 # if A_HAS_PERL(5, 10, 0)
1428    case OP_ONCE:
1429    case OP_DOR:
1430    case OP_DORASSIGN:
1431 # endif
1432     a_peep_rec(cLOGOPo->op_other);
1433     break;
1434    case OP_ENTERLOOP:
1435    case OP_ENTERITER:
1436     a_peep_rec(cLOOPo->op_redoop);
1437     a_peep_rec(cLOOPo->op_nextop);
1438     a_peep_rec(cLOOPo->op_lastop);
1439     break;
1440 # if A_HAS_PERL(5, 9, 5)
1441    case OP_SUBST:
1442     a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
1443     break;
1444 # else
1445    case OP_QR:
1446    case OP_MATCH:
1447    case OP_SUBST:
1448     a_peep_rec(cPMOPo->op_pmreplstart);
1449     break;
1450 # endif
1451 #endif /* !A_HAS_RPEEP */
1452    default:
1453     break;
1454   }
1455  }
1456 }
1457
1458 static void a_peep(pTHX_ OP *o) {
1459  dMY_CXT;
1460  ptable *seen = MY_CXT.seen;
1461
1462  a_old_peep(aTHX_ o);
1463
1464  if (seen) {
1465   ptable_seen_clear(seen);
1466   a_peep_rec(o);
1467   ptable_seen_clear(seen);
1468  }
1469 }
1470
1471 /* --- Interpreter setup/teardown ------------------------------------------ */
1472
1473 static U32 a_initialized = 0;
1474
1475 static void a_teardown(pTHX_ void *root) {
1476
1477  if (!a_initialized)
1478   return;
1479
1480 #if A_MULTIPLICITY
1481  if (aTHX != root)
1482   return;
1483 #endif
1484
1485  {
1486   dMY_CXT;
1487 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1488   ptable_hints_free(MY_CXT.tbl);
1489   MY_CXT.tbl  = NULL;
1490 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1491   ptable_seen_free(MY_CXT.seen);
1492   MY_CXT.seen = NULL;
1493  }
1494
1495  a_ck_restore(OP_PADANY, &a_old_ck_padany);
1496  a_ck_restore(OP_PADSV,  &a_old_ck_padsv);
1497
1498  a_ck_restore(OP_AELEM,  &a_old_ck_aelem);
1499  a_ck_restore(OP_HELEM,  &a_old_ck_helem);
1500  a_ck_restore(OP_RV2SV,  &a_old_ck_rv2sv);
1501
1502  a_ck_restore(OP_RV2AV,  &a_old_ck_rv2av);
1503  a_ck_restore(OP_RV2HV,  &a_old_ck_rv2hv);
1504
1505  a_ck_restore(OP_ASLICE, &a_old_ck_aslice);
1506  a_ck_restore(OP_HSLICE, &a_old_ck_hslice);
1507
1508  a_ck_restore(OP_EXISTS, &a_old_ck_exists);
1509  a_ck_restore(OP_DELETE, &a_old_ck_delete);
1510  a_ck_restore(OP_KEYS,   &a_old_ck_keys);
1511  a_ck_restore(OP_VALUES, &a_old_ck_values);
1512
1513 #if A_HAS_RPEEP
1514  PL_rpeepp  = a_old_peep;
1515 #else
1516  PL_peepp   = a_old_peep;
1517 #endif
1518  a_old_peep = 0;
1519
1520  a_initialized = 0;
1521 }
1522
1523 static void a_setup(pTHX) {
1524 #define a_setup() a_setup(aTHX)
1525  if (a_initialized)
1526   return;
1527
1528  {
1529   MY_CXT_INIT;
1530 # if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
1531   MY_CXT.tbl   = ptable_new();
1532   MY_CXT.owner = aTHX;
1533 # endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
1534   MY_CXT.seen  = ptable_new();
1535  }
1536
1537  a_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany);
1538  a_ck_replace(OP_PADSV,  a_ck_padsv,  &a_old_ck_padsv);
1539
1540  a_ck_replace(OP_AELEM,  a_ck_deref,  &a_old_ck_aelem);
1541  a_ck_replace(OP_HELEM,  a_ck_deref,  &a_old_ck_helem);
1542  a_ck_replace(OP_RV2SV,  a_ck_deref,  &a_old_ck_rv2sv);
1543
1544  a_ck_replace(OP_RV2AV,  a_ck_rv2xv,  &a_old_ck_rv2av);
1545  a_ck_replace(OP_RV2HV,  a_ck_rv2xv,  &a_old_ck_rv2hv);
1546
1547  a_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice);
1548  a_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice);
1549
1550  a_ck_replace(OP_EXISTS, a_ck_root,   &a_old_ck_exists);
1551  a_ck_replace(OP_DELETE, a_ck_root,   &a_old_ck_delete);
1552  a_ck_replace(OP_KEYS,   a_ck_root,   &a_old_ck_keys);
1553  a_ck_replace(OP_VALUES, a_ck_root,   &a_old_ck_values);
1554
1555 #if A_HAS_RPEEP
1556  a_old_peep = PL_rpeepp;
1557  PL_rpeepp  = a_peep;
1558 #else
1559  a_old_peep = PL_peepp;
1560  PL_peepp   = a_peep;
1561 #endif
1562
1563 #if A_MULTIPLICITY
1564  call_atexit(a_teardown, aTHX);
1565 #else
1566  call_atexit(a_teardown, NULL);
1567 #endif
1568
1569  a_initialized = 1;
1570 }
1571
1572 static U32 a_booted = 0;
1573
1574 /* --- XS ------------------------------------------------------------------ */
1575
1576 MODULE = autovivification      PACKAGE = autovivification
1577
1578 PROTOTYPES: ENABLE
1579
1580 BOOT:
1581 {
1582  if (!a_booted++) {
1583   HV *stash;
1584
1585   a_op_map = ptable_new();
1586 #ifdef USE_ITHREADS
1587   MUTEX_INIT(&a_op_map_mutex);
1588 #endif
1589
1590   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
1591
1592   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1593   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1594   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1595   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1596   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1597   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1598   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1599   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1600   newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(A_THREADSAFE));
1601   newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(A_FORKSAFE));
1602  }
1603
1604  a_setup();
1605 }
1606
1607 #if A_THREADSAFE
1608
1609 void
1610 CLONE(...)
1611 PROTOTYPE: DISABLE
1612 PREINIT:
1613 #if A_WORKAROUND_REQUIRE_PROPAGATION
1614  ptable *t;
1615 #endif
1616  ptable *s;
1617  GV     *gv;
1618 PPCODE:
1619  {
1620 #if A_WORKAROUND_REQUIRE_PROPAGATION
1621   dMY_CXT;
1622   {
1623    a_ptable_clone_ud ud;
1624
1625    t = ptable_new();
1626    a_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1627    ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
1628    a_ptable_clone_ud_deinit(ud);
1629   }
1630 #endif
1631   s = ptable_new();
1632  }
1633  {
1634   MY_CXT_CLONE;
1635 #if A_WORKAROUND_REQUIRE_PROPAGATION
1636   MY_CXT.tbl   = t;
1637   MY_CXT.owner = aTHX;
1638 #endif
1639   MY_CXT.seen  = s;
1640  }
1641  gv = gv_fetchpv(__PACKAGE__ "::_THREAD_CLEANUP", 0, SVt_PVCV);
1642  if (gv) {
1643   CV *cv = GvCV(gv);
1644   if (!PL_endav)
1645    PL_endav = newAV();
1646   SvREFCNT_inc(cv);
1647   if (!av_store(PL_endav, av_len(PL_endav) + 1, (SV *) cv))
1648    SvREFCNT_dec(cv);
1649   sv_magicext((SV *) PL_endav, NULL, PERL_MAGIC_ext, &a_endav_vtbl, NULL, 0);
1650  }
1651  XSRETURN(0);
1652
1653 void
1654 _THREAD_CLEANUP(...)
1655 PROTOTYPE: DISABLE
1656 PPCODE:
1657  a_thread_cleanup(aTHX_ NULL);
1658  XSRETURN(0);
1659
1660 #endif /* A_THREADSAFE */
1661
1662 SV *
1663 _tag(SV *hint)
1664 PROTOTYPE: $
1665 CODE:
1666  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
1667 OUTPUT:
1668  RETVAL
1669
1670 SV *
1671 _detag(SV *tag)
1672 PROTOTYPE: $
1673 CODE:
1674  if (!SvOK(tag))
1675   XSRETURN_UNDEF;
1676  RETVAL = newSVuv(a_detag(tag));
1677 OUTPUT:
1678  RETVAL