Types.xs

   1 /* This file is part of the Lexical-Types Perl module.
   2  * See http://search.cpan.org/dist/Lexical-Types/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "Lexical::Types"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 /* --- Compatibility wrappers ---------------------------------------------- */
  13
  14 #define LT_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  15
  16 #if LT_HAS_PERL(5, 10, 0) || defined(PL_parser)
  17 # ifndef PL_in_my_stash
  18 #  define PL_in_my_stash PL_parser->in_my_stash
  19 # endif
  20 #else
  21 # ifndef PL_in_my_stash
  22 #  define PL_in_my_stash PL_Iin_my_stash
  23 # endif
  24 #endif
  25
  26 #ifndef HvNAME_get
  27 # define HvNAME_get(H) HvNAME(H)
  28 #endif
  29
  30 #ifndef HvNAMELEN_get
  31 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  32 #endif
  33
  34 #ifndef SvIS_FREED
  35 # define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK)
  36 #endif
  37
  38 /* ... Thread safety and multiplicity ...................................... */
  39
  40 #ifndef LT_MULTIPLICITY
  41 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  42 #  define LT_MULTIPLICITY 1
  43 # else
  44 #  define LT_MULTIPLICITY 0
  45 # endif
  46 #endif
  47 #if LT_MULTIPLICITY && !defined(tTHX)
  48 # define tTHX PerlInterpreter*
  49 #endif
  50
  51 #if LT_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))
  52 # define LT_THREADSAFE 1
  53 # ifndef MY_CXT_CLONE
  54 #  define MY_CXT_CLONE \
  55     dMY_CXT_SV;                                                      \
  56     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  57     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  58     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  59 # endif
  60 #else
  61 # define LT_THREADSAFE 0
  62 #endif
  63
  64 /* --- Helpers ------------------------------------------------------------- */
  65
  66 /* ... Thread-safe hints ................................................... */
  67
  68 #if LT_THREADSAFE
  69
  70 #define PTABLE_NAME        ptable_hints
  71 #define PTABLE_VAL_FREE(V) if ((V) && !SvIS_FREED((SV *) (V))) SvREFCNT_dec(V)
  72
  73 #define pPTBL  pTHX
  74 #define pPTBL_ pTHX_
  75 #define aPTBL  aTHX
  76 #define aPTBL_ aTHX_
  77
  78 #include "ptable.h"
  79
  80 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
  81
  82 typedef struct {
  83  ptable *tbl;
  84  tTHX    owner;
  85 } my_cxt_t;
  86
  87 START_MY_CXT
  88
  89 STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) {
  90  my_cxt_t *ud  = ud_;
  91  SV       *val = ent->val;
  92
  93  if (ud->owner != aTHX) {
  94   CLONE_PARAMS param;
  95   AV *stashes = (SvTYPE(val) == SVt_PVHV && HvNAME_get(val)) ? newAV() : NULL;
  96   param.stashes    = stashes;
  97   param.flags      = 0;
  98   param.proto_perl = ud->owner;
  99   val = sv_dup(val, &param);
 100   if (stashes) {
 101    av_undef(stashes);
 102    SvREFCNT_dec(stashes);
 103   }
 104  }
 105
 106  ptable_hints_store(aPTBL_ ud->tbl, ent->key, val);
 107  SvREFCNT_inc(val);
 108 }
 109
 110 STATIC void lt_thread_cleanup(pTHX_ void *);
 111
 112 STATIC void lt_thread_cleanup(pTHX_ void *ud) {
 113  int *level = ud;
 114  SV  *id;
 115
 116  if (*level) {
 117   *level = 0;
 118   LEAVE;
 119   SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
 120   ENTER;
 121  } else {
 122   dMY_CXT;
 123   PerlMemShared_free(level);
 124   ptable_hints_free(aPTBL_ MY_CXT.tbl);
 125  }
 126 }
 127
 128 STATIC SV *lt_tag(pPTBL_ SV *value) {
 129 #define lt_tag(V) lt_tag(aPTBL_ (V))
 130  dMY_CXT;
 131
 132  value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL;
 133  /* We only need for the key to be an unique tag for looking up the value later.
 134   * Allocated memory provides convenient unique identifiers, so that's why we
 135   * use the value pointer as the key itself. */
 136  ptable_hints_store(aPTBL_ MY_CXT.tbl, value, value);
 137  SvREFCNT_inc(value);
 138
 139  return newSVuv(PTR2UV(value));
 140 }
 141
 142 STATIC SV *lt_detag(pTHX_ const SV *hint) {
 143 #define lt_detag(H) lt_detag(aTHX_ (H))
 144  void *tag;
 145  SV   *value;
 146
 147  if (!hint || !SvOK(hint) || !SvIOK(hint))
 148   croak("Wrong hint");
 149
 150  tag = INT2PTR(void *, SvIVX(hint));
 151  {
 152   dMY_CXT;
 153   value = ptable_fetch(MY_CXT.tbl, tag);
 154  }
 155
 156  return value;
 157 }
 158
 159 #else
 160
 161 STATIC SV *lt_tag(pTHX_ SV *value) {
 162 #define lt_tag(V) lt_tag(aTHX_ (V))
 163  UV tag = 0;
 164
 165  if (SvOK(value) && SvROK(value)) {
 166   value = SvRV(value);
 167   SvREFCNT_inc(value);
 168   tag = PTR2UV(value);
 169  }
 170
 171  return newSVuv(tag);
 172 }
 173
 174 #define lt_detag(H) INT2PTR(SV *, SvUVX(H))
 175
 176 #endif /* LT_THREADSAFE */
 177
 178 STATIC U32 lt_hash = 0;
 179
 180 STATIC SV *lt_hint(pTHX) {
 181 #define lt_hint() lt_hint(aTHX)
 182  SV *id;
 183 #if LT_HAS_PERL(5, 10, 0)
 184  id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 185                                      NULL,
 186                                      __PACKAGE__, __PACKAGE_LEN__,
 187                                      0,
 188                                      lt_hash);
 189 #else
 190  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, lt_hash);
 191  if (!val)
 192   return 0;
 193  id = *val;
 194 #endif
 195  return (id && SvOK(id)) ? id : NULL;
 196 }
 197
 198 /* ... op => info map ...................................................... */
 199
 200 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 201
 202 #include "ptable.h"
 203
 204 STATIC ptable *lt_op_map = NULL;
 205
 206 #ifdef USE_ITHREADS
 207 STATIC perl_mutex lt_op_map_mutex;
 208 #endif
 209
 210 typedef struct {
 211  SV *orig_pkg;
 212  SV *type_pkg;
 213  SV *type_meth;
 214  OP *(*pp_padsv)(pTHX);
 215 } lt_op_info;
 216
 217 STATIC void lt_map_store(pPTBL_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) {
 218 #define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aPTBL_ (O), (OP), (TP), (TM), (PP))
 219  lt_op_info *oi;
 220
 221 #ifdef USE_ITHREADS
 222  MUTEX_LOCK(&lt_op_map_mutex);
 223 #endif
 224
 225  if (!(oi = ptable_fetch(lt_op_map, o))) {
 226   oi = PerlMemShared_malloc(sizeof *oi);
 227   ptable_store(aPTBL_ lt_op_map, o, oi);
 228  }
 229
 230  oi->orig_pkg  = orig_pkg;
 231  oi->type_pkg  = type_pkg;
 232  oi->type_meth = type_meth;
 233  oi->pp_padsv  = pp_padsv;
 234
 235 #ifdef USE_ITHREADS
 236  MUTEX_UNLOCK(&lt_op_map_mutex);
 237 #endif
 238 }
 239
 240 STATIC const lt_op_info *lt_map_fetch(const OP *o, lt_op_info *oi) {
 241  const lt_op_info *val;
 242
 243 #ifdef USE_ITHREADS
 244  MUTEX_LOCK(&lt_op_map_mutex);
 245 #endif
 246
 247  val = ptable_fetch(lt_op_map, o);
 248  if (val) {
 249   *oi = *val;
 250   val = oi;
 251  }
 252
 253 #ifdef USE_ITHREADS
 254  MUTEX_UNLOCK(&lt_op_map_mutex);
 255 #endif
 256
 257  return val;
 258 }
 259
 260 /* --- Hooks --------------------------------------------------------------- */
 261
 262 /* ... Our pp_padsv ........................................................ */
 263
 264 STATIC OP *lt_pp_padsv(pTHX) {
 265  lt_op_info oi;
 266
 267  if ((PL_op->op_private & OPpLVAL_INTRO) && lt_map_fetch(PL_op, &oi)) {
 268   PADOFFSET targ = PL_op->op_targ;
 269   SV *sv         = PAD_SVl(targ);
 270
 271   if (sv) {
 272    int items;
 273    dSP;
 274
 275    ENTER;
 276    SAVETMPS;
 277
 278    PUSHMARK(SP);
 279    EXTEND(SP, 3);
 280    PUSHs(oi.type_pkg);
 281    PUSHs(sv);
 282    PUSHs(oi.orig_pkg);
 283    PUTBACK;
 284
 285    items = call_sv(oi.type_meth, G_ARRAY | G_METHOD);
 286
 287    SPAGAIN;
 288    switch (items) {
 289     case 0:
 290      break;
 291     case 1:
 292      sv_setsv(sv, POPs);
 293      break;
 294     default:
 295      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 296    }
 297    PUTBACK;
 298
 299    FREETMPS;
 300    LEAVE;
 301   }
 302
 303   return CALL_FPTR(oi.pp_padsv)(aTHX);
 304  }
 305
 306  return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
 307 }
 308
 309 STATIC OP *(*lt_pp_padsv_saved)(pTHX) = 0;
 310
 311 STATIC void lt_pp_padsv_save(void) {
 312  if (lt_pp_padsv_saved)
 313   return;
 314
 315  lt_pp_padsv_saved   = PL_ppaddr[OP_PADSV];
 316  PL_ppaddr[OP_PADSV] = lt_pp_padsv;
 317 }
 318
 319 STATIC void lt_pp_padsv_restore(OP *o) {
 320  if (!lt_pp_padsv_saved)
 321   return;
 322
 323  if (o->op_ppaddr == lt_pp_padsv)
 324   o->op_ppaddr = lt_pp_padsv_saved;
 325
 326  PL_ppaddr[OP_PADSV] = lt_pp_padsv_saved;
 327  lt_pp_padsv_saved   = 0;
 328 }
 329
 330 /* ... Our ck_pad{any,sv} .................................................. */
 331
 332 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 333  * function, but are instead manually mutated from a PADANY. This is why we set
 334  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 335  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 336  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 337  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 338  * globally. */
 339
 340 STATIC SV *lt_default_meth = NULL;
 341
 342 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 343
 344 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 345  HV *stash;
 346  SV *hint;
 347
 348  lt_pp_padsv_restore(o);
 349
 350  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 351
 352  stash = PL_in_my_stash;
 353  if (stash && (hint = lt_hint())) {
 354   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 355   SV *orig_meth = lt_default_meth;
 356   SV *type_pkg  = NULL;
 357   SV *type_meth = NULL;
 358   SV *code      = lt_detag(hint);
 359
 360   SvREADONLY_on(orig_pkg);
 361
 362   if (code) {
 363    int items;
 364    dSP;
 365
 366    ENTER;
 367    SAVETMPS;
 368
 369    PUSHMARK(SP);
 370    EXTEND(SP, 2);
 371    PUSHs(orig_pkg);
 372    PUSHs(orig_meth);
 373    PUTBACK;
 374
 375    items = call_sv(code, G_ARRAY);
 376
 377    SPAGAIN;
 378    if (items > 2)
 379     croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 380    if (items == 0) {
 381     SvREFCNT_dec(orig_pkg);
 382     goto skip;
 383    } else {
 384     SV *rsv;
 385     if (items > 1) {
 386      rsv = POPs;
 387      if (SvOK(rsv)) {
 388       type_meth = newSVsv(rsv);
 389       SvREADONLY_on(type_meth);
 390      }
 391     }
 392     rsv = POPs;
 393     if (SvOK(rsv)) {
 394      type_pkg = newSVsv(rsv);
 395      SvREADONLY_on(type_pkg);
 396     }
 397    }
 398    PUTBACK;
 399
 400    FREETMPS;
 401    LEAVE;
 402   }
 403
 404   if (!type_pkg) {
 405    type_pkg = orig_pkg;
 406    SvREFCNT_inc(orig_pkg);
 407   }
 408
 409   if (!type_meth) {
 410    type_meth = orig_meth;
 411    SvREFCNT_inc(orig_meth);
 412   }
 413
 414   lt_pp_padsv_save();
 415
 416   lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_pp_padsv_saved);
 417  }
 418
 419 skip:
 420  return o;
 421 }
 422
 423 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 424
 425 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 426  lt_pp_padsv_restore(o);
 427
 428  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 429 }
 430
 431 STATIC U32 lt_initialized = 0;
 432
 433 /* --- XS ------------------------------------------------------------------ */
 434
 435 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 436
 437 PROTOTYPES: ENABLE
 438
 439 BOOT:
 440 {
 441  if (!lt_initialized++) {
 442   HV *stash;
 443 #if LT_THREADSAFE
 444   MY_CXT_INIT;
 445   MY_CXT.tbl   = ptable_new();
 446   MY_CXT.owner = aTHX;
 447 #endif
 448
 449   lt_op_map = ptable_new();
 450 #ifdef USE_ITHREADS
 451   MUTEX_INIT(&lt_op_map_mutex);
 452 #endif
 453
 454   lt_default_meth = newSVpvn("TYPEDSCALAR", 11);
 455   SvREADONLY_on(lt_default_meth);
 456
 457   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 458
 459   lt_old_ck_padany    = PL_check[OP_PADANY];
 460   PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 461   lt_old_ck_padsv     = PL_check[OP_PADSV];
 462   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 463
 464   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 465   newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
 466  }
 467 }
 468
 469 #if LT_THREADSAFE
 470
 471 void
 472 CLONE(...)
 473 PROTOTYPE: DISABLE
 474 PREINIT:
 475  ptable *t;
 476  int    *level;
 477 CODE:
 478  {
 479   my_cxt_t ud;
 480   dMY_CXT;
 481   ud.tbl   = t = ptable_new();
 482   ud.owner = MY_CXT.owner;
 483   ptable_walk(MY_CXT.tbl, lt_ptable_hints_clone, &ud);
 484  }
 485  {
 486   MY_CXT_CLONE;
 487   MY_CXT.tbl   = t;
 488   MY_CXT.owner = aTHX;
 489  }
 490  {
 491   level = PerlMemShared_malloc(sizeof *level);
 492   *level = 1;
 493   LEAVE;
 494   SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
 495   ENTER;
 496  }
 497
 498 #endif
 499
 500 SV *
 501 _tag(SV *value)
 502 PROTOTYPE: $
 503 CODE:
 504  RETVAL = lt_tag(value);
 505 OUTPUT:
 506  RETVAL