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 #define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  15
  16 #ifndef A_WORKAROUND_REQUIRE_PROPAGATION
  17 # define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1)
  18 #endif
  19
  20 /* --- Helpers ------------------------------------------------------------- */
  21
  22 #if A_WORKAROUND_REQUIRE_PROPAGATION
  23
  24 #define A_ENCODE_UV(B, U)   \
  25  len = 0;                   \
  26  while (len < sizeof(UV)) { \
  27   (B)[len++] = (U) & 0xFF;  \
  28   (U) >>= 8;                \
  29  }
  30
  31 #define A_DECODE_UV(U, B)        \
  32  len = sizeof(UV);               \
  33  while (len > 0)                 \
  34   (U) = ((U) << 8) | (B)[--len];
  35
  36 STATIC SV *a_tag(pTHX_ UV bits) {
  37 #define a_tag(B) a_tag(aTHX_ (B))
  38  SV            *hint;
  39  const PERL_SI *si;
  40  UV             requires = 0;
  41  unsigned char  buf[sizeof(UV) * 2];
  42  STRLEN         len;
  43
  44  for (si = PL_curstackinfo; si; si = si->si_prev) {
  45   I32 cxix;
  46
  47   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
  48    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
  49
  50    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
  51     ++requires;
  52   }
  53  }
  54
  55  A_ENCODE_UV(buf,              requires);
  56  A_ENCODE_UV(buf + sizeof(UV), bits);
  57  hint = newSVpvn(buf, sizeof buf);
  58  SvREADONLY_on(hint);
  59
  60  return hint;
  61 }
  62
  63 STATIC UV a_detag(pTHX_ const SV *hint) {
  64 #define a_detag(H) a_detag(aTHX_ (H))
  65  const PERL_SI *si;
  66  UV             requires = 0, requires_max = 0, bits = 0;
  67  unsigned char *buf;
  68  STRLEN         len;
  69
  70  if (!(hint && SvOK(hint)))
  71   return 0;
  72
  73  buf = SvPVX(hint);
  74  A_DECODE_UV(requires_max, buf);
  75
  76  for (si = PL_curstackinfo; si; si = si->si_prev) {
  77   I32 cxix;
  78
  79   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
  80    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
  81
  82    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE
  83                               && ++requires > requires_max)
  84     return 0;
  85   }
  86  }
  87
  88  A_DECODE_UV(bits, buf + sizeof(UV));
  89
  90  return bits;
  91 }
  92
  93 #else /* A_WORKAROUND_REQUIRE_PROPAGATION */
  94
  95 #define a_tag(B)   newSVuv(B)
  96 #define a_detag(H) (((H) && SvOK(H)) ? SvUVX(H) : 0)
  97
  98 #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */
  99
 100 /* Used both for hints and op flags */
 101 #define A_HINT_STRICT 1
 102 #define A_HINT_WARN   2
 103 #define A_HINT_FETCH  4
 104 #define A_HINT_STORE  8
 105 #define A_HINT_EXISTS 16
 106 #define A_HINT_DELETE 32
 107 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN)
 108 #define A_HINT_DO     (A_HINT_FETCH|A_HINT_STORE|A_HINT_EXISTS|A_HINT_DELETE)
 109 #define A_HINT_MASK   (A_HINT_NOTIFY|A_HINT_DO)
 110
 111 /* Only used in op flags */
 112 #define A_HINT_DEREF  64
 113
 114 STATIC U32 a_hash = 0;
 115
 116 STATIC UV a_hint(pTHX) {
 117 #define a_hint() a_hint(aTHX)
 118  SV *hint;
 119 #if A_HAS_PERL(5, 9, 5)
 120  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 121                                        NULL,
 122                                        __PACKAGE__, __PACKAGE_LEN__,
 123                                        0,
 124                                        a_hash);
 125 #else
 126  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, a_hash);
 127  if (!val)
 128   return 0;
 129  hint = *val;
 130 #endif
 131  return a_detag(hint);
 132 }
 133
 134 /* ... op => info map ...................................................... */
 135
 136 typedef struct {
 137  OP *(*old_pp)(pTHX);
 138  const OP *root;
 139  UV flags;
 140 } a_op_info;
 141
 142 #define PTABLE_NAME        ptable_map
 143 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 144
 145 #include "ptable.h"
 146
 147 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 148 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 149
 150 STATIC ptable *a_op_map = NULL;
 151
 152 #ifdef USE_ITHREADS
 153 STATIC perl_mutex a_op_map_mutex;
 154 #endif
 155
 156 STATIC void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), UV flags) {
 157 #define a_map_store(O, PP, F) a_map_store(aPTBLMS_ (O), (PP), (F))
 158  a_op_info *oi;
 159
 160 #ifdef USE_ITHREADS
 161  MUTEX_LOCK(&a_op_map_mutex);
 162 #endif
 163
 164  if (!(oi = ptable_fetch(a_op_map, o))) {
 165   oi = PerlMemShared_malloc(sizeof *oi);
 166   ptable_map_store(a_op_map, o, oi);
 167  }
 168
 169  oi->old_pp = old_pp;
 170  oi->root   = NULL;
 171  oi->flags  = flags;
 172
 173 #ifdef USE_ITHREADS
 174  MUTEX_UNLOCK(&a_op_map_mutex);
 175 #endif
 176 }
 177
 178 STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
 179  const a_op_info *val;
 180
 181 #ifdef USE_ITHREADS
 182  MUTEX_LOCK(&a_op_map_mutex);
 183 #endif
 184
 185  val = ptable_fetch(a_op_map, o);
 186  if (val) {
 187   *oi = *val;
 188   val = oi;
 189  }
 190
 191 #ifdef USE_ITHREADS
 192  MUTEX_UNLOCK(&a_op_map_mutex);
 193 #endif
 194
 195  return val;
 196 }
 197
 198 STATIC void a_map_delete(pTHX_ const OP *o) {
 199 #define a_map_delete(O) a_map_delete(aTHX_ (O))
 200 #ifdef USE_ITHREADS
 201  MUTEX_LOCK(&a_op_map_mutex);
 202 #endif
 203
 204  ptable_map_store(a_op_map, o, NULL);
 205
 206 #ifdef USE_ITHREADS
 207  MUTEX_UNLOCK(&a_op_map_mutex);
 208 #endif
 209 }
 210
 211 STATIC void a_map_set_root(const OP *root, UV flags) {
 212  a_op_info *oi;
 213  const OP *o = root;
 214
 215 #ifdef USE_ITHREADS
 216  MUTEX_LOCK(&a_op_map_mutex);
 217 #endif
 218
 219  while (o) {
 220   if (oi = ptable_fetch(a_op_map, o)) {
 221    oi->root  = root;
 222    oi->flags = flags;
 223   }
 224   if (!(o->op_flags & OPf_KIDS))
 225    break;
 226   switch (PL_opargs[o->op_type] & OA_CLASS_MASK) {
 227    case OA_BASEOP:
 228    case OA_UNOP:
 229    case OA_BINOP:
 230    case OA_BASEOP_OR_UNOP:
 231     o = cUNOPo->op_first;
 232     break;
 233    case OA_LIST:
 234    case OA_LISTOP:
 235     o = cLISTOPo->op_last;
 236     break;
 237    default:
 238     goto done;
 239   }
 240  }
 241
 242 done:
 243 #ifdef USE_ITHREADS
 244  MUTEX_UNLOCK(&a_op_map_mutex);
 245 #endif
 246
 247  return;
 248 }
 249
 250 /* ... Lightweight pp_defined() ............................................ */
 251
 252 STATIC bool a_defined(pTHX_ SV *sv) {
 253 #define a_defined(S) a_defined(aTHX_ (S))
 254  bool defined = FALSE;
 255
 256  switch (SvTYPE(sv)) {
 257   case SVt_PVAV:
 258    if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
 259                       || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 260     defined = TRUE;
 261    break;
 262   case SVt_PVHV:
 263    if (HvARRAY(sv) || SvGMAGICAL(sv)
 264                    || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 265     defined = TRUE;
 266    break;
 267   default:
 268    defined = SvOK(sv);
 269  }
 270
 271  return defined;
 272 }
 273
 274 /* --- PP functions -------------------------------------------------------- */
 275
 276 /* ... pp_rv2av ............................................................ */
 277
 278 STATIC OP *a_pp_rv2av(pTHX) {
 279  a_op_info oi;
 280  UV hint;
 281  dSP;
 282
 283  a_map_fetch(PL_op, &oi);
 284
 285  if (PL_op == oi.root) { /* This means "@$arrayref" */
 286   PL_op->op_ppaddr = oi.old_pp;
 287  } else if (!SvOK(TOPs)) {
 288   /* We always need to push an empty array to fool the pp_aelem() that comes
 289    * later. */
 290   SV *av;
 291   POPs;
 292   av = sv_2mortal((SV *) newAV());
 293   PUSHs(av);
 294   RETURN;
 295  }
 296
 297  return CALL_FPTR(oi.old_pp)(aTHX);
 298 }
 299
 300 /* ... pp_rv2hv ............................................................ */
 301
 302 STATIC OP *a_pp_rv2hv(pTHX) {
 303  a_op_info oi;
 304  UV hint;
 305  dSP;
 306
 307  a_map_fetch(PL_op, &oi);
 308
 309  if (PL_op == oi.root) { /* This means "%$hashref" */
 310   PL_op->op_ppaddr = oi.old_pp;
 311  } else if (!SvOK(TOPs)) {
 312   RETURN;
 313  }
 314
 315  return CALL_FPTR(oi.old_pp)(aTHX);
 316 }
 317
 318 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
 319
 320 STATIC OP *a_pp_deref(pTHX) {
 321  a_op_info oi;
 322  UV flags;
 323  dSP;
 324
 325  a_map_fetch(PL_op, &oi);
 326  flags = oi.flags;
 327
 328  if (flags & A_HINT_DEREF) {
 329   OP *o;
 330   U8 old_private;
 331
 332 deref:
 333   old_private       = PL_op->op_private;
 334   PL_op->op_private = ((old_private & ~OPpDEREF) | OPpLVAL_DEFER);
 335   o = CALL_FPTR(oi.old_pp)(aTHX);
 336   PL_op->op_private = old_private;
 337
 338   if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
 339    SPAGAIN;
 340    if (!SvOK(TOPs)) {
 341     if (flags & A_HINT_STRICT)
 342      croak("Reference vivification forbidden");
 343     else if (flags & A_HINT_WARN)
 344       warn("Reference was vivified");
 345     else /* A_HINT_STORE */
 346      croak("Can't vivify reference");
 347    }
 348   }
 349
 350   return o;
 351  } else if (flags && (PL_op->op_private & OPpDEREF || PL_op == oi.root)) {
 352   oi.flags = flags & A_HINT_NOTIFY;
 353
 354   if (oi.root->op_flags & OPf_MOD) {
 355    if (flags & A_HINT_STORE)
 356     oi.flags |= (A_HINT_STORE|A_HINT_DEREF);
 357   } else if (flags & A_HINT_FETCH)
 358     oi.flags |= (A_HINT_FETCH|A_HINT_DEREF);
 359
 360   if (PL_op == oi.root)
 361    oi.flags &= ~A_HINT_DEREF;
 362
 363   /* We will need the updated flags value in the deref part */
 364   flags = oi.flags;
 365
 366   if (flags & A_HINT_DEREF)
 367    goto deref;
 368
 369   /* This op doesn't need to skip autovivification, so restore the original
 370    * state. Be aware that another extension might have saved a_pp_deref as the
 371    * ppaddr for this op, so restoring PL_op->op_ppaddr doesn't ensure that this
 372    * function will never be called again. That's why we don't remove the op info
 373    * from our map and we reset oi.flags to 0, so that it can still run correctly
 374    * if required. */
 375   oi.flags = 0;
 376   PL_op->op_ppaddr = oi.old_pp;
 377  }
 378
 379  return CALL_FPTR(oi.old_pp)(aTHX);
 380 }
 381
 382 /* ... pp_root (exists,delete,keys,values) ................................. */
 383
 384 STATIC OP *a_pp_root_unop(pTHX) {
 385  a_op_info oi;
 386  dSP;
 387
 388  if (!a_defined(TOPs)) {
 389   POPs;
 390   /* Can only be reached by keys or values */
 391   if (GIMME_V == G_SCALAR) {
 392    dTARGET;
 393    PUSHi(0);
 394   }
 395   RETURN;
 396  }
 397
 398  a_map_fetch(PL_op, &oi);
 399
 400  return CALL_FPTR(oi.old_pp)(aTHX);
 401 }
 402
 403 STATIC OP *a_pp_root_binop(pTHX) {
 404  a_op_info oi;
 405  dSP;
 406
 407  if (!a_defined(TOPm1s)) {
 408   POPs;
 409   POPs;
 410   if (PL_op->op_type == OP_EXISTS)
 411    RETPUSHNO;
 412   else
 413    RETPUSHUNDEF;
 414  }
 415
 416  a_map_fetch(PL_op, &oi);
 417
 418  return CALL_FPTR(oi.old_pp)(aTHX);
 419 }
 420
 421 /* --- Check functions ----------------------------------------------------- */
 422
 423 /* ... ck_pad{any,sv} ...................................................... */
 424
 425 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 426  * function, but are instead manually mutated from a PADANY. This is why we set
 427  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 428  * their op_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 429  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 430  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 431  * globally. */
 432
 433 STATIC OP *(*a_pp_padsv_saved)(pTHX) = 0;
 434
 435 STATIC void a_pp_padsv_save(void) {
 436  if (a_pp_padsv_saved)
 437   return;
 438
 439  a_pp_padsv_saved    = PL_ppaddr[OP_PADSV];
 440  PL_ppaddr[OP_PADSV] = a_pp_deref;
 441 }
 442
 443 STATIC void a_pp_padsv_restore(OP *o) {
 444  if (!a_pp_padsv_saved)
 445   return;
 446
 447  if (o->op_ppaddr == a_pp_deref)
 448   o->op_ppaddr = a_pp_padsv_saved;
 449
 450  PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
 451  a_pp_padsv_saved    = 0;
 452 }
 453
 454 STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
 455
 456 STATIC OP *a_ck_padany(pTHX_ OP *o) {
 457  UV hint;
 458
 459  a_pp_padsv_restore(o);
 460
 461  o = CALL_FPTR(a_old_ck_padany)(aTHX_ o);
 462
 463  hint = a_hint();
 464  if (hint & A_HINT_DO) {
 465   a_pp_padsv_save();
 466   a_map_store(o, a_pp_padsv_saved, hint);
 467  } else
 468   a_map_delete(o);
 469
 470  return o;
 471 }
 472
 473 STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
 474
 475 STATIC OP *a_ck_padsv(pTHX_ OP *o) {
 476  UV hint;
 477
 478  a_pp_padsv_restore(o);
 479
 480  o = CALL_FPTR(a_old_ck_padsv)(aTHX_ o);
 481
 482  hint = a_hint();
 483  if (hint & A_HINT_DO) {
 484   a_map_store(o, o->op_ppaddr, hint);
 485   o->op_ppaddr = a_pp_deref;
 486  } else
 487   a_map_delete(o);
 488
 489  return o;
 490 }
 491
 492 /* ... ck_deref (aelem,helem,rv2sv) ........................................ */
 493
 494 STATIC OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0;
 495 STATIC OP *(*a_old_ck_helem)(pTHX_ OP *) = 0;
 496 STATIC OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0;
 497
 498 STATIC OP *a_ck_deref(pTHX_ OP *o) {
 499  OP * (*old_ck)(pTHX_ OP *o) = 0;
 500  UV hint = a_hint();
 501
 502  switch (o->op_type) {
 503   case OP_AELEM:
 504    old_ck = a_old_ck_aelem;
 505    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) {
 506     OP *kid = cUNOPo->op_first;
 507     a_op_info oi;
 508     if (kid->op_type == OP_RV2AV && kid->op_ppaddr != a_pp_rv2av
 509                                  && kUNOP->op_first->op_type != OP_GV
 510                                  && a_map_fetch(kid, &oi)) {
 511      a_map_store(kid, kid->op_ppaddr, hint);
 512      kid->op_ppaddr = a_pp_rv2av;
 513     }
 514    }
 515    break;
 516   case OP_HELEM:
 517    old_ck = a_old_ck_helem;
 518    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) {
 519     OP *kid = cUNOPo->op_first;
 520     a_op_info oi;
 521     if (kid->op_type == OP_RV2HV && kid->op_ppaddr != a_pp_rv2hv
 522                                  && kUNOP->op_first->op_type != OP_GV
 523                                  && a_map_fetch(kid, &oi)) {
 524      a_map_store(kid, kid->op_ppaddr, hint);
 525      kid->op_ppaddr = a_pp_rv2hv;
 526     }
 527    }
 528    break;
 529   case OP_RV2SV:
 530    old_ck = a_old_ck_rv2sv;
 531    break;
 532  }
 533  o = CALL_FPTR(old_ck)(aTHX_ o);
 534
 535  if (hint & A_HINT_DO) {
 536   a_map_store(o, o->op_ppaddr, hint);
 537   o->op_ppaddr = a_pp_deref;
 538   a_map_set_root(o, hint);
 539  } else
 540   a_map_delete(o);
 541
 542  return o;
 543 }
 544
 545 /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */
 546
 547 STATIC OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0;
 548 STATIC OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0;
 549
 550 STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
 551  OP * (*old_ck)(pTHX_ OP *o) = 0;
 552  OP * (*new_pp)(pTHX)        = 0;
 553  UV hint;
 554
 555  switch (o->op_type) {
 556   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
 557   case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv; break;
 558  }
 559  o = CALL_FPTR(old_ck)(aTHX_ o);
 560
 561  if (cUNOPo->op_first->op_type == OP_GV)
 562   return o;
 563
 564  hint = a_hint();
 565  if (hint & A_HINT_DO) {
 566   if (!(hint & A_HINT_STRICT)) {
 567    a_map_store(o, o->op_ppaddr, hint);
 568    o->op_ppaddr = new_pp;
 569   }
 570   a_map_set_root(o, hint);
 571  } else
 572   a_map_delete(o);
 573
 574  return o;
 575 }
 576
 577 /* ... ck_root (exists,delete,keys,values) ................................. */
 578
 579 STATIC OP *(*a_old_ck_exists)(pTHX_ OP *) = 0;
 580 STATIC OP *(*a_old_ck_delete)(pTHX_ OP *) = 0;
 581 STATIC OP *(*a_old_ck_keys)  (pTHX_ OP *) = 0;
 582 STATIC OP *(*a_old_ck_values)(pTHX_ OP *) = 0;
 583
 584 STATIC OP *a_ck_root(pTHX_ OP *o) {
 585  OP * (*old_ck)(pTHX_ OP *o) = 0;
 586  OP * (*new_pp)(pTHX)        = 0;
 587  bool enabled = FALSE;
 588  UV hint = a_hint();
 589
 590  switch (o->op_type) {
 591   case OP_EXISTS:
 592    old_ck  = a_old_ck_exists;
 593    new_pp  = a_pp_root_binop;
 594    enabled = hint & A_HINT_EXISTS;
 595    break;
 596   case OP_DELETE:
 597    old_ck  = a_old_ck_delete;
 598    new_pp  = a_pp_root_binop;
 599    enabled = hint & A_HINT_DELETE;
 600    break;
 601   case OP_KEYS:
 602    old_ck  = a_old_ck_keys;
 603    new_pp  = a_pp_root_unop;
 604    enabled = hint & A_HINT_FETCH;
 605    break;
 606   case OP_VALUES:
 607    old_ck  = a_old_ck_values;
 608    new_pp  = a_pp_root_unop;
 609    enabled = hint & A_HINT_FETCH;
 610    break;
 611  }
 612  o = CALL_FPTR(old_ck)(aTHX_ o);
 613
 614  if (hint & A_HINT_DO) {
 615   if (enabled) {
 616    a_map_set_root(o, hint | A_HINT_DEREF);
 617    a_map_store(o, o->op_ppaddr, hint);
 618    o->op_ppaddr = new_pp;
 619   } else {
 620    a_map_set_root(o, 0);
 621   }
 622  } else
 623   a_map_delete(o);
 624
 625  return o;
 626 }
 627
 628 STATIC U32 a_initialized = 0;
 629
 630 /* --- XS ------------------------------------------------------------------ */
 631
 632 MODULE = autovivification      PACKAGE = autovivification
 633
 634 PROTOTYPES: ENABLE
 635
 636 BOOT:
 637 {
 638  if (!a_initialized++) {
 639   HV *stash;
 640
 641   a_op_map = ptable_new();
 642 #ifdef USE_ITHREADS
 643   MUTEX_INIT(&a_op_map_mutex);
 644 #endif
 645
 646   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
 647
 648   a_old_ck_padany     = PL_check[OP_PADANY];
 649   PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_ck_padany);
 650   a_old_ck_padsv      = PL_check[OP_PADSV];
 651   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(a_ck_padsv);
 652
 653   a_old_ck_aelem      = PL_check[OP_AELEM];
 654   PL_check[OP_AELEM]  = MEMBER_TO_FPTR(a_ck_deref);
 655   a_old_ck_helem      = PL_check[OP_HELEM];
 656   PL_check[OP_HELEM]  = MEMBER_TO_FPTR(a_ck_deref);
 657   a_old_ck_rv2sv      = PL_check[OP_RV2SV];
 658   PL_check[OP_RV2SV]  = MEMBER_TO_FPTR(a_ck_deref);
 659
 660   a_old_ck_rv2av      = PL_check[OP_RV2AV];
 661   PL_check[OP_RV2AV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
 662   a_old_ck_rv2hv      = PL_check[OP_RV2HV];
 663   PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
 664
 665   a_old_ck_exists     = PL_check[OP_EXISTS];
 666   PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
 667   a_old_ck_delete     = PL_check[OP_DELETE];
 668   PL_check[OP_DELETE] = MEMBER_TO_FPTR(a_ck_root);
 669   a_old_ck_keys       = PL_check[OP_KEYS];
 670   PL_check[OP_KEYS]   = MEMBER_TO_FPTR(a_ck_root);
 671   a_old_ck_values     = PL_check[OP_VALUES];
 672   PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_ck_root);
 673
 674   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 675   newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT));
 676   newCONSTSUB(stash, "A_HINT_WARN",   newSVuv(A_HINT_WARN));
 677   newCONSTSUB(stash, "A_HINT_FETCH",  newSVuv(A_HINT_FETCH));
 678   newCONSTSUB(stash, "A_HINT_STORE",  newSVuv(A_HINT_STORE));
 679   newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS));
 680   newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE));
 681   newCONSTSUB(stash, "A_HINT_MASK",   newSVuv(A_HINT_MASK));
 682  }
 683 }
 684
 685 SV *
 686 _tag(SV *hint)
 687 PROTOTYPE: $
 688 CODE:
 689  RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0);
 690 OUTPUT:
 691  RETVAL
 692
 693 SV *
 694 _detag(SV *tag)
 695 PROTOTYPE: $
 696 CODE:
 697  if (!SvOK(tag))
 698   XSRETURN_UNDEF;
 699  RETVAL = newSVuv(a_detag(tag));
 700 OUTPUT:
 701  RETVAL