1 /* This file is part of the Lexical-Types Perl module.
2 * See http://search.cpan.org/dist/Lexical-Types/ */
4 #define PERL_NO_GET_CONTEXT
9 /* --- XS helpers ---------------------------------------------------------- */
11 #define XSH_PACKAGE "Lexical::Types"
19 /* ... Lexical hints ....................................................... */
21 #define XSH_HINTS_TYPE_SV 1
23 #include "xsh/hints.h"
25 #define lt_hint() xsh_hints_detag(xsh_hints_fetch())
27 /* ... Thread-local storage ................................................ */
33 #define XSH_THREADS_COMPILE_TIME_PROTECTION 1
34 #define XSH_THREADS_USER_CLONE_NEEDS_DUP 1
38 static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params) {
39 new_cxt->default_meth = xsh_dup_inc(old_cxt->default_meth, params);
44 #endif /* XSH_THREADSAFE */
46 #include "xsh/threads.h"
48 /* ... op => info map ...................................................... */
50 #define PTABLE_NAME ptable_map
51 #define PTABLE_VAL_FREE(V) XSH_SHARED_FREE((V), 0, char)
52 #define PTABLE_VAL_NEED_CONTEXT 0
53 #define PTABLE_NEED_DELETE 1
54 #define PTABLE_NEED_WALK 0
56 #include "xsh/ptable.h"
58 #define ptable_map_store(T, K, V) ptable_map_store(aPMS_ (T), (K), (V))
59 #define ptable_map_delete(T, K) ptable_map_delete(aPMS_ (T), (K))
60 #define ptable_map_free(T) ptable_map_free(aPMS_ (T))
64 static perl_mutex lt_op_map_mutex;
66 #endif /* USE_ITHREADS */
68 static ptable *lt_op_padxv_map = NULL;
73 STRLEN buf_size, orig_pkg_len, type_pkg_len, type_meth_len;
75 #else /* MULTIPLICITY */
79 #endif /* !MULTIPLICITY */
82 static void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) {
83 #define lt_op_padxv_info_call(O, S) lt_op_padxv_info_call(aTHX_ (O), (S))
84 SV *orig_pkg, *type_pkg, *type_meth;
93 STRLEN op_len = oi->orig_pkg_len, tp_len = oi->type_pkg_len;
95 orig_pkg = sv_2mortal(newSVpvn(buf, op_len));
96 SvREADONLY_on(orig_pkg);
98 type_pkg = sv_2mortal(newSVpvn(buf, tp_len));
99 SvREADONLY_on(type_pkg);
101 type_meth = sv_2mortal(newSVpvn(buf, oi->type_meth_len));
102 SvREADONLY_on(type_meth);
104 #else /* MULTIPLICITY */
105 orig_pkg = oi->orig_pkg;
106 type_pkg = oi->type_pkg;
107 type_meth = oi->type_meth;
108 #endif /* !MULTIPLICITY */
117 items = call_sv(type_meth, G_ARRAY | G_METHOD);
127 croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
137 static void lt_padxv_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*old_pp)(pTHX)) {
138 #define lt_padxv_map_store(O, OP, TP, TM, PP) lt_padxv_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
139 lt_op_padxv_info *oi;
141 XSH_LOCK(<_op_map_mutex);
143 if (!(oi = ptable_fetch(lt_op_padxv_map, o))) {
144 XSH_SHARED_ALLOC(oi, 1, lt_op_padxv_info);
145 ptable_map_store(lt_op_padxv_map, o, oi);
149 #else /* MULTIPLICITY */
151 SvREFCNT_dec(oi->orig_pkg);
152 SvREFCNT_dec(oi->type_pkg);
153 SvREFCNT_dec(oi->type_meth);
154 #endif /* !MULTIPLICITY */
159 STRLEN op_len = SvCUR(orig_pkg);
160 STRLEN tp_len = SvCUR(type_pkg);
161 STRLEN tm_len = SvCUR(type_meth);
162 STRLEN new_buf_size = op_len + tp_len + tm_len;
164 if (new_buf_size > oi->buf_size) {
165 XSH_SHARED_REALLOC(oi->buf, oi->buf_size, new_buf_size, char);
166 oi->buf_size = new_buf_size;
169 Copy(SvPVX(orig_pkg), buf, op_len, char);
171 Copy(SvPVX(type_pkg), buf, tp_len, char);
173 Copy(SvPVX(type_meth), buf, tm_len, char);
174 oi->orig_pkg_len = op_len;
175 oi->type_pkg_len = tp_len;
176 oi->type_meth_len = tm_len;
177 SvREFCNT_dec(orig_pkg);
178 SvREFCNT_dec(type_pkg);
179 SvREFCNT_dec(type_meth);
181 #else /* MULTIPLICITY */
182 oi->orig_pkg = orig_pkg;
183 oi->type_pkg = type_pkg;
184 oi->type_meth = type_meth;
185 #endif /* !MULTIPLICITY */
189 XSH_UNLOCK(<_op_map_mutex);
192 static const lt_op_padxv_info *lt_padxv_map_fetch(const OP *o, lt_op_padxv_info *oi) {
193 const lt_op_padxv_info *val;
195 XSH_LOCK(<_op_map_mutex);
197 val = ptable_fetch(lt_op_padxv_map, o);
203 XSH_UNLOCK(<_op_map_mutex);
208 #if XSH_HAS_PERL(5, 17, 6)
210 static ptable *lt_op_padrange_map = NULL;
214 const OP *padxv_start;
215 } lt_op_padrange_info;
217 static void lt_padrange_map_store(pTHX_ const OP *o, const OP *s, OP *(*old_pp)(pTHX)) {
218 #define lt_padrange_map_store(O, S, PP) lt_padrange_map_store(aTHX_ (O), (S), (PP))
219 lt_op_padrange_info *oi;
221 XSH_LOCK(<_op_map_mutex);
223 if (!(oi = ptable_fetch(lt_op_padrange_map, o))) {
224 XSH_SHARED_ALLOC(oi, 1, lt_op_padrange_info);
225 ptable_map_store(lt_op_padrange_map, o, oi);
231 XSH_UNLOCK(<_op_map_mutex);
234 static const lt_op_padrange_info *lt_padrange_map_fetch(const OP *o, lt_op_padrange_info *oi) {
235 const lt_op_padrange_info *val;
237 XSH_LOCK(<_op_map_mutex);
239 val = ptable_fetch(lt_op_padrange_map, o);
245 XSH_UNLOCK(<_op_map_mutex);
252 static void lt_map_delete(pTHX_ const OP *o) {
253 #define lt_map_delete(O) lt_map_delete(aTHX_ (O))
254 XSH_LOCK(<_op_map_mutex);
256 ptable_map_delete(lt_op_padxv_map, o);
257 #if XSH_HAS_PERL(5, 17, 6)
258 ptable_map_delete(lt_op_padrange_map, o);
261 XSH_UNLOCK(<_op_map_mutex);
264 /* --- Compatibility wrappers ---------------------------------------------- */
266 #if XSH_HAS_PERL(5, 10, 0) || defined(PL_parser)
267 # ifndef PL_in_my_stash
268 # define PL_in_my_stash PL_parser->in_my_stash
271 # ifndef PL_in_my_stash
272 # define PL_in_my_stash PL_Iin_my_stash
277 # define HvNAME_get(H) HvNAME(H)
280 #ifndef HvNAMELEN_get
281 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
284 #ifndef SvREFCNT_inc_simple_void_NN
285 # define SvREFCNT_inc_simple_void_NN(S) ((void) SvREFCNT_inc(S))
288 /* --- PP functions -------------------------------------------------------- */
290 /* ... pp_padsv ............................................................ */
292 static OP *lt_pp_padsv(pTHX) {
295 if (lt_padxv_map_fetch(PL_op, &oi)) {
297 lt_op_padxv_info_call(&oi, TARG);
298 return oi.old_pp(aTHX);
301 return PL_op->op_ppaddr(aTHX);
304 /* ... pp_padrange (on perl 5.17.6 and above) .............................. */
306 #if XSH_HAS_PERL(5, 17, 6)
308 static OP *lt_pp_padrange(pTHX) {
309 lt_op_padrange_info roi;
311 if (lt_padrange_map_fetch(PL_op, &roi)) {
312 PADOFFSET i, base, count;
315 base = PL_op->op_targ;
316 count = PL_op->op_private & OPpPADRANGE_COUNTMASK;
318 for (i = 0, p = roi.padxv_start; i < count && p; ++i, p = p->op_next) {
320 while (p->op_type == OP_NULL)
322 if (p->op_type == OP_PADSV && lt_padxv_map_fetch(p, &oi))
323 lt_op_padxv_info_call(&oi, PAD_SV(base + i));
326 return roi.old_pp(aTHX);
329 return PL_op->op_ppaddr(aTHX);
334 /* --- Check functions ----------------------------------------------------- */
336 /* ... ck_pad{any,sv} ...................................................... */
338 /* Sadly, the padsv OPs we are interested in don't trigger the padsv check
339 * function, but are instead manually mutated from a padany. So we store
340 * the op entry in the op map in the padany check function, and we set their
341 * op_ppaddr member in our peephole optimizer replacement below. */
343 static OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
345 static OP *lt_ck_padany(pTHX_ OP *o) {
349 o = lt_old_ck_padany(aTHX_ o);
351 stash = PL_in_my_stash;
352 if (stash && (code = lt_hint())) {
354 SV *orig_pkg = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
355 SV *orig_meth = XSH_CXT.default_meth; /* Guarded by lt_hint() */
357 SV *type_meth = NULL;
362 SvREADONLY_on(orig_pkg);
373 items = call_sv(code, G_ARRAY);
377 croak(XSH_PACKAGE " mangler should return zero, one or two scalars, but got %d", items);
379 SvREFCNT_dec(orig_pkg);
388 type_meth = newSVsv(rsv);
389 SvREADONLY_on(type_meth);
394 type_pkg = newSVsv(rsv);
395 SvREADONLY_on(type_pkg);
405 SvREFCNT_inc_simple_void_NN(orig_pkg);
409 type_meth = orig_meth;
410 SvREFCNT_inc_simple_void_NN(orig_meth);
413 lt_padxv_map_store(o, orig_pkg, type_pkg, type_meth, o->op_ppaddr);
422 static OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
424 static OP *lt_ck_padsv(pTHX_ OP *o) {
427 return lt_old_ck_padsv(aTHX_ o);
430 /* --- Our peephole optimizer ---------------------------------------------- */
432 #if XSH_HAS_PERL(5, 17, 6)
434 static int lt_maybe_padrange_setup(pTHX_ OP *o, const OP *start) {
435 #define lt_maybe_padrange_setup(O, S) lt_maybe_padrange_setup(aTHX_ (O), (S))
439 count = o->op_private & OPpPADRANGE_COUNTMASK;
441 for (i = 0, p = start; i < count && p; ++i, p = p->op_next) {
442 if (p->op_type == OP_PADSV) {
443 /* In a padrange sequence, either all lexicals are typed, or none are.
444 * Thus we can stop at the first padsv op. However, note that these
445 * lexicals can need to call different methods in different packages. */
446 XSH_LOCK(<_op_map_mutex);
447 if (ptable_fetch(lt_op_padxv_map, p)) {
448 XSH_UNLOCK(<_op_map_mutex);
449 lt_padrange_map_store(o, start, o->op_ppaddr);
450 o->op_ppaddr = lt_pp_padrange;
452 XSH_UNLOCK(<_op_map_mutex);
463 static void xsh_peep_rec(pTHX_ OP *o, ptable *seen) {
464 for (; o; o = o->op_next) {
465 if (xsh_peep_seen(o, seen))
468 switch (o->op_type) {
470 if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) {
471 lt_op_padxv_info *oi;
472 XSH_LOCK(<_op_map_mutex);
473 oi = ptable_fetch(lt_op_padxv_map, o);
475 oi->old_pp = o->op_ppaddr;
476 o->op_ppaddr = lt_pp_padsv;
478 XSH_UNLOCK(<_op_map_mutex);
481 #if XSH_HAS_PERL(5, 17, 6)
483 /* We deal with special padrange ops later, in the aassign op they belong
485 if (o->op_ppaddr != lt_pp_padrange && o->op_private & OPpLVAL_INTRO
486 && !(o->op_flags & OPf_SPECIAL)) {
487 /* A padrange op is guaranteed to have previously been a pushmark.
488 * Moreover, for non-special padrange ops (i.e. that aren't for
489 * my (...) = @_), the first original padxv is its sibling or nephew.
491 OP *kid = OpSIBLING(o);
492 if (kid->op_type == OP_NULL && kid->op_flags & OPf_KIDS) {
493 kid = kUNOP->op_first;
494 if (kid->op_type == OP_NULL)
495 kid = OpSIBLING(kid);
497 lt_maybe_padrange_setup(o, kid);
502 if (cBINOPo->op_first && cBINOPo->op_first->op_flags & OPf_KIDS
503 && (op = cUNOPx(cBINOPo->op_first)->op_first)
504 && op->op_type == OP_PADRANGE
505 && op->op_ppaddr != lt_pp_padrange
506 && op->op_private & OPpLVAL_INTRO
507 && op->op_flags & OPf_SPECIAL) {
508 const OP *start = cUNOPx(cBINOPo->op_last)->op_first;
509 if (start->op_type == OP_PUSHMARK)
510 start = OpSIBLING(start);
511 lt_maybe_padrange_setup(op, start);
517 xsh_peep_maybe_recurse(o, seen);
523 /* --- Module setup/teardown ----------------------------------------------- */
525 static void xsh_user_global_setup(pTHX) {
526 lt_op_padxv_map = ptable_new(32);
527 #if XSH_HAS_PERL(5, 17, 6)
528 lt_op_padrange_map = ptable_new(32);
532 MUTEX_INIT(<_op_map_mutex);
535 xsh_ck_replace(OP_PADANY, lt_ck_padany, <_old_ck_padany);
536 xsh_ck_replace(OP_PADSV, lt_ck_padsv, <_old_ck_padsv);
541 static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt) {
544 stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1);
545 newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(XSH_THREADSAFE));
546 newCONSTSUB(stash, "LT_FORKSAFE", newSVuv(XSH_FORKSAFE));
548 cxt->default_meth = newSVpvn("TYPEDSCALAR", 11);
549 SvREADONLY_on(cxt->default_meth);
554 static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt) {
555 SvREFCNT_dec(cxt->default_meth);
556 cxt->default_meth = NULL;
561 static void xsh_user_global_teardown(pTHX) {
562 xsh_ck_restore(OP_PADANY, <_old_ck_padany);
563 xsh_ck_restore(OP_PADSV, <_old_ck_padsv);
565 ptable_map_free(lt_op_padxv_map);
566 lt_op_padxv_map = NULL;
568 #if XSH_HAS_PERL(5, 17, 6)
569 ptable_map_free(lt_op_padrange_map);
570 lt_op_padrange_map = NULL;
574 MUTEX_DESTROY(<_op_map_mutex);
580 /* --- XS ------------------------------------------------------------------ */
582 MODULE = Lexical::Types PACKAGE = Lexical::Types
608 else if (SvROK(code))
610 RETVAL = xsh_hints_tag(code);