In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3164fde474d170d03f8bbf31ee203012c027f711?hp=217f6fa330a187be32a68556507e3165b8747f55>
- Log ----------------------------------------------------------------- commit 3164fde474d170d03f8bbf31ee203012c027f711 Author: Reini Urban <[email protected]> Date: Thu Jul 18 14:50:35 2013 -0500 more op_folded support: B, dump also add more B::OP accessors for the missing bitfields M dump.c M ext/B/B.xs commit 51a35dd77045e0b4f435457b4c851f2561cde64f Author: Father Chrysostomos <[email protected]> Date: Thu Jul 18 18:51:54 2013 -0700 Add Niels Thykier to AUTHORS M AUTHORS commit 3513c7400a8b4d83055235684e2c6a0c5d89b061 Author: Niels Thykier <[email protected]> Date: Wed Jul 17 20:59:54 2013 +0200 op.c: Add op_folded to BASEOP Add a new member, op_folded, to BASEOP. It is replacement for OPpCONST_FOLDED (which can only be set on OP_CONST). At the moment OPpCONST_FOLDED remains, as it is exposed in B (e.g. B::Concise relies on it). Signed-off-by: Niels Thykier <[email protected]> M op.c M op.h M toke.c commit 2cc6fe62efccaf47e15982ddbe988a976469d887 Author: Father Chrysostomos <[email protected]> Date: Tue Jul 16 23:29:25 2013 -0700 toke.c:yylex: assert that PL_linestr is not a COW and fix the one bug this uncovers. With COW enabled all the time, it is easy to introduce bugs like this. See also 4e917a04. In short, toke.c expects to be able to modify PL_linestrâs buffer. Putting this assertion in yylex (a hot path) will make sure PL_linestr never becomes a COW again. M toke.c ----------------------------------------------------------------------- Summary of changes: AUTHORS | 1 + dump.c | 1 + ext/B/B.xs | 26 +++++++++++++++++++++++++- op.c | 14 ++++++++++---- op.h | 7 +++++-- toke.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++-- 6 files changed, 88 insertions(+), 9 deletions(-) diff --git a/AUTHORS b/AUTHORS index 1c3e9fe..3cc261b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -840,6 +840,7 @@ Nick Ing-Simmons Nick Johnston <[email protected]> Nick Williams <[email protected]> Nicolas Kaiser <[email protected]> +Niels Thykier <[email protected]> Nigel Sandever <[email protected]> Niko Tyni <[email protected]> Nikola Knezevic <[email protected]> diff --git a/dump.c b/dump.c index 6ba4fd2..84d3eb8 100644 --- a/dump.c +++ b/dump.c @@ -861,6 +861,7 @@ S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \ if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \ if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \ + if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \ if (!xml) \ Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \ SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : "");\ diff --git a/ext/B/B.xs b/ext/B/B.xs index e7049f0..20eeba8 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -718,6 +718,14 @@ struct OP_methods { STR_WITH_LEN("warnings"),0, -1, /*44*/ STR_WITH_LEN("io"), 0, -1, /*45*/ STR_WITH_LEN("hints_hash"),0, -1, /*46*/ +#if PERL_VERSION >= 17 + STR_WITH_LEN("slabbed"), 0, -1, /*47*/ + STR_WITH_LEN("savefree"),0, -1, /*48*/ + STR_WITH_LEN("static"), 0, -1, /*49*/ +#if PERL_VERSION >= 19 + STR_WITH_LEN("folded"), 0, -1, /*50*/ +#endif +#endif }; #include "const-c.inc" @@ -989,6 +997,10 @@ next(o) B::COP::warnings = 44 B::COP::io = 45 B::COP::hints_hash = 46 + B::OP::slabbed = 47 + B::OP::savefree = 48 + B::OP::static = 49 + B::OP::folded = 50 PREINIT: char *ptr; SV *ret; @@ -1064,10 +1076,22 @@ next(o) case 30: /* type */ case 31: /* opt */ case 32: /* spare */ - /* These 3 are all bitfields, so we can't take their addresses */ +#if PERL_VERSION >= 17 + case 47: /* slabbed */ + case 48: /* savefree */ + case 49: /* static */ +#if PERL_VERSION >= 19 + case 50: /* folded */ +#endif +#endif + /* These are all bitfields, so we can't take their addresses */ ret = sv_2mortal(newSVuv((UV)( ix == 30 ? o->op_type : ix == 31 ? o->op_opt + : ix == 47 ? o->op_slabbed + : ix == 48 ? o->op_savefree + : ix == 49 ? o->op_static + : ix == 50 ? o->op_folded : o->op_spare))); break; case 33: /* children */ diff --git a/op.c b/op.c index d5323a0..a9ee2d1 100644 --- a/op.c +++ b/op.c @@ -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; @@ -5880,6 +5883,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) other->op_flags |= OPf_SPECIAL; else if (other->op_type == OP_CONST) other->op_private |= OPpCONST_FOLDED; + + other->op_folded = 1; return other; } else { @@ -6041,6 +6046,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) live->op_flags |= OPf_SPECIAL; else if (live->op_type == OP_CONST) live->op_private |= OPpCONST_FOLDED; + live->op_folded = 1; return live; } NewOp(1101, logop, 1, LOGOP); @@ -8651,7 +8657,7 @@ Perl_ck_ftst(pTHX_ OP *o) const OPCODE kidtype = kid->op_type; if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) - && !(kid->op_private & OPpCONST_FOLDED)) { + && !kid->op_folded) { OP * const newop = newGVOP(type, OPf_REF, gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); #ifdef PERL_MAD @@ -9236,7 +9242,7 @@ Perl_ck_listiob(pTHX_ OP *o) kid = kid->op_sibling; else if (kid && !kid->op_sibling) { /* print HANDLE; */ if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE - && !(kid->op_private & OPpCONST_FOLDED)) { + && !kid->op_folded) { o->op_flags |= OPf_STACKED; /* make it a filehandle */ kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid)); cLISTOPo->op_first->op_sibling = kid; @@ -10603,8 +10609,8 @@ Perl_ck_trunc(pTHX_ OP *o) if (kid->op_type == OP_NULL) kid = (SVOP*)kid->op_sibling; if (kid && kid->op_type == OP_CONST && - (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED)) - == OPpCONST_BARE) + (kid->op_private & OPpCONST_BARE) && + !kid->op_folded) { o->op_flags |= OPf_SPECIAL; kid->op_private &= ~OPpCONST_STRICT; diff --git a/op.h b/op.h index 5d1a771..dcfd5be 100644 --- a/op.h +++ b/op.h @@ -23,7 +23,8 @@ * op_static tell op_free() to skip PerlMemShared_free(), when * !op_slabbed. * op_savefree on savestack via SAVEFREEOP - * op_spare Three spare bits + * op_folded Result/remainder of a constant fold operation. + * op_spare Two spare bits * op_flags Flags common to all operations. See OPf_* below. * op_private Flags peculiar to a particular operation (BUT, * by default, set to the number of children until @@ -56,7 +57,8 @@ typedef PERL_BITFIELD16 Optype; PERL_BITFIELD16 op_slabbed:1; \ PERL_BITFIELD16 op_savefree:1; \ PERL_BITFIELD16 op_static:1; \ - PERL_BITFIELD16 op_spare:3; \ + PERL_BITFIELD16 op_folded:1; \ + PERL_BITFIELD16 op_spare:2; \ U8 op_flags; \ U8 op_private; #endif @@ -257,6 +259,7 @@ Deprecated. Use C<GIMME_V> instead. #define OPpCONST_STRICT 8 /* bareword subject to strict 'subs' */ #define OPpCONST_ENTERED 16 /* Has been entered as symbol. */ #define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */ +/* Replaced by op_folded in perl itself, still used by B/B::Concise etc. */ #define OPpCONST_FOLDED 128 /* Result of constant folding */ /* Private for OP_FLIP/FLOP */ diff --git a/toke.c b/toke.c index 1615cb6..2ab2a71 100644 --- a/toke.c +++ b/toke.c @@ -5145,6 +5145,8 @@ Perl_yylex(pTHX) return yylex(); } + /* We really do *not* want PL_linestr ever becoming a COW. */ + assert (!SvIsCOW(PL_linestr)); s = PL_bufptr; PL_oldoldbufptr = PL_oldbufptr; PL_oldbufptr = s; @@ -7391,6 +7393,7 @@ Perl_yylex(pTHX) SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv); ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv); pl_yylval.opval->op_private = OPpCONST_FOLDED; + pl_yylval.opval->op_folded = 1; pl_yylval.opval->op_flags |= OPf_SPECIAL; TOKEN(WORD); } @@ -10536,8 +10539,49 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse, int offset = s - SvPVX_const(PL_linestr); const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, &offset, (char*)termstr, termlen); - const char * const ns = SvPVX_const(PL_linestr) + offset; - char * const svlast = SvEND(sv) - 1; + const char *ns; + char *svlast; + + if (SvIsCOW(PL_linestr)) { + STRLEN bufend_pos, bufptr_pos, oldbufptr_pos; + STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos; + STRLEN last_lop_pos, re_eval_start_pos, s_pos; + char *buf = SvPVX(PL_linestr); + bufend_pos = PL_parser->bufend - buf; + bufptr_pos = PL_parser->bufptr - buf; + oldbufptr_pos = PL_parser->oldbufptr - buf; + oldoldbufptr_pos = PL_parser->oldoldbufptr - buf; + linestart_pos = PL_parser->linestart - buf; + last_uni_pos = PL_parser->last_uni + ? PL_parser->last_uni - buf + : 0; + last_lop_pos = PL_parser->last_lop + ? PL_parser->last_lop - buf + : 0; + re_eval_start_pos = + PL_parser->lex_shared->re_eval_start ? + PL_parser->lex_shared->re_eval_start - buf : 0; + s_pos = s - buf; + + sv_force_normal(PL_linestr); + + buf = SvPVX(PL_linestr); + PL_parser->bufend = buf + bufend_pos; + PL_parser->bufptr = buf + bufptr_pos; + PL_parser->oldbufptr = buf + oldbufptr_pos; + PL_parser->oldoldbufptr = buf + oldoldbufptr_pos; + PL_parser->linestart = buf + linestart_pos; + if (PL_parser->last_uni) + PL_parser->last_uni = buf + last_uni_pos; + if (PL_parser->last_lop) + PL_parser->last_lop = buf + last_lop_pos; + if (PL_parser->lex_shared->re_eval_start) + PL_parser->lex_shared->re_eval_start = + buf + re_eval_start_pos; + s = buf + s_pos; + } + ns = SvPVX_const(PL_linestr) + offset; + svlast = SvEND(sv) - 1; for (; s < ns; s++) { if (*s == '\n' && !PL_rsfp && !PL_parser->filtered) -- Perl5 Master Repository
