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