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 #  define PL_tokenbuf    PL_parser->tokenbuf
  20 # endif
  21 #else
  22 # ifndef PL_in_my_stash
  23 #  define PL_in_my_stash PL_Iin_my_stash
  24 #  define PL_tokenbuf    PL_Itokenbuf
  25 # endif
  26 #endif
  27
  28 #ifndef LT_WORKAROUND_REQUIRE_PROPAGATION
  29 # define LT_WORKAROUND_REQUIRE_PROPAGATION !LT_HAS_PERL(5, 10, 1)
  30 #endif
  31
  32 #ifndef LT_HAS_RPEEP
  33 # define LT_HAS_RPEEP LT_HAS_PERL(5, 13, 5)
  34 #endif
  35
  36 #ifndef STR_WITH_LEN
  37 # define STR_WITH_LEN(s)  ("" s ""), (sizeof(s)-1)
  38 #endif
  39
  40 #ifndef newSVpvs
  41 # define newSVpvs(S) Perl_newSVpvn(aTHX_ STR_WITH_LEN(S))
  42 #endif
  43
  44 #ifndef HvNAME_get
  45 # define HvNAME_get(H) HvNAME(H)
  46 #endif
  47
  48 #ifndef HvNAMELEN_get
  49 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  50 #endif
  51
  52 #ifndef SvREFCNT_inc_simple_void_NN
  53 # define SvREFCNT_inc_simple_void_NN(S) ((void) SvREFCNT_inc(S))
  54 #endif
  55
  56 /* ... Thread safety and multiplicity ...................................... */
  57
  58 /* Safe unless stated otherwise in Makefile.PL */
  59 #ifndef LT_FORKSAFE
  60 # define LT_FORKSAFE 1
  61 #endif
  62
  63 #ifndef LT_MULTIPLICITY
  64 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  65 #  define LT_MULTIPLICITY 1
  66 # else
  67 #  define LT_MULTIPLICITY 0
  68 # endif
  69 #endif
  70
  71 #ifndef tTHX
  72 # define tTHX PerlInterpreter*
  73 #endif
  74
  75 #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))
  76 # define LT_THREADSAFE 1
  77 # ifndef MY_CXT_CLONE
  78 #  define MY_CXT_CLONE \
  79     dMY_CXT_SV;                                                      \
  80     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  81     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  82     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  83 # endif
  84 #else
  85 # define LT_THREADSAFE 0
  86 # undef  dMY_CXT
  87 # define dMY_CXT      dNOOP
  88 # undef  MY_CXT
  89 # define MY_CXT       lt_globaldata
  90 # undef  START_MY_CXT
  91 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
  92 # undef  MY_CXT_INIT
  93 # define MY_CXT_INIT  NOOP
  94 # undef  MY_CXT_CLONE
  95 # define MY_CXT_CLONE NOOP
  96 # undef  pMY_CXT
  97 # define pMY_CXT
  98 # undef  pMY_CXT_
  99 # define pMY_CXT_
 100 # undef  aMY_CXT
 101 # define aMY_CXT
 102 # undef  aMY_CXT_
 103 # define aMY_CXT_
 104 #endif
 105
 106 #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK)
 107 # define LT_CHECK_MUTEX_LOCK   OP_CHECK_MUTEX_LOCK
 108 # define LT_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK
 109 #else
 110 # define LT_CHECK_MUTEX_LOCK   OP_REFCNT_LOCK
 111 # define LT_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK
 112 #endif
 113
 114 typedef OP *(*lt_ck_t)(pTHX_ OP *);
 115
 116 #ifdef wrap_op_checker
 117
 118 # define lt_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP))
 119
 120 #else
 121
 122 STATIC void lt_ck_replace(pTHX_ OPCODE type, lt_ck_t new_ck, lt_ck_t *old_ck_p){
 123 #define lt_ck_replace(T, NC, OCP) lt_ck_replace(aTHX_ (T), (NC), (OCP))
 124  LT_CHECK_MUTEX_LOCK;
 125  if (!*old_ck_p) {
 126   *old_ck_p      = PL_check[type];
 127   PL_check[type] = new_ck;
 128  }
 129  LT_CHECK_MUTEX_UNLOCK;
 130 }
 131
 132 #endif
 133
 134 STATIC void lt_ck_restore(pTHX_ OPCODE type, lt_ck_t *old_ck_p) {
 135 #define lt_ck_restore(T, OCP) lt_ck_restore(aTHX_ (T), (OCP))
 136  LT_CHECK_MUTEX_LOCK;
 137  if (*old_ck_p) {
 138   PL_check[type] = *old_ck_p;
 139   *old_ck_p      = 0;
 140  }
 141  LT_CHECK_MUTEX_UNLOCK;
 142 }
 143
 144 /* --- Helpers ------------------------------------------------------------- */
 145
 146 /* ... Thread-safe hints ................................................... */
 147
 148 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 149
 150 typedef struct {
 151  SV *code;
 152  IV  require_tag;
 153 } lt_hint_t;
 154
 155 #define LT_HINT_STRUCT 1
 156
 157 #define LT_HINT_CODE(H) ((H)->code)
 158
 159 #define LT_HINT_FREE(H) { \
 160  lt_hint_t *h = (H);      \
 161  SvREFCNT_dec(h->code);   \
 162  PerlMemShared_free(h);   \
 163 }
 164
 165 #else  /*  LT_WORKAROUND_REQUIRE_PROPAGATION */
 166
 167 typedef SV lt_hint_t;
 168
 169 #define LT_HINT_STRUCT 0
 170
 171 #define LT_HINT_CODE(H) (H)
 172
 173 #define LT_HINT_FREE(H) SvREFCNT_dec(H);
 174
 175 #endif /* !LT_WORKAROUND_REQUIRE_PROPAGATION */
 176
 177 #if LT_THREADSAFE
 178
 179 #define PTABLE_NAME        ptable_hints
 180 #define PTABLE_VAL_FREE(V) LT_HINT_FREE(V)
 181
 182 #define pPTBL  pTHX
 183 #define pPTBL_ pTHX_
 184 #define aPTBL  aTHX
 185 #define aPTBL_ aTHX_
 186
 187 #include "ptable.h"
 188
 189 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
 190 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
 191
 192 #endif /* LT_THREADSAFE */
 193
 194 /* ... "Seen" pointer table ................................................ */
 195
 196 #define PTABLE_NAME        ptable_seen
 197 #define PTABLE_VAL_FREE(V) NOOP
 198
 199 #include "ptable.h"
 200
 201 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 202 #define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
 203 #define ptable_seen_clear(T)       ptable_seen_clear(aPTBLMS_ (T))
 204 #define ptable_seen_free(T)        ptable_seen_free(aPTBLMS_ (T))
 205
 206 /* ... Global data ......................................................... */
 207
 208 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 209
 210 #define LT_TYPE_SCALAR 0
 211
 212 #if LT_HAS_PERL(5, 11, 1)
 213
 214 #define LT_TYPE_ARRAY  1
 215 #define LT_TYPE_HASH   2
 216
 217 #define LT_TYPE_COUNT  3
 218
 219 #else
 220
 221 #define LT_TYPE_COUNT  1
 222
 223 #endif
 224
 225 typedef struct {
 226 #if LT_THREADSAFE
 227  ptable *tbl; /* It really is a ptable_hints */
 228  tTHX    owner;
 229 #endif
 230  ptable *seen; /* It really is a ptable_seen */
 231  SV     *default_meth[LT_TYPE_COUNT];
 232 } my_cxt_t;
 233
 234 START_MY_CXT
 235
 236 /* ... Cloning global data ................................................. */
 237
 238 #if LT_THREADSAFE
 239
 240 typedef struct {
 241  ptable *tbl;
 242 #if LT_HAS_PERL(5, 13, 2)
 243  CLONE_PARAMS *params;
 244 #else
 245  CLONE_PARAMS params;
 246 #endif
 247 } lt_ptable_clone_ud;
 248
 249 #if LT_HAS_PERL(5, 13, 2)
 250 # define lt_ptable_clone_ud_init(U, T, O) \
 251    (U).tbl    = (T); \
 252    (U).params = Perl_clone_params_new((O), aTHX)
 253 # define lt_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
 254 # define lt_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), (U)->params))
 255 #else
 256 # define lt_ptable_clone_ud_init(U, T, O) \
 257    (U).tbl               = (T);     \
 258    (U).params.stashes    = newAV(); \
 259    (U).params.flags      = 0;       \
 260    (U).params.proto_perl = (O)
 261 # define lt_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
 262 # define lt_dup_inc(S, U)             SvREFCNT_inc(sv_dup((S), &((U)->params)))
 263 #endif
 264
 265 STATIC void lt_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
 266  lt_ptable_clone_ud *ud = ud_;
 267  lt_hint_t *h1 = ent->val;
 268  lt_hint_t *h2;
 269
 270 #if LT_HINT_STRUCT
 271
 272  h2              = PerlMemShared_malloc(sizeof *h2);
 273  h2->code        = lt_dup_inc(h1->code, ud);
 274 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 275  h2->require_tag = PTR2IV(lt_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
 276 #endif
 277
 278 #else /*   LT_HINT_STRUCT */
 279
 280  h2 = lt_dup_inc(h1, ud);
 281
 282 #endif /* !LT_HINT_STRUCT */
 283
 284  ptable_hints_store(ud->tbl, ent->key, h2);
 285 }
 286
 287 #include "reap.h"
 288
 289 STATIC void lt_thread_cleanup(pTHX_ void *ud) {
 290  dMY_CXT;
 291
 292  ptable_hints_free(MY_CXT.tbl);
 293  ptable_seen_free(MY_CXT.seen);
 294 }
 295
 296 #endif /* LT_THREADSAFE */
 297
 298 /* ... Hint tags ........................................................... */
 299
 300 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 301
 302 STATIC IV lt_require_tag(pTHX) {
 303 #define lt_require_tag() lt_require_tag(aTHX)
 304  const CV *cv, *outside;
 305
 306  cv = PL_compcv;
 307
 308  if (!cv) {
 309   /* If for some reason the pragma is operational at run-time, try to discover
 310    * the current cv in use. */
 311   const PERL_SI *si;
 312
 313   for (si = PL_curstackinfo; si; si = si->si_prev) {
 314    I32 cxix;
 315
 316    for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 317     const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 318
 319     switch (CxTYPE(cx)) {
 320      case CXt_SUB:
 321      case CXt_FORMAT:
 322       /* The propagation workaround is only needed up to 5.10.0 and at that
 323        * time format and sub contexts were still identical. And even later the
 324        * cv members offsets should have been kept the same. */
 325       cv = cx->blk_sub.cv;
 326       goto get_enclosing_cv;
 327      case CXt_EVAL:
 328       cv = cx->blk_eval.cv;
 329       goto get_enclosing_cv;
 330      default:
 331       break;
 332     }
 333    }
 334   }
 335
 336   cv = PL_main_cv;
 337  }
 338
 339 get_enclosing_cv:
 340  for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
 341   cv = outside;
 342
 343  return PTR2IV(cv);
 344 }
 345
 346 #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 347
 348 STATIC SV *lt_tag(pTHX_ SV *value) {
 349 #define lt_tag(V) lt_tag(aTHX_ (V))
 350  lt_hint_t *h;
 351  SV *code = NULL;
 352
 353  if (SvROK(value)) {
 354   value = SvRV(value);
 355   if (SvTYPE(value) >= SVt_PVCV) {
 356    code = value;
 357    SvREFCNT_inc_simple_void_NN(code);
 358   }
 359  }
 360
 361 #if LT_HINT_STRUCT
 362  h = PerlMemShared_malloc(sizeof *h);
 363  h->code        = code;
 364 # if LT_WORKAROUND_REQUIRE_PROPAGATION
 365  h->require_tag = lt_require_tag();
 366 # endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 367 #else  /*  LT_HINT_STRUCT */
 368  h = code;
 369 #endif /* !LT_HINT_STRUCT */
 370
 371 #if LT_THREADSAFE
 372  {
 373   dMY_CXT;
 374   /* We only need for the key to be an unique tag for looking up the value later
 375    * Allocated memory provides convenient unique identifiers, so that's why we
 376    * use the hint as the key itself. */
 377   ptable_hints_store(MY_CXT.tbl, h, h);
 378  }
 379 #endif /* LT_THREADSAFE */
 380
 381  return newSViv(PTR2IV(h));
 382 }
 383
 384 STATIC SV *lt_detag(pTHX_ const SV *hint) {
 385 #define lt_detag(H) lt_detag(aTHX_ (H))
 386  lt_hint_t *h;
 387 #if LT_THREADSAFE
 388  dMY_CXT;
 389 #endif
 390
 391  if (!(hint && SvIOK(hint)))
 392   return NULL;
 393
 394  h = INT2PTR(lt_hint_t *, SvIVX(hint));
 395 #if LT_THREADSAFE
 396  h = ptable_fetch(MY_CXT.tbl, h);
 397 #endif /* LT_THREADSAFE */
 398 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 399  if (lt_require_tag() != h->require_tag)
 400   return NULL;
 401 #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 402
 403  return LT_HINT_CODE(h);
 404 }
 405
 406 STATIC U32 lt_hash = 0;
 407
 408 STATIC SV *lt_hint(pTHX) {
 409 #define lt_hint() lt_hint(aTHX)
 410  SV *hint;
 411 #ifdef cop_hints_fetch_pvn
 412  hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, lt_hash,0);
 413 #elif LT_HAS_PERL(5, 9, 5)
 414  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 415                                        NULL,
 416                                        __PACKAGE__, __PACKAGE_LEN__,
 417                                        0,
 418                                        lt_hash);
 419 #else
 420  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0);
 421  if (!val)
 422   return 0;
 423  hint = *val;
 424 #endif
 425  return lt_detag(hint);
 426 }
 427
 428 /* ... op => info map ...................................................... */
 429
 430 #define PTABLE_NAME        ptable_map
 431 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 432
 433 #include "ptable.h"
 434
 435 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 436 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 437 #define ptable_map_delete(T, K)   ptable_map_delete(aPTBLMS_ (T), (K))
 438
 439 #ifdef USE_ITHREADS
 440
 441 STATIC perl_mutex lt_op_map_mutex;
 442
 443 #define LT_LOCK(M)   MUTEX_LOCK(M)
 444 #define LT_UNLOCK(M) MUTEX_UNLOCK(M)
 445
 446 #else /* USE_ITHREADS */
 447
 448 #define LT_LOCK(M)
 449 #define LT_UNLOCK(M)
 450
 451 #endif /* !USE_ITHREADS */
 452
 453 STATIC ptable *lt_op_padxv_map = NULL;
 454
 455 typedef struct {
 456  OP *(*old_pp)(pTHX);
 457 #ifdef MULTIPLICITY
 458  STRLEN buf_size, orig_pkg_len, type_pkg_len, type_meth_len;
 459  char *buf;
 460 #else /* MULTIPLICITY */
 461  SV *orig_pkg;
 462  SV *type_pkg;
 463  SV *type_meth;
 464 #endif /* !MULTIPLICITY */
 465 } lt_op_padxv_info;
 466
 467 STATIC const char lt_type_desc_scalar[] = "scalar";
 468 STATIC const char lt_type_desc_array[]  = "array";
 469 STATIC const char lt_type_desc_hash[]   = "hash";
 470
 471 STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) {
 472 #define lt_op_padxv_info_call(O, S) lt_op_padxv_info_call(aTHX_ (O), (S))
 473  SV *orig_pkg, *type_pkg, *type_meth;
 474  svtype var_type;
 475  int items;
 476  dSP;
 477
 478  ENTER;
 479  SAVETMPS;
 480
 481 #ifdef MULTIPLICITY
 482  {
 483   STRLEN op_len = oi->orig_pkg_len, tp_len = oi->type_pkg_len;
 484   char *buf = oi->buf;
 485   orig_pkg  = sv_2mortal(newSVpvn(buf, op_len));
 486   SvREADONLY_on(orig_pkg);
 487   buf      += op_len;
 488   type_pkg  = sv_2mortal(newSVpvn(buf, tp_len));
 489   SvREADONLY_on(type_pkg);
 490   buf      += tp_len;
 491   type_meth = sv_2mortal(newSVpvn(buf, oi->type_meth_len));
 492   SvREADONLY_on(type_meth);
 493  }
 494 #else /* MULTIPLICITY */
 495  orig_pkg  = oi->orig_pkg;
 496  type_pkg  = oi->type_pkg;
 497  type_meth = oi->type_meth;
 498 #endif /* !MULTIPLICITY */
 499
 500  PUSHMARK(SP);
 501  EXTEND(SP, 3);
 502  PUSHs(type_pkg);
 503  var_type = SvTYPE(sv);
 504  switch (var_type) {
 505   case SVt_PVAV:
 506   case SVt_PVHV:
 507    PUSHs(sv_2mortal(newRV_inc(sv)));
 508    break;
 509   default:
 510    PUSHs(sv);
 511    break;
 512  }
 513  PUSHs(orig_pkg);
 514  PUTBACK;
 515
 516  items = call_sv(type_meth, G_ARRAY | G_METHOD);
 517
 518  SPAGAIN;
 519  switch (items) {
 520   case 0:
 521    break;
 522   case 1: {
 523    SV *rsv = POPs;
 524    switch (var_type) {
 525     case SVt_PVAV:
 526      if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) {
 527       AV *av = (AV *) SvRV(rsv);
 528       SV **src, **dst;
 529       I32 len = av_len(av);
 530       I32 i;
 531       av_fill((AV *) sv, len);
 532       src = AvARRAY(av);
 533       dst = AvARRAY(sv);
 534       for (i = 0; i <= len; ++i, ++src, ++dst) {
 535        SvREFCNT_dec(*dst);
 536        *dst = SvREFCNT_inc(*src);
 537       }
 538      } else {
 539       goto type_mismatch;
 540      }
 541      break;
 542     case SVt_PVHV:
 543      if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) {
 544       HV *hv = (HV *) SvRV(rsv);
 545       HE *he;
 546       hv_iterinit(hv);
 547       hv_clear((HV *) sv);
 548       while ((he = hv_iternext(hv)) != NULL) {
 549        SV *val = SvREFCNT_inc(HeVAL(he));
 550        if (!hv_store((HV *) sv, HeKEY(he), HeKLEN(he), val, HeHASH(he)))
 551         SvREFCNT_dec(val);
 552       }
 553      } else {
 554       goto type_mismatch;
 555      }
 556      break;
 557     default:
 558      sv_setsv(sv, rsv);
 559      break;
 560    }
 561    break;
 562 type_mismatch:
 563    croak("Type mismatch");
 564   }
 565   default: {
 566    const char *type_desc;
 567    switch (var_type) {
 568     case SVt_PVAV:
 569      type_desc = lt_type_desc_array;
 570      break;
 571     case SVt_PVHV:
 572      type_desc = lt_type_desc_hash;
 573      break;
 574     default:
 575      type_desc = lt_type_desc_scalar;
 576      break;
 577    }
 578    croak("Typed %s initializer method should return zero or one scalar, but got %d", type_desc, items);
 579   }
 580  }
 581  PUTBACK;
 582
 583  FREETMPS;
 584  LEAVE;
 585
 586  return;
 587 }
 588
 589 STATIC void lt_padxv_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*old_pp)(pTHX)) {
 590 #define lt_padxv_map_store(O, OP, TP, TM, PP) lt_padxv_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
 591  lt_op_padxv_info *oi;
 592
 593  LT_LOCK(&lt_op_map_mutex);
 594
 595  if (!(oi = ptable_fetch(lt_op_padxv_map, o))) {
 596   oi = PerlMemShared_malloc(sizeof *oi);
 597   ptable_map_store(lt_op_padxv_map, o, oi);
 598 #ifdef MULTIPLICITY
 599   oi->buf      = NULL;
 600   oi->buf_size = 0;
 601 #else /* MULTIPLICITY */
 602  } else {
 603   SvREFCNT_dec(oi->orig_pkg);
 604   SvREFCNT_dec(oi->type_pkg);
 605   SvREFCNT_dec(oi->type_meth);
 606 #endif /* !MULTIPLICITY */
 607  }
 608
 609 #ifdef MULTIPLICITY
 610  {
 611   STRLEN op_len       = SvCUR(orig_pkg);
 612   STRLEN tp_len       = SvCUR(type_pkg);
 613   STRLEN tm_len       = SvCUR(type_meth);
 614   STRLEN new_buf_size = op_len + tp_len + tm_len;
 615   char *buf;
 616   if (new_buf_size > oi->buf_size) {
 617    PerlMemShared_free(oi->buf);
 618    oi->buf      = PerlMemShared_malloc(new_buf_size);
 619    oi->buf_size = new_buf_size;
 620   }
 621   buf  = oi->buf;
 622   Copy(SvPVX(orig_pkg),  buf, op_len, char);
 623   buf += op_len;
 624   Copy(SvPVX(type_pkg),  buf, tp_len, char);
 625   buf += tp_len;
 626   Copy(SvPVX(type_meth), buf, tm_len, char);
 627   oi->orig_pkg_len  = op_len;
 628   oi->type_pkg_len  = tp_len;
 629   oi->type_meth_len = tm_len;
 630   SvREFCNT_dec(orig_pkg);
 631   SvREFCNT_dec(type_pkg);
 632   SvREFCNT_dec(type_meth);
 633  }
 634 #else /* MULTIPLICITY */
 635  oi->orig_pkg  = orig_pkg;
 636  oi->type_pkg  = type_pkg;
 637  oi->type_meth = type_meth;
 638 #endif /* !MULTIPLICITY */
 639
 640  oi->old_pp = old_pp;
 641
 642  LT_UNLOCK(&lt_op_map_mutex);
 643 }
 644
 645 STATIC const lt_op_padxv_info *lt_padxv_map_fetch(const OP *o, lt_op_padxv_info *oi) {
 646  const lt_op_padxv_info *val;
 647
 648  LT_LOCK(&lt_op_map_mutex);
 649
 650  val = ptable_fetch(lt_op_padxv_map, o);
 651  if (val) {
 652   *oi = *val;
 653   val = oi;
 654  }
 655
 656  LT_UNLOCK(&lt_op_map_mutex);
 657
 658  return val;
 659 }
 660
 661 #if LT_HAS_PERL(5, 17, 6)
 662
 663 STATIC ptable *lt_op_padrange_map = NULL;
 664
 665 typedef struct {
 666  OP *(*old_pp)(pTHX);
 667  const OP *padxv_start;
 668 } lt_op_padrange_info;
 669
 670 STATIC void lt_padrange_map_store(pTHX_ const OP *o, const OP *s, OP *(*old_pp)(pTHX)) {
 671 #define lt_padrange_map_store(O, S, PP) lt_padrange_map_store(aTHX_ (O), (S), (PP))
 672  lt_op_padrange_info *oi;
 673
 674  LT_LOCK(&lt_op_map_mutex);
 675
 676  if (!(oi = ptable_fetch(lt_op_padrange_map, o))) {
 677   oi = PerlMemShared_malloc(sizeof *oi);
 678   ptable_map_store(lt_op_padrange_map, o, oi);
 679  }
 680
 681  oi->old_pp      = old_pp;
 682  oi->padxv_start = s;
 683
 684  LT_UNLOCK(&lt_op_map_mutex);
 685 }
 686
 687 STATIC const lt_op_padrange_info *lt_padrange_map_fetch(const OP *o, lt_op_padrange_info *oi) {
 688  const lt_op_padrange_info *val;
 689
 690  LT_LOCK(&lt_op_map_mutex);
 691
 692  val = ptable_fetch(lt_op_padrange_map, o);
 693  if (val) {
 694   *oi = *val;
 695   val = oi;
 696  }
 697
 698  LT_UNLOCK(&lt_op_map_mutex);
 699
 700  return val;
 701 }
 702
 703 #endif
 704
 705 STATIC void lt_map_delete(pTHX_ const OP *o) {
 706 #define lt_map_delete(O) lt_map_delete(aTHX_ (O))
 707  LT_LOCK(&lt_op_map_mutex);
 708
 709  ptable_map_delete(lt_op_padxv_map,    o);
 710 #if LT_HAS_PERL(5, 17, 6)
 711  ptable_map_delete(lt_op_padrange_map, o);
 712 #endif
 713
 714  LT_UNLOCK(&lt_op_map_mutex);
 715 }
 716
 717 /* --- Hooks --------------------------------------------------------------- */
 718
 719 /* ... Our pp_padsv ........................................................ */
 720
 721 STATIC OP *lt_pp_padxv(pTHX) {
 722  lt_op_padxv_info oi;
 723
 724  if (lt_padxv_map_fetch(PL_op, &oi)) {
 725   dTARGET;
 726   lt_op_padxv_info_call(&oi, TARG);
 727   return oi.old_pp(aTHX);
 728  }
 729
 730  return PL_op->op_ppaddr(aTHX);
 731 }
 732
 733 /* ... Our pp_padrange (on perl 5.17.6 and above) .......................... */
 734
 735 #if LT_HAS_PERL(5, 17, 6)
 736
 737 STATIC OP *lt_pp_padrange(pTHX) {
 738  lt_op_padrange_info roi;
 739
 740  if (lt_padrange_map_fetch(PL_op, &roi)) {
 741   PADOFFSET i, base, count;
 742   const OP *p;
 743
 744   base  = PL_op->op_targ;
 745   count = PL_op->op_private & OPpPADRANGE_COUNTMASK;
 746
 747   for (i = 0, p = roi.padxv_start; i < count && p; ++i, p = p->op_sibling) {
 748    lt_op_padxv_info oi;
 749
 750    switch (p->op_type) {
 751     case OP_PADSV:
 752 #if LT_HAS_PERL(5, 11, 1)
 753     case OP_PADAV:
 754     case OP_PADHV:
 755 #endif
 756      if (lt_padxv_map_fetch(p, &oi))
 757       lt_op_padxv_info_call(&oi, PAD_SV(base + i));
 758      break;
 759     default:
 760      break;
 761    }
 762   }
 763
 764   return roi.old_pp(aTHX);
 765  }
 766
 767  return PL_op->op_ppaddr(aTHX);
 768 }
 769
 770 #endif
 771
 772 /* ... Our ck_pad{any,sv,av,hv} ............................................ */
 773
 774 /* Sadly, the padxv OPs we are interested in don't trigger the padxv check
 775  * functions, but are instead manually mutated from a padany. So we store
 776  * the op entry in the op map in the padany check function, and we set their
 777  * op_ppaddr member in our peephole optimizer replacement below. */
 778
 779 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 780
 781 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 782  HV *stash;
 783  SV *code;
 784
 785  o = lt_old_ck_padany(aTHX_ o);
 786
 787  stash = PL_in_my_stash;
 788  if (stash && (code = lt_hint())) {
 789   dMY_CXT;
 790   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 791   SV *orig_meth = NULL;
 792   SV *type_pkg  = NULL;
 793   SV *type_meth = NULL;
 794   unsigned int type;
 795   const char *s;
 796   int items;
 797
 798   s = PL_tokenbuf;
 799   while (*s && isSPACE(*s))
 800    ++s;
 801   switch (*s) {
 802    case '$':
 803     type = LT_TYPE_SCALAR;
 804     break;
 805 #if LT_HAS_PERL(5, 11, 1)
 806    case '@':
 807     type = LT_TYPE_ARRAY;
 808     break;
 809    case '%':
 810     type = LT_TYPE_HASH;
 811     break;
 812 #endif
 813    default:
 814     croak("Unsupported sigil '%c'", *s);
 815     break;
 816   }
 817   orig_meth = MY_CXT.default_meth[type];
 818
 819   dSP;
 820
 821   SvREADONLY_on(orig_pkg);
 822
 823   ENTER;
 824   SAVETMPS;
 825
 826   PUSHMARK(SP);
 827   EXTEND(SP, 2);
 828   PUSHs(orig_pkg);
 829   PUSHs(orig_meth);
 830   PUTBACK;
 831
 832   items = call_sv(code, G_ARRAY);
 833
 834   SPAGAIN;
 835   if (items > 2)
 836    croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 837   if (items == 0) {
 838    SvREFCNT_dec(orig_pkg);
 839    FREETMPS;
 840    LEAVE;
 841    goto skip;
 842   } else {
 843    SV *rsv;
 844    if (items > 1) {
 845     rsv = POPs;
 846     if (SvOK(rsv)) {
 847      type_meth = newSVsv(rsv);
 848      SvREADONLY_on(type_meth);
 849     }
 850    }
 851    rsv = POPs;
 852    if (SvOK(rsv)) {
 853     type_pkg = newSVsv(rsv);
 854     SvREADONLY_on(type_pkg);
 855    }
 856   }
 857   PUTBACK;
 858
 859   FREETMPS;
 860   LEAVE;
 861
 862   if (!type_pkg) {
 863    type_pkg = orig_pkg;
 864    SvREFCNT_inc_simple_void_NN(orig_pkg);
 865   }
 866
 867   if (!type_meth) {
 868    type_meth = orig_meth;
 869    SvREFCNT_inc_simple_void_NN(orig_meth);
 870   }
 871
 872   lt_padxv_map_store(o, orig_pkg, type_pkg, type_meth, o->op_ppaddr);
 873  } else {
 874 skip:
 875   lt_map_delete(o);
 876  }
 877
 878  return o;
 879 }
 880
 881 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 882
 883 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 884  lt_map_delete(o);
 885
 886  return lt_old_ck_padsv(aTHX_ o);
 887 }
 888
 889 #if LT_HAS_PERL(5, 11, 1)
 890
 891 STATIC OP *(*lt_old_ck_padav)(pTHX_ OP *) = 0;
 892
 893 STATIC OP *lt_ck_padav(pTHX_ OP *o) {
 894  lt_map_delete(o);
 895
 896  return lt_old_ck_padav(aTHX_ o);
 897 }
 898
 899 STATIC OP *(*lt_old_ck_padhv)(pTHX_ OP *) = 0;
 900
 901 STATIC OP *lt_ck_padhv(pTHX_ OP *o) {
 902  lt_map_delete(o);
 903
 904  return lt_old_ck_padhv(aTHX_ o);
 905 }
 906
 907 #endif
 908
 909 /* ... Our peephole optimizer .............................................. */
 910
 911 #if LT_HAS_PERL(5, 17, 6)
 912
 913 STATIC int lt_maybe_padrange_setup(pTHX_ OP *o, const OP *start) {
 914 #define lt_maybe_padrange_setup(O, S) lt_maybe_padrange_setup(aTHX_ (O), (S))
 915  PADOFFSET i, count;
 916  const OP *p;
 917
 918  count = o->op_private & OPpPADRANGE_COUNTMASK;
 919
 920  for (i = 0, p = start; i < count && p; ++i, p = p->op_sibling) {
 921   switch (p->op_type) {
 922    case OP_PADSV:
 923 #if LT_HAS_PERL(5, 11, 1)
 924    case OP_PADAV:
 925    case OP_PADHV:
 926 #endif
 927     /* In a padrange sequence, either all lexicals are typed, or none are.
 928      * Thus we can stop at the first padsv op. However, note that these
 929      * lexicals can need to call different methods in different packages. */
 930     LT_LOCK(&lt_op_map_mutex);
 931     if (ptable_fetch(lt_op_padxv_map, p)) {
 932      LT_UNLOCK(&lt_op_map_mutex);
 933      lt_padrange_map_store(o, start, o->op_ppaddr);
 934      o->op_ppaddr = lt_pp_padrange;
 935     } else {
 936      LT_UNLOCK(&lt_op_map_mutex);
 937     }
 938     return 1;
 939     break;
 940    default:
 941     break;
 942   }
 943  }
 944
 945  return 0;
 946 }
 947
 948 #endif
 949
 950 STATIC peep_t lt_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
 951
 952 STATIC void lt_peep_rec(pTHX_ OP *o, ptable *seen) {
 953 #define lt_peep_rec(O) lt_peep_rec(aTHX_ (O), seen)
 954  for (; o; o = o->op_next) {
 955   if (ptable_fetch(seen, o))
 956    break;
 957   ptable_seen_store(seen, o, o);
 958
 959   switch (o->op_type) {
 960    case OP_PADSV:
 961 #if LT_HAS_PERL(5, 11, 1)
 962    case OP_PADAV:
 963    case OP_PADHV:
 964 #endif
 965     if (o->op_ppaddr != lt_pp_padxv && o->op_private & OPpLVAL_INTRO) {
 966      lt_op_padxv_info *oi;
 967      LT_LOCK(&lt_op_map_mutex);
 968      oi = ptable_fetch(lt_op_padxv_map, o);
 969      if (oi) {
 970       oi->old_pp   = o->op_ppaddr;
 971       o->op_ppaddr = lt_pp_padxv;
 972      }
 973      LT_UNLOCK(&lt_op_map_mutex);
 974     }
 975     break;
 976 #if LT_HAS_PERL(5, 17, 6)
 977    case OP_PADRANGE:
 978     /* We deal with special padrange ops later, in the aassign op they belong
 979      * to. */
 980     if (o->op_ppaddr != lt_pp_padrange && o->op_private & OPpLVAL_INTRO
 981                                        && !(o->op_flags & OPf_SPECIAL)) {
 982      /* A padrange op is guaranteed to have previously been a pushmark.
 983       * Moreover, for non-special padrange ops (i.e. that aren't for
 984       * my (...) = @_), the original padxv ops are its siblings. */
 985      lt_maybe_padrange_setup(o, o->op_sibling);
 986     }
 987     break;
 988    case OP_AASSIGN: {
 989     OP *op;
 990     if (cBINOPo->op_first && cBINOPo->op_first->op_flags & OPf_KIDS
 991                           && (op = cUNOPx(cBINOPo->op_first)->op_first)
 992                           && op->op_type == OP_PADRANGE
 993                           && op->op_ppaddr != lt_pp_padrange
 994                           && op->op_private & OPpLVAL_INTRO
 995                           && op->op_flags & OPf_SPECIAL) {
 996      const OP *start = cUNOPx(cBINOPo->op_last)->op_first;
 997      if (start->op_type == OP_PUSHMARK)
 998       start = start->op_sibling;
 999      lt_maybe_padrange_setup(op, start);
1000     }
1001     break;
1002    }
1003 #endif
1004 #if !LT_HAS_RPEEP
1005    case OP_MAPWHILE:
1006    case OP_GREPWHILE:
1007    case OP_AND:
1008    case OP_OR:
1009    case OP_ANDASSIGN:
1010    case OP_ORASSIGN:
1011    case OP_COND_EXPR:
1012    case OP_RANGE:
1013 # if LT_HAS_PERL(5, 10, 0)
1014    case OP_ONCE:
1015    case OP_DOR:
1016    case OP_DORASSIGN:
1017 # endif
1018     lt_peep_rec(cLOGOPo->op_other);
1019     break;
1020    case OP_ENTERLOOP:
1021    case OP_ENTERITER:
1022     lt_peep_rec(cLOOPo->op_redoop);
1023     lt_peep_rec(cLOOPo->op_nextop);
1024     lt_peep_rec(cLOOPo->op_lastop);
1025     break;
1026 # if LT_HAS_PERL(5, 9, 5)
1027    case OP_SUBST:
1028     lt_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
1029     break;
1030 # else
1031    case OP_QR:
1032    case OP_MATCH:
1033    case OP_SUBST:
1034     lt_peep_rec(cPMOPo->op_pmreplstart);
1035     break;
1036 # endif
1037 #endif /* !LT_HAS_RPEEP */
1038    default:
1039     break;
1040   }
1041  }
1042 }
1043
1044 STATIC void lt_peep(pTHX_ OP *o) {
1045  dMY_CXT;
1046  ptable *seen = MY_CXT.seen;
1047
1048  lt_old_peep(aTHX_ o);
1049
1050  ptable_seen_clear(seen);
1051  lt_peep_rec(o);
1052  ptable_seen_clear(seen);
1053 }
1054
1055 /* --- Interpreter setup/teardown ------------------------------------------ */
1056
1057
1058 STATIC U32 lt_initialized = 0;
1059
1060 STATIC void lt_teardown(pTHX_ void *root) {
1061  if (!lt_initialized)
1062   return;
1063
1064 #if LT_MULTIPLICITY
1065  if (aTHX != root)
1066   return;
1067 #endif
1068
1069  {
1070   unsigned int i;
1071   dMY_CXT;
1072 #if LT_THREADSAFE
1073   ptable_hints_free(MY_CXT.tbl);
1074 #endif
1075   ptable_seen_free(MY_CXT.seen);
1076   for (i = 0; i < LT_TYPE_COUNT; ++i)
1077    SvREFCNT_dec(MY_CXT.default_meth[i]);
1078  }
1079
1080  lt_ck_restore(OP_PADANY, &lt_old_ck_padany);
1081  lt_ck_restore(OP_PADSV,  &lt_old_ck_padsv);
1082 #if LT_HAS_PERL(5, 11, 1)
1083  lt_ck_restore(OP_PADAV,  &lt_old_ck_padav);
1084  lt_ck_restore(OP_PADHV,  &lt_old_ck_padhv);
1085 #endif
1086
1087 #if LT_HAS_RPEEP
1088  PL_rpeepp   = lt_old_peep;
1089 #else
1090  PL_peepp    = lt_old_peep;
1091 #endif
1092  lt_old_peep = 0;
1093
1094  lt_initialized = 0;
1095 }
1096
1097 STATIC void lt_setup(pTHX) {
1098 #define lt_setup() lt_setup(aTHX)
1099  if (lt_initialized)
1100   return;
1101
1102  {
1103   MY_CXT_INIT;
1104 #if LT_THREADSAFE
1105   MY_CXT.tbl   = ptable_new();
1106   MY_CXT.owner = aTHX;
1107 #endif
1108   MY_CXT.seen  = ptable_new();
1109   MY_CXT.default_meth[LT_TYPE_SCALAR] = newSVpvs("TYPEDSCALAR");
1110   SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_SCALAR]);
1111 #if LT_HAS_PERL(5, 11, 1)
1112   MY_CXT.default_meth[LT_TYPE_ARRAY]  = newSVpvs("TYPEDARRAY");
1113   SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_ARRAY]);
1114   MY_CXT.default_meth[LT_TYPE_HASH]   = newSVpvs("TYPEDHASH");
1115   SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_HASH]);
1116 #endif
1117  }
1118
1119  lt_ck_replace(OP_PADANY, lt_ck_padany, &lt_old_ck_padany);
1120  lt_ck_replace(OP_PADSV,  lt_ck_padsv,  &lt_old_ck_padsv);
1121 #if LT_HAS_PERL(5, 11, 1)
1122  lt_ck_replace(OP_PADAV,  lt_ck_padav,  &lt_old_ck_padav);
1123  lt_ck_replace(OP_PADHV,  lt_ck_padhv,  &lt_old_ck_padhv);
1124 #endif
1125
1126 #if LT_HAS_RPEEP
1127  lt_old_peep = PL_rpeepp;
1128  PL_rpeepp   = lt_peep;
1129 #else
1130  lt_old_peep = PL_peepp;
1131  PL_peepp    = lt_peep;
1132 #endif
1133
1134 #if LT_MULTIPLICITY
1135  call_atexit(lt_teardown, aTHX);
1136 #else
1137  call_atexit(lt_teardown, NULL);
1138 #endif
1139
1140  lt_initialized = 1;
1141 }
1142
1143 STATIC U32 lt_booted = 0;
1144
1145 /* --- XS ------------------------------------------------------------------ */
1146
1147 MODULE = Lexical::Types      PACKAGE = Lexical::Types
1148
1149 PROTOTYPES: ENABLE
1150
1151 BOOT:
1152 {
1153  if (!lt_booted++) {
1154   HV *stash;
1155
1156   lt_op_padxv_map    = ptable_new();
1157 #if LT_HAS_PERL(5, 17, 6)
1158   lt_op_padrange_map = ptable_new();
1159 #endif
1160 #ifdef USE_ITHREADS
1161   MUTEX_INIT(&lt_op_map_mutex);
1162 #endif
1163
1164   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
1165
1166   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
1167   newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
1168   newCONSTSUB(stash, "LT_FORKSAFE",   newSVuv(LT_FORKSAFE));
1169  }
1170
1171  lt_setup();
1172 }
1173
1174 #if LT_THREADSAFE
1175
1176 void
1177 CLONE(...)
1178 PROTOTYPE: DISABLE
1179 PREINIT:
1180  ptable      *t;
1181  ptable      *s;
1182  SV          *cloned_default_meth[LT_TYPE_COUNT];
1183  unsigned int i;
1184 PPCODE:
1185  {
1186   {
1187    lt_ptable_clone_ud ud;
1188    dMY_CXT;
1189
1190    t = ptable_new();
1191    lt_ptable_clone_ud_init(ud, t, MY_CXT.owner);
1192    ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud);
1193    for (i = 0; i < LT_TYPE_COUNT; ++i)
1194     cloned_default_meth[i] = lt_dup_inc(MY_CXT.default_meth[i], &ud);
1195    lt_ptable_clone_ud_deinit(ud);
1196   }
1197   s = ptable_new();
1198  }
1199  {
1200   MY_CXT_CLONE;
1201   MY_CXT.tbl           = t;
1202   MY_CXT.owner         = aTHX;
1203   MY_CXT.seen          = s;
1204   for (i = 0; i < LT_TYPE_COUNT; ++i)
1205    MY_CXT.default_meth[i] = cloned_default_meth[i];
1206  }
1207  reap(3, lt_thread_cleanup, NULL);
1208  XSRETURN(0);
1209
1210 #endif
1211
1212 SV *
1213 _tag(SV *value)
1214 PROTOTYPE: $
1215 CODE:
1216  RETVAL = lt_tag(value);
1217 OUTPUT:
1218  RETVAL