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 LT_WORKAROUND_REQUIRE_PROPAGATION
  27 # define LT_WORKAROUND_REQUIRE_PROPAGATION !LT_HAS_PERL(5, 10, 1)
  28 #endif
  29
  30 #ifndef HvNAME_get
  31 # define HvNAME_get(H) HvNAME(H)
  32 #endif
  33
  34 #ifndef HvNAMELEN_get
  35 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  36 #endif
  37
  38 #ifndef SvREFCNT_inc_simple_NN
  39 # define SvREFCNT_inc_simple_NN SvREFCNT_inc
  40 #endif
  41
  42 /* ... Thread safety and multiplicity ...................................... */
  43
  44 #ifndef LT_MULTIPLICITY
  45 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  46 #  define LT_MULTIPLICITY 1
  47 # else
  48 #  define LT_MULTIPLICITY 0
  49 # endif
  50 #endif
  51 #if LT_MULTIPLICITY && !defined(tTHX)
  52 # define tTHX PerlInterpreter*
  53 #endif
  54
  55 #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))
  56 # define LT_THREADSAFE 1
  57 # ifndef MY_CXT_CLONE
  58 #  define MY_CXT_CLONE \
  59     dMY_CXT_SV;                                                      \
  60     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  61     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  62     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  63 # endif
  64 #else
  65 # define LT_THREADSAFE 0
  66 # undef  dMY_CXT
  67 # define dMY_CXT      dNOOP
  68 # undef  MY_CXT
  69 # define MY_CXT       lt_globaldata
  70 # undef  START_MY_CXT
  71 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
  72 # undef  MY_CXT_INIT
  73 # define MY_CXT_INIT  NOOP
  74 # undef  MY_CXT_CLONE
  75 # define MY_CXT_CLONE NOOP
  76 # undef  pMY_CXT
  77 # define pMY_CXT
  78 # undef  pMY_CXT_
  79 # define pMY_CXT_
  80 # undef  aMY_CXT
  81 # define aMY_CXT
  82 # undef  aMY_CXT_
  83 # define aMY_CXT_
  84 #endif
  85
  86 /* --- Helpers ------------------------------------------------------------- */
  87
  88 /* ... Thread-safe hints ................................................... */
  89
  90 #if LT_WORKAROUND_REQUIRE_PROPAGATION
  91
  92 typedef struct {
  93  SV *code;
  94  IV  require_tag;
  95 } lt_hint_t;
  96
  97 #define LT_HINT_STRUCT 1
  98
  99 #define LT_HINT_CODE(H) ((H)->code)
 100
 101 #define LT_HINT_FREE(H) { \
 102  lt_hint_t *h = (H);      \
 103  SvREFCNT_dec(h->code);   \
 104  PerlMemShared_free(h);   \
 105 }
 106
 107 #else  /*  LT_WORKAROUND_REQUIRE_PROPAGATION */
 108
 109 typedef SV lt_hint_t;
 110
 111 #define LT_HINT_STRUCT 0
 112
 113 #define LT_HINT_CODE(H) (H)
 114
 115 #define LT_HINT_FREE(H) SvREFCNT_dec(H);
 116
 117 #endif /* !LT_WORKAROUND_REQUIRE_PROPAGATION */
 118
 119 #if LT_THREADSAFE
 120
 121 #define PTABLE_NAME        ptable_hints
 122 #define PTABLE_VAL_FREE(V) LT_HINT_FREE(V)
 123
 124 #define pPTBL  pTHX
 125 #define pPTBL_ pTHX_
 126 #define aPTBL  aTHX
 127 #define aPTBL_ aTHX_
 128
 129 #include "ptable.h"
 130
 131 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
 132 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
 133
 134 #endif /* LT_THREADSAFE */
 135
 136 /* ... Global data ......................................................... */
 137
 138 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 139
 140 typedef struct {
 141 #if LT_THREADSAFE
 142  ptable *tbl; /* It really is a ptable_hints */
 143  tTHX    owner;
 144 #endif
 145  SV     *default_meth;
 146  OP *  (*pp_padsv_saved)(pTHX);
 147 } my_cxt_t;
 148
 149 START_MY_CXT
 150
 151 /* ... Cloning global data ................................................. */
 152
 153 #if LT_THREADSAFE
 154
 155 STATIC SV *lt_clone(pTHX_ SV *sv, tTHX owner) {
 156 #define lt_clone(S, O) lt_clone(aTHX_ (S), (O))
 157  CLONE_PARAMS  param;
 158  AV           *stashes = NULL;
 159  SV           *dupsv;
 160
 161  if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
 162   stashes = newAV();
 163
 164  param.stashes    = stashes;
 165  param.flags      = 0;
 166  param.proto_perl = owner;
 167
 168  dupsv = sv_dup(sv, &param);
 169
 170  if (stashes) {
 171   av_undef(stashes);
 172   SvREFCNT_dec(stashes);
 173  }
 174
 175  return SvREFCNT_inc(dupsv);
 176 }
 177
 178 STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) {
 179  my_cxt_t  *ud  = ud_;
 180  lt_hint_t *h1 = ent->val;
 181  lt_hint_t *h2;
 182
 183  if (ud->owner == aTHX)
 184   return;
 185
 186 #if LT_HINT_STRUCT
 187
 188  h2       = PerlMemShared_malloc(sizeof *h2);
 189  h2->code = lt_clone(h1->code, ud->owner);
 190  SvREFCNT_inc(h2->code);
 191 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 192  h2->require_tag = PTR2IV(lt_clone(INT2PTR(SV *, h1->require_tag), ud->owner));
 193 #endif
 194
 195 #else /*   LT_HINT_STRUCT */
 196
 197  h2 = lt_clone(h1, ud->owner);
 198  SvREFCNT_inc(h2);
 199
 200 #endif /* !LT_HINT_STRUCT */
 201
 202  ptable_hints_store(ud->tbl, ent->key, h2);
 203 }
 204
 205 #include "reap.h"
 206
 207 STATIC void lt_thread_cleanup(pTHX_ void *ud) {
 208  dMY_CXT;
 209
 210  ptable_hints_free(MY_CXT.tbl);
 211 }
 212
 213 #endif /* LT_THREADSAFE */
 214
 215 /* ... Hint tags ........................................................... */
 216
 217 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 218 STATIC IV lt_require_tag(pTHX) {
 219 #define lt_require_tag() lt_require_tag(aTHX)
 220  const CV *cv, *outside;
 221
 222  cv = PL_compcv;
 223
 224  if (!cv) {
 225   /* If for some reason the pragma is operational at run-time, try to discover
 226    * the current cv in use. */
 227   const PERL_SI *si;
 228
 229   for (si = PL_curstackinfo; si; si = si->si_prev) {
 230    I32 cxix;
 231
 232    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 233     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 234
 235     switch (CxTYPE(cx)) {
 236      case CXt_SUB:
 237      case CXt_FORMAT:
 238       /* The propagation workaround is only needed up to 5.10.0 and at that
 239        * time format and sub contexts were still identical. And even later the
 240        * cv members offsets should have been kept the same. */
 241       cv = cx->blk_sub.cv;
 242       goto get_enclosing_cv;
 243      case CXt_EVAL:
 244       cv = cx->blk_eval.cv;
 245       goto get_enclosing_cv;
 246      default:
 247       break;
 248     }
 249    }
 250   }
 251
 252   cv = PL_main_cv;
 253  }
 254
 255 get_enclosing_cv:
 256  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
 257   cv = outside;
 258
 259  return PTR2IV(cv);
 260 }
 261 #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 262
 263 STATIC SV *lt_tag(pTHX_ SV *value) {
 264 #define lt_tag(V) lt_tag(aTHX_ (V))
 265  lt_hint_t *h;
 266  SV *code = NULL;
 267  dMY_CXT;
 268
 269  if (SvROK(value)) {
 270   value = SvRV(value);
 271   if (SvTYPE(value) >= SVt_PVCV) {
 272    code = value;
 273    SvREFCNT_inc_simple_NN(code);
 274   }
 275  }
 276
 277 #if LT_HINT_STRUCT
 278  h = PerlMemShared_malloc(sizeof *h);
 279  h->code        = code;
 280 # if LT_WORKAROUND_REQUIRE_PROPAGATION
 281  h->require_tag = lt_require_tag();
 282 # endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 283 #else  /*  LT_HINT_STRUCT */
 284  h = code;
 285 #endif /* !LT_HINT_STRUCT */
 286
 287 #if LT_THREADSAFE
 288  /* We only need for the key to be an unique tag for looking up the value later.
 289   * Allocated memory provides convenient unique identifiers, so that's why we
 290   * use the hint as the key itself. */
 291  ptable_hints_store(MY_CXT.tbl, h, h);
 292 #endif /* LT_THREADSAFE */
 293
 294  return newSViv(PTR2IV(h));
 295 }
 296
 297 STATIC SV *lt_detag(pTHX_ const SV *hint) {
 298 #define lt_detag(H) lt_detag(aTHX_ (H))
 299  lt_hint_t *h;
 300  dMY_CXT;
 301
 302  if (!(hint && SvIOK(hint)))
 303   return NULL;
 304
 305  h = INT2PTR(lt_hint_t *, SvIVX(hint));
 306 #if LT_THREADSAFE
 307  h = ptable_fetch(MY_CXT.tbl, h);
 308 #endif /* LT_THREADSAFE */
 309 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 310  if (lt_require_tag() != h->require_tag)
 311   return NULL;
 312 #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 313
 314  return LT_HINT_CODE(h);
 315 }
 316
 317 STATIC U32 lt_hash = 0;
 318
 319 STATIC SV *lt_hint(pTHX) {
 320 #define lt_hint() lt_hint(aTHX)
 321  SV *hint;
 322 #if LT_HAS_PERL(5, 9, 5)
 323  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 324                                        NULL,
 325                                        __PACKAGE__, __PACKAGE_LEN__,
 326                                        0,
 327                                        lt_hash);
 328 #else
 329  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, lt_hash);
 330  if (!val)
 331   return 0;
 332  hint = *val;
 333 #endif
 334  return lt_detag(hint);
 335 }
 336
 337 /* ... op => info map ...................................................... */
 338
 339 #define PTABLE_NAME        ptable_map
 340 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 341
 342 #include "ptable.h"
 343
 344 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 345 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 346
 347 STATIC ptable *lt_op_map = NULL;
 348
 349 #ifdef USE_ITHREADS
 350 STATIC perl_mutex lt_op_map_mutex;
 351 #endif
 352
 353 typedef struct {
 354 #ifdef MULTIPLICITY
 355  STRLEN buf_size, orig_pkg_len, type_pkg_len, type_meth_len;
 356  char *buf;
 357 #else /* MULTIPLICITY */
 358  SV *orig_pkg;
 359  SV *type_pkg;
 360  SV *type_meth;
 361 #endif /* !MULTIPLICITY */
 362  OP *(*old_pp_padsv)(pTHX);
 363 } lt_op_info;
 364
 365 STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*old_pp_padsv)(pTHX)) {
 366 #define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
 367  lt_op_info *oi;
 368
 369 #ifdef USE_ITHREADS
 370  MUTEX_LOCK(&lt_op_map_mutex);
 371 #endif
 372
 373  if (!(oi = ptable_fetch(lt_op_map, o))) {
 374   oi = PerlMemShared_malloc(sizeof *oi);
 375   ptable_map_store(lt_op_map, o, oi);
 376 #ifdef MULTIPLICITY
 377   oi->buf      = NULL;
 378   oi->buf_size = 0;
 379 #else /* MULTIPLICITY */
 380  } else {
 381   SvREFCNT_dec(oi->orig_pkg);
 382   SvREFCNT_dec(oi->type_pkg);
 383   SvREFCNT_dec(oi->type_meth);
 384 #endif /* !MULTIPLICITY */
 385  }
 386
 387 #ifdef MULTIPLICITY
 388  {
 389   STRLEN op_len       = SvCUR(orig_pkg);
 390   STRLEN tp_len       = SvCUR(type_pkg);
 391   STRLEN tm_len       = SvCUR(type_meth);
 392   STRLEN new_buf_size = op_len + tp_len + tm_len;
 393   char *buf;
 394   if (new_buf_size > oi->buf_size) {
 395    PerlMemShared_free(oi->buf);
 396    oi->buf      = PerlMemShared_malloc(new_buf_size);
 397    oi->buf_size = new_buf_size;
 398   }
 399   buf  = oi->buf;
 400   Copy(SvPVX(orig_pkg),  buf, op_len, char);
 401   buf += op_len;
 402   Copy(SvPVX(type_pkg),  buf, tp_len, char);
 403   buf += tp_len;
 404   Copy(SvPVX(type_meth), buf, tm_len, char);
 405   oi->orig_pkg_len  = op_len;
 406   oi->type_pkg_len  = tp_len;
 407   oi->type_meth_len = tm_len;
 408   SvREFCNT_dec(orig_pkg);
 409   SvREFCNT_dec(type_pkg);
 410   SvREFCNT_dec(type_meth);
 411  }
 412 #else /* MULTIPLICITY */
 413  oi->orig_pkg  = orig_pkg;
 414  oi->type_pkg  = type_pkg;
 415  oi->type_meth = type_meth;
 416 #endif /* !MULTIPLICITY */
 417
 418  oi->old_pp_padsv = old_pp_padsv;
 419
 420 #ifdef USE_ITHREADS
 421  MUTEX_UNLOCK(&lt_op_map_mutex);
 422 #endif
 423 }
 424
 425 STATIC const lt_op_info *lt_map_fetch(const OP *o, lt_op_info *oi) {
 426  const lt_op_info *val;
 427
 428 #ifdef USE_ITHREADS
 429  MUTEX_LOCK(&lt_op_map_mutex);
 430 #endif
 431
 432  val = ptable_fetch(lt_op_map, o);
 433  if (val) {
 434   *oi = *val;
 435   val = oi;
 436  }
 437
 438 #ifdef USE_ITHREADS
 439  MUTEX_UNLOCK(&lt_op_map_mutex);
 440 #endif
 441
 442  return val;
 443 }
 444
 445 STATIC void lt_map_delete(pTHX_ const OP *o) {
 446 #define lt_map_delete(O) lt_map_delete(aTHX_ (O))
 447 #ifdef USE_ITHREADS
 448  MUTEX_LOCK(&lt_op_map_mutex);
 449 #endif
 450
 451  ptable_map_store(lt_op_map, o, NULL);
 452
 453 #ifdef USE_ITHREADS
 454  MUTEX_UNLOCK(&lt_op_map_mutex);
 455 #endif
 456 }
 457
 458 /* --- Hooks --------------------------------------------------------------- */
 459
 460 /* ... Our pp_padsv ........................................................ */
 461
 462 STATIC OP *lt_pp_padsv(pTHX) {
 463  lt_op_info oi;
 464
 465  if ((PL_op->op_private & OPpLVAL_INTRO) && lt_map_fetch(PL_op, &oi)) {
 466   PADOFFSET targ = PL_op->op_targ;
 467   SV *sv         = PAD_SVl(targ);
 468
 469   if (sv) {
 470    SV *orig_pkg, *type_pkg, *type_meth;
 471    int items;
 472    dSP;
 473
 474    ENTER;
 475    SAVETMPS;
 476
 477 #ifdef MULTIPLICITY
 478    {
 479     STRLEN op_len = oi.orig_pkg_len, tp_len = oi.type_pkg_len;
 480     char *buf = oi.buf;
 481     orig_pkg  = sv_2mortal(newSVpvn(buf, op_len));
 482     SvREADONLY_on(orig_pkg);
 483     buf      += op_len;
 484     type_pkg  = sv_2mortal(newSVpvn(buf, tp_len));
 485     SvREADONLY_on(type_pkg);
 486     buf      += tp_len;
 487     type_meth = sv_2mortal(newSVpvn(buf, oi.type_meth_len));
 488     SvREADONLY_on(type_meth);
 489    }
 490 #else /* MULTIPLICITY */
 491    orig_pkg  = oi.orig_pkg;
 492    type_pkg  = oi.type_pkg;
 493    type_meth = oi.type_meth;
 494 #endif /* !MULTIPLICITY */
 495
 496    PUSHMARK(SP);
 497    EXTEND(SP, 3);
 498    PUSHs(type_pkg);
 499    PUSHs(sv);
 500    PUSHs(orig_pkg);
 501    PUTBACK;
 502
 503    items = call_sv(type_meth, G_ARRAY | G_METHOD);
 504
 505    SPAGAIN;
 506    switch (items) {
 507     case 0:
 508      break;
 509     case 1:
 510      sv_setsv(sv, POPs);
 511      break;
 512     default:
 513      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 514    }
 515    PUTBACK;
 516
 517    FREETMPS;
 518    LEAVE;
 519   }
 520
 521   return CALL_FPTR(oi.old_pp_padsv)(aTHX);
 522  }
 523
 524  return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
 525 }
 526
 527 STATIC void lt_pp_padsv_save(pMY_CXT) {
 528 #define lt_pp_padsv_save() lt_pp_padsv_save(aMY_CXT)
 529  if (MY_CXT.pp_padsv_saved)
 530   return;
 531
 532  MY_CXT.pp_padsv_saved = PL_ppaddr[OP_PADSV];
 533  PL_ppaddr[OP_PADSV]   = lt_pp_padsv;
 534 }
 535
 536 STATIC void lt_pp_padsv_restore(pMY_CXT_ OP *o) {
 537 #define lt_pp_padsv_restore(O) lt_pp_padsv_restore(aMY_CXT_ (O))
 538  OP *(*saved)(pTHX) = MY_CXT.pp_padsv_saved;
 539
 540  if (!saved)
 541   return;
 542
 543  if (o->op_ppaddr == lt_pp_padsv)
 544   o->op_ppaddr = saved;
 545
 546  PL_ppaddr[OP_PADSV]   = saved;
 547  MY_CXT.pp_padsv_saved = 0;
 548 }
 549
 550 /* ... Our ck_pad{any,sv} .................................................. */
 551
 552 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 553  * function, but are instead manually mutated from a PADANY. This is why we set
 554  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 555  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 556  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 557  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 558  * globally. */
 559
 560 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 561
 562 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 563  HV *stash;
 564  SV *code;
 565  dMY_CXT;
 566
 567  lt_pp_padsv_restore(o);
 568
 569  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 570
 571  stash = PL_in_my_stash;
 572  if (stash && (code = lt_hint())) {
 573   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 574   SV *orig_meth = MY_CXT.default_meth;
 575   SV *type_pkg  = NULL;
 576   SV *type_meth = NULL;
 577   int items;
 578
 579   dSP;
 580
 581   SvREADONLY_on(orig_pkg);
 582
 583   ENTER;
 584   SAVETMPS;
 585
 586   PUSHMARK(SP);
 587   EXTEND(SP, 2);
 588   PUSHs(orig_pkg);
 589   PUSHs(orig_meth);
 590   PUTBACK;
 591
 592   items = call_sv(code, G_ARRAY);
 593
 594   SPAGAIN;
 595   if (items > 2)
 596    croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 597   if (items == 0) {
 598    SvREFCNT_dec(orig_pkg);
 599    FREETMPS;
 600    LEAVE;
 601    goto skip;
 602   } else {
 603    SV *rsv;
 604    if (items > 1) {
 605     rsv = POPs;
 606     if (SvOK(rsv)) {
 607      type_meth = newSVsv(rsv);
 608      SvREADONLY_on(type_meth);
 609     }
 610    }
 611    rsv = POPs;
 612    if (SvOK(rsv)) {
 613     type_pkg = newSVsv(rsv);
 614     SvREADONLY_on(type_pkg);
 615    }
 616   }
 617   PUTBACK;
 618
 619   FREETMPS;
 620   LEAVE;
 621
 622   if (!type_pkg) {
 623    type_pkg = orig_pkg;
 624    SvREFCNT_inc(orig_pkg);
 625   }
 626
 627   if (!type_meth) {
 628    type_meth = orig_meth;
 629    SvREFCNT_inc(orig_meth);
 630   }
 631
 632   lt_pp_padsv_save();
 633
 634   lt_map_store(o, orig_pkg, type_pkg, type_meth, MY_CXT.pp_padsv_saved);
 635  } else {
 636 skip:
 637   lt_map_delete(o);
 638  }
 639
 640  return o;
 641 }
 642
 643 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 644
 645 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 646  dMY_CXT;
 647
 648  lt_pp_padsv_restore(o);
 649
 650  lt_map_delete(o);
 651
 652  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 653 }
 654
 655 STATIC U32 lt_initialized = 0;
 656
 657 STATIC void lt_teardown(pTHX_ void *root) {
 658  dMY_CXT;
 659
 660  if (!lt_initialized)
 661   return;
 662
 663 #if LT_MULTIPLICITY
 664  if (aTHX != root)
 665   return;
 666 #endif
 667
 668 #if LT_THREADSAFE
 669  ptable_hints_free(MY_CXT.tbl);
 670 #endif
 671  SvREFCNT_dec(MY_CXT.default_meth);
 672
 673  PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_old_ck_padany);
 674  lt_old_ck_padany    = 0;
 675  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_old_ck_padsv);
 676  lt_old_ck_padsv     = 0;
 677
 678  lt_initialized = 0;
 679 }
 680
 681 STATIC void lt_setup(pTHX) {
 682 #define lt_setup() lt_setup(aTHX)
 683  if (lt_initialized)
 684   return;
 685
 686  {
 687   MY_CXT_INIT;
 688 #if LT_THREADSAFE
 689   MY_CXT.tbl            = ptable_new();
 690   MY_CXT.owner          = aTHX;
 691 #endif
 692   MY_CXT.pp_padsv_saved = 0;
 693   MY_CXT.default_meth   = newSVpvn("TYPEDSCALAR", 11);
 694   SvREADONLY_on(MY_CXT.default_meth);
 695  }
 696
 697  lt_old_ck_padany    = PL_check[OP_PADANY];
 698  PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 699  lt_old_ck_padsv     = PL_check[OP_PADSV];
 700  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 701
 702 #if LT_MULTIPLICITY
 703  call_atexit(lt_teardown, aTHX);
 704 #else
 705  call_atexit(lt_teardown, NULL);
 706 #endif
 707
 708  lt_initialized = 1;
 709 }
 710
 711 STATIC U32 lt_booted = 0;
 712
 713 /* --- XS ------------------------------------------------------------------ */
 714
 715 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 716
 717 PROTOTYPES: ENABLE
 718
 719 BOOT:
 720 {
 721  if (!lt_booted++) {
 722   HV *stash;
 723
 724   lt_op_map = ptable_new();
 725 #ifdef USE_ITHREADS
 726   MUTEX_INIT(&lt_op_map_mutex);
 727 #endif
 728
 729   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 730
 731   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 732   newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
 733  }
 734
 735  lt_setup();
 736 }
 737
 738 #if LT_THREADSAFE
 739
 740 void
 741 CLONE(...)
 742 PROTOTYPE: DISABLE
 743 PREINIT:
 744  ptable *t;
 745  SV     *cloned_default_meth;
 746 PPCODE:
 747  {
 748   my_cxt_t ud;
 749   dMY_CXT;
 750   ud.tbl   = t = ptable_new();
 751   ud.owner = MY_CXT.owner;
 752   ptable_walk(MY_CXT.tbl, lt_ptable_hints_clone, &ud);
 753   cloned_default_meth = lt_clone(MY_CXT.default_meth, MY_CXT.owner);
 754  }
 755  {
 756   MY_CXT_CLONE;
 757   MY_CXT.tbl            = t;
 758   MY_CXT.owner          = aTHX;
 759   MY_CXT.pp_padsv_saved = 0;
 760   MY_CXT.default_meth   = cloned_default_meth;
 761  }
 762  reap(3, lt_thread_cleanup, NULL);
 763  XSRETURN(0);
 764
 765 #endif
 766
 767 SV *
 768 _tag(SV *value)
 769 PROTOTYPE: $
 770 CODE:
 771  RETVAL = lt_tag(value);
 772 OUTPUT:
 773  RETVAL