ext/arybase/arybase.xs

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