ext/arybase/arybase.xs

   1 #define PERL_NO_GET_CONTEXT     /* we want efficiency */
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 /* ... op => info map ................................................. */
   7
   8 typedef struct {
   9  OP *(*old_pp)(pTHX);
  10  IV base;
  11 } ab_op_info;
  12
  13 #define PTABLE_NAME        ptable_map
  14 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
  15 #include "ptable.h"
  16 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
  17
  18 STATIC ptable *ab_op_map = NULL;
  19
  20 #ifdef USE_ITHREADS
  21 STATIC perl_mutex ab_op_map_mutex;
  22 #endif
  23
  24 STATIC const ab_op_info *ab_map_fetch(const OP *o, ab_op_info *oi) {
  25  const ab_op_info *val;
  26
  27 #ifdef USE_ITHREADS
  28  MUTEX_LOCK(&ab_op_map_mutex);
  29 #endif
  30
  31  val = (ab_op_info *)ptable_fetch(ab_op_map, o);
  32  if (val) {
  33   *oi = *val;
  34   val = oi;
  35  }
  36
  37 #ifdef USE_ITHREADS
  38  MUTEX_UNLOCK(&ab_op_map_mutex);
  39 #endif
  40
  41  return val;
  42 }
  43
  44 STATIC const ab_op_info *ab_map_store_locked(
  45  pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base
  46 ) {
  47 #define ab_map_store_locked(O, PP, B) \
  48   ab_map_store_locked(aPTBLMS_ (O), (PP), (B))
  49  ab_op_info *oi;
  50
  51  if (!(oi = (ab_op_info *)ptable_fetch(ab_op_map, o))) {
  52   oi = (ab_op_info *)PerlMemShared_malloc(sizeof *oi);
  53   ptable_map_store(ab_op_map, o, oi);
  54  }
  55
  56  oi->old_pp = old_pp;
  57  oi->base   = base;
  58  return oi;
  59 }
  60
  61 STATIC void ab_map_store(
  62  pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), IV base)
  63 {
  64 #define ab_map_store(O, PP, B) ab_map_store(aPTBLMS_ (O),(PP),(B))
  65
  66 #ifdef USE_ITHREADS
  67  MUTEX_LOCK(&ab_op_map_mutex);
  68 #endif
  69
  70  ab_map_store_locked(o, old_pp, base);
  71
  72 #ifdef USE_ITHREADS
  73  MUTEX_UNLOCK(&ab_op_map_mutex);
  74 #endif
  75 }
  76
  77 STATIC void ab_map_delete(pTHX_ const OP *o) {
  78 #define ab_map_delete(O) ab_map_delete(aTHX_ (O))
  79 #ifdef USE_ITHREADS
  80  MUTEX_LOCK(&ab_op_map_mutex);
  81 #endif
  82
  83  ptable_map_store(ab_op_map, o, NULL);
  84
  85 #ifdef USE_ITHREADS
  86  MUTEX_UNLOCK(&ab_op_map_mutex);
  87 #endif
  88 }
  89
  90 /* ... $[ Implementation .............................................. */
  91
  92 #define hintkey     "$["
  93 #define hintkey_len  (sizeof(hintkey)-1)
  94
  95 STATIC SV * ab_hint(pTHX_ const bool create) {
  96 #define ab_hint(c) ab_hint(aTHX_ c)
  97  dVAR;
  98  SV **val
  99   = hv_fetch(GvHV(PL_hintgv), hintkey, hintkey_len, create);
 100  if (!val)
 101   return 0;
 102  return *val;
 103 }
 104
 105 STATIC IV current_base(pTHX) {
 106 #define current_base() current_base(aTHX)
 107  SV *hsv = ab_hint(0);
 108  if (!hsv || !SvOK(hsv)) return 0;
 109  return SvIV(hsv);
 110 }
 111
 112 STATIC void set_arybase_to(pTHX_ IV base) {
 113 #define set_arybase_to(base) set_arybase_to(aTHX_ (base))
 114  dVAR;
 115  SV *hsv = ab_hint(1);
 116  sv_setiv_mg(hsv, base);
 117 }
 118
 119 #define old_ck(opname) STATIC OP *(*ab_old_ck_##opname)(pTHX_ OP *) = 0
 120 old_ck(sassign);
 121 old_ck(aassign);
 122 old_ck(aelem);
 123 old_ck(aslice);
 124 old_ck(lslice);
 125 old_ck(av2arylen);
 126 old_ck(splice);
 127 old_ck(keys);
 128 old_ck(each);
 129 old_ck(substr);
 130 old_ck(rindex);
 131 old_ck(index);
 132 old_ck(pos);
 133
 134 STATIC bool ab_op_is_dollar_bracket(pTHX_ OP *o) {
 135 #define ab_op_is_dollar_bracket(o) ab_op_is_dollar_bracket(aTHX_ (o))
 136  OP *c;
 137  return o->op_type == OP_RV2SV && (o->op_flags & OPf_KIDS)
 138   && (c = cUNOPx(o)->op_first)
 139   && c->op_type == OP_GV
 140   && GvSTASH(cGVOPx_gv(c)) == PL_defstash
 141   && strEQ(GvNAME(cGVOPx_gv(c)), "[");
 142 }
 143
 144 STATIC void ab_neuter_dollar_bracket(pTHX_ OP *o) {
 145 #define ab_neuter_dollar_bracket(o) ab_neuter_dollar_bracket(aTHX_ (o))
 146  OP *oldc, *newc;
 147  /*
 148   * Must replace the core's $[ with something that can accept assignment
 149   * of non-zero value and can be local()ised.  Simplest thing is a
 150   * different global variable.
 151   */
 152  oldc = cUNOPx(o)->op_first;
 153  newc = newGVOP(OP_GV, 0,
 154    gv_fetchpvs("arybase::leftbrack", GV_ADDMULTI, SVt_PVGV));
 155  cUNOPx(o)->op_first = newc;
 156  op_free(oldc);
 157 }
 158
 159 STATIC void ab_process_assignment(pTHX_ OP *left, OP *right) {
 160 #define ab_process_assignment(l, r) \
 161     ab_process_assignment(aTHX_ (l), (r))
 162  if (ab_op_is_dollar_bracket(left) && right->op_type == OP_CONST) {
 163   set_arybase_to(SvIV(cSVOPx_sv(right)));
 164   ab_neuter_dollar_bracket(left);
 165   Perl_ck_warner_d(aTHX_
 166    packWARN(WARN_DEPRECATED), "Use of assignment to $[ is deprecated"
 167   );
 168  }
 169 }
 170
 171 STATIC OP *ab_ck_sassign(pTHX_ OP *o) {
 172  o = (*ab_old_ck_sassign)(aTHX_ o);
 173  if (o->op_type == OP_SASSIGN) {
 174   OP *right = cBINOPx(o)->op_first;
 175   OP *left = right->op_sibling;
 176   if (left) ab_process_assignment(left, right);
 177  }
 178  return o;
 179 }
 180
 181 STATIC OP *ab_ck_aassign(pTHX_ OP *o) {
 182  o = (*ab_old_ck_aassign)(aTHX_ o);
 183  if (o->op_type == OP_AASSIGN) {
 184   OP *right = cBINOPx(o)->op_first;
 185   OP *left = cBINOPx(right->op_sibling)->op_first->op_sibling;
 186   right = cBINOPx(right)->op_first->op_sibling;
 187   ab_process_assignment(left, right);
 188  }
 189  return o;
 190 }
 191
 192 void
 193 tie(pTHX_ SV * const sv, SV * const obj, HV *const stash)
 194 {
 195     SV *rv = newSV_type(SVt_RV);
 196
 197     SvRV_set(rv, obj ? SvREFCNT_inc_simple_NN(obj) : newSV(0));
 198     SvROK_on(rv);
 199     sv_bless(rv, stash);
 200
 201     sv_unmagic((SV *)sv, PERL_MAGIC_tiedscalar);
 202     sv_magic((SV *)sv, rv, PERL_MAGIC_tiedscalar, NULL, 0);
 203     SvREFCNT_dec(rv); /* As sv_magic increased it by one.  */
 204 }
 205
 206 /* This function converts from base-based to 0-based an index to be passed
 207    as an argument. */
 208 static IV
 209 adjust_index(IV index, IV base)
 210 {
 211  if (index >= base || index > -1) return index-base;
 212  return index;
 213 }
 214 /* This function converts from 0-based to base-based an index to
 215    be returned. */
 216 static IV
 217 adjust_index_r(IV index, IV base)
 218 {
 219  return index + base;
 220 }
 221
 222 #define replace_sv(sv,base) \
 223  ((sv) = sv_2mortal(newSViv(adjust_index(SvIV(sv),base))))
 224 #define replace_sv_r(sv,base) \
 225  ((sv) = sv_2mortal(newSViv(adjust_index_r(SvIV(sv),base))))
 226
 227 static OP *ab_pp_basearg(pTHX) {
 228  dVAR; dSP;
 229  SV **firstp = NULL;
 230  SV **svp;
 231  UV count = 1;
 232  ab_op_info oi;
 233  ab_map_fetch(PL_op, &oi);
 234
 235  switch (PL_op->op_type) {
 236  case OP_AELEM:
 237   firstp = SP;
 238   break;
 239  case OP_ASLICE:
 240   firstp = PL_stack_base + TOPMARK + 1;
 241   count = SP-firstp;
 242   break;
 243  case OP_LSLICE:
 244   firstp = PL_stack_base + *(PL_markstack_ptr-2)+1;
 245   count = TOPMARK - *(PL_markstack_ptr-2);
 246   if (GIMME != G_ARRAY) {
 247    firstp += count-1;
 248    count = 1;
 249   }
 250   break;
 251  case OP_SPLICE:
 252   if (SP - PL_stack_base - TOPMARK >= 2)
 253    firstp = PL_stack_base + TOPMARK + 2;
 254   else count = 0;
 255   break;
 256  case OP_SUBSTR:
 257   firstp = SP-(PL_op->op_private & 7)+2;
 258   break;
 259  default:
 260   DIE(aTHX_
 261      "panic: invalid op type for arybase.xs:ab_pp_basearg: %d",
 262       PL_op->op_type);
 263  }
 264  svp = firstp;
 265  while (count--) replace_sv(*svp,oi.base), svp++;
 266  return (*oi.old_pp)(aTHX);
 267 }
 268
 269 static OP *ab_pp_av2arylen(pTHX) {
 270  dSP; dVAR;
 271  SV *sv;
 272  ab_op_info oi;
 273  OP *ret;
 274  ab_map_fetch(PL_op, &oi);
 275  ret = (*oi.old_pp)(aTHX);
 276  if (PL_op->op_flags & OPf_MOD || LVRET) {
 277   sv = newSV(0);
 278   tie(aTHX_ sv, TOPs, gv_stashpv("arybase::mg",1));
 279   SETs(sv);
 280  }
 281  else {
 282   SvGETMAGIC(TOPs);
 283   if (SvOK(TOPs)) replace_sv_r(TOPs, oi.base);
 284  }
 285  return ret;
 286 }
 287
 288 static OP *ab_pp_keys(pTHX) {
 289  dVAR; dSP;
 290  ab_op_info oi;
 291  OP *retval;
 292  const I32 offset = SP - PL_stack_base;
 293  SV **svp;
 294  ab_map_fetch(PL_op, &oi);
 295  retval = (*oi.old_pp)(aTHX);
 296  if (GIMME_V == G_SCALAR) return retval;
 297  SPAGAIN;
 298  svp = PL_stack_base + offset;
 299  while (svp <= SP) replace_sv_r(*svp,oi.base), ++svp;
 300  return retval;
 301 }
 302
 303 static OP *ab_pp_each(pTHX) {
 304  dVAR; dSP;
 305  ab_op_info oi;
 306  OP *retval;
 307  const I32 offset = SP - PL_stack_base;
 308  ab_map_fetch(PL_op, &oi);
 309  retval = (*oi.old_pp)(aTHX);
 310  SPAGAIN;
 311  if (GIMME_V == G_SCALAR) {
 312   if (SvOK(TOPs)) replace_sv_r(TOPs,oi.base);
 313  }
 314  else if (offset < SP - PL_stack_base) replace_sv_r(TOPm1s,oi.base);
 315  return retval;
 316 }
 317
 318 static OP *ab_pp_index(pTHX) {
 319  dVAR; dSP;
 320  ab_op_info oi;
 321  OP *retval;
 322  ab_map_fetch(PL_op, &oi);
 323  if (MAXARG == 3 && TOPs) replace_sv(TOPs,oi.base);
 324  retval = (*oi.old_pp)(aTHX);
 325  SPAGAIN;
 326  replace_sv_r(TOPs,oi.base);
 327  return retval;
 328 }
 329
 330 static OP *ab_ck_base(pTHX_ OP *o)
 331 {
 332  OP * (*old_ck)(pTHX_ OP *o) = 0;
 333  OP * (*new_pp)(pTHX)        = ab_pp_basearg;
 334  switch (o->op_type) {
 335  case OP_AELEM    : old_ck = ab_old_ck_aelem    ; break;
 336  case OP_ASLICE   : old_ck = ab_old_ck_aslice   ; break;
 337  case OP_LSLICE   : old_ck = ab_old_ck_lslice   ; break;
 338  case OP_AV2ARYLEN: old_ck = ab_old_ck_av2arylen; break;
 339  case OP_SPLICE   : old_ck = ab_old_ck_splice   ; break;
 340  case OP_KEYS     : old_ck = ab_old_ck_keys     ; break;
 341  case OP_EACH     : old_ck = ab_old_ck_each     ; break;
 342  case OP_SUBSTR   : old_ck = ab_old_ck_substr   ; break;
 343  case OP_RINDEX   : old_ck = ab_old_ck_rindex   ; break;
 344  case OP_INDEX    : old_ck = ab_old_ck_index    ; break;
 345  case OP_POS      : old_ck = ab_old_ck_pos      ; break;
 346  default:
 347   DIE(aTHX_
 348      "panic: invalid op type for arybase.xs:ab_ck_base: %d",
 349       PL_op->op_type);
 350  }
 351  o = (*old_ck)(aTHX_ o);
 352  /* We need two switch blocks, as the type may have changed. */
 353  switch (o->op_type) {
 354  case OP_AELEM    :
 355  case OP_ASLICE   :
 356  case OP_LSLICE   :
 357  case OP_SPLICE   :
 358  case OP_SUBSTR   : break;
 359  case OP_POS      :
 360  case OP_AV2ARYLEN: new_pp = ab_pp_av2arylen    ; break;
 361  case OP_AKEYS    : new_pp = ab_pp_keys         ; break;
 362  case OP_AEACH    : new_pp = ab_pp_each         ; break;
 363  case OP_RINDEX   :
 364  case OP_INDEX    : new_pp = ab_pp_index        ; break;
 365  default: return o;
 366  }
 367  {
 368   IV const base = current_base();
 369   if (base) {
 370    ab_map_store(o, o->op_ppaddr, base);
 371    o->op_ppaddr = new_pp;
 372    /* Break the aelemfast optimisation */
 373    if (o->op_type == OP_AELEM &&
 374        cBINOPo->op_first->op_sibling->op_type == OP_CONST) {
 375      cBINOPo->op_first->op_sibling
 376       = newUNOP(OP_NULL,0,cBINOPo->op_first->op_sibling);
 377    }
 378   }
 379   else ab_map_delete(o);
 380  }
 381  return o;
 382 }
 383
 384
 385 STATIC U32 ab_initialized = 0;
 386
 387 /* --- XS ------------------------------------------------------------- */
 388
 389 MODULE = arybase        PACKAGE = arybase
 390 PROTOTYPES: DISABLE
 391
 392 BOOT:
 393 {
 394     GV *const gv = gv_fetchpvn("[", 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PV);
 395     tie(aTHX_ GvSV(gv), NULL, GvSTASH(CvGV(cv)));
 396
 397     if (!ab_initialized++) {
 398         ab_op_map = ptable_new();
 399 #ifdef USE_ITHREADS
 400         MUTEX_INIT(&ab_op_map_mutex);
 401 #endif
 402 #define check(uc,lc,ck) ab_old_ck_##lc = PL_check[OP_##uc]; \
 403                         PL_check[OP_##uc] = ab_ck_##ck
 404         check(SASSIGN,  sassign,  sassign);
 405         check(AASSIGN,  aassign,  aassign);
 406         check(AELEM,    aelem,    base);
 407         check(ASLICE,   aslice,   base);
 408         check(LSLICE,   lslice,   base);
 409         check(AV2ARYLEN,av2arylen,base);
 410         check(SPLICE,   splice,   base);
 411         check(KEYS,     keys,     base);
 412         check(EACH,     each,     base);
 413         check(SUBSTR,   substr,   base);
 414         check(RINDEX,   rindex,   base);
 415         check(INDEX,    index,    base);
 416         check(POS,      pos,      base);
 417     }
 418 }
 419
 420 void
 421 FETCH(...)
 422     PREINIT:
 423         SV *ret = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
 424     PPCODE:
 425         if (!SvOK(ret)) mXPUSHi(0);
 426         else XPUSHs(ret);
 427
 428 void
 429 STORE(SV *sv, IV newbase)
 430     PREINIT:
 431         SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
 432     CODE:
 433         if (SvOK(base) ? SvIV(base) == newbase : !newbase) XSRETURN_EMPTY;
 434         Perl_croak(aTHX_ "That use of $[ is unsupported");
 435
 436
 437 MODULE = arybase        PACKAGE = arybase::mg
 438 PROTOTYPES: DISABLE
 439
 440 void
 441 FETCH(SV *sv)
 442     PPCODE:
 443         if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
 444             Perl_croak(aTHX_ "Not a SCALAR reference");
 445         {
 446             SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
 447             SvGETMAGIC(SvRV(sv));
 448             if (!SvOK(SvRV(sv))) XSRETURN_UNDEF;
 449             mXPUSHi(adjust_index_r(
 450                 SvIV_nomg(SvRV(sv)), SvOK(base)?SvIV(base):0
 451             ));
 452         }
 453
 454 void
 455 STORE(SV *sv, SV *newbase)
 456     CODE:
 457         if (!SvROK(sv) || SvTYPE(SvRV(sv)) >= SVt_PVAV)
 458             Perl_croak(aTHX_ "Not a SCALAR reference");
 459         {
 460             SV *base = cop_hints_fetch_pvs(PL_curcop, "$[", 0);
 461             SvGETMAGIC(newbase);
 462             if (!SvOK(newbase)) SvSetMagicSV(SvRV(sv),&PL_sv_undef);
 463             else
 464                 sv_setiv_mg(
 465                    SvRV(sv),
 466                    adjust_index(SvIV_nomg(newbase),SvOK(base)?SvIV(base):0)
 467                 );
 468         }