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