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