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