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