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