From 401d481e22f218be07530ed5ba64dc4974b62104 Mon Sep 17 00:00:00 2001 From: "Paul \"LeoNerd\" Evans" Date: Wed, 4 Dec 2024 16:59:15 +0000 Subject: [PATCH] Initial progress at OP_MULTIPARAM An initial attempt at implementing OP_MULTIPARAM by rewriting arg ops. Handles mandatory, optional, and slurpy params. Implement optional parameters with OP_PARAMTEST and OP_PARAMSTORE; use the same SvPADSTALE flag trick that XS-Parse-Sublike uses --- dump.c | 30 +++++ lib/B/Op_private.pm | 8 +- op.h | 10 ++ opcode.h | 10 +- peep.c | 283 +++++++++++++++++++++++++++++++++++++++ pp.c | 117 +++++++++++++++- regen/op_private | 6 + t/op/signatures_faster.t | 100 ++++++++++++++ t/perf/opcount.t | 57 ++++++++ 9 files changed, 613 insertions(+), 8 deletions(-) create mode 100644 t/op/signatures_faster.t diff --git a/dump.c b/dump.c index cdbbb0e2819d..4bf39302c0a7 100644 --- a/dump.c +++ b/dump.c @@ -1446,6 +1446,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_ARGDEFELEM: case OP_ENTERTRY: case OP_ONCE: + case OP_PARAMTEST: S_opdump_indent(aTHX_ o, level, bar, file, "OTHER"); S_opdump_link(aTHX_ o, cLOGOPo->op_other, file); break; @@ -1563,6 +1564,35 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) break; } + case OP_MULTIPARAM: + { + struct op_multiparam_aux *aux = (struct op_multiparam_aux *)cUNOP_AUXo->op_aux; + UV nparams = aux->params; + UV nparams_mandatory = nparams - aux->opt_params; + if(aux->opt_params) + S_opdump_indent(aTHX_ o, level, bar, file, "PARAMS = %" UVuf " .. %" UVuf "\n", + nparams - aux->opt_params, nparams); + else + S_opdump_indent(aTHX_ o, level, bar, file, "PARAMS = %" UVuf "\n", + nparams); + + for(Size_t i = 0; i < nparams; i++) { + PADOFFSET padix = aux->param_padix[i]; + if(padix) + S_opdump_indent(aTHX_ o, level, bar, file, " PARAM [%zd] PADIX = %" UVuf "%s\n", + i, aux->param_padix[i], i >= nparams_mandatory ? " OPT" : ""); + else + S_opdump_indent(aTHX_ o, level, bar, file, " PARAM [%zd] ANON\n", + i); + } + + if(aux->slurpy) + S_opdump_indent(aTHX_ o, level, bar, file, "SLURPY = '%c' PADIX = %" UVuf "\n", + aux->slurpy, aux->slurpy_padix); + + break; + } + case OP_CUSTOM: { void (*custom_dumper)(pTHX_ const OP *o, struct Perl_OpDumpContext *ctx) = diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm index cd15fcc7512d..bf5547dd282d 100644 --- a/lib/B/Op_private.pm +++ b/lib/B/Op_private.pm @@ -498,7 +498,7 @@ $bits{padhv}{0} = 'OPpPADHV_ISKEYS'; @{$bits{padsv}}{5,4} = ($bf[9], $bf[9]); $bits{padsv_store}{0} = $bf[0]; $bits{paramstore}{0} = $bf[0]; -$bits{paramtest}{0} = $bf[0]; +@{$bits{paramtest}}{7,6,0} = ('OPpPARAM_IF_UNDEF', 'OPpPARAM_IF_FALSE', $bf[0]); @{$bits{pipe_op}}{3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5]); $bits{pop}{0} = $bf[0]; $bits{pos}{0} = $bf[0]; @@ -723,6 +723,8 @@ our %defines = ( OPpPADRANGE_COUNTMASK => 127, OPpPADRANGE_COUNTSHIFT => 7, OPpPAD_STATE => 64, + OPpPARAM_IF_FALSE => 64, + OPpPARAM_IF_UNDEF => 128, OPpPV_IS_UTF8 => 128, OPpREFCOUNTED => 64, OPpREPEAT_DOLIST => 64, @@ -844,6 +846,8 @@ our %labels = ( OPpOUR_INTRO => 'OURINTR', OPpPADHV_ISKEYS => 'KEYS', OPpPAD_STATE => 'STATE', + OPpPARAM_IF_FALSE => 'IF_FALSE', + OPpPARAM_IF_UNDEF => 'IF_UNDEF', OPpPV_IS_UTF8 => 'UTF', OPpREFCOUNTED => 'REFC', OPpREPEAT_DOLIST => 'DOLIST', @@ -920,6 +924,7 @@ our %ops_using = ( OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)], OPpPADHV_ISKEYS => [qw(padhv)], OPpPAD_STATE => [qw(emptyavhv lvavref lvref padav padhv padsv padsv_store pushmark refassign undef)], + OPpPARAM_IF_FALSE => [qw(paramtest)], OPpPV_IS_UTF8 => [qw(dump goto last next redo)], OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)], OPpREPEAT_DOLIST => [qw(repeat)], @@ -966,6 +971,7 @@ $ops_using{OPpMULTIDEREF_EXISTS} = $ops_using{OPpMULTIDEREF_DELETE}; $ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF}; $ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF}; $ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF}; +$ops_using{OPpPARAM_IF_UNDEF} = $ops_using{OPpPARAM_IF_FALSE}; $ops_using{OPpSLICE} = $ops_using{OPpKVSLICE}; $ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND}; $ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND}; diff --git a/op.h b/op.h index 0440de81f0a5..989a287ec2e3 100644 --- a/op.h +++ b/op.h @@ -1182,6 +1182,16 @@ struct op_argcheck_aux { char slurpy; /* presence of slurpy: may be '\0', '@' or '%' */ }; +/* for OP_MULTIPARAM */ + +struct op_multiparam_aux { + UV params; + UV opt_params; + char slurpy; + PADOFFSET *param_padix; /* points at storage allocated along with the struct itself, immediately following */ + PADOFFSET slurpy_padix; +}; + #define MI_INIT_WORKAROUND_PACK "Module::Install::DSL" diff --git a/opcode.h b/opcode.h index 25df804d9c38..359bb07dbbf6 100644 --- a/opcode.h +++ b/opcode.h @@ -2388,6 +2388,7 @@ END_EXTERN_C #define OPpOPEN_OUT_RAW 0x40 #define OPpOUR_INTRO 0x40 #define OPpPAD_STATE 0x40 +#define OPpPARAM_IF_FALSE 0x40 #define OPpREFCOUNTED 0x40 #define OPpREPEAT_DOLIST 0x40 #define OPpSLICE 0x40 @@ -2405,6 +2406,7 @@ END_EXTERN_C #define OPpLVAL_INTRO 0x80 #define OPpOFFBYONE 0x80 #define OPpOPEN_OUT_CRLF 0x80 +#define OPpPARAM_IF_UNDEF 0x80 #define OPpPV_IS_UTF8 0x80 #define OPpTRANS_DELETE 0x80 #define OPpCONST_TOKEN_MASK 0xc0 @@ -2997,7 +2999,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { 267, /* initfield */ -1, /* classname */ 0, /* multiparam */ - 0, /* paramtest */ + 192, /* paramtest */ 0, /* paramstore */ }; @@ -3017,7 +3019,7 @@ EXTCONST I16 PL_op_private_bitdef_ix[] = { */ EXTCONST U16 PL_op_private_bitdefs[] = { - 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, anywhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch, is_bool, is_weak, weaken, unweaken, is_tainted, multiparam, paramtest, paramstore */ + 0x0003, /* scalar, prototype, refgen, srefgen, readline, regcmaybe, regcreset, regcomp, substcont, chop, schop, defined, study, preinc, i_preinc, predec, i_predec, postinc, i_postinc, postdec, i_postdec, not, ucfirst, lcfirst, uc, lc, quotemeta, aeach, avalues, each, pop, shift, grepstart, anywhile, mapstart, mapwhile, range, and, or, dor, andassign, orassign, dorassign, argcheck, untie, tied, dbmclose, getsockname, getpeername, lstat, stat, readlink, readdir, telldir, rewinddir, closedir, localtime, alarm, require, dofile, entertry, ghbyname, gnbyname, gpbyname, shostent, snetent, sprotoent, sservent, gpwnam, gpwuid, ggrnam, ggrgid, lock, once, fc, anonconst, cmpchain_and, cmpchain_dup, entertrycatch, catch, is_bool, is_weak, weaken, unweaken, is_tainted, multiparam, paramstore */ 0x3cfc, 0x5379, /* pushmark */ 0x00bd, /* wantarray, runcv */ 0x077e, 0x0554, 0x1b70, 0x542c, 0x4fc8, 0x4225, /* const */ @@ -3073,7 +3075,7 @@ EXTCONST U16 PL_op_private_bitdefs[] = { 0x3cfc, 0x1198, 0x04f6, 0x014c, 0x5728, 0x5424, 0x2cc1, /* entersub */ 0x4b98, 0x0003, /* leavesub, leavesublv, leavewrite, leaveeval */ 0x03ca, 0x0003, /* argelem */ - 0x2adc, 0x29b8, 0x0003, /* argdefelem */ + 0x2adc, 0x29b8, 0x0003, /* argdefelem, paramtest */ 0x00bc, 0x02af, /* caller */ 0x27f5, /* nextstate, dbstate */ 0x3b9c, 0x4b99, /* leave */ @@ -3526,7 +3528,7 @@ EXTCONST U8 PL_op_private_valid[] = { /* INITFIELD */ (OPpARG1_MASK|OPpINITFIELD_AV|OPpINITFIELD_HV), /* CLASSNAME */ (0), /* MULTIPARAM */ (OPpARG1_MASK), - /* PARAMTEST */ (OPpARG1_MASK), + /* PARAMTEST */ (OPpARG1_MASK|OPpPARAM_IF_FALSE|OPpPARAM_IF_UNDEF), /* PARAMSTORE */ (OPpARG1_MASK), }; diff --git a/peep.c b/peep.c index 5b5082862ceb..3738abf8cd2b 100644 --- a/peep.c +++ b/peep.c @@ -24,6 +24,7 @@ #include "EXTERN.h" #define PERL_IN_PEEP_C #include "perl.h" +#include "feature.h" #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) @@ -1016,6 +1017,283 @@ S_maybe_multiconcat(pTHX_ OP *o) ? pad_alloc(OP_MULTICONCAT, SVs_PADTMP) : 0; } +/* S_maybe_multiparam(): + * + * Analyse the optree at the start of a CV to see if the various OP_ARG* ops + * can be rewritten into a single OP_MULTIPARAM instead. If so, the original + * ops are spliced out from the tree and destroyed, being entirely replaced by + * the OP_MULTIPARAM. + */ + +#define SKIP_COP(o) \ + STMT_START { if(OP_TYPE_IS_COP_NN(o)) o = OpSIBLING(o); } STMT_END + +STATIC void +S_maybe_multiparam(pTHX_ OP *o) +{ + /* Expect a LEAVESUB or LEAVESUBLV, containing a LINESEQ, whose first + * (non-null) child is itself a LINESEQ, whose first kids are NEXTSTATE, + * ARGCHECK, ... This is the start of the signature ops + */ + + /* This function operates in two phases. In the first phase, we simply + * look at the incoming optree to decide if it is a suitable candidate + * for an OP_MULTIPARAM rewrite, and while we're there count up various + * items so as to know how bit an aux structure to allocate. If we make + * it past these checks into the second phase, that is when the actual + * rewrite happens. + */ + + /* Phase 1: Test for validity and count things */ + + if(OP_TYPE_IS(o, OP_LEAVEEVAL)) + /* eval blocks don't have signatures */ + return; + + assert(OP_TYPE_IS(o, OP_LEAVESUB) || OP_TYPE_IS(o, OP_LEAVESUBLV)); + o = cUNOPo->op_first; + + /* Most subs have an OP_LINESEQ at toplevel, whose first child is the + * argcheck subtree, the rest is the body. However, subs with no body will + * go straight to the NULL[LINESEQ[ARGCHECK...]] + */ + if(o->op_type == OP_LINESEQ) o = cLISTOPo->op_first; + if(o->op_type == OP_NULL && (o->op_flags & OPf_KIDS)) o = cUNOPo->op_first; + if(o->op_type == OP_LINESEQ) o = cLISTOPo->op_first; + + OP *cop_before_argcheck = NULL; + if(OP_TYPE_IS_COP_NN(o)) { + cop_before_argcheck = o; + o = OpSIBLING(o); + } + + if(!o || o->op_type != OP_ARGCHECK) + return; + + OP *argcheck = o; + struct op_argcheck_aux *argcheck_aux = (struct op_argcheck_aux *)cUNOP_AUXo->op_aux; + + UV nparams = argcheck_aux->params; + UV nparams_mandatory = nparams - argcheck_aux->opt_params; + + o = OpSIBLING(o); + + /* Now we should expect to see some COP/ARGELEM pairs. + * Anonymous scalar params do not appear in the sequence at all, so we can + * ignore those for now + */ + OP *final_argelem = NULL; + for(/**/; o; o = OpSIBLING(o)) { + SKIP_COP(o); + + if(!o) + /* We ran out of args already after the final cop */ + break; + + /* If this is now anything but an OP_ARGELEM then we don't understand + * what's going on; just give up + */ + if(o->op_type != OP_ARGELEM) + return; + + UV parami = PTR2IV(cUNOP_AUXo->op_aux); + + if(parami < nparams_mandatory) { + if(o->op_flags & OPf_STACKED) + return; + } + else if(parami < nparams) { + if(!(o->op_flags & OPf_STACKED)) + return; + if(!(o->op_flags & OPf_KIDS)) + return; + + OP *defelem = cUNOPo->op_first; + if(defelem->op_type != OP_ARGDEFELEM) + return; + if(!(defelem->op_flags & OPf_KIDS)) + return; + } + else { + if(!argcheck_aux->slurpy) + return; + } + + final_argelem = o; + } + + if(argcheck_aux->slurpy) { + /* Make sure we did find the slurpy */ + if(!final_argelem) + return; + + U8 priv = final_argelem->op_private & OPpARGELEM_MASK; + if(!(priv == OPpARGELEM_AV || priv == OPpARGELEM_HV)) + return; + } + + OP *next_after_args = (final_argelem) ? + final_argelem->op_next : argcheck->op_next; + OP *cop_after_args = (final_argelem && OpSIBLING(final_argelem)) ? + OpSIBLING(final_argelem) : OpSIBLING(argcheck); + assert(cop_after_args->op_type == OP_NEXTSTATE || cop_after_args->op_type == OP_DBSTATE); + + /* If we made it this far then we must be good. onward to: + * Phase 2: Allocate a OP_MULTIPARAM, store information into it */ + + struct op_multiparam_aux *aux = (struct op_multiparam_aux *)PerlMemShared_malloc( + sizeof(struct op_multiparam_aux) + nparams * sizeof(PADOFFSET)); + aux->param_padix = (PADOFFSET *)((char *)aux + sizeof(struct op_multiparam_aux)); + + aux->params = nparams; + aux->opt_params = argcheck_aux->opt_params; + aux->slurpy = argcheck_aux->slurpy; + aux->slurpy_padix = 0; + + /* We could store an OP_LINESEQ but it's only temporary. Instead store + * head+tail separately + */ + OP *paramtests_first = NULL, *paramtests_last = NULL; + + o = OpSIBLING(argcheck); + UV max_parami = 0; + for(OP *onext; o; o = onext) { + OP *cop_for_param = NULL; + if(OP_TYPE_IS_COP_NN(o)) { + cop_for_param = o; + o = OpSIBLING(o); + } + + if(!o) + break; + + onext = OpSIBLING(o); + + UV parami = PTR2IV(cUNOP_AUXo->op_aux); + while(max_parami < parami) { + aux->param_padix[max_parami] = 0; + max_parami++; + } + + if(parami >= nparams) { + /* This is final slurpy */ + aux->slurpy_padix = o->op_targ; + break; + } + + /* Otherwise this is some kind of non-final scalar */ + + PADOFFSET padix = aux->param_padix[parami] = o->op_targ; + + if(parami < nparams_mandatory) { + /* This is mandatory param */ + + /* Only the pad offset is interesting. We don't need either the + * COP or the op itself */ + if(cop_for_param) + op_free(cop_for_param); + op_free(o); + } + else if(parami < nparams) { + /* This is optional param */ + + /* We'll have to capture the defaulting expression subtree and + * rewrite it somewhat + * + * o is currently OP_ARGELEM[ OP_ARGDEFELEM[ other: default-expr ] ] + * + * We need to generate OP_PARAMTEST[ other: OP_PARAMSTORE[ default-expr ] ] + * + * We can't just slice it apart and rebuild it because the + * ->op_next pointers in the default-expr fragment are already set + * to point out at OP_ARGELEM. + * + * What we can do though is steal the existing OP_ARGELEM to be our + * new OP_PARAMSTORE by changing its optype. That will allow us to + * reuse the existing defexpr without disturbing these pointers. + */ + OP *defelem = cUNOPo->op_first; + OP *defexpr = cLOGOPx(defelem)->op_first; + OP *defexpr_start = cLOGOPx(defelem)->op_other; + U8 defexpr_priv = defelem->op_private; + + cLOGOPx(defelem)->op_first = NULL; + cLOGOPx(defelem)->op_other = NULL; + defelem->op_flags &= ~OPf_KIDS; + op_free(defelem); defelem = NULL; + + OP *paramstore = o; + OpTYPE_set(paramstore, OP_PARAMSTORE); + OpLASTSIB_set(paramstore, NULL); /* temporarily to slice it out */ + cUNOPx(paramstore)->op_first = defexpr; + paramstore->op_flags |= OPf_KIDS; + paramstore->op_targ = padix; + paramstore->op_next = NULL; + OpLASTSIB_set(defexpr, paramstore); + + /* We can't easily just use newLOGOP() here either, because of + * more ->op_next issues. We'll have to fix them up later. */ + OP *paramtest = (OP *)alloc_LOGOP(OP_PARAMTEST, paramstore, defexpr_start); + paramtest->op_flags |= OPf_WANT_VOID; + if(defexpr_priv & OPpARG_IF_UNDEF) + paramtest->op_private |= OPpPARAM_IF_UNDEF; + if(defexpr_priv & OPpARG_IF_FALSE) + paramtest->op_private |= OPpPARAM_IF_FALSE; + paramtest->op_targ = padix; + OpLASTSIB_set(paramstore, paramtest); + + OpLASTSIB_set(cop_for_param, NULL); + if(paramtests_last) OpMORESIB_set(paramtests_last, cop_for_param); + paramtests_last = cop_for_param; + if(!paramtests_first) paramtests_first = paramtests_last; + + OpLASTSIB_set(paramtest, NULL); + if(paramtests_last) OpMORESIB_set(paramtests_last, paramtest); + paramtests_last = paramtest; + } + + max_parami = parami + 1; + } + + while(max_parami < nparams) { + aux->param_padix[max_parami] = 0; + max_parami++; + } + + op_free(argcheck); argcheck = NULL; + + OP *multiparam = newUNOP_AUX(OP_MULTIPARAM, 0, NULL, (UNOP_AUX_item *)aux); + + OpMORESIB_set(cop_before_argcheck, multiparam); + cop_before_argcheck->op_next = multiparam; + + OP *tail = multiparam; + + if(paramtests_first) { + for(OP *kid = paramtests_first, *nextkid; kid; kid = nextkid) { + nextkid = OpSIBLING(kid); + OpMORESIB_set(tail, kid); + + /* tail is either a OP_PARAMTEST or a COP */ + if(tail->op_type == OP_PARAMTEST) + /* set ->op_next of both OP_PARAMTEST and OP_PARAMSTORE */ + tail->op_next = cLOGOPx(tail)->op_first->op_next = kid; + else + tail->op_next = kid; + + tail = kid; + } + } + + OpMORESIB_set(tail, cop_after_args); + + if(tail->op_type == OP_PARAMTEST) + /* set ->op_next of both OP_PARAMTEST and OP_PARAMSTORE */ + tail->op_next = cLOGOPx(tail)->op_first->op_next = next_after_args; + else + tail->op_next = next_after_args; +} + /* =for apidoc_section $optree_manipulation @@ -1040,10 +1318,15 @@ Perl_optimize_optree(pTHX_ OP* o) optimize_op(o); + if(CvSIGNATURE(PL_compcv) && FEATURE_FASTER_SIGNATURES_IS_ENABLED) { + S_maybe_multiparam(aTHX_ o); + } + LEAVE; } + #define warn_implicit_snail_cvsig(o) S_warn_implicit_snail_cvsig(aTHX_ o) static void S_warn_implicit_snail_cvsig(pTHX_ OP *o) diff --git a/pp.c b/pp.c index b132ac817694..7391f27480ae 100644 --- a/pp.c +++ b/pp.c @@ -7811,17 +7811,128 @@ PP(pp_argcheck) PP(pp_multiparam) { - croak("TODO pp_multiparam"); + struct op_multiparam_aux *aux = (struct op_multiparam_aux *)cUNOP_AUX->op_aux; + UV nparams = aux->params; + UV nparams_mandatory = nparams - aux->opt_params; + char slurpy = aux->slurpy; + AV *defav = GvAV(PL_defgv); /* @_ */ + + assert(!SvMAGICAL(defav)); + UV argc = (UV)(AvFILLp(defav) + 1); + + S_check_argc(aTHX_ argc, nparams, aux->opt_params, slurpy); + + UV parami; + for(parami = 0; parami < nparams; parami++) { + PADOFFSET padix = aux->param_padix[parami]; + if(!padix) { + if(argc) + argc--; + continue; + } + + SV **padentry = &PAD_SVl(padix); + save_clearsv(padentry); + + if(!argc) { + /* Ran out of arg values for this param. It must be a missing + * optional. Remark that it's missing so a subsequent OP_PARAMTEST + * knows */ + SvPADSTALE_on(*padentry); + continue; + } + + SV **valp = av_fetch(defav, parami, FALSE); + SV *val = valp ? *valp : &PL_sv_undef; + argc--; + + assert(TAINTING_get || !TAINT_get); + if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) + TAINT_NOT; + + SvSetMagicSV(*padentry, val); + } + + if(!slurpy) + return PL_op->op_next; + + /* Now we know we have a slurpy */ + assert(aux->slurpy_padix); + SV **padentry = &PAD_SVl(aux->slurpy_padix); + save_clearsv(padentry); + + if(slurpy == '@') { + AV *av = (AV *)*padentry; + assert(SvTYPE(av) == SVt_PVAV); + + av_extend(av, argc); + + IV avidx = 0; + for(; argc; parami++, argc--) { + SV **valp = av_fetch(defav, parami, FALSE); + SV *val = valp ? *valp : &PL_sv_undef; + + assert(TAINTING_get || !TAINT_get); + if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) + TAINT_NOT; + + av_store(av, avidx++, newSVsv(val)); + } + } + else if(slurpy == '%') { + HV *hv = (HV *)*padentry; + assert(SvTYPE(hv) == SVt_PVHV); + + assert((argc % 2) == 0); + + while(argc) { + SV **svp; + + svp = av_fetch(defav, parami, FALSE); parami++; + SV *key = svp ? *svp : &PL_sv_undef; + svp = av_fetch(defav, parami, FALSE); parami++; + SV *val = svp ? *svp : &PL_sv_undef; + argc -= 2; + + if (UNLIKELY(SvGMAGICAL(key))) + key = sv_mortalcopy(key); + + hv_store_ent(hv, key, newSVsv(val), 0); + if (UNLIKELY(TAINT_get) && !SvTAINTED(val)) + TAINT_NOT; + } + } + + return PL_op->op_next; } PP(pp_paramtest) { - croak("TODO pp_paramtest"); + dTARGET; + + bool ok = TARG && !SvPADSTALE(TARG); + + if (ok && (PL_op->op_private & OPpPARAM_IF_UNDEF) && !SvOK(TARG)) + ok = false; + if (ok && (PL_op->op_private & OPpPARAM_IF_FALSE) && !SvTRUE(TARG)) + ok = false; + + if(!ok) + return cLOGOP->op_other; + + return PL_op->op_next; } PP(pp_paramstore) { - croak("TODO pp_paramstore"); + dSP; + dTARGET; + SV *value = POPs; + + SvPADSTALE_off(TARG); + SvSetMagicSV(TARG, value); + + RETURN; } PP_wrapped(pp_isa, 2, 0) diff --git a/regen/op_private b/regen/op_private index 409db837faf0..aeaddae1b479 100644 --- a/regen/op_private +++ b/regen/op_private @@ -925,6 +925,12 @@ addbits('argdefelem', 6 => qw(OPpARG_IF_FALSE IF_FALSE), ); +# These paramtest bits must be in the same place as argdefelem +addbits('paramtest', + 7 => qw(OPpPARAM_IF_UNDEF IF_UNDEF), + 6 => qw(OPpPARAM_IF_FALSE IF_FALSE), +); + addbits('helemexistsor', 7 => qw(OPpHELEMEXISTSOR_DELETE DELETE), ); diff --git a/t/op/signatures_faster.t b/t/op/signatures_faster.t new file mode 100644 index 000000000000..8d74554eaf6c --- /dev/null +++ b/t/op/signatures_faster.t @@ -0,0 +1,100 @@ +#!perl + +BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc('../lib'); +} + +use v5.40; + +# a TEMPORARY unit test file for ensuring the 'faster_signatures' feature +# works properly. + +sub fails_ok ( $code, $failure_pattern, $title ) +{ + eval { $code->(); 1 } and + return ok( 0, "$title fails" ); + my $e = $@; + ok( 1, "$title fails" ); + like( $e, $failure_pattern, "$title exception" ); +} + +use feature 'faster_signatures'; + +# zero params and zero body +sub empty () {} +is( empty(), undef, 'empty OK' ); + +# zero params +sub p0 () { return "P0" } +is( p0(), "P0", 'p0 OK' ); +fails_ok( sub { p0("a1") }, qr/^Too many arguments for subroutine 'main::p0' \(got 1; expected 0\) at /, + 'p0 on one argument' ); + +# one param +sub p1 ( $x ) { return "P1-$x"; } +is( p1("a1"), "P1-a1", 'p1 OK' ); +fails_ok( sub { p1() }, qr/^Too few arguments for subroutine 'main::p1' \(got 0; expected 1\) at /, + 'p1 on zero arguments' ); +fails_ok( sub { p1("a1","a2") }, qr/^Too many arguments for subroutine 'main::p1' \(got 2; expected 1\) at /, + 'p1 on two arguments' ); + +# one unnamed param +sub p1u ( $ ) { return "P1u"; } +is( p1u("a1"), "P1u", 'p1u OK' ); + +# two params +sub p2 ( $x, $y ) { return "P2-$x-$y"; } +is( p2("a1", "a2"), "P2-a1-a2", 'p2 OK' ); +fails_ok( sub { p2("a1") }, qr/^Too few arguments for subroutine 'main::p2' \(got 1; expected 2\) at /, + 'p2 on one arguments' ); +fails_ok( sub { p2("a1","a2","a3") }, qr/^Too many arguments for subroutine 'main::p2' \(got 3; expected 2\) at /, + 'p2 on three arguments' ); + +# two params, one is optional +sub p2o1 ( $x, $y = 100 ) { return "P2O1-$x-$y"; } +is( p2o1("a1"), "P2O1-a1-100", 'p2o1(1) OK' ); +is( p2o1("a1", "a2"), "P2O1-a1-a2", 'p2o1(2) OK' ); +fails_ok( sub { p2o1() }, qr/^Too few arguments for subroutine 'main::p2o1' \(got 0; expected at least 1\) at /, + 'p2o1 on zero arguments' ); +fails_ok( sub { p2o1("a1","a2","a3") }, qr/^Too many arguments for subroutine 'main::p2o1' \(got 3; expected at most 2\) at /, + 'p2o1 on three arguments' ); + +# two params, one is optional with other defaulting modes +sub p2o1d ( $x, $y //= 100 ) { return "P2O1D-$x-$y"; } +is( p2o1d("a1"), "P2O1D-a1-100", 'p2o1d(1) OK' ); +is( p2o1d("a1", undef), "P2O1D-a1-100", 'p2o1d(1+u) OK' ); +is( p2o1d("a1", "a2"), "P2O1D-a1-a2", 'p2o1d(2) OK' ); +sub p2o1t ( $x, $y ||= 100 ) { return "P2O1T-$x-$y"; } +is( p2o1t("a1"), "P2O1T-a1-100", 'p2o1t(1) OK' ); +is( p2o1t("a1", 0), "P2O1T-a1-100", 'p2o1t(1+z) OK' ); +is( p2o1t("a1", "a2"), "P2O1T-a1-a2", 'p2o1t(2) OK' ); + +# two params, first is unnamed +sub p2u1 ( $, $y ) { return "P2U1-$y"; } +is( p2u1("a1", "a2"), "P2U1-a2", 'p2u1 OK' ); + +# three params, two are optional +sub p3o2 ( $x, $y = 100, $z = 200 ) { return "P3O2-$x-$y-$z"; } +is( p3o2("a1"), "P3O2-a1-100-200", 'p3o2(1) OK' ); +is( p3o2("a1", "a2"), "P3O2-a1-a2-200", 'p3o2(2) OK' ); +is( p3o2("a1", "a2", "a3"), "P3O2-a1-a2-a3", 'p3o2(3) OK' ); + +# with slurpy array +sub p1sa ( $x, @rest ) { + return "P1SA-$x+" . join( '+', @rest ); +} +is( p1sa("a1", qw( a b c )), "P1SA-a1+a+b+c", 'p1sa OK' ); +fails_ok( sub { p1sa() }, qr/^Too few arguments for subroutine 'main::p1sa' \(got 0; expected at least 1\) at /, + 'p1sa on zero arguments' ); + +# with slurpy hash +sub p1sh ( $x, %rest ) { + return "P1SH-$x+" . join( '+', map { "$_=$rest{$_}" } sort keys %rest ); +} +is( p1sh("a1", a => "A", b => "B"), "P1SH-a1+a=A+b=B", 'p1ha OK' ); +fails_ok( sub { p1sh() }, qr/^Too few arguments for subroutine 'main::p1sh' \(got 0; expected at least 1\) at /, + 'p1sh on zero arguments' ); + +done_testing; diff --git a/t/perf/opcount.t b/t/perf/opcount.t index f904764c1409..d2afb7d0b62b 100644 --- a/t/perf/opcount.t +++ b/t/perf/opcount.t @@ -1027,5 +1027,62 @@ test_opcount(0, "foreach 2 lexicals on builtin::indexed LIST", enteriter => 1, iter => 1, }); +{ + use feature qw( signatures faster_signatures ); + + test_opcount(0, "Zero-arg empty subroutine uses OP_MULTIPARAM", + sub () {}, + { + multiparam => 1, + argcheck => 0, + }); + + test_opcount(0, "Zero-arg subroutine uses OP_MULTIPARAM", + sub () { return; }, + { + multiparam => 1, + argcheck => 0, + }); + + test_opcount(0, "Two-arg subroutine uses OP_MULTIPARAM", + sub ($x, $y) { return; }, + { + multiparam => 1, + argcheck => 0, + argelem => 0, + }); + + test_opcount(0, "Two-arg one-optional subroutine uses OP_MULTIPARAM", + sub ($x, $y = "default") { return; }, + { + multiparam => 1, + argcheck => 0, + argelem => 0, + }); + + test_opcount(0, "Two-arg one-anon subroutine uses OP_MULTIPARAM", + sub ($, $y) { return; }, + { + multiparam => 1, + argcheck => 0, + argelem => 0, + }); + + test_opcount(0, "One-arg plus slurpy array subroutine uses OP_MULTIPARAM", + sub ($x, @rest) { return; }, + { + multiparam => 1, + argcheck => 0, + argelem => 0, + }); + + test_opcount(0, "One-arg plus slurpy hash subroutine uses OP_MULTIPARAM", + sub ($x, %rest) { return; }, + { + multiparam => 1, + argcheck => 0, + argelem => 0, + }); +} done_testing();