X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/106d2451aadbd20e554aed6fb9fa741f230dce4b..1b59a1329eefc8fe6584a8e8ed841d661ab326b8:/op.c?ds=sidebyside diff --git a/op.c b/op.c index edc2362..a9ee2d1 100644 --- a/op.c +++ b/op.c @@ -165,11 +165,23 @@ Perl_Slab_Alloc(pTHX_ size_t sz) OP *o; size_t opsz, space; + /* We only allocate ops from the slab during subroutine compilation. + We find the slab via PL_compcv, hence that must be non-NULL. It could + also be pointing to a subroutine which is now fully set up (CvROOT() + pointing to the top of the optree for that sub), or a subroutine + which isn't using the slab allocator. If our sanity checks aren't met, + don't use a slab, but allocate the OP directly from the heap. */ if (!PL_compcv || CvROOT(PL_compcv) || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv))) return PerlMemShared_calloc(1, sz); - if (!CvSTART(PL_compcv)) { /* sneak it in here */ + /* While the subroutine is under construction, the slabs are accessed via + CvSTART(), to avoid needing to expand PVCV by one pointer for something + unneeded at runtime. Once a subroutine is constructed, the slabs are + accessed via CvROOT(). So if CvSTART() is NULL, no slab has been + allocated yet. See the commit message for 8be227ab5eaa23f2 for more + details. */ + if (!CvSTART(PL_compcv)) { CvSTART(PL_compcv) = (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE)); CvSLABBED_on(PL_compcv); @@ -180,6 +192,9 @@ Perl_Slab_Alloc(pTHX_ size_t sz) opsz = SIZE_TO_PSIZE(sz); sz = opsz + OPSLOT_HEADER_P; + /* The slabs maintain a free list of OPs. In particular, constant folding + will free up OPs, so it makes sense to re-use them where possible. A + freed up slot is used in preference to a new allocation. */ if (slab->opslab_freed) { OP **too = &slab->opslab_freed; o = *too; @@ -283,7 +298,7 @@ Perl_Slab_to_rw(pTHX_ OPSLAB *const slab) } #else -# define Slab_to_rw(op) +# define Slab_to_rw(op) NOOP #endif /* This cannot possibly be right, but it was copied from the old slab @@ -520,9 +535,10 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP } STATIC void -S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid) +S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - PERL_ARGS_ASSERT_BAD_TYPE_SV; + SV * const namesv = gv_ename(gv); + PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags); @@ -579,9 +595,9 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) } } else if (len == 2 && name[1] == '_' && !is_our) - /* diag_listed_as: Use of my $_ is deprecated */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Use of %s $_ is deprecated", + /* diag_listed_as: Use of my $_ is experimental */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC), + "Use of %s $_ is experimental", PL_parser->in_my == KEY_state ? "state" : "my"); @@ -712,9 +728,8 @@ Perl_op_free(pTHX_ OP *o) if (type == OP_NULL) type = (OPCODE)o->op_targ; - if (o->op_slabbed) { - Slab_to_rw(OpSLAB(o)); - } + if (o->op_slabbed) + Slab_to_rw(OpSLAB(o)); /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ @@ -1366,29 +1381,16 @@ Perl_scalarvoid(pTHX_ OP *o) else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = NULL; else if (SvPOK(sv)) { - /* perl4's way of mixing documentation and code - (before the invention of POD) was based on a - trick to mix nroff and perl code. The trick was - built upon these three nroff macros being used in - void context. The pink camel has the details in - the script wrapman near page 319. */ - const char * const maybe_macro = SvPVX_const(sv); - if (strnEQ(maybe_macro, "di", 2) || - strnEQ(maybe_macro, "ds", 2) || - strnEQ(maybe_macro, "ig", 2)) - useless = NULL; - else { - SV * const dsv = newSVpvs(""); - useless_sv - = Perl_newSVpvf(aTHX_ - "a constant (%s)", - pv_pretty(dsv, maybe_macro, - SvCUR(sv), 32, NULL, NULL, - PERL_PV_PRETTY_DUMP - | PERL_PV_ESCAPE_NOCLEAR - | PERL_PV_ESCAPE_UNI_DETECT)); - SvREFCNT_dec_NN(dsv); - } + SV * const dsv = newSVpvs(""); + useless_sv + = Perl_newSVpvf(aTHX_ + "a constant (%s)", + pv_pretty(dsv, SvPVX_const(sv), + SvCUR(sv), 32, NULL, NULL, + PERL_PV_PRETTY_DUMP + | PERL_PV_ESCAPE_NOCLEAR + | PERL_PV_ESCAPE_UNI_DETECT)); + SvREFCNT_dec_NN(dsv); } else if (SvOK(sv)) { useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv); @@ -1707,7 +1709,7 @@ S_finalize_op(pTHX_ OP* o) case OP_EXEC: if ( o->op_sibling && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE) - && ckWARN(WARN_SYNTAX)) + && ckWARN(WARN_EXEC)) { if (o->op_sibling->op_sibling) { const OPCODE type = o->op_sibling->op_sibling->op_type; @@ -2141,9 +2143,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) lvalue_func: if (type == OP_LEAVESUBLV) o->op_private |= OPpMAYBE_LVSUB; - pad_free(o->op_targ); - o->op_targ = pad_alloc(o->op_type, SVs_PADMY); - assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL); if (o->op_flags & OPf_KIDS) op_lvalue(cBINOPo->op_first->op_sibling, type); break; @@ -3229,6 +3228,7 @@ S_fold_constants(pTHX_ OP *o) case OP_LCFIRST: case OP_UC: case OP_LC: + case OP_FC: case OP_SLT: case OP_SGT: case OP_SLE: @@ -3345,7 +3345,10 @@ S_fold_constants(pTHX_ OP *o) if (type == OP_RV2GV) newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else + { newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv)); + newop->op_folded = 1; + } op_getmad(o,newop,'f'); return newop; @@ -4371,7 +4374,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if(del && rlen == tlen) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); - } else if(rlen > tlen) { + } else if(rlen > tlen && !complement) { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); } @@ -4545,11 +4548,21 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) LINKLIST(expr); - /* fix up DO blocks; treat each one as a separate little sub */ + /* fix up DO blocks; treat each one as a separate little sub; + * also, mark any arrays as LIST/REF */ if (expr->op_type == OP_LIST) { OP *o; for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) { + + if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) { + assert( !(o->op_flags & OPf_WANT)); + /* push the array rather than its contents. The regex + * engine will retrieve and join the elements later */ + o->op_flags |= (OPf_WANT_LIST | OPf_REF); + continue; + } + if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))) continue; o->op_next = NULL; /* undo temporary hack from above */ @@ -4563,7 +4576,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) o->op_next = leaveop->op_first->op_sibling; /* skip leave */ assert(leaveop->op_flags & OPf_KIDS); - assert(leaveop->op_last->op_next = (OP*)leaveop); + assert(leaveop->op_last->op_next == (OP*)leaveop); leaveop->op_next = NULL; /* stop on last op */ op_null((OP*)leaveop); } @@ -4583,6 +4596,12 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) finalize_optree(o); } } + else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) { + assert( !(expr->op_flags & OPf_WANT)); + /* push the array rather than its contents. The regex + * engine will retrieve and join the elements later */ + expr->op_flags |= (OPf_WANT_LIST | OPf_REF); + } PL_hints |= HINT_BLOCK_SCOPE; pm = (PMOP*)o; @@ -4592,6 +4611,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; regexp_engine const *eng = current_re_engine(); + if (o->op_flags & OPf_SPECIAL) + rx_flags |= RXf_SPLIT; + if (!has_code || !eng->op_comp) { /* compile-time simple constant pattern */ @@ -4668,6 +4690,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) pm->op_pmflags |= PMf_CODELIST_PRIVATE; } + if (o->op_flags & OPf_SPECIAL) + pm->op_pmflags |= PMf_SPLIT; + /* the OP_REGCMAYBE is a placeholder in the non-threaded case * to allow its op_next to be pointed past the regcomp and * preceding stacking ops; @@ -4931,7 +4956,7 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) Constructs, checks, and returns an op of any type that involves an embedded C-level pointer (PV). I is the opcode. I gives the eight bits of C. I supplies the C-level pointer, which -must have been allocated using L; the memory will +must have been allocated using C; the memory will be freed when the op is destroyed. =cut @@ -5598,9 +5623,22 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { - SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; + SV ** const svp = + &((SVOP*)((LISTOP*)right)->op_last)->op_sv; + SV * const sv = *svp; if (SvIOK(sv) && SvIVX(sv) == 0) + { + if (right->op_private & OPpSPLIT_IMPLIM) { + /* our own SV, created in ck_split */ + SvREADONLY_off(sv); sv_setiv(sv, PL_modcount+1); + } + else { + /* SV may belong to someone else */ + SvREFCNT_dec(sv); + *svp = newSViv(PL_modcount+1); + } + } } } } @@ -5626,7 +5664,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) Constructs a state op (COP). The state op is normally a C op, but will be a C op if debugging is enabled for currently-compiled -code. The state op is populated from L (or L). +code. The state op is populated from C (or C). If I