From 74e0ddf711449aba3fac400d9102bd461ee7265b Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Tue, 26 Apr 2011 12:12:34 +0100 Subject: [PATCH] Store the compiled format in mg_ptr instead of after SvCUR() - fixes RT #89218 Formats are compiled down to a sequence of U32 opcodes in doparseform(). Previously the block of opcodes was stored in the buffer of SvPVX() after the raw string by extending the buffer, and calculating the first U32 aligned address after SvCUR(). A flag bit on the scalar was set to signal this hackery, tested with SvCOMPILED() The flag bit used happened to be the same as one of the two used by to signal Boyer-Moore compiled scalars. The assumption was that no scalar can be used for both. Unfortunately, this isn't quite true. Given that the scalar is alway upgraded to PVMG to add PERL_MAGIC_fm magic, to clear the cached compiled version, there's no extra memory cost in using mg_ptr in the MAGIC struct to point directly to the block of U32 opcodes. The test for "is there a compiled version" can switch to mg_find(..., PERL_MAGIC_fm) returning a pointer, and the use of a flag bit abolished. Retain SvCOMPILED() and SvCOMPILED_{on,off}() as compatibility for XS code on CPAN - the first is always 0, the other two now no-ops. --- dump.c | 1 - embed.fnc | 2 +- mg.c | 1 - pod/perldelta.pod | 8 +++++--- pp_ctl.c | 49 +++++++++++++++++++++++++++++-------------------- proto.h | 2 +- sv.h | 10 +++++----- t/op/index.t | 23 ++++++++++++++++++++++- 8 files changed, 63 insertions(+), 33 deletions(-) diff --git a/dump.c b/dump.c index a340a9c..4e98394 100644 --- a/dump.c +++ b/dump.c @@ -1627,7 +1627,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo case SVt_PVCV: case SVt_PVFM: append_flags(d, CvFLAGS(sv), cv_flags_names); - if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); break; case SVt_PVHV: append_flags(d, flags, hv_flags_names); diff --git a/embed.fnc b/embed.fnc index f32471c..161729e 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1721,7 +1721,7 @@ snR |char * |bytes_to_uni |NN const U8 *start|STRLEN len|NN char *dest #if defined(PERL_IN_PP_CTL_C) sR |OP* |docatch |NULLOK OP *o sR |OP* |dofindlabel |NN OP *o|NN const char *label|NN OP **opstack|NN OP **oplimit -s |void |doparseform |NN SV *sv +s |MAGIC *|doparseform |NN SV *sv snR |bool |num_overflow |NV value|I32 fldsize|I32 frcsize sR |I32 |dopoptoeval |I32 startingblock sR |I32 |dopoptogiven |I32 startingblock diff --git a/mg.c b/mg.c index e821415..54791cb 100644 --- a/mg.c +++ b/mg.c @@ -2415,7 +2415,6 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) SvVALID_off(sv); } else { assert(type == PERL_MAGIC_fm); - SvCOMPILED_off(sv); } return sv_unmagic(sv, type); } diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 845f1a0..02669de 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -278,13 +278,15 @@ XXX Changes which affect the interface available to C code go here. Other significant internal changes for future core maintainers should be noted as well. -[ List each test improvement as a =item entry ] - =over 4 =item * -XXX +The compiled representation of formats is now stored via the mg_ptr of +their PERL_MAGIC_fm. Previously it was stored in the string buffer, +beyond SvLEN(), the regular end of the string. SvCOMPILED() and +SvCOMPILED_{on,off}() now exist solely for compatibility for XS code. +The first is always 0, the other two now no-ops. =back diff --git a/pp_ctl.c b/pp_ctl.c index 4fb3b40..28e258b 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -34,10 +34,6 @@ #define PERL_IN_PP_CTL_C #include "perl.h" -#ifndef WORD_ALIGN -#define WORD_ALIGN sizeof(U32) -#endif - #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) @@ -548,16 +544,27 @@ PP(pp_formline) bool targ_is_utf8 = FALSE; SV * nsv = NULL; const char *fmt; + MAGIC *mg = NULL; + + if (SvTYPE(tmpForm) >= SVt_PVMG) { + /* This might, of course, still return NULL. */ + mg = mg_find(tmpForm, PERL_MAGIC_fm); + } else { + sv_upgrade(tmpForm, SVt_PVMG); + } - if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { + if(!mg) { if (SvREADONLY(tmpForm)) { SvREADONLY_off(tmpForm); - doparseform(tmpForm); + mg = doparseform(tmpForm); SvREADONLY_on(tmpForm); } else - doparseform(tmpForm); + mg = doparseform(tmpForm); + assert(mg); } + fpc = (U32*)mg->mg_ptr; + SvPV_force(PL_formtarget, len); if (SvTAINTED(tmpForm)) SvTAINTED_on(PL_formtarget); @@ -566,8 +573,6 @@ PP(pp_formline) t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ t += len; f = SvPV_const(tmpForm, len); - /* need to jump to the next word */ - fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); for (;;) { DEBUG_f( { @@ -4914,7 +4919,7 @@ PP(pp_break) RETURNOP(cx->blk_givwhen.leave_op); } -static void +static MAGIC * S_doparseform(pTHX_ SV *sv) { STRLEN len; @@ -4932,6 +4937,7 @@ S_doparseform(pTHX_ SV *sv) bool ischop; bool unchopnum = FALSE; int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ + MAGIC *mg; PERL_ARGS_ASSERT_DOPARSEFORM; @@ -5117,19 +5123,22 @@ S_doparseform(pTHX_ SV *sv) assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ arg = fpc - fops; - { /* need to jump to the next word */ - int z; - z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; - SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); - s = SvPVX(sv) + SvCUR(sv) + z; - } - Copy(fops, s, arg, U32); - Safefree(fops); - sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0); - SvCOMPILED_on(sv); + + /* If we pass the length in to sv_magicext() it will copy the buffer for us. + We don't need that, so by setting the length on return we "donate" the + buffer to the magic, avoiding an allocation. We could realloc() the + buffer to the exact size used, but that feels like it's not worth it + (particularly if the rumours are true and some realloc() implementations + don't shrink blocks). However, set the true length used in mg_len so that + mg_dup only allocates and copies what's actually needed. */ + mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, + (const char *const) fops, 0); + mg->mg_len = arg * sizeof(U32); if (unchopnum && repeat) Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)"); + + return mg; } diff --git a/proto.h b/proto.h index a733e50..845658b 100644 --- a/proto.h +++ b/proto.h @@ -5710,7 +5710,7 @@ STATIC OP* S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **opli #define PERL_ARGS_ASSERT_DOFINDLABEL \ assert(o); assert(label); assert(opstack); assert(oplimit) -STATIC void S_doparseform(pTHX_ SV *sv) +STATIC MAGIC * S_doparseform(pTHX_ SV *sv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_DOPARSEFORM \ assert(sv) diff --git a/sv.h b/sv.h index 77a9712..7f46675 100644 --- a/sv.h +++ b/sv.h @@ -388,8 +388,6 @@ perform the upgrade if necessary. See C. #define SVpav_REIFY 0x80000000 /* can become real */ /* PVHV */ #define SVphv_HASKFLAGS 0x80000000 /* keys have flag byte after hash */ -/* PVFM */ -#define SVpfm_COMPILED 0x80000000 /* FORMLINE is compiled */ /* PVGV when SVpbm_VALID is true */ #define SVpbm_TAIL 0x80000000 /* RV upwards. However, SVf_ROK and SVp_IOK are exclusive */ @@ -923,9 +921,11 @@ the scalar's value cannot change unless written to. #define SvSCREAM_on(sv) (SvFLAGS(sv) |= SVp_SCREAM) #define SvSCREAM_off(sv) (SvFLAGS(sv) &= ~SVp_SCREAM) -#define SvCOMPILED(sv) (SvFLAGS(sv) & SVpfm_COMPILED) -#define SvCOMPILED_on(sv) (SvFLAGS(sv) |= SVpfm_COMPILED) -#define SvCOMPILED_off(sv) (SvFLAGS(sv) &= ~SVpfm_COMPILED) +#ifndef PERL_CORE +# define SvCOMPILED(sv) 0 +# define SvCOMPILED_on(sv) +# define SvCOMPILED_off(sv) +#endif #define SvEVALED(sv) (SvFLAGS(sv) & SVrepl_EVAL) #define SvEVALED_on(sv) (SvFLAGS(sv) |= SVrepl_EVAL) diff --git a/t/op/index.t b/t/op/index.t index 5ef69fc..c8aafcf 100644 --- a/t/op/index.t +++ b/t/op/index.t @@ -7,7 +7,7 @@ BEGIN { } use strict; -plan( tests => 113 ); +plan( tests => 120 ); run_tests() unless caller; @@ -203,4 +203,25 @@ SKIP: { 'UTF-8 cache handles offset beyond the end of the string'); } +# RT #89218 +use constant {PVBM => 'galumphing', PVBM2 => 'bang'}; + +sub index_it { + is(index('galumphing', PVBM), 0, + "index isn't confused by format compilation"); +} + +index_it(); +is($^A, '', '$^A is empty'); +formline PVBM; +is($^A, 'galumphing', "formline isn't confused by index compilation"); +index_it(); + +$^A = ''; +# must not do index here before formline. +is($^A, '', '$^A is empty'); +formline PVBM2; +is($^A, 'bang', "formline isn't confused by index compilation"); +is(index('bang', PVBM2), 0, "index isn't confused by format compilation"); + } -- 1.8.3.1