X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/03acb64848c7cc3a02259a87b82a11a401c46810..43e5477e1cb9b5aed5748aeeb8d72fe147e673a7:/op.c diff --git a/op.c b/op.c index 625eaba..94ff49f 100644 --- a/op.c +++ b/op.c @@ -109,6 +109,24 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o) #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o) +/* remove any leading "empty" ops from the op_next chain whose first + * node's address is stored in op_p. Store the updated address of the + * first node in op_p. + */ + +STATIC void +S_prune_chain_head(pTHX_ OP** op_p) +{ + while (*op_p + && ( (*op_p)->op_type == OP_NULL + || (*op_p)->op_type == OP_SCOPE + || (*op_p)->op_type == OP_SCALAR + || (*op_p)->op_type == OP_LINESEQ) + ) + *op_p = (*op_p)->op_next; +} + + /* See the explanatory comments above struct opslab in op.h. */ #ifdef PERL_DEBUG_READONLY_OPS @@ -672,6 +690,15 @@ S_op_destroy(pTHX_ OP *o) /* Destructor */ +/* +=for apidoc Am|void|op_free|OP *o + +Free an op. Only use this when an op is no longer linked to from any +optree. + +=cut +*/ + void Perl_op_free(pTHX_ OP *o) { @@ -766,6 +793,7 @@ Perl_op_clear(pTHX_ OP *o) o->op_targ = 0; goto retry; } + /* FALLTHROUGH */ case OP_ENTERTRY: case OP_ENTEREVAL: /* Was holding hints. */ o->op_targ = 0; @@ -774,7 +802,7 @@ Perl_op_clear(pTHX_ OP *o) if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != Perl_ck_ftst)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_GVSV: case OP_GV: case OP_AELEMFAST: @@ -846,7 +874,7 @@ Perl_op_clear(pTHX_ OP *o) case OP_REDO: if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_TRANS: case OP_TRANSR: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { @@ -879,7 +907,7 @@ Perl_op_clear(pTHX_ OP *o) #else SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_MATCH: case OP_QR: clear_pmop: @@ -986,6 +1014,15 @@ S_find_and_forget_pmops(pTHX_ OP *o) } } +/* +=for apidoc Am|void|op_null|OP *o + +Neutralizes an op when it is no longer needed, but is still linked to from +other ops. + +=cut +*/ + void Perl_op_null(pTHX_ OP *o) { @@ -1050,7 +1087,7 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) =head1 Optree Manipulation Functions =for apidoc Am|OP*|op_linklist|OP *o -This function is the implementation of the L macro. It should +This function is the implementation of the L macro. It should not be called directly. =cut @@ -1210,6 +1247,11 @@ S_scalar_slice_warning(pTHX_ const OP *o) case OP_RVALUES: return; } + + /* Don't warn if we have a nulled list either. */ + if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST) + return; + assert(kid->op_sibling); name = S_op_varname(aTHX_ kid->op_sibling); if (!name) /* XS module fiddling with the op tree */ @@ -1259,7 +1301,7 @@ Perl_scalar(pTHX_ OP *o) for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalar(kid); break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SPLIT: case OP_MATCH: case OP_QR: @@ -1393,7 +1435,7 @@ Perl_scalarvoid(pTHX_ OP *o) default: if (!(PL_opargs[o->op_type] & OA_FOLDCONST)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_REPEAT: if (o->op_flags & OPf_STACKED) break; @@ -1401,7 +1443,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_SUBSTR: if (o->op_private == 4) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_GVSV: case OP_WANTARRAY: case OP_GV: @@ -1532,8 +1574,7 @@ Perl_scalarvoid(pTHX_ OP *o) /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ - else if (SvNIOK(sv) && (NV_eq_nowarn(SvNV(sv), 0.0) || - NV_eq_nowarn(SvNV(sv), 1.0))) + else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = NULL; else if (SvPOK(sv)) { SV * const dsv = newSVpvs(""); @@ -1638,6 +1679,7 @@ Perl_scalarvoid(pTHX_ OP *o) } op_null(kid); } + /* FALLTHROUGH */ case OP_DOR: case OP_COND_EXPR: @@ -1650,14 +1692,14 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_NULL: if (o->op_flags & OPf_STACKED) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: if (!(o->op_flags & OPf_KIDS)) break; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SCOPE: case OP_LEAVE: case OP_LEAVETRY: @@ -1813,8 +1855,8 @@ S_modkids(pTHX_ OP *o, I32 type) /* =for apidoc finalize_optree -This function finalizes the optree. Should be called directly after -the complete optree is built. It does some additional +This function finalizes the optree. Should be called directly after +the complete optree is built. It does some additional checking which can't be done in the normal ck_xxx functions and makes the tree thread-safe. @@ -1934,11 +1976,16 @@ S_finalize_op(pTHX_ OP* o) case OP_HSLICE: S_scalar_slice_warning(aTHX_ o); + /* FALLTHROUGH */ + case OP_KVHSLICE: + kid = cLISTOPo->op_first->op_sibling; if (/* I bet there's always a pushmark... */ - (kid = cLISTOPo->op_first->op_sibling)->op_type != OP_LIST - && kid->op_type != OP_CONST) + OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST) + && OP_TYPE_ISNT_NN(kid, OP_CONST)) + { break; + } key_op = (SVOP*)(kid->op_type == OP_CONST ? kid @@ -2030,7 +2077,7 @@ because it has no op type of its own (it is signalled by a flag on the lvalue op). This function detects things that can't be modified, such as C<$x+1>, and -generates errors for them. For example, C<$x+1 = 2> would cause it to be +generates errors for them. For example, C<$x+1 = 2> would cause it to be called with an op of type OP_ADD and a C argument of OP_SASSIGN. It also flags things that need to behave specially in an lvalue context, @@ -2039,6 +2086,21 @@ such as C<$$x = 5> which might have to vivify a reference in C<$x>. =cut */ +static bool +S_vivifies(const OPCODE type) +{ + switch(type) { + case OP_RV2AV: case OP_ASLICE: + case OP_RV2HV: case OP_KVASLICE: + case OP_RV2SV: case OP_HSLICE: + case OP_AELEMFAST: case OP_KVHSLICE: + case OP_HELEM: + case OP_AELEM: + return 1; + } + return 0; +} + OP * Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) { @@ -2126,7 +2188,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; } } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: nomod: if (flags & OP_LVALUE_NO_CROAK) return NULL; @@ -2180,16 +2242,16 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_RV2GV: if (scalar_mod_type(o, type)) goto nomod; ref(cUNOPo->op_first, o->op_type); - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_ASLICE: case OP_HSLICE: localize = 1; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_AASSIGN: /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */ if (type == OP_LEAVESUBLV && ( @@ -2197,7 +2259,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR )) o->op_private |= OPpMAYBE_LVSUB; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: PL_modcount = RETURN_UNLIMITED_NUMBER; @@ -2216,9 +2278,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_RV2SV: ref(cUNOPo->op_first, o->op_type); localize = 1; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_GV: PL_hints |= HINT_BLOCK_SCOPE; + /* FALLTHROUGH */ case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: @@ -2242,7 +2305,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR && type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_PADSV: PL_modcount++; if (!type) /* local() */ @@ -2262,7 +2325,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_SUBSTR: if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */ goto nomod; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_POS: case OP_VEC: lvalue_func: @@ -2287,6 +2350,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_LEAVE: case OP_LEAVELOOP: o->op_private |= OPpLVALUE; + /* FALLTHROUGH */ case OP_SCOPE: case OP_ENTER: case OP_LINESEQ: @@ -2305,7 +2369,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) op_lvalue(cBINOPo->op_first, type); break; } - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_LIST: localize = 0; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) @@ -2325,8 +2389,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) case OP_AND: case OP_OR: - op_lvalue(cLOGOPo->op_first, type); - op_lvalue(cLOGOPo->op_first->op_sibling, type); + if (type == OP_LEAVESUBLV + || !S_vivifies(cLOGOPo->op_first->op_type)) + op_lvalue(cLOGOPo->op_first, type); + if (type == OP_LEAVESUBLV + || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type)) + op_lvalue(cLOGOPo->op_first->op_sibling, type); goto nomod; } @@ -2370,7 +2438,7 @@ S_scalar_mod_type(const OP *o, I32 type) case OP_SASSIGN: if (o && o->op_type == OP_RV2GV) return FALSE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_PREINC: case OP_PREDEC: case OP_POSTINC: @@ -2422,7 +2490,7 @@ S_is_handle_constructor(const OP *o, I32 numargs) case OP_SOCKPAIR: if (numargs == 2) return TRUE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SYSOPEN: case OP_OPEN: case OP_SELECT: /* XXX c.f. SelectSaver.pm */ @@ -2487,7 +2555,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ doref(cUNOPo->op_first, o->op_type, set_op_ref); - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_PADSV: if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) { o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV @@ -2501,7 +2569,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) case OP_RV2HV: if (set_op_ref) o->op_flags |= OPf_REF; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_RV2GV: if (type == OP_DEFINED) o->op_flags |= OPf_SPECIAL; /* don't create GV */ @@ -2534,7 +2602,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) case OP_SCOPE: case OP_LEAVE: set_op_ref = FALSE; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_ENTER: case OP_LIST: if (!(o->op_flags & OPf_KIDS)) @@ -2588,7 +2656,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) PERL_ARGS_ASSERT_APPLY_ATTRS; /* fake up C */ - ENTER; /* need to protect against side-effects of 'use' */ #define ATTRSMODULE "attributes" #define ATTRSMODULE_PM "attributes.pm" @@ -2602,7 +2669,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) newSVOP(OP_CONST, 0, newRV(target)), dup_attrlist(attrs)))); - LEAVE; } STATIC void @@ -2622,7 +2688,6 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ - ENTER; /* need to protect against side-effects of 'use' */ /* Don't force the C if we don't need it. */ svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE); if (svp && *svp != &PL_sv_undef) @@ -2630,7 +2695,6 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) else Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs(ATTRSMODULE), NULL); - LEAVE; /* Need package name for method call. */ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE)); @@ -2800,6 +2864,22 @@ S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name) } } +static void +S_cant_declare(pTHX_ OP *o) +{ + if (o->op_type == OP_NULL + && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS) + o = cUNOPo->op_first; + yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", + o->op_type == OP_NULL + && o->op_flags & OPf_SPECIAL + ? "do block" + : OP_DESC(o), + PL_parser->in_my == KEY_our ? "our" : + PL_parser->in_my == KEY_state ? "state" : + "my")); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { @@ -2829,13 +2909,10 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ - yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - OP_DESC(o), - PL_parser->in_my == KEY_our - ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); + S_cant_declare(aTHX_ o); } else if (attrs) { GV * const gv = cGVOPx_gv(cUNOPo->op_first); + assert(PL_parser); PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; apply_attrs(GvSTASH(gv), @@ -2852,16 +2929,13 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) type != OP_PADHV && type != OP_PUSHMARK) { - yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - OP_DESC(o), - PL_parser->in_my == KEY_our - ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); + S_cant_declare(aTHX_ o); return o; } else if (attrs && type != OP_PUSHMARK) { HV *stash; + assert(PL_parser); PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; @@ -2979,8 +3053,10 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) /* !~ doesn't make sense with /r, so error on it for now */ if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) && type == OP_NOT) + /* diag_listed_as: Using !~ with %s doesn't make sense */ yyerror("Using !~ with s///r doesn't make sense"); if (rtype == OP_TRANSR && type == OP_NOT) + /* diag_listed_as: Using !~ with %s doesn't make sense */ yyerror("Using !~ with tr///r doesn't make sense"); ismatchop = (rtype == OP_MATCH || @@ -3183,7 +3259,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) =for apidoc Aox||blockhook_register Register a set of hooks to be called when the Perl lexical scope changes -at compile time. See L. +at compile time. See L. =cut */ @@ -3246,6 +3322,7 @@ Perl_newPROG(pTHX_ OP *o) ENTER; CALL_PEEP(PL_eval_start); finalize_optree(PL_eval_root); + S_prune_chain_head(aTHX_ &PL_eval_start); LEAVE; PL_savestack_ix = i; } @@ -3290,6 +3367,7 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_next = 0; CALL_PEEP(PL_main_start); finalize_optree(PL_main_root); + S_prune_chain_head(aTHX_ &PL_main_start); cv_forget_slab(PL_compcv); PL_compcv = 0; @@ -3565,7 +3643,10 @@ S_fold_constants(pTHX_ OP *o) #endif assert(sv); if (type == OP_STRINGIFY) SvPADTMP_off(sv); - else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv); + else if (!SvIMMORTAL(sv)) { + SvPADTMP_on(sv); + SvREADONLY_on(sv); + } if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else @@ -3593,9 +3674,11 @@ S_gen_constant_list(pTHX_ OP *o) if (PL_parser && PL_parser->error_count) return o; /* Don't attempt to run with errors */ - PL_op = curop = LINKLIST(o); + curop = LINKLIST(o); o->op_next = 0; CALL_PEEP(curop); + S_prune_chain_head(aTHX_ &curop); + PL_op = curop; Perl_pp_pushmark(aTHX); CALLRUNOPS(aTHX); PL_op = curop; @@ -3614,7 +3697,10 @@ S_gen_constant_list(pTHX_ OP *o) ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av); if (AvFILLp(av) != -1) for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp) + { SvPADTMP_on(*svp); + SvREADONLY_on(*svp); + } #ifdef PERL_MAD op_getmad(curop,o,'O'); #else @@ -4230,7 +4316,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) dVAR; BINOP *binop; - assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP + ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP || type == OP_SASSIGN || type == OP_NULL ); NewOp(1101, binop, 1, BINOP); @@ -4686,7 +4772,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) } else { SV * const repointer = &PL_sv_undef; av_push(PL_regex_padav, repointer); - pmop->op_pmoffset = av_len(PL_regex_padav); + pmop->op_pmoffset = av_tindex(PL_regex_padav); PL_regex_pad = AvARRAY(PL_regex_padav); } #endif @@ -4819,6 +4905,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) /* have to peep the DOs individually as we've removed it from * the op_next chain */ CALL_PEEP(o); + S_prune_chain_head(aTHX_ &(o->op_next)); if (is_compiletime) /* runtime finalizes as part of finalizing whole tree */ finalize_optree(o); @@ -5135,7 +5222,6 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); - SvPADTMP_on(sv); padop->op_next = (OP*)padop; padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) @@ -5425,7 +5511,8 @@ Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS -(or 0 for no flags). ver, if specified and not NULL, provides version semantics +(or 0 for no flags). ver, if specified +and not NULL, provides version semantics similar to C. The optional trailing SV* arguments can be used to specify arguments to the module's import() method, similar to C. They must be @@ -5498,7 +5585,8 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) * that it has a PL_parser to play with while doing that, and also * that it doesn't mess with any existing parser, by creating a tmp * new parser with lex_start(). This won't actually be used for much, - * since pp_require() will create another parser for the real work. */ + * since pp_require() will create another parser for the real work. + * The ENTER/LEAVE pair protect callers from any side effects of use. */ ENTER; SAVEVPTR(PL_curcop); @@ -5726,8 +5814,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); o->op_private = (U8)(0 | (flags >> 8)); - if ((left->op_type == OP_LIST - || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) + if (OP_TYPE_IS_OR_WAS(left, OP_LIST)) { OP* lop = ((LISTOP*)left)->op_first; maybe_common_vars = FALSE; @@ -5753,7 +5840,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) (state $a, my $b, our $c, $d, undef) = ... */ } } else if (lop->op_type == OP_UNDEF || - lop->op_type == OP_PUSHMARK) { + OP_TYPE_IS_OR_WAS(lop, OP_PUSHMARK)) { /* undef may be interesting in (state $a, undef, state $c) */ } else { @@ -6429,12 +6516,20 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP* listop; OP* o; const bool once = block && block->op_flags & OPf_SPECIAL && - (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL); + block->op_type == OP_NULL; PERL_UNUSED_ARG(debuggable); if (expr) { - if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) + if (once && ( + (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) + || ( expr->op_type == OP_NOT + && cUNOPx(expr)->op_first->op_type == OP_CONST + && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first)) + ) + )) + /* Return the block now, so that S_new_logop does not try to + fold it away. */ return block; /* do {} while 0 does once */ if (expr->op_type == OP_READLINE || expr->op_type == OP_READDIR @@ -6473,11 +6568,19 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0)); o = new_logop(OP_AND, 0, &expr, &listop); + if (once) { + ASSUME(listop); + } + if (listop) ((LISTOP*)listop)->op_last->op_next = LINKLIST(o); if (once && o != listop) + { + assert(cUNOPo->op_first->op_type == OP_AND + || cUNOPo->op_first->op_type == OP_OR); o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other; + } if (o == listop) o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */ @@ -6986,7 +7089,7 @@ S_looks_like_bool(pTHX_ const OP *o) else return FALSE; - /* FALL THROUGH */ + /* FALLTHROUGH */ default: return FALSE; } @@ -7119,7 +7222,7 @@ static void const_av_xsub(pTHX_ CV* cv); =for apidoc cv_const_sv -If C is a constant sub eligible for inlining. returns the constant +If C is a constant sub eligible for inlining, returns the constant value returned by the sub. Otherwise, returns NULL. Constant subs can be created with C or as described in @@ -7152,10 +7255,28 @@ Perl_cv_const_sv_or_av(pTHX_ const CV * const cv) } /* op_const_sv: examine an optree to determine whether it's in-lineable. + * Can be called in 3 ways: + * + * !cv + * look for a single OP_CONST with attached value: return the value + * + * cv && CvCLONE(cv) && !CvCONST(cv) + * + * examine the clone prototype, and if contains only a single + * OP_CONST referencing a pad const, or a single PADSV referencing + * an outer lexical, return a non-zero value to indicate the CV is + * a candidate for "constizing" at clone time + * + * cv && CvCONST(cv) + * + * We have just cloned an anon prototype that was marked as a const + * candidate. Try to grab the current value, and in the case of + * PADSV, ignore it if it has multiple references. In this case we + * return a newly created *copy* of the value. */ SV * -Perl_op_const_sv(pTHX_ const OP *o) +Perl_op_const_sv(pTHX_ const OP *o, CV *cv) { dVAR; SV *sv = NULL; @@ -7188,6 +7309,27 @@ Perl_op_const_sv(pTHX_ const OP *o) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; + else if (cv && type == OP_CONST) { + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + if (!sv) + return NULL; + } + else if (cv && type == OP_PADSV) { + if (CvCONST(cv)) { /* newly cloned anon */ + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + /* the candidate should have 1 ref from this pad and 1 ref + * from the parent */ + if (!sv || SvREFCNT(sv) != 2) + return NULL; + sv = newSVsv(sv); + SvREADONLY_on(sv); + return sv; + } + else { + if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE) + sv = &PL_sv_undef; /* an arbitrary non-null value */ + } + } else { return NULL; } @@ -7197,8 +7339,7 @@ Perl_op_const_sv(pTHX_ const OP *o) static bool S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, - PADNAME * const name, SV ** const const_svp, - GV * const gv) + PADNAME * const name, SV ** const const_svp) { assert (cv); assert (o || name); @@ -7249,8 +7390,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, #endif { /* (PL_madskills unset in used file.) */ - if (gv) GvCV_set(gv,NULL); - SvREFCNT_dec(cv); + SAVEFREESV(cv); } return TRUE; } @@ -7361,7 +7501,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ) const_sv = NULL; else - const_sv = op_const_sv(block); + const_sv = op_const_sv(block, NULL); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7374,7 +7514,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8); /* already defined? */ if (exists) { - if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv,NULL)) + if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv)) cv = NULL; else { if (attrs) goto attrs; @@ -7528,11 +7668,18 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); + S_prune_chain_head(aTHX_ &CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + if (CvCLONE(cv)) { + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); + } + attrs: if (attrs) { /* Need to do a C. */ @@ -7602,15 +7749,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) return cv; } +/* _x = extended */ CV * -Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) -{ - return newATTRSUB_flags(floor, o, proto, attrs, block, 0); -} - -CV * -Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, - OP *block, U32 flags) +Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, + OP *block, bool o_is_gv) { dVAR; GV *gv; @@ -7631,7 +7773,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; STRLEN namlen = 0; - const bool o_is_gv = flags & 1; const char * const name = o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL; bool has_name; @@ -7733,7 +7874,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, ) const_sv = NULL; else - const_sv = op_const_sv(block); + const_sv = op_const_sv(block, NULL); if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7746,7 +7887,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { - if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv, gv)) + if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) cv = NULL; else { if (attrs) goto attrs; @@ -7889,11 +8030,18 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); + S_prune_chain_head(aTHX_ &CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + if (CvCLONE(cv)) { + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); + } + attrs: if (attrs) { /* Need to do a C. */ @@ -7957,8 +8105,10 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, if (*name == 'B') { if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; + dSP; if (floor) LEAVE_SCOPE(floor); ENTER; + PUSHSTACKi(PERLSI_REQUIRE); SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); SAVEVPTR(PL_curcop); @@ -7968,6 +8118,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GvCV_set(gv,0); /* cv has been hijacked */ call_list(oldscope, PL_beginav); + POPSTACK; LEAVE; } else @@ -8115,6 +8266,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, U32 flags) { CV *cv; + bool interleave = FALSE; PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS; @@ -8144,8 +8296,9 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, ), cv, const_svp); } - GvCV_set(gv,NULL); - SvREFCNT_dec_NN(cv); + interleave = TRUE; + ENTER; + SAVEFREESV(cv); cv = NULL; } } @@ -8180,6 +8333,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, CvDYNFILE_on(cv); } sv_setpv(MUTABLE_SV(cv), proto); + if (interleave) LEAVE; return cv; } @@ -8280,6 +8434,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvROOT(cv)->op_next = 0; CALL_PEEP(CvSTART(cv)); finalize_optree(CvROOT(cv)); + S_prune_chain_head(aTHX_ &CvSTART(cv)); cv_forget_slab(cv); finish: @@ -8468,6 +8623,7 @@ Perl_ck_anoncode(pTHX_ OP *o) static void S_io_hints(pTHX_ OP *o) { +#if O_BINARY != 0 || O_TEXT != 0 HV * const table = PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;; if (table) { @@ -8476,10 +8632,15 @@ S_io_hints(pTHX_ OP *o) STRLEN len = 0; const char *d = SvPV_const(*svp, len); const I32 mode = mode_from_discipline(d, len); + /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ +# if O_BINARY != 0 if (mode & O_BINARY) o->op_private |= OPpOPEN_IN_RAW; - else if (mode & O_TEXT) +# endif +# if O_TEXT != 0 + if (mode & O_TEXT) o->op_private |= OPpOPEN_IN_CRLF; +# endif } svp = hv_fetchs(table, "open_OUT", FALSE); @@ -8487,12 +8648,20 @@ S_io_hints(pTHX_ OP *o) STRLEN len = 0; const char *d = SvPV_const(*svp, len); const I32 mode = mode_from_discipline(d, len); + /* bit-and:ing with zero O_BINARY or O_TEXT would be useless. */ +# if O_BINARY != 0 if (mode & O_BINARY) o->op_private |= OPpOPEN_OUT_RAW; - else if (mode & O_TEXT) +# endif +# if O_TEXT != 0 + if (mode & O_TEXT) o->op_private |= OPpOPEN_OUT_CRLF; +# endif } } +#else + PERL_UNUSED_ARG(o); +#endif } OP * @@ -8639,13 +8808,13 @@ Perl_ck_delete(pTHX_ OP *o) switch (kid->op_type) { case OP_ASLICE: o->op_flags |= OPf_SPECIAL; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_HSLICE: o->op_private |= OPpSLICE; break; case OP_AELEM: o->op_flags |= OPf_SPECIAL; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_HELEM: break; case OP_KVASLICE: @@ -9077,7 +9246,14 @@ Perl_ck_fun(pTHX_ OP *o) /* Defer checks to run-time if we have a scalar arg */ if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV) op_lvalue(kid, type); - else scalar(kid); + else { + scalar(kid); + /* diag_listed_as: push on reference is experimental */ + Perl_ck_warner_d(aTHX_ + packWARN(WARN_EXPERIMENTAL__AUTODEREF), + "%s on reference is experimental", + PL_op_desc[type]); + } break; case OA_HVREF: if (kid->op_type == OP_CONST && @@ -9590,7 +9766,7 @@ Perl_ck_sassign(pTHX_ OP *o) /* For state variable assignment, kkid is a list op whose op_last is a padsv. */ if ((kkid->op_type == OP_PADSV || - (kkid->op_type == OP_LIST && + (OP_TYPE_IS_OR_WAS(kkid, OP_LIST) && (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV ) ) @@ -9884,9 +10060,12 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_flags & OPf_STACKED) simplify_sort(o); firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */ OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ + /* if the first arg is a code block, process it and mark sort as + * OPf_SPECIAL */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { LINKLIST(kid); if (kid->op_type == OP_LEAVE) @@ -9913,6 +10092,16 @@ Perl_ck_sort(pTHX_ OP *o) return o; } +/* for sort { X } ..., where X is one of + * $a <=> $b, $b <= $a, $a cmp $b, $b cmp $a + * elide the second child of the sort (the one containing X), + * and set these flags as appropriate + OPpSORT_NUMERIC; + OPpSORT_INTEGER; + OPpSORT_DESCEND; + * Also, check and warn on lexical $a, $b. + */ + STATIC void S_simplify_sort(pTHX_ OP *o) { @@ -10061,6 +10250,7 @@ Perl_ck_split(pTHX_ OP *o) op_append_elem(OP_SPLIT, o, newDEFSVOP()); kid = kid->op_sibling; + assert(kid); scalar(kid); if (!kid->op_sibling) @@ -10320,6 +10510,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) /* _ must be at the end */ if (proto[1] && !strchr(";@%", proto[1])) goto oops; + /* FALLTHROUGH */ case '$': proto++; arg++; @@ -10592,7 +10783,7 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) ) ); } - assert(0); + NOT_REACHED; } else { OP *prev, *cvop; @@ -10702,8 +10893,11 @@ subroutine call, not marked with C<&>, where the callee can be identified at compile time as I. The C-level function pointer is supplied in I, and an SV argument -for it is supplied in I. The function is intended to be called -in this manner: +for it is supplied in I. The function should be defined like this: + + STATIC OP * ckfun(pTHX_ OP *op, GV *namegv, SV *ckobj) + +It is intended to be called in this manner: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); @@ -10731,6 +10925,7 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) MAGIC *callmg; sv_magic((SV*)cv, &PL_sv_undef, PERL_MAGIC_checkcall, NULL, 0); callmg = mg_find((SV*)cv, PERL_MAGIC_checkcall); + assert(callmg); if (callmg->mg_flags & MGf_REFCOUNTED) { SvREFCNT_dec(callmg->mg_obj); callmg->mg_flags &= ~MGf_REFCOUNTED; @@ -10822,6 +11017,9 @@ Perl_ck_svconst(pTHX_ OP *o) if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) { SvIsCOW_on(sv); CowREFCNT(sv) = 0; +# ifdef PERL_DEBUG_READONLY_COW + sv_buf_to_ro(sv); +# endif } #endif SvREADONLY_on(sv); @@ -10916,7 +11114,13 @@ Perl_ck_each(pTHX_ OP *o) } } /* if treating as a reference, defer additional checks to runtime */ - return o->op_type == ref_type ? o : ck_fun(o); + if (o->op_type == ref_type) { + /* diag_listed_as: keys on reference is experimental */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__AUTODEREF), + "%s is experimental", PL_op_desc[ref_type]); + return o; + } + return ck_fun(o); } OP * @@ -11046,18 +11250,48 @@ S_inplace_aassign(pTHX_ OP *o) { op_null(oleft); } + + +/* mechanism for deferring recursion in rpeep() */ + #define MAX_DEFERRED 4 #define DEFER(o) \ STMT_START { \ if (defer_ix == (MAX_DEFERRED-1)) { \ - CALL_RPEEP(defer_queue[defer_base]); \ + OP **defer = defer_queue[defer_base]; \ + CALL_RPEEP(*defer); \ + S_prune_chain_head(aTHX_ defer); \ defer_base = (defer_base + 1) % MAX_DEFERRED; \ defer_ix--; \ } \ - defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = o; \ + defer_queue[(defer_base + ++defer_ix) % MAX_DEFERRED] = &(o); \ } STMT_END +#define IS_AND_OP(o) (o->op_type == OP_AND) +#define IS_OR_OP(o) (o->op_type == OP_OR) + + +STATIC void +S_null_listop_in_list_context(pTHX_ OP *o) +{ + OP *kid; + + PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT; + + /* This is an OP_LIST in list context. That means we + * can ditch the OP_LIST and the OP_PUSHMARK within. */ + + kid = cLISTOPo->op_first; + /* Find the end of the chain of OPs executed within the OP_LIST. */ + while (kid->op_next != o) + kid = kid->op_next; + + kid->op_next = o->op_next; /* patch list out of exec chain */ + op_null(cUNOPo->op_first); /* NULL the pushmark */ + op_null(o); /* NULL the list */ +} + /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ @@ -11068,7 +11302,7 @@ Perl_rpeep(pTHX_ OP *o) dVAR; OP* oldop = NULL; OP* oldoldop = NULL; - OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ + OP** defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */ int defer_base = 0; int defer_ix = -1; @@ -11081,8 +11315,12 @@ Perl_rpeep(pTHX_ OP *o) if (o && o->op_opt) o = NULL; if (!o) { - while (defer_ix >= 0) - CALL_RPEEP(defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]); + while (defer_ix >= 0) { + OP **defer = + defer_queue[(defer_base + defer_ix--) % MAX_DEFERRED]; + CALL_RPEEP(*defer); + S_prune_chain_head(aTHX_ defer); + } break; } @@ -11090,6 +11328,44 @@ Perl_rpeep(pTHX_ OP *o) clear this again. */ o->op_opt = 1; PL_op = o; + + + /* The following will have the OP_LIST and OP_PUSHMARK + * patched out later IF the OP_LIST is in list context. + * So in that case, we can set the this OP's op_next + * to skip to after the OP_PUSHMARK: + * a THIS -> b + * d list -> e + * b pushmark -> c + * c whatever -> d + * e whatever + * will eventually become: + * a THIS -> c + * - ex-list -> - + * - ex-pushmark -> - + * c whatever -> e + * e whatever + */ + { + OP *sibling; + OP *other_pushmark; + if (OP_TYPE_IS(o->op_next, OP_PUSHMARK) + && (sibling = o->op_sibling) + && sibling->op_type == OP_LIST + /* This KIDS check is likely superfluous since OP_LIST + * would otherwise be an OP_STUB. */ + && sibling->op_flags & OPf_KIDS + && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST + && (other_pushmark = cLISTOPx(sibling)->op_first) + /* Pointer equality also effectively checks that it's a + * pushmark. */ + && other_pushmark == o->op_next) + { + o->op_next = other_pushmark->op_next; + null_listop_in_list_context(sibling); + } + } + switch (o->op_type) { case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ @@ -11097,6 +11373,110 @@ Perl_rpeep(pTHX_ OP *o) case OP_NEXTSTATE: PL_curcop = ((COP*)o); /* for warnings */ + /* Optimise a "return ..." at the end of a sub to just be "...". + * This saves 2 ops. Before: + * 1 <;> nextstate(main 1 -e:1) v ->2 + * 4 <@> return K ->5 + * 2 <0> pushmark s ->3 + * - <1> ex-rv2sv sK/1 ->4 + * 3 <#> gvsv[*cat] s ->4 + * + * After: + * - <@> return K ->- + * - <0> pushmark s ->2 + * - <1> ex-rv2sv sK/1 ->- + * 2 <$> gvsv(*cat) s ->3 + */ + { + OP *next = o->op_next; + OP *sibling = o->op_sibling; + if ( OP_TYPE_IS(next, OP_PUSHMARK) + && OP_TYPE_IS(sibling, OP_RETURN) + && OP_TYPE_IS(sibling->op_next, OP_LINESEQ) + && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB) + && cUNOPx(sibling)->op_first == next + && next->op_sibling && next->op_sibling->op_next + && next->op_next + ) { + /* Look through the PUSHMARK's siblings for one that + * points to the RETURN */ + OP *top = next->op_sibling; + while (top && top->op_next) { + if (top->op_next == sibling) { + top->op_next = sibling->op_next; + o->op_next = next->op_next; + break; + } + top = top->op_sibling; + } + } + } + + /* Optimise 'my $x; my $y;' into 'my ($x, $y);' + * + * This latter form is then suitable for conversion into padrange + * later on. Convert: + * + * nextstate1 -> padop1 -> nextstate2 -> padop2 -> nextstate3 + * + * into: + * + * nextstate1 -> listop -> nextstate3 + * / \ + * pushmark -> padop1 -> padop2 + */ + if (o->op_next && ( + o->op_next->op_type == OP_PADSV + || o->op_next->op_type == OP_PADAV + || o->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next && o->op_next->op_next->op_type == OP_NEXTSTATE + && o->op_next->op_next->op_next && ( + o->op_next->op_next->op_next->op_type == OP_PADSV + || o->op_next->op_next->op_next->op_type == OP_PADAV + || o->op_next->op_next->op_next->op_type == OP_PADHV + ) + && !(o->op_next->op_next->op_next->op_private & ~OPpLVAL_INTRO) + && o->op_next->op_next->op_next->op_next && o->op_next->op_next->op_next->op_next->op_type == OP_NEXTSTATE + && (!CopLABEL((COP*)o)) /* Don't mess with labels */ + && (!CopLABEL((COP*)o->op_next->op_next)) /* ... */ + ) { + OP *first; + OP *last; + OP *newop; + + first = o->op_next; + last = o->op_next->op_next->op_next; + + newop = newLISTOP(OP_LIST, 0, first, last); + newop->op_flags |= OPf_PARENS; + newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + + /* Kill nextstate2 between padop1/padop2 */ + op_free(first->op_next); + + first->op_next = last; /* padop2 */ + first->op_sibling = last; /* ... */ + o->op_next = cUNOPx(newop)->op_first; /* pushmark */ + o->op_next->op_next = first; /* padop1 */ + o->op_next->op_sibling = first; /* ... */ + newop->op_next = last->op_next; /* nextstate3 */ + newop->op_sibling = last->op_sibling; + last->op_next = newop; /* listop */ + last->op_sibling = NULL; + o->op_sibling = newop; /* ... */ + + newop->op_flags = (newop->op_flags & ~OPf_WANT) | OPf_WANT_VOID; + + /* Ensure pushmark has this flag if padops do */ + if (first->op_flags & OPf_MOD && last->op_flags & OPf_MOD) { + o->op_next->op_flags |= OPf_MOD; + } + + break; + } + /* Two NEXTSTATEs in a row serve no purpose. Except if they happen to carry two labels. For now, take the easier option, and skip this optimisation if the first NEXTSTATE has a label. */ @@ -11180,12 +11560,12 @@ Perl_rpeep(pTHX_ OP *o) though (See 20010220.007). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ o->op_opt = 0; - /* FALL THROUGH */ + /* FALLTHROUGH */ case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: nothin: - if (oldop && o->op_next) { + if (oldop) { oldop->op_next = o->op_next; o->op_opt = 0; continue; @@ -11276,7 +11656,7 @@ Perl_rpeep(pTHX_ OP *o) ) break; - /* let $a[N] potentially be optimised into ALEMFAST_LEX + /* let $a[N] potentially be optimised into AELEMFAST_LEX * instead */ if ( p->op_type == OP_PADAV && p->op_next @@ -11348,7 +11728,7 @@ Perl_rpeep(pTHX_ OP *o) */ assert(followop); if (gimme == OPf_WANT_VOID) { - if (followop->op_type == OP_LIST + if (OP_TYPE_IS_OR_WAS(followop, OP_LIST) && gimme == (followop->op_flags & OPf_WANT) && ( followop->op_next->op_type == OP_NEXTSTATE || followop->op_next->op_type == OP_DBSTATE)) @@ -11399,6 +11779,7 @@ Perl_rpeep(pTHX_ OP *o) || p->op_type == OP_PADHV) && (p->op_flags & OPf_WANT) == OPf_WANT_VOID && (p->op_private & OPpLVAL_INTRO) == intro + && !(p->op_private & ~OPpLVAL_INTRO) && p->op_next && ( p->op_next->op_type == OP_NEXTSTATE || p->op_next->op_type == OP_DBSTATE) @@ -11449,7 +11830,7 @@ Perl_rpeep(pTHX_ OP *o) pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && - (i = SvIV(((SVOP*)pop)->op_sv)) <= 255 && i >= 0) + (i = SvIV(((SVOP*)pop)->op_sv)) >= -128 && i <= 127) { GV *gv; if (cSVOPx(pop)->op_private & OPpCONST_STRICT) @@ -11525,6 +11906,21 @@ Perl_rpeep(pTHX_ OP *o) while (o->op_next && ( o->op_type == o->op_next->op_type || o->op_next->op_type == OP_NULL)) o->op_next = o->op_next->op_next; + + /* if we're an OR and our next is a AND in void context, we'll + follow it's op_other on short circuit, same for reverse. + We can't do this with OP_DOR since if it's true, its return + value is the underlying value which must be evaluated + by the next op */ + if (o->op_next && + ( + (IS_AND_OP(o) && IS_OR_OP(o->op_next)) + || (IS_OR_OP(o) && IS_AND_OP(o->op_next)) + ) + && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID + ) { + o->op_next = ((LOGOP*)o->op_next)->op_other; + } DEFER(cLOGOP->op_other); o->op_opt = 1; @@ -11600,6 +11996,11 @@ Perl_rpeep(pTHX_ OP *o) DEFER(cLOOP->op_lastop); break; + case OP_ENTERTRY: + assert(cLOGOPo->op_other->op_type == OP_LEAVETRY); + DEFER(cLOGOPo->op_other); + break; + case OP_SUBST: assert(!(cPMOP->op_pmflags & PMf_ONCE)); while (cPMOP->op_pmstashstartu.op_pmreplstart && @@ -11612,12 +12013,28 @@ Perl_rpeep(pTHX_ OP *o) case OP_SORT: { OP *oright; - if (o->op_flags & OPf_STACKED) { - OP * const kid = - cUNOPx(cLISTOP->op_first->op_sibling)->op_first; - if (kid->op_type == OP_SCOPE - || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)) - DEFER(kLISTOP->op_first); + if (o->op_flags & OPf_SPECIAL) { + /* first arg is a code block */ + OP * const nullop = cLISTOP->op_first->op_sibling; + OP * kid = cUNOPx(nullop)->op_first; + + assert(nullop->op_type == OP_NULL); + assert(kid->op_type == OP_SCOPE + || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE)); + /* since OP_SORT doesn't have a handy op_other-style + * field that can point directly to the start of the code + * block, store it in the otherwise-unused op_next field + * of the top-level OP_NULL. This will be quicker at + * run-time, and it will also allow us to remove leading + * OP_NULLs by just messing with op_nexts without + * altering the basic op_first/op_sibling layout. */ + kid = kLISTOP->op_first; + assert( + (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + || kid->op_type == OP_STUB + || kid->op_type == OP_ENTER); + nullop->op_next = kLISTOP->op_next; + DEFER(nullop->op_next); } /* check that RHS of sort is a single plain array */ @@ -11769,6 +12186,23 @@ Perl_rpeep(pTHX_ OP *o) if (OP_GIMME(o,0) == G_VOID) { OP *right = cBINOP->op_first; if (right) { + /* sassign + * RIGHT + * substr + * pushmark + * arg1 + * arg2 + * ... + * becomes + * + * ex-sassign + * substr + * pushmark + * RIGHT + * arg1 + * arg2 + * ... + */ OP *left = right->op_sibling; if (left->op_type == OP_SUBSTR && (left->op_private & 7) < 4) { @@ -11794,8 +12228,16 @@ Perl_rpeep(pTHX_ OP *o) } } - oldoldop = oldop; - oldop = o; + /* did we just null the current op? If so, re-process it to handle + * eliding "empty" ops from the chain */ + if (o->op_type == OP_NULL && oldop && oldop->op_next == o) { + o->op_opt = 0; + o = oldop; + } + else { + oldoldop = oldop; + oldop = o; + } } LEAVE; } @@ -11810,9 +12252,10 @@ Perl_peep(pTHX_ OP *o) =head1 Custom Operators =for apidoc Ao||custom_op_xop -Return the XOP structure for a given custom op. This macro should be +Return the XOP structure for a given custom op. This macro should be considered internal to OP_NAME and the other access macros: use them instead. -This macro does call a function. Prior to 5.19.6, this was implemented as a +This macro does call a function. Prior +to 5.19.6, this was implemented as a function. =cut @@ -11916,7 +12359,7 @@ Perl_custom_op_get_field(pTHX_ const OP *o, const xop_flags_enum field) /* =for apidoc Ao||custom_op_register -Register a custom op. See L. +Register a custom op. See L. =cut */ @@ -12081,7 +12524,7 @@ Perl_coresub_op(pTHX_ SV * const coreargssv, const int code, OP_SSELECT), coresub_op(coreargssv, 0, OP_SELECT) ); - /* FALL THROUGH */ + /* FALLTHROUGH */ default: switch (PL_opargs[opnum] & OA_CLASS_MASK) { case OA_BASEOP: @@ -12179,6 +12622,18 @@ pointer to the next function in the chain will be stored. The value of I is written into the L array, while the value previously stored there is written to I<*old_checker_p>. +The function should be defined like this: + + static OP *new_checker(pTHX_ OP *op) { ... } + +It is intended to be called in this manner: + + new_checker(aTHX_ op) + +I should be defined like this: + + static Perl_check_t old_checker_p; + L is global to an entire process, and a module wishing to hook op checking may find itself invoked more than once per process, typically in different threads. To handle that situation, this function @@ -12258,7 +12713,7 @@ const_av_xsub(pTHX_ CV* cv) Perl_croak(aTHX_ "Magical list constants are not supported"); if (GIMME_V != G_ARRAY) { EXTEND(SP, 1); - ST(0) = newSViv((IV)AvFILLp(av)+1); + ST(0) = sv_2mortal(newSViv((IV)AvFILLp(av)+1)); XSRETURN(1); } EXTEND(SP, AvFILLp(av)+1);