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 /* --- XS helpers ---------------------------------------------------------- */
  10
  11 #define XSH_PACKAGE "autovivification"
  12
  13 #include "xsh/caps.h"
  14 #include "xsh/util.h"
  15 #include "xsh/ops.h"
  16 #include "xsh/peep.h"
  17
  18 /* ... Lexical hints ....................................................... */
  19
  20 /* Used both for hints and op flags */
  21 #define A_HINT_STRICT 1
  22 #define A_HINT_WARN   2
  23 #define A_HINT_FETCH  4
  24 #define A_HINT_STORE  8
  25 #define A_HINT_EXISTS 16
  26 #define A_HINT_DELETE 32
  27 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
  28 #define A_HINT_DO     (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
  29 #define A_HINT_MASK   (A_HINT_NOTIFY|A_HINT_DO)
  30
  31 /* Only used in op flags */
  32 #define A_HINT_ROOT   64
  33 #define A_HINT_DEREF  128
  34
  35 #define XSH_HINTS_TYPE_UV 1
  36
  37 #include "xsh/hints.h"
  38
  39 #define a_hint() xsh_hints_detag(xsh_hints_fetch())
  40
  41 /* ... Thread-local storage ................................................ */
  42
  43 #define XSH_THREADS_COMPILE_TIME_PROTECTION 1
  44 #define XSH_THREADS_USER_CONTEXT            0
  45
  46 #include "xsh/threads.h"
  47
  48 /* --- Compatibility wrappers ---------------------------------------------- */
  49
  50 #ifndef HvNAME_get
  51 # define HvNAME_get(H) HvNAME(H)
  52 #endif
  53
  54 #ifndef HvNAMELEN_get
  55 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  56 #endif
  57
  58 #ifndef A_HAS_MULTIDEREF
  59 # define A_HAS_MULTIDEREF XSH_HAS_PERL(5, 21, 7)
  60 #endif
  61
  62 /* ... Our vivify_ref() .................................................... */
  63
  64 /* Perl_vivify_ref() is not exported, so we have to reimplement it. */
  65
  66 #if A_HAS_MULTIDEREF
  67
  68 static SV *a_vivify_ref(pTHX_ SV *sv, int to_hash) {
  69 #define a_vivify_ref(S, TH) a_vivify_ref(aTHX_ (S), (TH))
  70  SvGETMAGIC(sv);
  71
  72  if (!SvOK(sv)) {
  73   SV *val;
  74
  75   if (SvREADONLY(sv))
  76    Perl_croak_no_modify();
  77
  78   /* Inlined prepare_SV_for_RV() */
  79   if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV) {
  80    sv_upgrade(sv, SVt_IV);
  81   } else if (SvTYPE(sv) >= SVt_PV) {
  82    SvPV_free(sv);
  83    SvLEN_set(sv, 0);
  84    SvCUR_set(sv, 0);
  85   }
  86
  87   val = to_hash ? MUTABLE_SV(newHV()) : MUTABLE_SV(newAV());
  88   SvRV_set(sv, val);
  89   SvROK_on(sv);
  90   SvSETMAGIC(sv);
  91   SvGETMAGIC(sv);
  92  }
  93
  94  if (SvGMAGICAL(sv)) {
  95   SV *msv = sv_newmortal();
  96   sv_setsv_nomg(msv, sv);
  97   return msv;
  98  }
  99
 100  return sv;
 101 }
 102
 103 #endif /* A_HAS_MULTIDEREF */
 104
 105 /* --- op => info map ------------------------------------------------------ */
 106
 107 typedef struct {
 108  OP   *(*old_pp)(pTHX);
 109  void   *next;
 110  UV      flags;
 111 } a_op_info;
 112
 113 #define PTABLE_NAME             ptable_map
 114 #define PTABLE_VAL_FREE(V)      PerlMemShared_free(V)
 115 #define PTABLE_VAL_NEED_CONTEXT 0
 116 #define PTABLE_NEED_DELETE      1
 117 #define PTABLE_NEED_WALK        0
 118
 119 #include "xsh/ptable.h"
 120
 121 #define ptable_map_store(T, K, V) ptable_map_store(aPMS_ (T), (K), (V))
 122 #define ptable_map_delete(T, K)   ptable_map_delete(aPMS_ (T), (K))
 123 #define ptable_map_free(T)        ptable_map_free(aPMS_ (T))
 124
 125 static ptable *a_op_map = NULL;
 126
 127 #ifdef USE_ITHREADS
 128
 129 #define dA_MAP_THX a_op_info a_op_map_tmp_oi
 130
 131 static perl_mutex a_op_map_mutex;
 132
 133 static const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
 134  const a_op_info *val;
 135
 136  XSH_LOCK(&a_op_map_mutex);
 137
 138  val = ptable_fetch(a_op_map, o);
 139  if (val) {
 140   *oi = *val;
 141   val = oi;
 142  }
 143
 144  XSH_UNLOCK(&a_op_map_mutex);
 145
 146  return val;
 147 }
 148
 149 #define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi)
 150
 151 #else /* USE_ITHREADS */
 152
 153 #define dA_MAP_THX dNOOP
 154
 155 #define a_map_fetch(O) ptable_fetch(a_op_map, (O))
 156
 157 #endif /* !USE_ITHREADS */
 158
 159 static const a_op_info *a_map_store_locked(pPMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
 160 #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPMS_ (O), (PP), (N), (F))
 161  a_op_info *oi;
 162
 163  if (!(oi = ptable_fetch(a_op_map, o))) {
 164   oi = PerlMemShared_malloc(sizeof *oi);
 165   ptable_map_store(a_op_map, o, oi);
 166  }
 167
 168  oi->old_pp = old_pp;
 169  oi->next   = next;
 170  oi->flags  = flags;
 171
 172  return oi;
 173 }
 174
 175 static void a_map_store(pTHX_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
 176 #define a_map_store(O, PP, N, F) a_map_store(aTHX_ (O), (PP), (N), (F))
 177  XSH_LOCK(&a_op_map_mutex);
 178
 179  a_map_store_locked(o, old_pp, next, flags);
 180
 181  XSH_UNLOCK(&a_op_map_mutex);
 182 }
 183
 184 static void a_map_delete(pTHX_ const OP *o) {
 185 #define a_map_delete(O) a_map_delete(aTHX_ (O))
 186  XSH_LOCK(&a_op_map_mutex);
 187
 188  ptable_map_delete(a_op_map, o);
 189
 190  XSH_UNLOCK(&a_op_map_mutex);
 191 }
 192
 193 static const OP *a_map_descend(const OP *o) {
 194  switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 195   case OA_BASEOP:
 196   case OA_UNOP:
 197   case OA_BINOP:
 198   case OA_BASEOP_OR_UNOP:
 199    return cUNOPo->op_first;
 200   case OA_LIST:
 201   case OA_LISTOP:
 202    return cLISTOPo->op_last;
 203  }
 204
 205  return NULL;
 206 }
 207
 208 static void a_map_store_root(pTHX_ const OP *root, OP *(*old_pp)(pTHX), UV flags) {
 209 #define a_map_store_root(R, PP, F) a_map_store_root(aTHX_ (R), (PP), (F))
 210  const a_op_info *roi;
 211  a_op_info *oi;
 212  const OP *o = root;
 213
 214  XSH_LOCK(&a_op_map_mutex);
 215
 216  roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT);
 217
 218  while (o->op_flags & OPf_KIDS) {
 219   o = a_map_descend(o);
 220   if (!o)
 221    break;
 222   if ((oi = ptable_fetch(a_op_map, o))) {
 223    oi->flags &= ~A_HINT_ROOT;
 224    oi->next   = (a_op_info *) roi;
 225    break;
 226   }
 227  }
 228
 229  XSH_UNLOCK(&a_op_map_mutex);
 230
 231  return;
 232 }
 233
 234 static void a_map_update_flags_topdown(const OP *root, UV flags) {
 235  a_op_info *oi;
 236  const OP *o = root;
 237
 238  XSH_LOCK(&a_op_map_mutex);
 239
 240  flags &= ~A_HINT_ROOT;
 241
 242  do {
 243   if ((oi = ptable_fetch(a_op_map, o)))
 244    oi->flags = (oi->flags & A_HINT_ROOT) | flags;
 245   if (!(o->op_flags & OPf_KIDS))
 246    break;
 247   o = a_map_descend(o);
 248  } while (o);
 249
 250  XSH_UNLOCK(&a_op_map_mutex);
 251
 252  return;
 253 }
 254
 255 #define a_map_cancel(R) a_map_update_flags_topdown((R), 0)
 256
 257 static void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
 258  a_op_info *oi;
 259
 260  XSH_LOCK(&a_op_map_mutex);
 261
 262  flags  &= ~A_HINT_ROOT;
 263  rflags |=  A_HINT_ROOT;
 264
 265  oi = ptable_fetch(a_op_map, o);
 266  while (!(oi->flags & A_HINT_ROOT)) {
 267   oi->flags = flags;
 268   oi        = oi->next;
 269  }
 270  oi->flags = rflags;
 271
 272  XSH_UNLOCK(&a_op_map_mutex);
 273
 274  return;
 275 }
 276
 277 /* ... Decide whether this expression should be autovivified or not ........ */
 278
 279 static UV a_map_resolve(const OP *o, const a_op_info *oi) {
 280  UV flags = 0, rflags;
 281  const OP *root;
 282  const a_op_info *roi = oi;
 283
 284  while (!(roi->flags & A_HINT_ROOT))
 285   roi = roi->next;
 286  if (!roi)
 287   goto cancel;
 288
 289  rflags = roi->flags & ~A_HINT_ROOT;
 290  if (!rflags)
 291   goto cancel;
 292
 293  root = roi->next;
 294  if (root->op_flags & OPf_MOD) {
 295   if (rflags & A_HINT_STORE)
 296    flags = (A_HINT_STORE|A_HINT_DEREF);
 297  } else if (rflags & A_HINT_FETCH)
 298    flags = (A_HINT_FETCH|A_HINT_DEREF);
 299
 300  if (!flags) {
 301 cancel:
 302   a_map_update_flags_bottomup(o, 0, 0);
 303   return 0;
 304  }
 305
 306  flags |= (rflags & A_HINT_NOTIFY);
 307  a_map_update_flags_bottomup(o, flags, 0);
 308
 309  return oi->flags & A_HINT_ROOT ? 0 : flags;
 310 }
 311
 312 /* ... Inspired from pp_defined() .......................................... */
 313
 314 static int a_undef(pTHX_ SV *sv) {
 315 #define a_undef(S) a_undef(aTHX_ (S))
 316  switch (SvTYPE(sv)) {
 317   case SVt_NULL:
 318    return 1;
 319   case SVt_PVAV:
 320    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
 321                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 322     return 0;
 323    break;
 324   case SVt_PVHV:
 325    if (HvARRAY(sv) || SvGMAGICAL(sv)
 326                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 327     return 0;
 328    break;
 329   default:
 330    SvGETMAGIC(sv);
 331    if (SvOK(sv))
 332     return 0;
 333  }
 334
 335  return 1;
 336 }
 337
 338 /* --- PP functions -------------------------------------------------------- */
 339
 340 /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp
 341  * value, another extension might have saved our pp replacement as the ppaddr
 342  * for this op, so this doesn't ensure that our function will never be called
 343  * again. That's why we don't remove the op info from our map, so that it can
 344  * still run correctly if required. */
 345
 346 /* ... pp_rv2av ............................................................ */
 347
 348 static OP *a_pp_rv2av(pTHX) {
 349  dA_MAP_THX;
 350  const a_op_info *oi;
 351  dSP;
 352
 353  oi = a_map_fetch(PL_op);
 354
 355  if (oi->flags & A_HINT_DEREF) {
 356   if (a_undef(TOPs)) {
 357    /* We always need to push an empty array to fool the pp_aelem() that comes
 358     * later. */
 359    SV *av;
 360    (void) POPs;
 361    av = sv_2mortal((SV *) newAV());
 362    PUSHs(av);
 363    RETURN;
 364   }
 365  }
 366
 367  return oi->old_pp(aTHX);
 368 }
 369
 370 /* ... pp_rv2hv ............................................................ */
 371
 372 static OP *a_pp_rv2hv_simple(pTHX) {
 373  dA_MAP_THX;
 374  const a_op_info *oi;
 375  dSP;
 376
 377  oi = a_map_fetch(PL_op);
 378
 379  if (oi->flags & A_HINT_DEREF) {
 380   if (a_undef(TOPs))
 381    RETURN;
 382  }
 383
 384  return oi->old_pp(aTHX);
 385 }
 386
 387 static OP *a_pp_rv2hv(pTHX) {
 388  dA_MAP_THX;
 389  const a_op_info *oi;
 390  dSP;
 391
 392  oi = a_map_fetch(PL_op);
 393
 394  if (oi->flags & A_HINT_DEREF) {
 395   if (a_undef(TOPs)) {
 396    SV *hv;
 397    (void) POPs;
 398    hv = sv_2mortal((SV *) newHV());
 399    PUSHs(hv);
 400    RETURN;
 401   }
 402  }
 403
 404  return oi->old_pp(aTHX);
 405 }
 406
 407 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
 408
 409 static void a_cannot_vivify(pTHX_ UV flags) {
 410 #define a_cannot_vivify(F) a_cannot_vivify(aTHX_ (F))
 411  if (flags & A_HINT_STRICT)
 412   croak("Reference vivification forbidden");
 413  else if (flags & A_HINT_WARN)
 414   warn("Reference was vivified");
 415  else /* A_HINT_STORE */
 416   croak("Can't vivify reference");
 417 }
 418
 419 static OP *a_pp_deref(pTHX) {
 420  dA_MAP_THX;
 421  const a_op_info *oi;
 422  UV flags;
 423  dSP;
 424
 425  oi = a_map_fetch(PL_op);
 426
 427  flags = oi->flags;
 428  if (flags & A_HINT_DEREF) {
 429   OP *o;
 430
 431   o = oi->old_pp(aTHX);
 432
 433   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
 434    SPAGAIN;
 435    if (a_undef(TOPs))
 436     a_cannot_vivify(flags);
 437   }
 438
 439   return o;
 440  }
 441
 442  return oi->old_pp(aTHX);
 443 }
 444
 445 /* ... pp_root (exists,delete,keys,values) ................................. */
 446
 447 static OP *a_pp_root_unop(pTHX) {
 448  dSP;
 449
 450  if (a_undef(TOPs)) {
 451   (void) POPs;
 452   /* Can only be reached by keys or values */
 453   if (GIMME_V == G_SCALAR) {
 454    dTARGET;
 455    PUSHi(0);
 456   }
 457   RETURN;
 458  }
 459
 460  {
 461   dA_MAP_THX;
 462   const a_op_info *oi = a_map_fetch(PL_op);
 463   return oi->old_pp(aTHX);
 464  }
 465 }
 466
 467 static OP *a_pp_root_binop(pTHX) {
 468  dSP;
 469
 470  if (a_undef(TOPm1s)) {
 471   (void) POPs;
 472   (void) POPs;
 473   if (PL_op->op_type == OP_EXISTS)
 474    RETPUSHNO;
 475   else
 476    RETPUSHUNDEF;
 477  }
 478
 479  {
 480   dA_MAP_THX;
 481   const a_op_info *oi = a_map_fetch(PL_op);
 482   return oi->old_pp(aTHX);
 483  }
 484 }
 485
 486 #if A_HAS_MULTIDEREF
 487
 488 /* ... pp_multideref ....................................................... */
 489
 490 /* This pp replacement is actually only called for topmost exists/delete ops,
 491  * because we hijack the [ah]elem check functions and this disables the
 492  * optimization for lvalue and rvalue dereferencing. In particular, the
 493  * OPf_MOD branches should never be covered. In the future, the multideref
 494  * optimization might also be disabled for custom exists/delete check functions,
 495  * which will make this section unnecessary. However, the code tries to be as
 496  * general as possible in case I think of a way to reenable the multideref
 497  * optimization even when this module is in use. */
 498
 499 static UV a_do_multideref(const OP *o, UV flags) {
 500  UV isexdel, other_flags;
 501
 502  XSH_ASSERT(o->op_type == OP_MULTIDEREF);
 503
 504  other_flags = flags & ~A_HINT_DO;
 505
 506  isexdel = o->op_private & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE);
 507  if (isexdel) {
 508   if (isexdel & OPpMULTIDEREF_EXISTS) {
 509    flags &= A_HINT_EXISTS;
 510   } else {
 511    flags &= A_HINT_DELETE;
 512   }
 513  } else {
 514   if (o->op_flags & OPf_MOD) {
 515    flags &= A_HINT_STORE;
 516   } else {
 517    flags &= A_HINT_FETCH;
 518   }
 519  }
 520
 521  return flags ? (flags | other_flags) : 0;
 522 }
 523
 524 static SV *a_do_fake_pp(pTHX_ OP *op) {
 525 #define a_do_fake_pp(O) a_do_fake_pp(aTHX_ (O))
 526  {
 527   OP *o = PL_op;
 528   ENTER;
 529   SAVEOP();
 530   PL_op = op;
 531   PL_op->op_ppaddr(aTHX);
 532   PL_op = o;
 533   LEAVE;
 534  }
 535
 536  {
 537   SV *ret;
 538   dSP;
 539   ret = POPs;
 540   PUTBACK;
 541   return ret;
 542  }
 543 }
 544
 545 static void a_do_fake_pp_unop_init(pTHX_ UNOP *unop, U32 type, U32 flags) {
 546 #define a_do_fake_pp_unop_init(O, T, F) a_do_fake_pp_unop_init(aTHX_ (O), (T), (F))
 547  unop->op_type    = type;
 548  unop->op_flags   = OPf_WANT_SCALAR | (~OPf_WANT & flags);
 549  unop->op_private = 0;
 550  unop->op_first   = NULL;
 551  unop->op_ppaddr  = PL_ppaddr[type];
 552 }
 553
 554 static SV *a_do_fake_pp_unop_arg1(pTHX_ U32 type, U32 flags, SV *arg) {
 555 #define a_do_fake_pp_unop_arg1(T, F, A) a_do_fake_pp_unop_arg1(aTHX_ (T), (F), (A))
 556  UNOP unop;
 557  dSP;
 558
 559  a_do_fake_pp_unop_init(&unop, type, flags);
 560
 561  EXTEND(SP, 1);
 562  PUSHs(arg);
 563  PUTBACK;
 564
 565  return a_do_fake_pp((OP *) &unop);
 566 }
 567
 568 static SV *a_do_fake_pp_unop_arg2(pTHX_ U32 type, U32 flags, SV *arg1, SV *arg2) {
 569 #define a_do_fake_pp_unop_arg2(T, F, A1, A2) a_do_fake_pp_unop_arg2(aTHX_ (T), (F), (A1), (A2))
 570  UNOP unop;
 571  dSP;
 572
 573  a_do_fake_pp_unop_init(&unop, type, flags);
 574
 575  EXTEND(SP, 2);
 576  PUSHs(arg1);
 577  PUSHs(arg2);
 578  PUTBACK;
 579
 580  return a_do_fake_pp((OP *) &unop);
 581 }
 582
 583 #define a_do_pp_rv2av(R)        a_do_fake_pp_unop_arg1(OP_RV2AV,  OPf_REF,     (R))
 584 #define a_do_pp_afetch(A, I)    a_do_fake_pp_unop_arg2(OP_AELEM,  0,           (A), (I))
 585 #define a_do_pp_afetch_lv(A, I) a_do_fake_pp_unop_arg2(OP_AELEM,  OPf_MOD,     (A), (I))
 586 #define a_do_pp_aexists(A, I)   a_do_fake_pp_unop_arg2(OP_EXISTS, OPf_SPECIAL, (A), (I))
 587 #define a_do_pp_adelete(A, I)   a_do_fake_pp_unop_arg2(OP_DELETE, OPf_SPECIAL, (A), (I))
 588
 589 #define a_do_pp_rv2hv(R)        a_do_fake_pp_unop_arg1(OP_RV2HV,  OPf_REF, (R))
 590 #define a_do_pp_hfetch(H, K)    a_do_fake_pp_unop_arg2(OP_HELEM,  0,       (H), (K))
 591 #define a_do_pp_hfetch_lv(H, K) a_do_fake_pp_unop_arg2(OP_HELEM,  OPf_MOD, (H), (K))
 592 #define a_do_pp_hexists(H, K)   a_do_fake_pp_unop_arg2(OP_EXISTS, 0,  (H), (K))
 593 #define a_do_pp_hdelete(H, K)   a_do_fake_pp_unop_arg2(OP_DELETE, 0,  (H), (K))
 594
 595 static OP *a_pp_multideref(pTHX) {
 596  UNOP_AUX_item *items;
 597  UV  actions;
 598  UV  flags = 0;
 599  SV *sv    = NULL;
 600  dSP;
 601
 602  {
 603   dA_MAP_THX;
 604   const a_op_info *oi = a_map_fetch(PL_op);
 605   XSH_ASSERT(oi);
 606   flags = a_do_multideref(PL_op, oi->flags);
 607   if (!flags)
 608    return oi->old_pp(aTHX);
 609  }
 610
 611  items   = cUNOP_AUXx(PL_op)->op_aux;
 612  actions = items->uv;
 613
 614  PL_multideref_pc = items;
 615
 616  while (1) {
 617   switch (actions & MDEREF_ACTION_MASK) {
 618    case MDEREF_reload:
 619     actions = (++items)->uv;
 620     continue;
 621    case MDEREF_AV_padav_aelem: /* $lex[...] */
 622     sv = PAD_SVl((++items)->pad_offset);
 623     if (a_undef(sv))
 624      goto ret_undef;
 625     goto do_AV_aelem;
 626    case MDEREF_AV_gvav_aelem: /* $pkg[...] */
 627     sv = UNOP_AUX_item_sv(++items);
 628     XSH_ASSERT(isGV_with_GP(sv));
 629     sv = (SV *) GvAVn((GV *) sv);
 630     if (a_undef(sv))
 631      goto ret_undef;
 632     goto do_AV_aelem;
 633    case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
 634     sv = POPs;
 635     if (a_undef(sv))
 636      goto ret_undef;
 637     goto do_AV_rv2av_aelem;
 638    case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
 639     sv = UNOP_AUX_item_sv(++items);
 640     XSH_ASSERT(isGV_with_GP(sv));
 641     sv = GvSVn((GV *) sv);
 642     if (a_undef(sv))
 643      goto ret_undef;
 644     goto do_AV_vivify_rv2av_aelem;
 645    case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
 646     sv = PAD_SVl((++items)->pad_offset);
 647     /* FALLTHROUGH */
 648    case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
 649     if (a_undef(sv))
 650      goto ret_undef;
 651 do_AV_vivify_rv2av_aelem:
 652     sv = a_vivify_ref(sv, 0);
 653 do_AV_rv2av_aelem:
 654     sv = a_do_pp_rv2av(sv);
 655 do_AV_aelem:
 656     {
 657      SV *esv;
 658      XSH_ASSERT(SvTYPE(sv) == SVt_PVAV);
 659      switch (actions & MDEREF_INDEX_MASK) {
 660       case MDEREF_INDEX_none:
 661        goto finish;
 662       case MDEREF_INDEX_const:
 663        esv = sv_2mortal(newSViv((++items)->iv));
 664        break;
 665       case MDEREF_INDEX_padsv:
 666        esv = PAD_SVl((++items)->pad_offset);
 667        goto check_elem;
 668       case MDEREF_INDEX_gvsv:
 669        esv = UNOP_AUX_item_sv(++items);
 670        XSH_ASSERT(isGV_with_GP(esv));
 671        esv = GvSVn((GV *) esv);
 672 check_elem:
 673        if (UNLIKELY(SvROK(esv) && !SvGAMAGIC(esv) && ckWARN(WARN_MISC)))
 674         Perl_warner(aTHX_ packWARN(WARN_MISC),
 675                           "Use of reference \"%"SVf"\" as array index",
 676                           SVfARG(esv));
 677        break;
 678      }
 679      PL_multideref_pc = items;
 680      if (actions & MDEREF_FLAG_last) {
 681       switch (flags & A_HINT_DO) {
 682        case A_HINT_FETCH:
 683         sv = a_do_pp_afetch(sv, esv);
 684         break;
 685        case A_HINT_STORE:
 686         sv = a_do_pp_afetch_lv(sv, esv);
 687         break;
 688        case A_HINT_EXISTS:
 689         sv = a_do_pp_aexists(sv, esv);
 690         break;
 691        case A_HINT_DELETE:
 692         sv = a_do_pp_adelete(sv, esv);
 693         break;
 694       }
 695       goto finish;
 696      }
 697      sv = a_do_pp_afetch(sv, esv);
 698      break;
 699     }
 700    case MDEREF_HV_padhv_helem: /* $lex{...} */
 701     sv = PAD_SVl((++items)->pad_offset);
 702     if (a_undef(sv))
 703      goto ret_undef;
 704     goto do_HV_helem;
 705    case MDEREF_HV_gvhv_helem: /* $pkg{...} */
 706     sv = UNOP_AUX_item_sv(++items);
 707     XSH_ASSERT(isGV_with_GP(sv));
 708     sv = (SV *) GvHVn((GV *) sv);
 709     if (a_undef(sv))
 710      goto ret_undef;
 711     goto do_HV_helem;
 712    case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
 713     sv = POPs;
 714     if (a_undef(sv))
 715      goto ret_undef;
 716     goto do_HV_rv2hv_helem;
 717    case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
 718     sv = UNOP_AUX_item_sv(++items);
 719     XSH_ASSERT(isGV_with_GP(sv));
 720     sv = GvSVn((GV *) sv);
 721     if (a_undef(sv))
 722      goto ret_undef;
 723     goto do_HV_vivify_rv2hv_helem;
 724    case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
 725     sv = PAD_SVl((++items)->pad_offset);
 726     /* FALLTHROUGH */
 727    case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
 728     if (a_undef(sv))
 729      goto ret_undef;
 730 do_HV_vivify_rv2hv_helem:
 731     sv = a_vivify_ref(sv, 1);
 732 do_HV_rv2hv_helem:
 733     sv = a_do_pp_rv2hv(sv);
 734 do_HV_helem:
 735     {
 736      SV *key;
 737      XSH_ASSERT(SvTYPE(sv) == SVt_PVHV);
 738      switch (actions & MDEREF_INDEX_MASK) {
 739       case MDEREF_INDEX_none:
 740        goto finish;
 741       case MDEREF_INDEX_const:
 742        key = UNOP_AUX_item_sv(++items);
 743        break;
 744       case MDEREF_INDEX_padsv:
 745        key = PAD_SVl((++items)->pad_offset);
 746        break;
 747       case MDEREF_INDEX_gvsv:
 748        key = UNOP_AUX_item_sv(++items);
 749        XSH_ASSERT(isGV_with_GP(key));
 750        key = GvSVn((GV *) key);
 751        break;
 752      }
 753      PL_multideref_pc = items;
 754      if (actions & MDEREF_FLAG_last) {
 755       switch (flags & A_HINT_DO) {
 756        case A_HINT_FETCH:
 757         sv = a_do_pp_hfetch(sv, key);
 758         break;
 759        case A_HINT_STORE:
 760         sv = a_do_pp_hfetch_lv(sv, key);
 761         break;
 762        case A_HINT_EXISTS:
 763         sv = a_do_pp_hexists(sv, key);
 764         break;
 765        case A_HINT_DELETE:
 766         sv = a_do_pp_hdelete(sv, key);
 767         break;
 768        default:
 769         break;
 770       }
 771       goto finish;
 772      }
 773      sv = a_do_pp_hfetch(sv, key);
 774      break;
 775     }
 776   }
 777
 778   actions >>= MDEREF_SHIFT;
 779  }
 780
 781 ret_undef:
 782  if (flags & (A_HINT_NOTIFY|A_HINT_STORE))
 783   a_cannot_vivify(flags);
 784  if (flags & A_HINT_EXISTS)
 785   sv = &PL_sv_no;
 786  else
 787   sv = &PL_sv_undef;
 788 finish:
 789  XPUSHs(sv);
 790  RETURN;
 791 }
 792
 793 #endif /* A_HAS_MULTIDEREF */
 794
 795 /* --- Check functions ----------------------------------------------------- */
 796
 797 static void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
 798 #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
 799
 800  if (o->op_type == type && o->op_ppaddr != new_pp
 801                         && cUNOPo->op_first->op_type != OP_GV) {
 802   dA_MAP_THX;
 803   const a_op_info *oi = a_map_fetch(o);
 804   if (oi) {
 805    a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
 806    o->op_ppaddr = new_pp;
 807   }
 808  }
 809
 810  return;
 811 }
 812
 813 /* ... ck_pad{any,sv} ...................................................... */
 814
 815 /* Sadly, the padsv OPs we are interested in don't trigger the padsv check
 816  * function, but are instead manually mutated from a padany. So we store
 817  * the op entry in the op map in the padany check function, and we set their
 818  * op_ppaddr member in our peephole optimizer replacement below. */
 819
 820 static OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
 821
 822 static OP *a_ck_padany(pTHX_ OP *o) {
 823  UV hint;
 824
 825  o = a_old_ck_padany(aTHX_ o);
 826
 827  hint = a_hint();
 828  if (hint & A_HINT_DO)
 829   a_map_store_root(o, o->op_ppaddr, hint);
 830  else
 831   a_map_delete(o);
 832
 833  return o;
 834 }
 835
 836 static OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
 837
 838 static OP *a_ck_padsv(pTHX_ OP *o) {
 839  UV hint;
 840
 841  o = a_old_ck_padsv(aTHX_ o);
 842
 843  hint = a_hint();
 844  if (hint & A_HINT_DO) {
 845   a_map_store_root(o, o->op_ppaddr, hint);
 846   o->op_ppaddr = a_pp_deref;
 847  } else
 848   a_map_delete(o);
 849
 850  return o;
 851 }
 852
 853 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
 854
 855 /* Those ops appear both at the root and inside an expression but there's no
 856  * way to distinguish both situations. Worse, we can't even know if we are in a
 857  * modifying context, so the expression can't be resolved yet. It will be at the
 858  * first invocation of a_pp_deref() for this expression. */
 859
 860 static OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
 861 static OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
 862 static OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
 863
 864 static OP *a_ck_deref(pTHX_ OP *o) {
 865  OP * (*old_ck)(pTHX_ OP *o) = 0;
 866  UV hint = a_hint();
 867
 868  switch (o->op_type) {
 869   case OP_AELEM:
 870    old_ck = a_old_ck_aelem;
 871    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 872     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av);
 873    break;
 874   case OP_HELEM:
 875    old_ck = a_old_ck_helem;
 876    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
 877     a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
 878    break;
 879   case OP_RV2SV:
 880    old_ck = a_old_ck_rv2sv;
 881    break;
 882  }
 883  o = old_ck(aTHX_ o);
 884
 885 #if A_HAS_MULTIDEREF
 886  if (old_ck == a_old_ck_rv2sv && o->op_flags & OPf_KIDS) {
 887   OP *kid = cUNOPo->op_first;
 888   if (kid && kid->op_type == OP_GV) {
 889    if (hint & A_HINT_DO)
 890     a_map_store(kid, kid->op_ppaddr, NULL, hint);
 891    else
 892     a_map_delete(kid);
 893   }
 894  }
 895 #endif
 896
 897  if (hint & A_HINT_DO) {
 898   a_map_store_root(o, o->op_ppaddr, hint);
 899   o->op_ppaddr = a_pp_deref;
 900  } else
 901   a_map_delete(o);
 902
 903  return o;
 904 }
 905
 906 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
 907
 908 /* Those ops also appear both inisde and at the root, hence the caveats for
 909  * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a
 910  * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the
 911  * expression. */
 912
 913 static OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
 914 static OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
 915
 916 static OP *a_ck_rv2xv(pTHX_ OP *o) {
 917  OP * (*old_ck)(pTHX_ OP *o) = 0;
 918  OP * (*new_pp)(pTHX)        = 0;
 919  UV hint;
 920
 921  switch (o->op_type) {
 922   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
 923   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
 924  }
 925  o = old_ck(aTHX_ o);
 926
 927  if (cUNOPo->op_first->op_type == OP_GV)
 928   return o;
 929
 930  hint = a_hint();
 931  if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) {
 932   a_map_store_root(o, o->op_ppaddr, hint);
 933   o->op_ppaddr = new_pp;
 934  } else
 935   a_map_delete(o);
 936
 937  return o;
 938 }
 939
 940 /* ... ck_xslice (aslice,hslice) ........................................... */
 941
 942 /* I think those are only found at the root, but there's nothing that really
 943  * prevent them to be inside the expression too. We only need to update the
 944  * root so that the rest of the expression will see the right context when
 945  * resolving. That's why we don't replace the ppaddr. */
 946
 947 static OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
 948 static OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
 949
 950 static OP *a_ck_xslice(pTHX_ OP *o) {
 951  OP * (*old_ck)(pTHX_ OP *o) = 0;
 952  UV hint = a_hint();
 953
 954  switch (o->op_type) {
 955   case OP_ASLICE:
 956    old_ck = a_old_ck_aslice;
 957    break;
 958   case OP_HSLICE:
 959    old_ck = a_old_ck_hslice;
 960    if (hint & A_HINT_DO)
 961     a_recheck_rv2xv(OpSIBLING(cUNOPo->op_first), OP_RV2HV, a_pp_rv2hv);
 962    break;
 963  }
 964  o = old_ck(aTHX_ o);
 965
 966  if (hint & A_HINT_DO) {
 967   a_map_store_root(o, 0, hint);
 968  } else
 969   a_map_delete(o);
 970
 971  return o;
 972 }
 973
 974 /* ... ck_root (exists,delete,keys,values) ................................. */
 975
 976 /* Those ops are only found at the root of a dereferencing expression. We can
 977  * then resolve at compile time if vivification must take place or not. */
 978
 979 static OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
 980 static OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
 981 static OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
 982 static OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
 983
 984 static OP *a_ck_root(pTHX_ OP *o) {
 985  OP * (*old_ck)(pTHX_ OP *o) = 0;
 986  OP * (*new_pp)(pTHX)        = 0;
 987  int enabled = 0;
 988  UV hint = a_hint();
 989
 990  switch (o->op_type) {
 991   case OP_EXISTS:
 992    old_ck  = a_old_ck_exists;
 993    new_pp  = a_pp_root_binop;
 994    enabled = hint & A_HINT_EXISTS;
 995    break;
 996   case OP_DELETE:
 997    old_ck  = a_old_ck_delete;
 998    new_pp  = a_pp_root_binop;
 999    enabled = hint & A_HINT_DELETE;
1000    break;
1001   case OP_KEYS:
1002    old_ck  = a_old_ck_keys;
1003    new_pp  = a_pp_root_unop;
1004    enabled = hint & A_HINT_FETCH;
1005    break;
1006   case OP_VALUES:
1007    old_ck  = a_old_ck_values;
1008    new_pp  = a_pp_root_unop;
1009    enabled = hint & A_HINT_FETCH;
1010    break;
1011  }
1012  o = old_ck(aTHX_ o);
1013
1014  if (hint & A_HINT_DO) {
1015   if (enabled) {
1016    a_map_update_flags_topdown(o, hint | A_HINT_DEREF);
1017    a_map_store_root(o, o->op_ppaddr, hint);
1018    o->op_ppaddr = new_pp;
1019   } else {
1020    a_map_cancel(o);
1021   }
1022  } else
1023   a_map_delete(o);
1024
1025  return o;
1026 }
1027
1028 /* --- Our peephole optimizer ---------------------------------------------- */
1029
1030 static void xsh_peep_rec(pTHX_ OP *o, ptable *seen) {
1031  for (; o; o = o->op_next) {
1032   dA_MAP_THX;
1033   const a_op_info *oi = NULL;
1034   UV flags = 0;
1035
1036   if (xsh_peep_seen(o, seen))
1037    break;
1038
1039   switch (o->op_type) {
1040    case OP_PADSV:
1041     if (o->op_ppaddr != a_pp_deref) {
1042      oi = a_map_fetch(o);
1043      if (oi && (oi->flags & A_HINT_DO)) {
1044       a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
1045       o->op_ppaddr = a_pp_deref;
1046      }
1047     }
1048     /* FALLTHROUGH */
1049    case OP_AELEM:
1050    case OP_AELEMFAST:
1051    case OP_HELEM:
1052    case OP_RV2SV:
1053     if (o->op_ppaddr != a_pp_deref)
1054      break;
1055     oi = a_map_fetch(o);
1056     if (!oi)
1057      break;
1058     flags = oi->flags;
1059     if (!(flags & A_HINT_DEREF)
1060         && (flags & A_HINT_DO)
1061         && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
1062      /* Decide if the expression must autovivify or not. */
1063      flags = a_map_resolve(o, oi);
1064     }
1065     if (flags & A_HINT_DEREF)
1066      o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER);
1067     else
1068      o->op_ppaddr  = oi->old_pp;
1069     break;
1070    case OP_RV2AV:
1071    case OP_RV2HV:
1072     if (   o->op_ppaddr != a_pp_rv2av
1073         && o->op_ppaddr != a_pp_rv2hv
1074         && o->op_ppaddr != a_pp_rv2hv_simple)
1075      break;
1076     oi = a_map_fetch(o);
1077     if (!oi)
1078      break;
1079     if (!(oi->flags & A_HINT_DEREF))
1080      o->op_ppaddr  = oi->old_pp;
1081     break;
1082 #if A_HAS_MULTIDEREF
1083    case OP_MULTIDEREF:
1084     if (o->op_ppaddr != a_pp_multideref) {
1085      oi = a_map_fetch(cUNOPo->op_first);
1086      if (!oi)
1087       break;
1088      flags = oi->flags;
1089      if (a_do_multideref(o, flags)) {
1090       a_map_store_root(o, o->op_ppaddr, flags & ~A_HINT_DEREF);
1091       o->op_ppaddr = a_pp_multideref;
1092      }
1093     }
1094     break;
1095 #endif
1096    default:
1097     xsh_peep_maybe_recurse(o, seen);
1098     break;
1099   }
1100  }
1101 }
1102
1103 /* --- Module setup/teardown ----------------------------------------------- */
1104
1105 static void xsh_user_global_setup(pTHX) {
1106  a_op_map = ptable_new(32);
1107
1108 #ifdef USE_ITHREADS
1109  MUTEX_INIT(&a_op_map_mutex);
1110 #endif
1111
1112  xsh_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany);
1113  xsh_ck_replace(OP_PADSV,  a_ck_padsv,  &a_old_ck_padsv);
1114
1115  xsh_ck_replace(OP_AELEM,  a_ck_deref,  &a_old_ck_aelem);
1116  xsh_ck_replace(OP_HELEM,  a_ck_deref,  &a_old_ck_helem);
1117  xsh_ck_replace(OP_RV2SV,  a_ck_deref,  &a_old_ck_rv2sv);
1118
1119  xsh_ck_replace(OP_RV2AV,  a_ck_rv2xv,  &a_old_ck_rv2av);
1120  xsh_ck_replace(OP_RV2HV,  a_ck_rv2xv,  &a_old_ck_rv2hv);
1121
1122  xsh_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice);
1123  xsh_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice);
1124
1125  xsh_ck_replace(OP_EXISTS, a_ck_root,   &a_old_ck_exists);
1126  xsh_ck_replace(OP_DELETE, a_ck_root,   &a_old_ck_delete);
1127  xsh_ck_replace(OP_KEYS,   a_ck_root,   &a_old_ck_keys);
1128  xsh_ck_replace(OP_VALUES, a_ck_root,   &a_old_ck_values);
1129
1130  return;
1131 }
1132
1133 static void xsh_user_local_setup(pTHX) {
1134  HV *stash;
1135
1136  stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1);
1137  newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
1138  newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
1139  newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
1140  newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
1141  newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
1142  newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
1143  newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
1144  newCONSTSUB(stash, "A_THREADSAFE",  newSVuv(XSH_THREADSAFE));
1145  newCONSTSUB(stash, "A_FORKSAFE",    newSVuv(XSH_FORKSAFE));
1146
1147  return;
1148 }
1149
1150 static void xsh_user_local_teardown(pTHX) {
1151  return;
1152 }
1153
1154 static void xsh_user_global_teardown(pTHX) {
1155  xsh_ck_restore(OP_PADANY, &a_old_ck_padany);
1156  xsh_ck_restore(OP_PADSV,  &a_old_ck_padsv);
1157
1158  xsh_ck_restore(OP_AELEM,  &a_old_ck_aelem);
1159  xsh_ck_restore(OP_HELEM,  &a_old_ck_helem);
1160  xsh_ck_restore(OP_RV2SV,  &a_old_ck_rv2sv);
1161
1162  xsh_ck_restore(OP_RV2AV,  &a_old_ck_rv2av);
1163  xsh_ck_restore(OP_RV2HV,  &a_old_ck_rv2hv);
1164
1165  xsh_ck_restore(OP_ASLICE, &a_old_ck_aslice);
1166  xsh_ck_restore(OP_HSLICE, &a_old_ck_hslice);
1167
1168  xsh_ck_restore(OP_EXISTS, &a_old_ck_exists);
1169  xsh_ck_restore(OP_DELETE, &a_old_ck_delete);
1170  xsh_ck_restore(OP_KEYS,   &a_old_ck_keys);
1171  xsh_ck_restore(OP_VALUES, &a_old_ck_values);
1172
1173  ptable_map_free(a_op_map);
1174  a_op_map = NULL;
1175
1176 #ifdef USE_ITHREADS
1177  MUTEX_DESTROY(&a_op_map_mutex);
1178 #endif
1179
1180  return;
1181 }
1182
1183 /* --- XS ------------------------------------------------------------------ */
1184
1185 MODULE = autovivification      PACKAGE = autovivification
1186
1187 PROTOTYPES: ENABLE
1188
1189 BOOT:
1190 {
1191  xsh_setup();
1192 }
1193
1194 #if XSH_THREADSAFE
1195
1196 void
1197 CLONE(...)
1198 PROTOTYPE: DISABLE
1199 PPCODE:
1200  xsh_clone();
1201  XSRETURN(0);
1202
1203 #endif /* XSH_THREADSAFE */
1204
1205 SV *
1206 _tag(SV *hint)
1207 PROTOTYPE: $
1208 CODE:
1209  RETVAL = xsh_hints_tag(SvOK(hint) ? SvUV(hint) : 0);
1210 OUTPUT:
1211  RETVAL
1212
1213 SV *
1214 _detag(SV *tag)
1215 PROTOTYPE: $
1216 CODE:
1217  if (!SvOK(tag))
1218   XSRETURN_UNDEF;
1219  RETVAL = newSVuv(xsh_hints_detag(tag));
1220 OUTPUT:
1221  RETVAL