X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4748e0020f8a6874cca537d6f4191150c046410c..1f1ec7b5edaeafba5f018dd0956c9953cddd826f:/op.c diff --git a/op.c b/op.c index a9dafaa..4e569dd 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(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 @@ -145,6 +163,10 @@ S_new_slab(pTHX_ size_t sz) #else OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *)); #endif +#ifndef WIN32 + /* The context is unused in non-Windows */ + PERL_UNUSED_CONTEXT; +#endif slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1); return slab; } @@ -198,11 +220,11 @@ Perl_Slab_Alloc(pTHX_ size_t sz) if (slab->opslab_freed) { OP **too = &slab->opslab_freed; o = *too; - DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab)); + DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", (void*)o, (void*)slab)); while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) { DEBUG_S_warn((aTHX_ "Alas! too small")); o = *(too = &o->op_next); - if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); } + if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", (void*)o)); } } if (o) { *too = o->op_next; @@ -253,7 +275,7 @@ Perl_Slab_Alloc(pTHX_ size_t sz) < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) slot = &slab2->opslab_slots; INIT_OPSLOT; - DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab)); + DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab)); return (void *)o; } @@ -329,7 +351,7 @@ Perl_Slab_Free(pTHX_ void *op) o->op_type = OP_FREED; o->op_next = slab->opslab_freed; slab->opslab_freed = o; - DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab)); + DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", (void*)o, (void*)slab)); OpslabREFCNT_dec_padok(slab); } @@ -353,7 +375,7 @@ Perl_opslab_free(pTHX_ OPSLAB *slab) dVAR; OPSLAB *slab2; PERL_ARGS_ASSERT_OPSLAB_FREE; - DEBUG_S_warn((aTHX_ "freeing slab %p", slab)); + DEBUG_S_warn((aTHX_ "freeing slab %p", (void*)slab)); assert(slab->opslab_refcnt == 1); for (; slab; slab = slab2) { slab2 = slab->opslab_next; @@ -362,7 +384,7 @@ Perl_opslab_free(pTHX_ OPSLAB *slab) #endif #ifdef PERL_DEBUG_READONLY_OPS DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n", - slab)); + (void*)slab)); if (munmap(slab, slab->opslab_size * sizeof(I32 *))) { perror("munmap failed"); abort(); @@ -493,7 +515,7 @@ STATIC OP * S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv), + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), SvUTF8(namesv) | flags); return o; } @@ -549,8 +571,6 @@ S_no_bareword_allowed(pTHX_ OP *o) { PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED; - if (PL_madskills) - return; /* various ok barewords are hidden in extra OP_NULL */ qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", SVfARG(cSVOPo_sv))); @@ -625,6 +645,8 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) } /* +=head1 Optree Manipulation Functions + =for apidoc alloccopstash Available only under threaded builds, this function allocates an entry in @@ -672,6 +694,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) { @@ -753,19 +784,9 @@ Perl_op_clear(pTHX_ OP *o) PERL_ARGS_ASSERT_OP_CLEAR; -#ifdef PERL_MAD - mad_free(o->op_madprop); - o->op_madprop = 0; -#endif - - retry: switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ - if (PL_madskills && o->op_targ != OP_NULL) { - o->op_type = (Optype)o->op_targ; - o->op_targ = 0; - goto retry; - } + /* FALLTHROUGH */ case OP_ENTERTRY: case OP_ENTEREVAL: /* Was holding hints. */ o->op_targ = 0; @@ -774,7 +795,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 +867,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 +900,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 +1007,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) { @@ -995,8 +1025,7 @@ Perl_op_null(pTHX_ OP *o) if (o->op_type == OP_NULL) return; - if (!PL_madskills) - op_clear(o); + op_clear(o); o->op_targ = o->op_type; o->op_type = OP_NULL; o->op_ppaddr = PL_ppaddr[OP_NULL]; @@ -1042,15 +1071,13 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context) default: Perl_croak(aTHX_ "panic: op_contextualize bad context %ld", (long) context); - return o; } } /* -=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 +1237,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 */ @@ -1229,8 +1261,8 @@ S_scalar_slice_warning(pTHX_ const OP *o) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Scalar value @%"SVf"%c%"SVf"%c better written as $%" SVf"%c%"SVf"%c", - SVfARG(name), lbrack, keysv, rbrack, - SVfARG(name), lbrack, keysv, rbrack); + SVfARG(name), lbrack, SVfARG(keysv), rbrack, + SVfARG(name), lbrack, SVfARG(keysv), rbrack); } OP * @@ -1259,7 +1291,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: @@ -1332,8 +1364,8 @@ Perl_scalar(pTHX_ OP *o) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%%%"SVf"%c%"SVf"%c in scalar context better " "written as $%"SVf"%c%"SVf"%c", - SVfARG(name), lbrack, keysv, rbrack, - SVfARG(name), lbrack, keysv, rbrack); + SVfARG(name), lbrack, SVfARG(keysv), rbrack, + SVfARG(name), lbrack, SVfARG(keysv), rbrack); } } return o; @@ -1351,21 +1383,6 @@ Perl_scalarvoid(pTHX_ OP *o) PERL_ARGS_ASSERT_SCALARVOID; - /* trailing mad null ops don't count as "there" for void processing */ - if (PL_madskills && - o->op_type != OP_NULL && - o->op_sibling && - o->op_sibling->op_type == OP_NULL) - { - OP *sib; - for (sib = o->op_sibling; - sib && sib->op_type == OP_NULL; - sib = sib->op_sibling) ; - - if (!sib) - return o; - } - if (o->op_type == OP_NEXTSTATE || o->op_type == OP_DBSTATE || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE @@ -1393,7 +1410,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 +1418,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: @@ -1547,7 +1564,7 @@ Perl_scalarvoid(pTHX_ OP *o) SvREFCNT_dec_NN(dsv); } else if (SvOK(sv)) { - useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv); + useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv)); } else useless = "a constant (undef)"; @@ -1626,8 +1643,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_AND: kid = cLOGOPo->op_first; if (kid->op_type == OP_NOT - && (kid->op_flags & OPf_KIDS) - && !PL_madskills) { + && (kid->op_flags & OPf_KIDS)) { if (o->op_type == OP_AND) { o->op_type = OP_OR; o->op_ppaddr = PL_ppaddr[OP_OR]; @@ -1637,6 +1653,7 @@ Perl_scalarvoid(pTHX_ OP *o) } op_null(kid); } + /* FALLTHROUGH */ case OP_DOR: case OP_COND_EXPR: @@ -1649,14 +1666,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: @@ -1679,7 +1696,7 @@ Perl_scalarvoid(pTHX_ OP *o) /* mortalise it, in case warnings are fatal. */ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context", - sv_2mortal(useless_sv)); + SVfARG(sv_2mortal(useless_sv))); } else if (useless) { Perl_ck_warner(aTHX_ packWARN(WARN_VOID), @@ -1812,8 +1829,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. @@ -1837,23 +1854,6 @@ S_finalize_op(pTHX_ OP* o) { PERL_ARGS_ASSERT_FINALIZE_OP; -#if defined(PERL_MAD) && defined(USE_ITHREADS) - { - /* Make sure mad ops are also thread-safe */ - MADPROP *mp = o->op_madprop; - while (mp) { - if (mp->mad_type == MAD_OP && mp->mad_vlen) { - OP *prop_op = (OP *) mp->mad_val; - /* We only need "Relocate sv to the pad for thread safety.", but this - easiest way to make sure it traverses everything */ - if (prop_op->op_type == OP_CONST) - cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT; - finalize_op(prop_op); - } - mp = mp->mad_next; - } - } -#endif switch (o->op_type) { case OP_NEXTSTATE: @@ -1933,12 +1933,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 +2034,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 +2043,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) { @@ -2065,7 +2084,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) PL_modcount++; return o; case OP_STUB: - if ((o->op_flags & OPf_PARENS) || PL_madskills) + if ((o->op_flags & OPf_PARENS)) break; goto nomod; case OP_ENTERSUB: @@ -2126,7 +2145,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 +2199,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 +2216,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 +2235,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 +2262,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 +2282,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 +2307,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 +2326,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 +2346,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 +2395,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 +2447,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 +2512,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 +2526,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 +2559,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)) @@ -2562,10 +2587,6 @@ S_dup_attrlist(pTHX_ OP *o) */ if (o->op_type == OP_CONST) rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv)); -#ifdef PERL_MAD - else if (o->op_type == OP_NULL) - rop = NULL; -#endif else { assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS)); rop = NULL; @@ -2825,10 +2846,6 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) return o; type = o->op_type; - if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) { - (void)my_kid(cUNOPo->op_first, attrs, imopsp); - return o; - } if (type == OP_LIST) { OP *kid; @@ -2844,6 +2861,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) 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), @@ -2866,6 +2884,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) else if (attrs && type != OP_PUSHMARK) { HV *stash; + assert(PL_parser); PL_parser->in_my = FALSE; PL_parser->in_my_stash = NULL; @@ -2963,7 +2982,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) if (name) Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %"SVf" will act on scalar(%"SVf")", - desc, name, name); + desc, SVfARG(name), SVfARG(name)); else { const char * const sample = (isary ? "@array" : "%hash"); @@ -3189,7 +3208,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 */ @@ -3252,6 +3271,7 @@ Perl_newPROG(pTHX_ OP *o) ENTER; CALL_PEEP(PL_eval_start); finalize_optree(PL_eval_root); + S_prune_chain_head(&PL_eval_start); LEAVE; PL_savestack_ix = i; } @@ -3296,6 +3316,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(&PL_main_start); cv_forget_slab(PL_compcv); PL_compcv = 0; @@ -3451,15 +3472,27 @@ S_fold_constants(pTHX_ OP *o) case OP_UC: case OP_LC: case OP_FC: +#ifdef USE_LOCALE_CTYPE + if (IN_LC_COMPILETIME(LC_CTYPE)) + goto nope; +#endif + break; case OP_SLT: case OP_SGT: case OP_SLE: case OP_SGE: case OP_SCMP: +#ifdef USE_LOCALE_COLLATE + if (IN_LC_COMPILETIME(LC_COLLATE)) + goto nope; +#endif + break; case OP_SPRINTF: /* XXX what about the numeric ops? */ - if (IN_LOCALE_COMPILETIME) +#ifdef USE_LOCALE_NUMERIC + if (IN_LC_COMPILETIME(LC_NUMERIC)) goto nope; +#endif break; case OP_PACK: if (!cLISTOPo->op_first->op_sibling @@ -3525,14 +3558,7 @@ S_fold_constants(pTHX_ OP *o) CALLRUNOPS(aTHX); sv = *(PL_stack_sp--); if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */ -#ifdef PERL_MAD - /* Can't simply swipe the SV from the pad, because that relies on - the op being freed "real soon now". Under MAD, this doesn't - happen (see the #ifdef below). */ - sv = newSVsv(sv); -#else pad_swipe(o->op_targ, FALSE); -#endif } else if (SvTEMP(sv)) { /* grab mortal temp? */ SvREFCNT_inc_simple_void(sv); @@ -3566,9 +3592,7 @@ S_fold_constants(pTHX_ OP *o) if (ret) goto nope; -#ifndef PERL_MAD op_free(o); -#endif assert(sv); if (type == OP_STRINGIFY) SvPADTMP_off(sv); else if (!SvIMMORTAL(sv)) { @@ -3582,7 +3606,6 @@ S_fold_constants(pTHX_ OP *o) newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); if (type != OP_STRINGIFY) newop->op_folded = 1; } - op_getmad(o,newop,'f'); return newop; nope: @@ -3602,9 +3625,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(&curop); + PL_op = curop; Perl_pp_pushmark(aTHX); CALLRUNOPS(aTHX); PL_op = curop; @@ -3627,11 +3652,7 @@ S_gen_constant_list(pTHX_ OP *o) SvPADTMP_on(*svp); SvREADONLY_on(*svp); } -#ifdef PERL_MAD - op_getmad(curop,o,'O'); -#else op_free(curop); -#endif LINKLIST(o); return list(o); } @@ -3743,21 +3764,6 @@ Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last) ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last; first->op_flags |= (last->op_flags & OPf_KIDS); -#ifdef PERL_MAD - if (((LISTOP*)last)->op_first && first->op_madprop) { - MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop; - if (mp) { - while (mp->mad_next) - mp = mp->mad_next; - mp->mad_next = first->op_madprop; - } - else { - ((LISTOP*)last)->op_first->op_madprop = first->op_madprop; - } - } - first->op_madprop = last->op_madprop; - last->op_madprop = 0; -#endif S_op_destroy(aTHX_ last); @@ -3810,251 +3816,6 @@ Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last) /* Constructors */ -#ifdef PERL_MAD - -TOKEN * -Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop) -{ - TOKEN *tk; - Newxz(tk, 1, TOKEN); - tk->tk_type = (OPCODE)optype; - tk->tk_type = 12345; - tk->tk_lval = lval; - tk->tk_mad = madprop; - return tk; -} - -void -Perl_token_free(pTHX_ TOKEN* tk) -{ - PERL_ARGS_ASSERT_TOKEN_FREE; - - if (tk->tk_type != 12345) - return; - mad_free(tk->tk_mad); - Safefree(tk); -} - -void -Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) -{ - MADPROP* mp; - MADPROP* tm; - - PERL_ARGS_ASSERT_TOKEN_GETMAD; - - if (tk->tk_type != 12345) { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Invalid TOKEN object ignored"); - return; - } - tm = tk->tk_mad; - if (!tm) - return; - - /* faked up qw list? */ - if (slot == '(' && - tm->mad_type == MAD_SV && - SvPVX((SV *)tm->mad_val)[0] == 'q') - slot = 'x'; - - if (o) { - mp = o->op_madprop; - if (mp) { - for (;;) { - /* pretend constant fold didn't happen? */ - if (mp->mad_key == 'f' && - (o->op_type == OP_CONST || - o->op_type == OP_GV) ) - { - token_getmad(tk,(OP*)mp->mad_val,slot); - return; - } - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = tm; - mp = mp->mad_next; - } - else { - o->op_madprop = tm; - mp = o->op_madprop; - } - if (mp->mad_key == 'X') - mp->mad_key = slot; /* just change the first one */ - - tk->tk_mad = 0; - } - else - mad_free(tm); - Safefree(tk); -} - -void -Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot) -{ - MADPROP* mp; - if (!from) - return; - if (o) { - mp = o->op_madprop; - if (mp) { - for (;;) { - /* pretend constant fold didn't happen? */ - if (mp->mad_key == 'f' && - (o->op_type == OP_CONST || - o->op_type == OP_GV) ) - { - op_getmad(from,(OP*)mp->mad_val,slot); - return; - } - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = newMADPROP(slot,MAD_OP,from,0); - } - else { - o->op_madprop = newMADPROP(slot,MAD_OP,from,0); - } - } -} - -void -Perl_op_getmad(pTHX_ OP* from, OP* o, char slot) -{ - MADPROP* mp; - if (!from) - return; - if (o) { - mp = o->op_madprop; - if (mp) { - for (;;) { - /* pretend constant fold didn't happen? */ - if (mp->mad_key == 'f' && - (o->op_type == OP_CONST || - o->op_type == OP_GV) ) - { - op_getmad(from,(OP*)mp->mad_val,slot); - return; - } - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = newMADPROP(slot,MAD_OP,from,1); - } - else { - o->op_madprop = newMADPROP(slot,MAD_OP,from,1); - } - } - else { - PerlIO_printf(PerlIO_stderr(), - "DESTROYING op = %0"UVxf"\n", PTR2UV(from)); - op_free(from); - } -} - -void -Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot) -{ - MADPROP* tm; - if (!mp || !o) - return; - if (slot) - mp->mad_key = slot; - tm = o->op_madprop; - o->op_madprop = mp; - for (;;) { - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = tm; -} - -void -Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot) -{ - if (!o) - return; - addmad(tm, &(o->op_madprop), slot); -} - -void -Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot) -{ - MADPROP* mp; - if (!tm || !root) - return; - if (slot) - tm->mad_key = slot; - mp = *root; - if (!mp) { - *root = tm; - return; - } - for (;;) { - if (!mp->mad_next) - break; - mp = mp->mad_next; - } - mp->mad_next = tm; -} - -MADPROP * -Perl_newMADsv(pTHX_ char key, SV* sv) -{ - PERL_ARGS_ASSERT_NEWMADSV; - - return newMADPROP(key, MAD_SV, sv, 0); -} - -MADPROP * -Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) -{ - MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP)); - mp->mad_next = 0; - mp->mad_key = key; - mp->mad_vlen = vlen; - mp->mad_type = type; - mp->mad_val = val; -/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */ - return mp; -} - -void -Perl_mad_free(pTHX_ MADPROP* mp) -{ -/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */ - if (!mp) - return; - if (mp->mad_next) - mad_free(mp->mad_next); -/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen) - PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */ - switch (mp->mad_type) { - case MAD_NULL: - break; - case MAD_PV: - Safefree(mp->mad_val); - break; - case MAD_OP: - if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */ - op_free((OP*)mp->mad_val); - break; - case MAD_SV: - sv_free(MUTABLE_SV(mp->mad_val)); - break; - default: - PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); - break; - } - PerlMemShared_free(mp); -} - -#endif /* =head1 Optree construction @@ -4242,7 +4003,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); @@ -4295,10 +4056,6 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; SV * const rstr = -#ifdef PERL_MAD - (repl->op_type == OP_NULL) - ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : -#endif ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; @@ -4359,7 +4116,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) rend = r + len; } -/* There is a snag with this code on EBCDIC: scan_const() in toke.c has +/* There is a snag with this code on EBCDIC: scan_const() in toke.c has * encoded chars in native encoding which makes ranges in the EBCDIC 0..255 * odd. */ @@ -4529,13 +4286,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) Safefree(tsave); Safefree(rsave); -#ifdef PERL_MAD - op_getmad(expr,o,'e'); - op_getmad(repl,o,'r'); -#else op_free(expr); op_free(repl); -#endif return o; } @@ -4620,13 +4372,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (grows) o->op_private |= OPpTRANS_GROWS; -#ifdef PERL_MAD - op_getmad(expr,o,'e'); - op_getmad(repl,o,'r'); -#else op_free(expr); op_free(repl); -#endif return o; } @@ -4657,13 +4404,13 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) if (PL_hints & HINT_RE_TAINT) pmop->op_pmflags |= PMf_RETAINT; - if (IN_LOCALE_COMPILETIME) { +#ifdef USE_LOCALE_CTYPE + if (IN_LC_COMPILETIME(LC_CTYPE)) { set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET); } - else if ((! (PL_hints & HINT_BYTES)) - /* Both UNI_8_BIT and locale :not_characters imply Unicode */ - && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS))) - { + else +#endif + if (IN_UNI_8_BIT) { set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET); } if (PL_hints & HINT_RE_FLAGS) { @@ -4698,7 +4445,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 @@ -4831,6 +4578,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(&(o->op_next)); if (is_compiletime) /* runtime finalizes as part of finalizing whole tree */ finalize_optree(o); @@ -4877,11 +4625,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) : Perl_re_op_compile(aTHX_ NULL, 0, expr, eng, NULL, NULL, rx_flags, pm->op_pmflags) ); -#ifdef PERL_MAD - op_getmad(expr,(OP*)pm,'e'); -#else op_free(expr); -#endif } else { /* compile-time pattern that includes literal code blocks */ @@ -5147,7 +4891,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) @@ -5225,18 +4968,11 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) return CHECKOP(type, pvop); } -#ifdef PERL_MAD -OP* -#else void -#endif Perl_package(pTHX_ OP *o) { dVAR; SV *const sv = cSVOPo->op_sv; -#ifdef PERL_MAD - OP *pegop; -#endif PERL_ARGS_ASSERT_PACKAGE; @@ -5251,18 +4987,7 @@ Perl_package(pTHX_ OP *o) PL_parser->copline = NOLINE; PL_parser->expect = XSTATE; -#ifndef PERL_MAD op_free(o); -#else - if (!PL_madskills) { - op_free(o); - return NULL; - } - - pegop = newOP(OP_NULL,0); - op_getmad(o,pegop,'P'); - return pegop; -#endif } void @@ -5277,20 +5002,13 @@ Perl_package_version( pTHX_ OP *v ) op_free(v); } -#ifdef PERL_MAD -OP* -#else void -#endif Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) { dVAR; OP *pack; OP *imop; OP *veop; -#ifdef PERL_MAD - OP *pegop = PL_madskills ? newOP(OP_NULL,0) : NULL; -#endif SV *use_version = NULL; PERL_ARGS_ASSERT_UTILIZE; @@ -5298,16 +5016,11 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) if (idop->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); - if (PL_madskills) - op_getmad(idop,pegop,'U'); - veop = NULL; if (version) { SV * const vesv = ((SVOP*)version)->op_sv; - if (PL_madskills) - op_getmad(version,pegop,'V'); if (!arg && !SvNIOKp(vesv)) { arg = version; } @@ -5332,8 +5045,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) { - if (PL_madskills) - op_getmad(arg,pegop,'S'); imop = arg; /* no import on explicit () */ } else if (SvNIOKp(((SVOP*)idop)->op_sv)) { @@ -5346,9 +5057,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) else { SV *meth; - if (PL_madskills) - op_getmad(arg,pegop,'A'); - /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); @@ -5423,9 +5131,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; -#ifdef PERL_MAD - return pegop; -#endif } /* @@ -5437,7 +5142,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 @@ -5739,8 +5445,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; @@ -5766,7 +5471,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 { @@ -5819,7 +5524,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) LINKLIST(o); } - if (right && right->op_type == OP_SPLIT && !PL_madskills) { + if (right && right->op_type == OP_SPLIT) { OP* tmpop = ((LISTOP*)right)->op_first; if (tmpop && (tmpop->op_type == OP_PUSHRE)) { PMOP * const pm = (PMOP*)tmpop; @@ -6120,7 +5825,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) && (first->op_flags & OPf_KIDS) && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ - && !PL_madskills) { + ) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; @@ -6145,12 +5850,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) *firstp = NULL; if (other->op_type == OP_CONST) other->op_private |= OPpCONST_SHORTCIRCUIT; - if (PL_madskills) { - OP *newop = newUNOP(OP_NULL, 0, other); - op_getmad(first, newop, '1'); - newop->op_targ = type; /* set "was" field */ - return newop; - } op_free(first); if (other->op_type == OP_LEAVE) other = newUNOP(OP_NULL, OPf_SPECIAL, other); @@ -6185,13 +5884,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) *otherp = NULL; if (cstop->op_type == OP_CONST) cstop->op_private |= OPpCONST_SHORTCIRCUIT; - if (PL_madskills) { - first = newUNOP(OP_NULL, 0, first); - op_getmad(other, first, '2'); - first->op_targ = type; /* set "was" field */ - } - else - op_free(other); + op_free(other); return first; } } @@ -6306,15 +5999,8 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) cstop->op_private & OPpCONST_STRICT) { no_bareword_allowed(cstop); } - if (PL_madskills) { - /* This is all dead code when PERL_MAD is not defined. */ - live = newUNOP(OP_NULL, 0, live); - op_getmad(first, live, 'C'); - op_getmad(dead, live, left ? 'e' : 't'); - } else { - op_free(first); - op_free(dead); - } + op_free(first); + op_free(dead); if (live->op_type == OP_LEAVE) live = newUNOP(OP_NULL, OPf_SPECIAL, live); else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST @@ -6442,12 +6128,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 @@ -6486,11 +6180,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 */ @@ -6660,7 +6362,6 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) PADOFFSET padoff = 0; I32 iterflags = 0; I32 iterpflags = 0; - OP *madsv = NULL; PERL_ARGS_ASSERT_NEWFOROP; @@ -6683,12 +6384,8 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) else if (sv->op_type == OP_PADSV) { /* private variable */ iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */ padoff = sv->op_targ; - if (PL_madskills) - madsv = sv; - else { - sv->op_targ = 0; - op_free(sv); - } + sv->op_targ = 0; + op_free(sv); sv = NULL; } else @@ -6739,11 +6436,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) right->op_next = (OP*)listop; listop->op_next = listop->op_first; -#ifdef PERL_MAD - op_getmad(expr,(OP*)listop,'O'); -#else op_free(expr); -#endif expr = (OP*)(listop); op_null(expr); iterflags |= OPf_STACKED; @@ -6772,8 +6465,6 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP)); loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0); - if (madsv) - op_getmad(madsv, (OP*)loop, 'v'); return wop; } @@ -6826,11 +6517,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) /* If we have already created an op, we do not need the label. */ if (o) -#ifdef PERL_MAD - op_getmad(label,o,'L'); -#else op_free(label); -#endif else o = newUNOP(type, OPf_STACKED, label); PL_hints |= HINT_BLOCK_SCOPE; @@ -6999,7 +6686,7 @@ S_looks_like_bool(pTHX_ const OP *o) else return FALSE; - /* FALL THROUGH */ + /* FALLTHROUGH */ default: return FALSE; } @@ -7132,7 +6819,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 @@ -7165,17 +6852,32 @@ 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; - if (PL_madskills) - return NULL; - if (!o) return NULL; @@ -7201,6 +6903,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; } @@ -7216,9 +6939,6 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, assert (o || name); assert (const_svp); if ((!block -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif )) { if (CvFLAGS(PL_compcv)) { /* might have had built-in attrs applied */ @@ -7256,13 +6976,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o, SvREFCNT_inc_simple_void_NN(PL_compcv); CopLINE_set(PL_curcop, oldline); } -#ifdef PERL_MAD - if (!PL_minus_c) /* keep old one around for madskills */ -#endif - { - /* (PL_madskills unset in used file.) */ - SAVEFREESV(cv); - } + SAVEFREESV(cv); return TRUE; } @@ -7318,12 +7032,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (!PL_madskills) { - if (proto) - SAVEFREEOP(proto); - if (attrs) - SAVEFREEOP(attrs); - } + if (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); if (PL_parser && PL_parser->error_count) { op_free(block); @@ -7366,13 +7078,10 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!block || !ps || *ps || attrs || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS) -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif ) 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); @@ -7417,8 +7126,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); CvISXSUB_on(cv); - if (PL_madskills) - goto install_block; op_free(block); SvREFCNT_dec(compcv); PL_compcv = NULL; @@ -7439,9 +7146,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (cv) { /* must reuse cv in case stub is referenced elsewhere */ /* transfer PL_compcv to cv */ if (block -#ifdef PERL_MAD - && block->op_type != OP_NULL -#endif ) { cv_flags_t preserved_flags = CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED); @@ -7505,7 +7209,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } - install_block: if (!block) goto attrs; @@ -7518,11 +7221,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { OP* const newblock = newSTATEOP(0, NULL, 0); -#ifdef PERL_MAD - op_getmad(block,newblock,'B'); -#else op_free(block); -#endif block = newblock; } CvROOT(cv) = CvLVALUE(cv) @@ -7539,11 +7238,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(&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. */ @@ -7613,15 +7319,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; @@ -7638,11 +7339,9 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, store it. */ const I32 gv_fetch_flags = ec ? GV_NOADD_NOINIT : - (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) - || PL_madskills) + (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) ? 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; @@ -7684,14 +7383,12 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, else ps = NULL; - if (!PL_madskills) { - if (o) - SAVEFREEOP(o); - if (proto) - SAVEFREEOP(proto); - if (attrs) - SAVEFREEOP(attrs); - } + if (o) + SAVEFREEOP(o); + if (proto) + SAVEFREEOP(proto); + if (attrs) + SAVEFREEOP(attrs); if (ec) { op_free(block); @@ -7738,13 +7435,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) -#ifdef PERL_MAD - || block->op_type == OP_NULL -#endif ) 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); @@ -7786,8 +7480,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, const_sv ); } - if (PL_madskills) - goto install_block; op_free(block); SvREFCNT_dec(PL_compcv); PL_compcv = NULL; @@ -7796,9 +7488,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (cv) { /* must reuse cv if autoloaded */ /* transfer PL_compcv to cv */ if (block -#ifdef PERL_MAD - && block->op_type != OP_NULL -#endif ) { cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS; PADLIST *const temp_av = CvPADLIST(cv); @@ -7863,7 +7552,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); } - install_block: if (!block) goto attrs; @@ -7876,11 +7564,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, /* This makes sub {}; work as expected. */ if (block->op_type == OP_STUB) { OP* const newblock = newSTATEOP(0, NULL, 0); -#ifdef PERL_MAD - op_getmad(block,newblock,'B'); -#else op_free(block); -#endif block = newblock; } CvROOT(cv) = CvLVALUE(cv) @@ -7900,11 +7584,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(&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. */ @@ -8241,18 +7932,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) ); } -#ifdef PERL_MAD -OP * -#else void -#endif Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { dVAR; CV *cv; -#ifdef PERL_MAD - OP* pegop = newOP(OP_NULL, 0); -#endif GV *gv; @@ -8297,21 +7981,14 @@ 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(&CvSTART(cv)); cv_forget_slab(cv); finish: -#ifdef PERL_MAD - op_getmad(o,pegop,'n'); - op_getmad_weak(block, pegop, 'b'); -#else op_free(o); -#endif if (PL_parser) PL_parser->copline = NOLINE; LEAVE_SCOPE(floor); -#ifdef PERL_MAD - return pegop; -#endif } OP * @@ -8409,8 +8086,7 @@ Perl_newAVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Using an array as a reference is deprecated"); + Perl_croak(aTHX_ "Can't use an array as a reference"); } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -8436,8 +8112,7 @@ Perl_newHVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Using a hash as a reference is deprecated"); + Perl_croak(aTHX_ "Can't use a hash as a reference"); } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -8477,14 +8152,14 @@ Perl_ck_anoncode(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_ANONCODE; cSVOPo->op_targ = pad_add_anon((CV*)cSVOPo->op_sv, o->op_type); - if (!PL_madskills) - cSVOPo->op_sv = NULL; + cSVOPo->op_sv = NULL; return 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) { @@ -8493,10 +8168,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); @@ -8504,12 +8184,21 @@ 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_CONTEXT; + PERL_UNUSED_ARG(o); +#endif } OP * @@ -8527,11 +8216,7 @@ Perl_ck_backtick(pTHX_ OP *o) else if (!(o->op_flags & OPf_KIDS)) newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP()); if (newop) { -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else op_free(o); -#endif return newop; } S_io_hints(aTHX_ o); @@ -8631,11 +8316,7 @@ Perl_ck_spair(pTHX_ OP *o) type == OP_RV2AV || type == OP_RV2HV) return o; } -#ifdef PERL_MAD - op_getmad(kUNOP->op_first,newop,'K'); -#else op_free(kUNOP->op_first); -#endif kUNOP->op_first = newop; } /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP, @@ -8656,13 +8337,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: @@ -8694,11 +8375,7 @@ Perl_ck_eof(pTHX_ OP *o) if (cLISTOPo->op_first->op_type == OP_STUB) { OP * const newop = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else op_free(o); -#endif o = newop; } o = ck_fun(o); @@ -8723,14 +8400,9 @@ Perl_ck_eval(pTHX_ OP *o) if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) { LOGOP *enter; -#ifdef PERL_MAD - OP* const oldo = o; -#endif cUNOPo->op_first = 0; -#ifndef PERL_MAD op_free(o); -#endif NewOp(1101, enter, 1, LOGOP); enter->op_type = OP_ENTERTRY; @@ -8744,7 +8416,6 @@ Perl_ck_eval(pTHX_ OP *o) o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; enter->op_other = o; - op_getmad(oldo,o,'O'); return o; } else { @@ -8754,13 +8425,8 @@ Perl_ck_eval(pTHX_ OP *o) } else { const U8 priv = o->op_private; -#ifdef PERL_MAD - OP* const oldo = o; -#else op_free(o); -#endif o = newUNOP(OP_ENTEREVAL, priv <<8, newDEFSVOP()); - op_getmad(oldo,o,'O'); } o->op_targ = (PADOFFSET)PL_hints; if (o->op_private & OPpEVAL_BYTES) o->op_targ &= ~HINT_UTF8; @@ -8953,11 +8619,7 @@ Perl_ck_ftst(pTHX_ OP *o) && !kid->op_folded) { OP * const newop = newGVOP(type, OPf_REF, gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else op_free(o); -#endif return newop; } if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) @@ -8974,16 +8636,11 @@ Perl_ck_ftst(pTHX_ OP *o) } } else { -#ifdef PERL_MAD - OP* const oldo = o; -#else op_free(o); -#endif if (type == OP_FTTTY) o = newGVOP(type, OPf_REF, PL_stdingv); else o = newUNOP(type, 0, newDEFSVOP()); - op_getmad(oldo,o,'O'); } return o; } @@ -9038,12 +8695,6 @@ Perl_ck_fun(pTHX_ OP *o) numargs++; sibl = kid->op_sibling; -#ifdef PERL_MAD - if (!sibl && kid->op_type == OP_STUB) { - numargs--; - break; - } -#endif switch (oa & 7) { case OA_SCALAR: /* list seen where single (scalar) arg expected? */ @@ -9069,24 +8720,7 @@ Perl_ck_fun(pTHX_ OP *o) "Useless use of %s with no values", PL_op_desc[type]); - if (kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) - { - OP * const newop = newAVREF(newGVOP(OP_GV, 0, - gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); -#ifdef PERL_MAD - op_getmad(kid,newop,'K'); -#else - op_free(kid); -#endif - kid = newop; - kid->op_sibling = sibl; - *tokid = kid; - } - else if (kid->op_type == OP_CONST + if (kid->op_type == OP_CONST && ( !SvROK(cSVOPx_sv(kid)) || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV ) ) @@ -9094,27 +8728,17 @@ 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 && - (kid->op_private & OPpCONST_BARE)) - { - OP * const newop = newHVREF(newGVOP(OP_GV, 0, - gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); -#ifdef PERL_MAD - op_getmad(kid,newop,'K'); -#else - op_free(kid); -#endif - kid = newop; - kid->op_sibling = sibl; - *tokid = kid; - } - else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) + if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV) bad_type_pv(numargs, "hash", PL_op_desc[type], 0, kid); op_lvalue(kid, type); break; @@ -9138,11 +8762,7 @@ Perl_ck_fun(pTHX_ OP *o) if (!(o->op_private & 1) && /* if not unop */ kid == cLISTOPo->op_last) cLISTOPo->op_last = newop; -#ifdef PERL_MAD - op_getmad(kid,newop,'K'); -#else op_free(kid); -#endif kid = newop; } else if (kid->op_type == OP_READLINE) { @@ -9264,28 +8884,17 @@ Perl_ck_fun(pTHX_ OP *o) tokid = &kid->op_sibling; kid = kid->op_sibling; } -#ifdef PERL_MAD - if (kid && kid->op_type != OP_STUB) - return too_many_arguments_pv(o,OP_DESC(o), 0); - o->op_private |= numargs; -#else - /* FIXME - should the numargs move as for the PERL_MAD case? */ + /* FIXME - should the numargs or-ing move after the too many + * arguments check? */ o->op_private |= numargs; if (kid) return too_many_arguments_pv(o,OP_DESC(o), 0); -#endif listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { -#ifdef PERL_MAD - OP *newop = newUNOP(type, 0, newDEFSVOP()); - op_getmad(o,newop,'O'); - return newop; -#else /* Ordering of these two is important to keep f_map.t passing. */ op_free(o); return newUNOP(type, 0, newDEFSVOP()); -#endif } if (oa) { @@ -9485,11 +9094,7 @@ Perl_ck_readline(pTHX_ OP *o) else { OP * const newop = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); -#ifdef PERL_MAD - op_getmad(o,newop,'O'); -#else op_free(o); -#endif return newop; } return o; @@ -9581,8 +9186,6 @@ Perl_ck_sassign(pTHX_ OP *o) && !(kid->op_flags & OPf_STACKED) /* Cannot steal the second time! */ && !(kid->op_private & OPpTARGET_MY) - /* Keep the full thing for madskills */ - && !PL_madskills ) { OP * const kkid = kid->op_sibling; @@ -9607,7 +9210,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 ) ) @@ -9677,11 +9280,7 @@ Perl_ck_method(pTHX_ OP *o) kSVOP->op_sv = NULL; } cmop = newSVOP(OP_METHOD_NAMED, 0, sv); -#ifdef PERL_MAD - op_getmad(o,cmop,'O'); -#else op_free(o); -#endif return cmop; } } @@ -9791,11 +9390,8 @@ Perl_ck_require(pTHX_ OP *o) else { kid = newDEFSVOP(); } -#ifndef PERL_MAD op_free(o); -#endif newop = S_new_entersubop(aTHX_ gv, kid); - op_getmad(o,newop,'O'); return newop; } @@ -9860,17 +9456,8 @@ Perl_ck_shift(pTHX_ OP *o) } argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv))); -#ifdef PERL_MAD - { - OP * const oldo = o; - o = newUNOP(type, 0, scalar(argop)); - op_getmad(oldo,o,'O'); - return o; - } -#else op_free(o); return newUNOP(type, 0, scalar(argop)); -#endif } return scalar(ck_fun(o)); } @@ -9901,9 +9488,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) @@ -9930,6 +9520,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) { @@ -10026,11 +9626,7 @@ S_simplify_sort(pTHX_ OP *o) o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER; kid = cLISTOPo->op_first->op_sibling; cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ -#ifdef PERL_MAD - op_getmad(kid,o,'S'); /* then delete it */ -#else op_free(kid); /* then delete it */ -#endif } OP * @@ -10078,6 +9674,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) @@ -10218,7 +9815,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } break; default: { return NULL; - } break; + } NOT_REACHED; /* NOTREACHED */ } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; @@ -10253,10 +9850,8 @@ Perl_ck_entersub_args_list(pTHX_ OP *entersubop) if (!aop->op_sibling) aop = cUNOPx(aop)->op_first; for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { - if (!(PL_madskills && aop->op_type == OP_STUB)) { - list(aop); - op_lvalue(aop, OP_ENTERSUB); - } + list(aop); + op_lvalue(aop, OP_ENTERSUB); } return entersubop; } @@ -10315,15 +9910,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) aop = aop->op_sibling; for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; while (aop != cvop) { - OP* o3; - if (PL_madskills && aop->op_type == OP_STUB) { - aop = aop->op_sibling; - continue; - } - if (PL_madskills && aop->op_type == OP_NULL) - o3 = ((UNOP*)aop)->op_first; - else - o3 = aop; + OP* o3 = aop; if (proto >= proto_end) return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); @@ -10337,6 +9924,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++; @@ -10379,14 +9967,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) GV * const gv = cGVOPx_gv(gvop); OP * const sibling = aop->op_sibling; SV * const n = newSVpvs(""); -#ifdef PERL_MAD - OP * const oldaop = aop; -#else op_free(aop); -#endif gv_fullname4(n, gv, "", FALSE); aop = newSVOP(OP_CONST, 0, n); - op_getmad(oldaop,aop,'O'); prev->op_sibling = aop; aop->op_sibling = sibling; } @@ -10409,7 +9992,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) break; case '[': case ']': goto oops; - break; + case '\\': proto++; arg++; @@ -10424,7 +10007,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) else goto oops; goto again; - break; + case ']': if (contextclass) { const char *p = proto; @@ -10586,9 +10169,6 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) aop = cUNOPx(aop)->op_first; aop = aop->op_sibling; for (cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ; - if (PL_madskills) while (aop != cvop && aop->op_type == OP_STUB) { - aop = aop->op_sibling; - } if (aop != cvop) (void)too_many_arguments_pv(entersubop, GvNAME(namegv), 0); @@ -10609,14 +10189,11 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) ) ); } - assert(0); + NOT_REACHED; } else { OP *prev, *cvop; U32 flags; -#ifdef PERL_MAD - bool seenarg = FALSE; -#endif if (!aop->op_sibling) aop = cUNOPx(aop)->op_first; @@ -10626,10 +10203,6 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) for (cvop = aop; cvop->op_sibling; prev=cvop, cvop = cvop->op_sibling) -#ifdef PERL_MAD - if (PL_madskills && cvop->op_sibling - && cvop->op_type != OP_STUB) seenarg = TRUE -#endif ; prev->op_sibling = NULL; flags = OPf_SPECIAL * !(cvop->op_private & OPpENTERSUB_NOPAREN); @@ -10648,9 +10221,6 @@ Perl_ck_entersub_args_core(pTHX_ OP *entersubop, GV *namegv, SV *protosv) return aop ? newUNOP(opnum,flags,aop) : newOP(opnum,flags); case OA_BASEOP: if (aop) { -#ifdef PERL_MAD - if (!PL_madskills || seenarg) -#endif (void)too_many_arguments_pv(aop, GvNAME(namegv), 0); op_free(aop); } @@ -10719,8 +10289,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); @@ -10748,6 +10321,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; @@ -10839,6 +10413,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); @@ -10933,7 +10510,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 * @@ -10964,7 +10547,7 @@ Perl_ck_length(pTHX_ OP *o) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "length() used on %"SVf" (did you mean \"scalar(%s%"SVf ")\"?)", - name, hash ? "keys " : "", name + SVfARG(name), hash ? "keys " : "", SVfARG(name) ); else if (hash) /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */ @@ -11063,21 +10646,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(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 */ @@ -11088,9 +10698,11 @@ 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; + OP *fop; + OP *sop; if (!o || o->op_opt) return; @@ -11101,8 +10713,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(defer); + } break; } @@ -11110,6 +10726,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 */ @@ -11140,12 +10794,85 @@ Perl_rpeep(pTHX_ OP *o) && 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_sibling->op_next == sibling - && next->op_next && sibling->op_next) - { - next->op_sibling->op_next = sibling->op_next; - o->op_next = next->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 @@ -11231,12 +10958,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; @@ -11327,7 +11054,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 @@ -11399,7 +11126,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)) @@ -11450,6 +11177,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) @@ -11500,7 +11228,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) @@ -11548,10 +11276,6 @@ Perl_rpeep(pTHX_ OP *o) break; - { - OP *fop; - OP *sop; - #define HV_OR_SCALARHV(op) \ ( (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \ ? (op) \ @@ -11637,8 +11361,7 @@ Perl_rpeep(pTHX_ OP *o) if ((fop = HV_OR_SCALARHV(cLOGOP->op_first))) fop->op_private |= OPpTRUEBOOL; #undef HV_OR_SCALARHV - /* GERONIMO! */ - } + /* GERONIMO! */ /* FALLTHROUGH */ case OP_MAPWHILE: case OP_GREPWHILE: @@ -11666,6 +11389,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 && @@ -11678,12 +11406,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 */ @@ -11835,6 +11579,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) { @@ -11860,8 +11621,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; } @@ -11876,9 +11645,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.7, this was implemented as a +This macro does call a function. Prior +to 5.19.6, this was implemented as a function. =cut @@ -11982,7 +11752,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 */ @@ -12005,9 +11775,9 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) } /* -=head1 Functions in file op.c =for apidoc core_prototype + This function assigns the prototype of the named core function to C, or to a new mortal SV if C is NULL. It returns the modified C, or NULL if the core function has no prototype. C is a code as returned @@ -12147,7 +11917,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: @@ -12221,7 +11991,7 @@ Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, is_const ? "Constant subroutine %"SVf" redefined" : "Subroutine %"SVf" redefined", - name); + SVfARG(name)); } /* @@ -12245,6 +12015,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 @@ -12279,6 +12061,7 @@ Perl_wrap_op_checker(pTHX_ Optype opcode, { dVAR; + PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_WRAP_OP_CHECKER; if (*old_checker_p) return; OP_CHECK_MUTEX_LOCK; @@ -12324,7 +12107,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);