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