X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e6dae479a92dc835be9b026ea350a20b94199aa2..4fa06845e75d453a3101cff32e24c5b743f9819e:/ext/B/B.xs diff --git a/ext/B/B.xs b/ext/B/B.xs index 66198e3..4e35c03 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -22,24 +22,14 @@ typedef FILE * InputStream; static const char* const svclassnames[] = { "B::NULL", -#if PERL_VERSION < 19 - "B::BIND", -#endif "B::IV", "B::NV", -#if PERL_VERSION <= 10 - "B::RV", -#endif "B::PV", -#if PERL_VERSION >= 19 "B::INVLIST", -#endif "B::PVIV", "B::PVNV", "B::PVMG", -#if PERL_VERSION >= 11 "B::REGEXP", -#endif "B::GV", "B::PVLV", "B::AV", @@ -103,8 +93,8 @@ static const size_t opsizes[] = { #define MY_CXT_KEY "B::_guts" XS_VERSION typedef struct { - int x_walkoptree_debug; /* Flag for walkoptree debug hook */ SV * x_specialsv_list[7]; + int x_walkoptree_debug; /* Flag for walkoptree debug hook */ } my_cxt_t; START_MY_CXT @@ -112,6 +102,17 @@ START_MY_CXT #define walkoptree_debug (MY_CXT.x_walkoptree_debug) #define specialsv_list (MY_CXT.x_specialsv_list) + +static void B_init_my_cxt(pTHX_ my_cxt_t * cxt) { + cxt->x_specialsv_list[0] = Nullsv; + cxt->x_specialsv_list[1] = &PL_sv_undef; + cxt->x_specialsv_list[2] = &PL_sv_yes; + cxt->x_specialsv_list[3] = &PL_sv_no; + cxt->x_specialsv_list[4] = (SV *) pWARN_ALL; + cxt->x_specialsv_list[5] = (SV *) pWARN_NONE; + cxt->x_specialsv_list[6] = (SV *) pWARN_STD; +} + static opclass cc_opclass(pTHX_ const OP *o) { @@ -130,11 +131,6 @@ cc_opclass(pTHX_ const OP *o) return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPc_UNOP : OPc_BINOP); if (o->op_type == OP_AELEMFAST) { -#if PERL_VERSION <= 14 - if (o->op_flags & OPf_SPECIAL) - return OPc_BASEOP; - else -#endif #ifdef USE_ITHREADS return OPc_PADOP; #else @@ -607,9 +603,7 @@ typedef SV *B__IV; typedef SV *B__PV; typedef SV *B__NV; typedef SV *B__PVMG; -#if PERL_VERSION >= 11 typedef SV *B__REGEXP; -#endif typedef SV *B__PVLV; typedef SV *B__BM; typedef SV *B__RV; @@ -672,7 +666,7 @@ static XSPROTO(intrpvar_sv_common) /* table that drives most of the B::*OP methods */ -struct OP_methods { +static const struct OP_methods { const char *name; U8 namelen; U8 type; /* if op_offset_special, access is handled on a case-by-case basis */ @@ -691,11 +685,7 @@ struct OP_methods { { STR_WITH_LEN("nextop"), OPp, STRUCT_OFFSET(struct loop, op_nextop), },/*10*/ { STR_WITH_LEN("lastop"), OPp, STRUCT_OFFSET(struct loop, op_lastop), },/*11*/ { STR_WITH_LEN("pmflags"), U32p, STRUCT_OFFSET(struct pmop, op_pmflags),},/*12*/ -#if PERL_VERSION >= 17 { STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/ -#else - { STR_WITH_LEN("code_list"),op_offset_special, 0, }, /*13*/ -#endif { STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/ { STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/ { STR_WITH_LEN("padix"), PADOFFSETp,STRUCT_OFFSET(struct padop, op_padix),},/*16*/ @@ -707,13 +697,8 @@ struct OP_methods { { STR_WITH_LEN("filegv"), op_offset_special, 0, },/*21*/ { STR_WITH_LEN("file"), char_pp, STRUCT_OFFSET(struct cop, cop_file), },/*22*/ { STR_WITH_LEN("stash"), op_offset_special, 0, },/*23*/ -# if PERL_VERSION < 17 - { STR_WITH_LEN("stashpv"), char_pp, STRUCT_OFFSET(struct cop, cop_stashpv),}, /*24*/ - { STR_WITH_LEN("stashoff"),op_offset_special, 0, },/*25*/ -# else { STR_WITH_LEN("stashpv"), op_offset_special, 0, },/*24*/ { STR_WITH_LEN("stashoff"),PADOFFSETp,STRUCT_OFFSET(struct cop,cop_stashoff),},/*25*/ -# endif #else { STR_WITH_LEN("pmoffset"),op_offset_special, 0, },/*20*/ { STR_WITH_LEN("filegv"), SVp, STRUCT_OFFSET(struct cop, cop_filegv),},/*21*/ @@ -743,17 +728,12 @@ struct OP_methods { { STR_WITH_LEN("warnings"),op_offset_special, 0, },/*44*/ { STR_WITH_LEN("io"), op_offset_special, 0, },/*45*/ { STR_WITH_LEN("hints_hash"),op_offset_special, 0, },/*46*/ -#if PERL_VERSION >= 17 { STR_WITH_LEN("slabbed"), op_offset_special, 0, },/*47*/ { STR_WITH_LEN("savefree"),op_offset_special, 0, },/*48*/ { STR_WITH_LEN("static"), op_offset_special, 0, },/*49*/ -# if PERL_VERSION >= 19 { STR_WITH_LEN("folded"), op_offset_special, 0, },/*50*/ - { STR_WITH_LEN("lastsib"), op_offset_special, 0, },/*51*/ + { STR_WITH_LEN("moresib"), op_offset_special, 0, },/*51*/ { STR_WITH_LEN("parent"), op_offset_special, 0, },/*52*/ -# endif -#endif -#if PERL_VERSION >= 21 { STR_WITH_LEN("first"), op_offset_special, 0, },/*53*/ { STR_WITH_LEN("meth_sv"), op_offset_special, 0, },/*54*/ { STR_WITH_LEN("pmregexp"),op_offset_special, 0, },/*55*/ @@ -762,7 +742,6 @@ struct OP_methods { # else { STR_WITH_LEN("rclass"), op_offset_special, 0, },/*56*/ # endif -#endif }; #include "const-c.inc" @@ -777,15 +756,9 @@ BOOT: { CV *cv; const char *file = __FILE__; + SV *sv; MY_CXT_INIT; - specialsv_list[0] = Nullsv; - specialsv_list[1] = &PL_sv_undef; - specialsv_list[2] = &PL_sv_yes; - specialsv_list[3] = &PL_sv_no; - specialsv_list[4] = (SV *) pWARN_ALL; - specialsv_list[5] = (SV *) pWARN_NONE; - specialsv_list[6] = (SV *) pWARN_STD; - + B_init_my_cxt(aTHX_ &(MY_CXT)); cv = newXS("B::init_av", intrpvar_sv_common, file); ASSIGN_COMMON_ALIAS(I, initav); cv = newXS("B::check_av", intrpvar_sv_common, file); @@ -816,6 +789,12 @@ BOOT: ASSIGN_COMMON_ALIAS(I, warnhook); cv = newXS("B::diehook", intrpvar_sv_common, file); ASSIGN_COMMON_ALIAS(I, diehook); + sv = get_sv("B::OP::does_parent", GV_ADDMULTI); +#ifdef PERL_OP_PARENT + sv_setsv(sv, &PL_sv_yes); +#else + sv_setsv(sv, &PL_sv_no); +#endif } #ifndef PL_formfeed @@ -975,7 +954,18 @@ threadsv_names() PPCODE: +#ifdef USE_ITHREADS +void +CLONE(...) +PPCODE: + PUTBACK; /* some vars go out of scope now in machine code */ + { + MY_CXT_CLONE; + B_init_my_cxt(aTHX_ &(MY_CXT)); + } + return; /* dont execute another implied XSPP PUTBACK */ +#endif MODULE = B PACKAGE = B::OP @@ -1038,7 +1028,7 @@ next(o) B::OP::savefree = 48 B::OP::static = 49 B::OP::folded = 50 - B::OP::lastsib = 51 + B::OP::moresib = 51 B::OP::parent = 52 B::METHOP::first = 53 B::METHOP::meth_sv = 54 @@ -1086,18 +1076,12 @@ next(o) ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o)); break; #endif -#if PERL_VERSION >= 17 || !defined USE_ITHREADS case 24: /* B::COP::stashpv */ -# if PERL_VERSION >= 17 ret = sv_2mortal(CopSTASH((COP*)o) && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV ? newSVhek(HvNAME_HEK(CopSTASH((COP*)o))) : &PL_sv_undef); -# else - ret = sv_2mortal(newSVpv(CopSTASHPV((COP*)o), 0)); -# endif break; -#endif case 26: /* B::OP::size */ ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)]))); break; @@ -1118,15 +1102,11 @@ next(o) case 30: /* B::OP::type */ case 31: /* B::OP::opt */ case 32: /* B::OP::spare */ -#if PERL_VERSION >= 17 case 47: /* B::OP::slabbed */ case 48: /* B::OP::savefree */ case 49: /* B::OP::static */ -#if PERL_VERSION >= 19 case 50: /* B::OP::folded */ - case 51: /* B::OP::lastsib */ -#endif -#endif + case 51: /* B::OP::moresib */ /* These are all bitfields, so we can't take their addresses */ ret = sv_2mortal(newSVuv((UV)( ix == 30 ? o->op_type @@ -1135,7 +1115,7 @@ next(o) : ix == 48 ? o->op_savefree : ix == 49 ? o->op_static : ix == 50 ? o->op_folded - : ix == 51 ? o->op_lastsib + : ix == 51 ? o->op_moresib : o->op_spare))); break; case 33: /* B::LISTOP::children */ @@ -1238,7 +1218,11 @@ next(o) PTR2IV(CopHINTHASH_get(cCOPo))); break; case 52: /* B::OP::parent */ +#ifdef PERL_OP_PARENT ret = make_op_object(aTHX_ op_parent(o)); +#else + ret = make_op_object(aTHX_ NULL); +#endif break; case 53: /* B::METHOP::first */ /* METHOP struct has an op_first/op_meth_sv union @@ -1341,14 +1325,30 @@ string(o, cv) B::CV cv PREINIT: SV *ret; + UNOP_AUX_item *aux; PPCODE: + aux = cUNOP_AUXo->op_aux; switch (o->op_type) { case OP_MULTIDEREF: - ret = unop_aux_stringify(o, cv); + ret = multideref_stringify(o, cv); + break; + + case OP_ARGELEM: + ret = sv_2mortal(Perl_newSVpvf(aTHX_ "%"UVuf, + PTR2UV(aux))); + break; + + case OP_ARGCHECK: + ret = Perl_newSVpvf(aTHX_ "%"UVuf",%"UVuf, aux[0].uv, aux[1].uv); + if (aux[2].iv) + Perl_sv_catpvf(aTHX_ ret, ",%c", (char)aux[2].iv); + ret = sv_2mortal(ret); break; + default: ret = sv_2mortal(newSVpvn("", 0)); } + ST(0) = ret; XSRETURN(1); @@ -1362,12 +1362,28 @@ void aux_list(o, cv) B::OP o B::CV cv + PREINIT: + UNOP_AUX_item *aux; PPCODE: PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */ + aux = cUNOP_AUXo->op_aux; switch (o->op_type) { default: XSRETURN(0); /* by default, an empty list */ + case OP_ARGELEM: + XPUSHs(sv_2mortal(newSVuv(PTR2UV(aux)))); + XSRETURN(1); + break; + + case OP_ARGCHECK: + EXTEND(SP, 3); + PUSHs(sv_2mortal(newSVuv(aux[0].uv))); + PUSHs(sv_2mortal(newSVuv(aux[1].uv))); + PUSHs(sv_2mortal(aux[2].iv ? Perl_newSVpvf(aTHX_ "%c", + (char)aux[2].iv) : &PL_sv_no)); + break; + case OP_MULTIDEREF: #ifdef USE_ITHREADS # define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE); @@ -1383,10 +1399,12 @@ aux_list(o, cv) bool is_hash = FALSE; #ifdef USE_ITHREADS PADLIST * const padlist = CvPADLIST(cv); - PAD *comppad = comppad = PadlistARRAY(padlist)[1]; + PAD *comppad = PadlistARRAY(padlist)[1]; #endif - EXTEND(SP, len); + /* len should never be big enough to truncate or wrap */ + assert(len <= SSize_t_MAX); + EXTEND(SP, (SSize_t)len); PUSHs(sv_2mortal(newSViv(actions))); while (!last) { @@ -1396,36 +1414,46 @@ aux_list(o, cv) actions = (++items)->uv; PUSHs(sv_2mortal(newSVuv(actions))); continue; + NOT_REACHED; /* NOTREACHED */ case MDEREF_HV_padhv_helem: is_hash = TRUE; + /* FALLTHROUGH */ case MDEREF_AV_padav_aelem: PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); goto do_elem; + NOT_REACHED; /* NOTREACHED */ case MDEREF_HV_gvhv_helem: is_hash = TRUE; + /* FALLTHROUGH */ case MDEREF_AV_gvav_aelem: sv = ITEM_SV(++items); PUSHs(make_sv_object(aTHX_ sv)); goto do_elem; + NOT_REACHED; /* NOTREACHED */ case MDEREF_HV_gvsv_vivify_rv2hv_helem: is_hash = TRUE; + /* FALLTHROUGH */ case MDEREF_AV_gvsv_vivify_rv2av_aelem: sv = ITEM_SV(++items); PUSHs(make_sv_object(aTHX_ sv)); goto do_vivify_rv2xv_elem; + NOT_REACHED; /* NOTREACHED */ case MDEREF_HV_padsv_vivify_rv2hv_helem: is_hash = TRUE; + /* FALLTHROUGH */ case MDEREF_AV_padsv_vivify_rv2av_aelem: PUSHs(sv_2mortal(newSVuv((++items)->pad_offset))); goto do_vivify_rv2xv_elem; + NOT_REACHED; /* NOTREACHED */ case MDEREF_HV_pop_rv2hv_helem: case MDEREF_HV_vivify_rv2hv_helem: is_hash = TRUE; + /* FALLTHROUGH */ do_vivify_rv2xv_elem: case MDEREF_AV_pop_rv2av_aelem: case MDEREF_AV_vivify_rv2av_aelem: @@ -1521,13 +1549,7 @@ MODULE = B PACKAGE = B::IV #define PVMG_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvmg, xmg_stash) -#if PERL_VERSION > 18 -# define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv) -#elif PERL_VERSION > 14 -# define PVBM_useful_ix sv_I32p | STRUCT_OFFSET(struct xpvgv, xnv_u.xbm_s.xbm_useful) -#else -#define PVBM_useful_ix sv_I32p | STRUCT_OFFSET(struct xpvgv, xiv_u.xivu_i32) -#endif +#define PVBM_useful_ix sv_IVp | STRUCT_OFFSET(struct xpviv, xiv_u.xivu_iv) #define PVLV_targoff_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targoff) #define PVLV_targlen_ix sv_U32p | STRUCT_OFFSET(struct xpvlv, xlv_targlen) @@ -1553,23 +1575,14 @@ MODULE = B PACKAGE = B::IV #define PVAV_max_ix sv_SSize_tp | STRUCT_OFFSET(struct xpvav, xav_max) #define PVCV_stash_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_stash) -#if PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 3) -# define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv) -#else -# define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv) -#endif +#define PVCV_gv_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_gv_u.xcv_gv) #define PVCV_file_ix sv_char_pp | STRUCT_OFFSET(struct xpvcv, xcv_file) #define PVCV_outside_ix sv_SVp | STRUCT_OFFSET(struct xpvcv, xcv_outside) #define PVCV_outside_seq_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_outside_seq) #define PVCV_flags_ix sv_U32p | STRUCT_OFFSET(struct xpvcv, xcv_flags) #define PVHV_max_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_max) - -#if PERL_VERSION > 12 #define PVHV_keys_ix sv_STRLENp | STRUCT_OFFSET(struct xpvhv, xhv_keys) -#else -#define PVHV_keys_ix sv_IVp | STRUCT_OFFSET(struct xpvhv, xhv_keys) -#endif # The type checking code in B has always been identical for all SV types, # irrespective of whether the action is actually defined on that SV. @@ -1695,18 +1708,6 @@ NV SvNV(sv) B::NV sv -#if PERL_VERSION < 11 - -MODULE = B PACKAGE = B::RV PREFIX = Sv - -void -SvRV(sv) - B::RV sv - PPCODE: - PUSHs(make_sv_object(aTHX_ SvRV(sv))); - -#else - MODULE = B PACKAGE = B::REGEXP void @@ -1715,19 +1716,21 @@ REGEX(sv) ALIAS: precomp = 1 qr_anoncv = 2 + compflags = 3 PPCODE: if (ix == 1) { PUSHs(newSVpvn_flags(RX_PRECOMP(sv), RX_PRELEN(sv), SVs_TEMP)); - } else if (ix) { + } else if (ix == 2) { PUSHs(make_sv_object(aTHX_ (SV *)ReANY(sv)->qr_anoncv)); } else { dXSTARG; + if (ix) + PUSHu(RX_COMPFLAGS(sv)); + else /* FIXME - can we code this method more efficiently? */ - PUSHi(PTR2IV(sv)); + PUSHi(PTR2IV(sv)); } -#endif - MODULE = B PACKAGE = B::PV void @@ -1899,9 +1902,7 @@ U32 BmPREVIOUS(sv) B::BM sv CODE: -#if PERL_VERSION >= 19 PERL_UNUSED_VAR(sv); -#endif RETVAL = BmPREVIOUS(sv); OUTPUT: RETVAL @@ -1911,9 +1912,7 @@ U8 BmRARE(sv) B::BM sv CODE: -#if PERL_VERSION >= 19 PERL_UNUSED_VAR(sv); -#endif RETVAL = BmRARE(sv); OUTPUT: RETVAL @@ -2150,8 +2149,6 @@ GV(cv) CODE: ST(0) = make_sv_object(aTHX_ (SV*)CvGV(cv)); -#if PERL_VERSION > 17 - SV * NAME_HEK(cv) B::CV cv @@ -2160,8 +2157,6 @@ NAME_HEK(cv) OUTPUT: RETVAL -#endif - MODULE = B PACKAGE = B::HV PREFIX = Hv STRLEN @@ -2178,8 +2173,12 @@ HvARRAY(hv) PPCODE: if (HvUSEDKEYS(hv) > 0) { HE *he; + SSize_t extend_size; (void)hv_iterinit(hv); - EXTEND(sp, HvUSEDKEYS(hv) * 2); + /* 2*HvUSEDKEYS() should never be big enough to truncate or wrap */ + assert(HvUSEDKEYS(hv) <= (SSize_t_MAX >> 1)); + extend_size = (SSize_t)HvUSEDKEYS(hv) * 2; + EXTEND(sp, extend_size); while ((he = hv_iternext(hv))) { if (HeSVKEY(he)) { mPUSHs(HeSVKEY(he)); @@ -2310,10 +2309,6 @@ PadnamelistARRAYelt(pnl, idx) OUTPUT: RETVAL -U32 -PadnamelistREFCNT(pnl) - B::PADNAMELIST pnl - MODULE = B PACKAGE = B::PADNAME PREFIX = Padname #define PN_type_ix \ @@ -2328,10 +2323,13 @@ MODULE = B PACKAGE = B::PADNAME PREFIX = Padname sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low) #define PN_cop_seq_range_high_ix \ sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high) -#define PN_parent_pad_index_ix \ - sv_U32p | STRUCT_OFFSET(struct padname, xpadn_low) -#define PN_parent_fakelex_flags_ix \ - sv_U32p | STRUCT_OFFSET(struct padname, xpadn_high) +#define PNL_refcnt_ix \ + sv_U32p | STRUCT_OFFSET(struct padnamelist, xpadnl_refcnt) +#define PL_id_ix \ + sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_id) +#define PL_outid_ix \ + sv_U32p | STRUCT_OFFSET(struct padlist, xpadl_outid) + void PadnameTYPE(pn) @@ -2343,8 +2341,9 @@ PadnameTYPE(pn) B::PADNAME::REFCNT = PN_refcnt_ix B::PADNAME::COP_SEQ_RANGE_LOW = PN_cop_seq_range_low_ix B::PADNAME::COP_SEQ_RANGE_HIGH = PN_cop_seq_range_high_ix - B::PADNAME::PARENT_PAD_INDEX = PN_parent_pad_index_ix - B::PADNAME::PARENT_FAKELEX_FLAGS = PN_parent_fakelex_flags_ix + B::PADNAMELIST::REFCNT = PNL_refcnt_ix + B::PADLIST::id = PL_id_ix + B::PADLIST::outid = PL_outid_ix PREINIT: char *ptr; SV *ret; @@ -2385,6 +2384,13 @@ BOOT: sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PROTOCV",1,SVt_PVGV),(SV *)gv); sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PVX",1,SVt_PVGV), (SV *)gv_fetchpvs("B::PADNAME::PV" ,1,SVt_PVGV)); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_PAD_INDEX" ,1,SVt_PVGV), + (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_LOW",1, + SVt_PVGV)); + sv_setsv((SV *)gv_fetchpvs("B::PADNAME::PARENT_FAKELEX_FLAGS",1, + SVt_PVGV), + (SV *)gv_fetchpvs("B::PADNAME::COP_SEQ_RANGE_HIGH" ,1, + SVt_PVGV)); } U32 @@ -2395,7 +2401,7 @@ PadnameFLAGS(pn) /* backward-compatibility hack, which should be removed if the flags field becomes large enough to hold SVf_FAKE (and PADNAMEt_OUTER should be renumbered to match SVf_FAKE) */ - assert(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS(pn)) * 8)); + STATIC_ASSERT_STMT(SVf_FAKE >= 1<<(sizeof(PadnameFLAGS((B__PADNAME)NULL)) * 8)); if (PadnameOUTER(pn)) RETVAL |= SVf_FAKE; OUTPUT: