From: Vincent Pit Date: Sat, 4 Oct 2014 22:23:01 +0000 (+0200) Subject: WIP X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FLexical-Types.git;a=commitdiff_plain;h=6ffadfb9c7a61ecec543531ef0a56c7c6918faf5 WIP --- diff --git a/Types.xs b/Types.xs index 6ead2eb..c0b1d1d 100644 --- a/Types.xs +++ b/Types.xs @@ -16,10 +16,12 @@ #if LT_HAS_PERL(5, 10, 0) || defined(PL_parser) # ifndef PL_in_my_stash # define PL_in_my_stash PL_parser->in_my_stash +# define PL_tokenbuf PL_parser->tokenbuf # endif #else # ifndef PL_in_my_stash # define PL_in_my_stash PL_Iin_my_stash +# define PL_tokenbuf PL_Itokenbuf # endif #endif @@ -31,6 +33,14 @@ # define LT_HAS_RPEEP LT_HAS_PERL(5, 13, 5) #endif +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) ("" s ""), (sizeof(s)-1) +#endif + +#ifndef newSVpvs +# define newSVpvs(S) Perl_newSVpvn(aTHX_ STR_WITH_LEN(S)) +#endif + #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif @@ -197,13 +207,28 @@ typedef SV lt_hint_t; #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION +#define LT_TYPE_SCALAR 0 + +#if LT_HAS_PERL(5, 11, 1) + +#define LT_TYPE_ARRAY 1 +#define LT_TYPE_HASH 2 + +#define LT_TYPE_COUNT 3 + +#else + +#define LT_TYPE_COUNT 1 + +#endif + typedef struct { #if LT_THREADSAFE ptable *tbl; /* It really is a ptable_hints */ tTHX owner; #endif ptable *seen; /* It really is a ptable_seen */ - SV *default_meth; + SV *default_meth[LT_TYPE_COUNT]; } my_cxt_t; START_MY_CXT @@ -439,9 +464,14 @@ typedef struct { #endif /* !MULTIPLICITY */ } lt_op_padxv_info; +STATIC const char lt_type_desc_scalar[] = "scalar"; +STATIC const char lt_type_desc_array[] = "array"; +STATIC const char lt_type_desc_hash[] = "hash"; + STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) { #define lt_op_padxv_info_call(O, S) lt_op_padxv_info_call(aTHX_ (O), (S)) SV *orig_pkg, *type_pkg, *type_meth; + svtype var_type; int items; dSP; @@ -470,7 +500,16 @@ STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) { PUSHMARK(SP); EXTEND(SP, 3); PUSHs(type_pkg); - PUSHs(sv); + var_type = SvTYPE(sv); + switch (var_type) { + case SVt_PVAV: + case SVt_PVHV: + PUSHs(sv_2mortal(newRV_inc(sv))); + break; + default: + PUSHs(sv); + break; + } PUSHs(orig_pkg); PUTBACK; @@ -480,11 +519,64 @@ STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) { switch (items) { case 0: break; - case 1: - sv_setsv(sv, POPs); + case 1: { + SV *rsv = POPs; + switch (var_type) { + case SVt_PVAV: + if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) { + AV *av = (AV *) SvRV(rsv); + SV **src, **dst; + I32 len = av_len(av); + I32 i; + av_fill((AV *) sv, len); + src = AvARRAY(av); + dst = AvARRAY(sv); + for (i = 0; i <= len; ++i, ++src, ++dst) { + SvREFCNT_dec(*dst); + *dst = SvREFCNT_inc(*src); + } + } else { + goto type_mismatch; + } + break; + case SVt_PVHV: + if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) { + HV *hv = (HV *) SvRV(rsv); + HE *he; + hv_iterinit(hv); + hv_clear((HV *) sv); + while ((he = hv_iternext(hv)) != NULL) { + SV *val = SvREFCNT_inc(HeVAL(he)); + if (!hv_store((HV *) sv, HeKEY(he), HeKLEN(he), val, HeHASH(he))) + SvREFCNT_dec(val); + } + } else { + goto type_mismatch; + } + break; + default: + sv_setsv(sv, rsv); + break; + } break; - default: - croak("Typed scalar initializer method should return zero or one scalar, but got %d", items); +type_mismatch: + croak("Type mismatch"); + } + default: { + const char *type_desc; + switch (var_type) { + case SVt_PVAV: + type_desc = lt_type_desc_array; + break; + case SVt_PVHV: + type_desc = lt_type_desc_hash; + break; + default: + type_desc = lt_type_desc_scalar; + break; + } + croak("Typed %s initializer method should return zero or one scalar, but got %d", type_desc, items); + } } PUTBACK; @@ -626,7 +718,7 @@ STATIC void lt_map_delete(pTHX_ const OP *o) { /* ... Our pp_padsv ........................................................ */ -STATIC OP *lt_pp_padsv(pTHX) { +STATIC OP *lt_pp_padxv(pTHX) { lt_op_padxv_info oi; if (lt_padxv_map_fetch(PL_op, &oi)) { @@ -654,8 +746,19 @@ STATIC OP *lt_pp_padrange(pTHX) { for (i = 0, p = roi.padxv_start; i < count && p; ++i, p = p->op_sibling) { lt_op_padxv_info oi; - if (p->op_type == OP_PADSV && lt_padxv_map_fetch(p, &oi)) - lt_op_padxv_info_call(&oi, PAD_SV(base + i)); + + switch (p->op_type) { + case OP_PADSV: +#if LT_HAS_PERL(5, 11, 1) + case OP_PADAV: + case OP_PADHV: +#endif + if (lt_padxv_map_fetch(p, &oi)) + lt_op_padxv_info_call(&oi, PAD_SV(base + i)); + break; + default: + break; + } } return roi.old_pp(aTHX); @@ -666,10 +769,10 @@ STATIC OP *lt_pp_padrange(pTHX) { #endif -/* ... Our ck_pad{any,sv} .................................................. */ +/* ... Our ck_pad{any,sv,av,hv} ............................................ */ -/* Sadly, the padsv OPs we are interested in don't trigger the padsv check - * function, but are instead manually mutated from a padany. So we store +/* Sadly, the padxv OPs we are interested in don't trigger the padxv check + * functions, but are instead manually mutated from a padany. So we store * the op entry in the op map in the padany check function, and we set their * op_ppaddr member in our peephole optimizer replacement below. */ @@ -685,11 +788,34 @@ STATIC OP *lt_ck_padany(pTHX_ OP *o) { if (stash && (code = lt_hint())) { dMY_CXT; SV *orig_pkg = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash)); - SV *orig_meth = MY_CXT.default_meth; + SV *orig_meth = NULL; SV *type_pkg = NULL; SV *type_meth = NULL; + unsigned int type; + const char *s; int items; + s = PL_tokenbuf; + while (*s && isSPACE(*s)) + ++s; + switch (*s) { + case '$': + type = LT_TYPE_SCALAR; + break; +#if LT_HAS_PERL(5, 11, 1) + case '@': + type = LT_TYPE_ARRAY; + break; + case '%': + type = LT_TYPE_HASH; + break; +#endif + default: + croak("Unsupported sigil '%c'", *s); + break; + } + orig_meth = MY_CXT.default_meth[type]; + dSP; SvREADONLY_on(orig_pkg); @@ -760,6 +886,26 @@ STATIC OP *lt_ck_padsv(pTHX_ OP *o) { return lt_old_ck_padsv(aTHX_ o); } +#if LT_HAS_PERL(5, 11, 1) + +STATIC OP *(*lt_old_ck_padav)(pTHX_ OP *) = 0; + +STATIC OP *lt_ck_padav(pTHX_ OP *o) { + lt_map_delete(o); + + return lt_old_ck_padav(aTHX_ o); +} + +STATIC OP *(*lt_old_ck_padhv)(pTHX_ OP *) = 0; + +STATIC OP *lt_ck_padhv(pTHX_ OP *o) { + lt_map_delete(o); + + return lt_old_ck_padhv(aTHX_ o); +} + +#endif + /* ... Our peephole optimizer .............................................. */ #if LT_HAS_PERL(5, 17, 6) @@ -772,19 +918,27 @@ STATIC int lt_maybe_padrange_setup(pTHX_ OP *o, const OP *start) { count = o->op_private & OPpPADRANGE_COUNTMASK; for (i = 0, p = start; i < count && p; ++i, p = p->op_sibling) { - if (p->op_type == OP_PADSV) { - /* In a padrange sequence, either all lexicals are typed, or none are. - * Thus we can stop at the first padsv op. However, note that these - * lexicals can need to call different methods in different packages. */ - LT_LOCK(<_op_map_mutex); - if (ptable_fetch(lt_op_padxv_map, p)) { - LT_UNLOCK(<_op_map_mutex); - lt_padrange_map_store(o, start, o->op_ppaddr); - o->op_ppaddr = lt_pp_padrange; - } else { - LT_UNLOCK(<_op_map_mutex); - } - return 1; + switch (p->op_type) { + case OP_PADSV: +#if LT_HAS_PERL(5, 11, 1) + case OP_PADAV: + case OP_PADHV: +#endif + /* In a padrange sequence, either all lexicals are typed, or none are. + * Thus we can stop at the first padsv op. However, note that these + * lexicals can need to call different methods in different packages. */ + LT_LOCK(<_op_map_mutex); + if (ptable_fetch(lt_op_padxv_map, p)) { + LT_UNLOCK(<_op_map_mutex); + lt_padrange_map_store(o, start, o->op_ppaddr); + o->op_ppaddr = lt_pp_padrange; + } else { + LT_UNLOCK(<_op_map_mutex); + } + return 1; + break; + default: + break; } } @@ -804,13 +958,17 @@ STATIC void lt_peep_rec(pTHX_ OP *o, ptable *seen) { switch (o->op_type) { case OP_PADSV: - if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) { +#if LT_HAS_PERL(5, 11, 1) + case OP_PADAV: + case OP_PADHV: +#endif + if (o->op_ppaddr != lt_pp_padxv && o->op_private & OPpLVAL_INTRO) { lt_op_padxv_info *oi; LT_LOCK(<_op_map_mutex); oi = ptable_fetch(lt_op_padxv_map, o); if (oi) { oi->old_pp = o->op_ppaddr; - o->op_ppaddr = lt_pp_padsv; + o->op_ppaddr = lt_pp_padxv; } LT_UNLOCK(<_op_map_mutex); } @@ -909,16 +1067,22 @@ STATIC void lt_teardown(pTHX_ void *root) { #endif { + unsigned int i; dMY_CXT; #if LT_THREADSAFE ptable_hints_free(MY_CXT.tbl); #endif ptable_seen_free(MY_CXT.seen); - SvREFCNT_dec(MY_CXT.default_meth); + for (i = 0; i < LT_TYPE_COUNT; ++i) + SvREFCNT_dec(MY_CXT.default_meth[i]); } lt_ck_restore(OP_PADANY, <_old_ck_padany); lt_ck_restore(OP_PADSV, <_old_ck_padsv); +#if LT_HAS_PERL(5, 11, 1) + lt_ck_restore(OP_PADAV, <_old_ck_padav); + lt_ck_restore(OP_PADHV, <_old_ck_padhv); +#endif #if LT_HAS_RPEEP PL_rpeepp = lt_old_peep; @@ -938,16 +1102,26 @@ STATIC void lt_setup(pTHX) { { MY_CXT_INIT; #if LT_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; +#endif + MY_CXT.seen = ptable_new(); + MY_CXT.default_meth[LT_TYPE_SCALAR] = newSVpvs("TYPEDSCALAR"); + SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_SCALAR]); +#if LT_HAS_PERL(5, 11, 1) + MY_CXT.default_meth[LT_TYPE_ARRAY] = newSVpvs("TYPEDARRAY"); + SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_ARRAY]); + MY_CXT.default_meth[LT_TYPE_HASH] = newSVpvs("TYPEDHASH"); + SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_HASH]); #endif - MY_CXT.seen = ptable_new(); - MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11); - SvREADONLY_on(MY_CXT.default_meth); } lt_ck_replace(OP_PADANY, lt_ck_padany, <_old_ck_padany); lt_ck_replace(OP_PADSV, lt_ck_padsv, <_old_ck_padsv); +#if LT_HAS_PERL(5, 11, 1) + lt_ck_replace(OP_PADAV, lt_ck_padav, <_old_ck_padav); + lt_ck_replace(OP_PADHV, lt_ck_padhv, <_old_ck_padhv); +#endif #if LT_HAS_RPEEP lt_old_peep = PL_rpeepp; @@ -1003,9 +1177,10 @@ void CLONE(...) PROTOTYPE: DISABLE PREINIT: - ptable *t; - ptable *s; - SV *cloned_default_meth; + ptable *t; + ptable *s; + SV *cloned_default_meth[LT_TYPE_COUNT]; + unsigned int i; PPCODE: { { @@ -1015,17 +1190,19 @@ PPCODE: t = ptable_new(); lt_ptable_clone_ud_init(ud, t, MY_CXT.owner); ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud); - cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud); + for (i = 0; i < LT_TYPE_COUNT; ++i) + cloned_default_meth[i] = lt_dup_inc(MY_CXT.default_meth[i], &ud); lt_ptable_clone_ud_deinit(ud); } s = ptable_new(); } { MY_CXT_CLONE; - MY_CXT.tbl = t; - MY_CXT.owner = aTHX; - MY_CXT.seen = s; - MY_CXT.default_meth = cloned_default_meth; + MY_CXT.tbl = t; + MY_CXT.owner = aTHX; + MY_CXT.seen = s; + for (i = 0; i < LT_TYPE_COUNT; ++i) + MY_CXT.default_meth[i] = cloned_default_meth[i]; } reap(3, lt_thread_cleanup, NULL); XSRETURN(0);