X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=befacc38c012cdbb1a35642ed1bcaf55907c9f57;hb=5b813a60552784a5664fa2a5fa659e60caf6d6b3;hp=56b9d9fd17c09b2a5fb0661eef1e58788edf062b;hpb=ad639bfb68f3fce4864d833950ed2ff9dd1cb28d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 56b9d9f..befacc3 100644 --- a/op.c +++ b/op.c @@ -186,7 +186,6 @@ Perl_pending_Slabs_to_ro(pTHX) { read only. Also, do it ahead of the loop in case the warn triggers, and a warn handler has an eval */ - free(PL_slabs); PL_slabs = NULL; PL_slab_count = 0; @@ -194,13 +193,15 @@ Perl_pending_Slabs_to_ro(pTHX) { PL_OpSpace = 0; while (count--) { - const void *start = slabs[count]; + void *const start = slabs[count]; const size_t size = PERL_SLAB_SIZE* sizeof(I32*); if(mprotect(start, size, PROT_READ)) { Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", start, (unsigned long) size, errno); } } + + free(slabs); } STATIC void @@ -216,6 +217,24 @@ S_Slab_to_rw(pTHX_ void *op) slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno); } } + +OP * +Perl_op_refcnt_inc(pTHX_ OP *o) +{ + if(o) { + Slab_to_rw(o); + ++o->op_targ; + } + return o; + +} + +PADOFFSET +Perl_op_refcnt_dec(pTHX_ OP *o) +{ + Slab_to_rw(o); + return --o->op_targ; +} #else # define Slab_to_rw(op) #endif @@ -249,17 +268,12 @@ Perl_Slab_Free(pTHX_ void *op) PL_slabs[count] = PL_slabs[--PL_slab_count]; /* Could realloc smaller at this point, but probably not worth it. */ - goto gotcha; + if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) { + perror("munmap failed"); + abort(); + } + break; } - - } - Perl_croak(aTHX_ - "panic: Couldn't find slab at %p (%lu allocated)", - slab, (unsigned long) PL_slabs); - gotcha: - if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) { - perror("munmap failed"); - abort(); } } #else @@ -394,6 +408,11 @@ S_op_destroy(pTHX_ OP *o) FreeOp(o); } +#ifdef USE_ITHREADS +# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b) +#else +# define forget_pmop(a,b) S_forget_pmop(aTHX_ a) +#endif /* Destructor */ @@ -422,9 +441,6 @@ Perl_op_free(pTHX_ OP *o) case OP_LEAVEWRITE: { PADOFFSET refcnt; -#ifdef PERL_DEBUG_READONLY_OPS - Slab_to_rw(o); -#endif OP_REFCNT_LOCK; refcnt = OpREFCNT_dec(o); OP_REFCNT_UNLOCK; @@ -451,12 +467,13 @@ Perl_op_free(pTHX_ OP *o) if (type == OP_NULL) type = (OPCODE)o->op_targ; +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_rw(o); +#endif + /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) { -#ifdef PERL_DEBUG_READONLY_OPS - Slab_to_rw(o); -#endif cop_free((COP*)o); } @@ -569,24 +586,24 @@ Perl_op_clear(pTHX_ OP *o) } break; case OP_SUBST: - op_free(cPMOPo->op_pmreplroot); + op_free(cPMOPo->op_pmreplrootu.op_pmreplroot); goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS - if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { + if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { /* No GvIN_PAD_off here, because other references may still * exist on the pad */ - pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); + pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else - SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); + SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv); #endif /* FALL THROUGH */ case OP_MATCH: case OP_QR: clear_pmop: forget_pmop(cPMOPo, 1); - cPMOPo->op_pmreplroot = NULL; + cPMOPo->op_pmreplrootu.op_pmreplroot = NULL; /* we use the "SAFE" version of the PM_ macros here * since sv_clean_all might release some PMOPs * after PL_regex_padav has been cleared @@ -625,7 +642,11 @@ S_cop_free(pTHX_ COP* cop) } STATIC void -S_forget_pmop(pTHX_ PMOP *const o, U32 flags) +S_forget_pmop(pTHX_ PMOP *const o +#ifdef USE_ITHREADS + , U32 flags +#endif + ) { HV * const pmstash = PmopSTASH(o); if (pmstash && !SvIS_FREED(pmstash)) { @@ -652,8 +673,12 @@ S_forget_pmop(pTHX_ PMOP *const o, U32 flags) } } } + if (PL_curpm == o) + PL_curpm = NULL; +#ifdef USE_ITHREADS if (flags) PmopSTASH_free(o); +#endif } STATIC void @@ -793,7 +818,7 @@ Perl_scalar(pTHX_ OP *o) break; case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) + if (!kPMOP->op_pmreplrootu.op_pmreplroot) deprecate_old("implicit split to @_"); } /* FALL THROUGH */ @@ -1088,7 +1113,7 @@ Perl_scalarvoid(pTHX_ OP *o) return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplroot) + if (!kPMOP->op_pmreplrootu.op_pmreplroot) deprecate_old("implicit split to @_"); } break; @@ -1792,7 +1817,7 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ - SAVEINT(PL_expect); + SAVEI8(PL_expect); stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no; #define ATTRSMODULE "attributes" @@ -3411,8 +3436,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) } if (DO_UTF8(pat)) pm_flags |= RXf_UTF8; - /* FIXME - can we make this function take const char * args? */ - PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags)); + PM_SETRE(pm, CALLREGCOMP(pat, pm_flags)); #ifdef PERL_MAD op_getmad(expr,(OP*)pm,'e'); @@ -3524,8 +3548,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) rcop->op_next = LINKLIST(repl); repl->op_next = (OP*)rcop; - pm->op_pmreplroot = scalar((OP*)rcop); - pm->op_pmreplstart = LINKLIST(rcop); + pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop); + assert(!(pm->op_pmflags & PMf_ONCE)); + pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop); rcop->op_next = 0; } } @@ -3623,6 +3648,11 @@ Perl_package(pTHX_ OP *o) save_item(PL_curstname); PL_curstash = gv_stashsv(sv, GV_ADD); + + /* In case mg.c:Perl_magic_setisa faked + this package earlier, we clear the fake flag */ + HvMROMETA(PL_curstash)->fake = 0; + sv_setsv(PL_curstname, sv); PL_hints |= HINT_BLOCK_SCOPE; @@ -3833,7 +3863,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; - const int oexpect = PL_expect; + const U8 oexpect = PL_expect; utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); @@ -4006,19 +4036,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) break; } else if (curop->op_type == OP_PUSHRE) { - if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS - GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, - ((PMOP*)curop)->op_pmreplroot)); -#else - GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; -#endif + if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { + GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; GvASSIGN_GENERATION_set(gv, PL_generation); + } +#else + GV *const gv + = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv; + if (gv) { + if (gv == PL_defgv + || (int)GvASSIGN_GENERATION(gv) == PL_generation) + break; GvASSIGN_GENERATION_set(gv, PL_generation); } +#endif } else break; @@ -4076,12 +4111,20 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) !(o->op_private & OPpASSIGN_COMMON) ) { tmpop = ((UNOP*)left)->op_first; - if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { + if (tmpop->op_type == OP_GV +#ifdef USE_ITHREADS + && !pm->op_pmreplrootu.op_pmtargetoff +#else + && !pm->op_pmreplrootu.op_pmtargetgv +#endif + ) { #ifdef USE_ITHREADS - pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); + pm->op_pmreplrootu.op_pmtargetoff + = cPADOPx(tmpop)->op_padix; cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else - pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; + pm->op_pmreplrootu.op_pmtargetgv + = (GV*)cSVOPx(tmpop)->op_sv; cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif pm->op_pmflags |= PMf_ONCE; @@ -4768,7 +4811,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) o = newOP(type, OPf_SPECIAL); else { o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST - ? SvPVx_nolen_const(((SVOP*)label)->op_sv) + ? SvPV_nolen_const(((SVOP*)label)->op_sv) : "")); } #ifdef PERL_MAD @@ -5205,11 +5248,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; - const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL; + const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; if (proto) { assert(proto->op_type == OP_CONST); - ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len); + ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len); } else ps = NULL; @@ -5252,9 +5295,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) sv_setpvn((SV*)gv, ps, ps_len); else sv_setiv((SV*)gv, -1); + SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; - PL_sub_generation++; goto done; } @@ -5348,7 +5391,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GvCV(gv) = NULL; cv = newCONSTSUB(NULL, name, const_sv); } - PL_sub_generation++; + mro_method_changed_in( /* sub Foo::Bar () { 123 } */ + (CvGV(cv) && GvSTASH(CvGV(cv))) + ? GvSTASH(CvGV(cv)) + : CvSTASH(cv) + ? CvSTASH(cv) + : PL_curstash + ); if (PL_madskills) goto install_block; op_free(block); @@ -5431,7 +5480,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } GvCVGEN(gv) = 0; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ } } CvGV(cv) = gv; @@ -5763,7 +5812,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* newXS */ } } CvGV(cv) = gv; @@ -7824,13 +7873,15 @@ Perl_peep(pTHX_ register OP *o) for (; o; o = o->op_next) { if (o->op_opt) break; + /* By default, this op has now been optimised. A couple of cases below + clear this again. */ + o->op_opt = 1; PL_op = o; switch (o->op_type) { case OP_SETSTATE: case OP_NEXTSTATE: case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ - o->op_opt = 1; break; case OP_CONST: @@ -7873,14 +7924,13 @@ Perl_peep(pTHX_ register OP *o) o->op_targ = ix; } #endif - o->op_opt = 1; break; case OP_CONCAT: if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { if (o->op_next->op_private & OPpTARGET_MY) { if (o->op_flags & OPf_STACKED) /* chained concats */ - goto ignore_optimization; + break; /* ignore_optimization */ else { /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ o->op_targ = o->op_next->op_targ; @@ -7890,12 +7940,9 @@ Perl_peep(pTHX_ register OP *o) } op_null(o->op_next); } - ignore_optimization: - o->op_opt = 1; break; case OP_STUB: if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { - o->op_opt = 1; break; /* Scalar stub must produce undef. List stub is noop */ } goto nothin; @@ -7911,20 +7958,17 @@ Perl_peep(pTHX_ register OP *o) has already occurred. This doesn't fix the real problem, though (See 20010220.007). AMS 20010719 */ /* op_seq functionality is now replaced by op_opt */ - if (oldop && o->op_next) { - oldop->op_next = o->op_next; - continue; - } - break; + o->op_opt = 0; + /* FALL THROUGH */ case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: - nothin: + nothin: if (oldop && o->op_next) { oldop->op_next = o->op_next; + o->op_opt = 0; continue; } - o->op_opt = 1; break; case OP_PADAV: @@ -7961,7 +8005,6 @@ Perl_peep(pTHX_ register OP *o) o->op_flags |= OPf_SPECIAL; o->op_type = OP_AELEMFAST; } - o->op_opt = 1; break; } @@ -7998,7 +8041,6 @@ Perl_peep(pTHX_ register OP *o) op_null(o->op_next); } - o->op_opt = 1; break; case OP_MAPWHILE: @@ -8011,7 +8053,6 @@ Perl_peep(pTHX_ register OP *o) case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: - o->op_opt = 1; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ @@ -8019,7 +8060,6 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: case OP_ENTERITER: - o->op_opt = 1; while (cLOOP->op_redoop->op_type == OP_NULL) cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); @@ -8031,18 +8071,16 @@ Perl_peep(pTHX_ register OP *o) peep(cLOOP->op_lastop); break; - case OP_QR: - case OP_MATCH: case OP_SUBST: - o->op_opt = 1; - while (cPMOP->op_pmreplstart && - cPMOP->op_pmreplstart->op_type == OP_NULL) - cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; - peep(cPMOP->op_pmreplstart); + assert(!(cPMOP->op_pmflags & PMf_ONCE)); + while (cPMOP->op_pmstashstartu.op_pmreplstart && + cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmstashstartu.op_pmreplstart + = cPMOP->op_pmstashstartu.op_pmreplstart->op_next; + peep(cPMOP->op_pmstashstartu.op_pmreplstart); break; case OP_EXEC: - o->op_opt = 1; if (o->op_next && o->op_next->op_type == OP_NEXTSTATE && ckWARN(WARN_SYNTAX)) { @@ -8069,8 +8107,6 @@ Perl_peep(pTHX_ register OP *o) const char *key = NULL; STRLEN keylen; - o->op_opt = 1; - if (((BINOP*)o)->op_last->op_type != OP_CONST) break; @@ -8197,8 +8233,6 @@ Perl_peep(pTHX_ register OP *o) /* make @a = sort @a act in-place */ - o->op_opt = 1; - oright = cUNOPx(oright)->op_sibling; if (!oright) break; @@ -8289,7 +8323,6 @@ Perl_peep(pTHX_ register OP *o) OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; LISTOP *enter, *exlist; - o->op_opt = 1; enter = (LISTOP *) o->op_next; if (!enter) @@ -8380,13 +8413,6 @@ Perl_peep(pTHX_ register OP *o) UNOP *refgen, *rv2cv; LISTOP *exlist; - /* I do not understand this, but if o->op_opt isn't set to 1, - various tests in ext/B/t/bytecode.t fail with no readily - apparent cause. */ - - o->op_opt = 1; - - if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID) break; @@ -8427,8 +8453,11 @@ Perl_peep(pTHX_ register OP *o) } - default: - o->op_opt = 1; + case OP_QR: + case OP_MATCH: + if (!(cPMOP->op_pmflags & PMf_ONCE)) { + assert (!cPMOP->op_pmstashstartu.op_pmreplstart); + } break; } oldop = o;