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;
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
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
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
/* free the body of an op without examining its contents.
* Always use this rather than FreeOp directly */
-void
+static void
S_op_destroy(pTHX_ OP *o)
{
if (o->op_latefree) {
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 */
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;
- if (refcnt)
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from the list
+ we maintain for reset(). */
+ find_and_forget_pmops(o);
return;
}
+ }
break;
default:
break;
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)
+ if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
cop_free((COP*)o);
+ }
op_clear(o);
if (o->op_latefree) {
}
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:
- {
- HV * const pmstash = PmopSTASH(cPMOPo);
- if (pmstash && !SvIS_FREED(pmstash)) {
- MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
- if (mg) {
- PMOP *pmop = (PMOP*) mg->mg_obj;
- PMOP *lastpmop = NULL;
- while (pmop) {
- if (cPMOPo == pmop) {
- if (lastpmop)
- lastpmop->op_pmnext = pmop->op_pmnext;
- else
- mg->mg_obj = (SV*) pmop->op_pmnext;
- break;
- }
- lastpmop = pmop;
- pmop = pmop->op_pmnext;
- }
- }
- }
- PmopSTASH_free(cPMOPo);
- }
- cPMOPo->op_pmreplroot = NULL;
+ forget_pmop(cPMOPo, 1);
+ 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
Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
}
+STATIC void
+S_forget_pmop(pTHX_ PMOP *const o
+#ifdef USE_ITHREADS
+ , U32 flags
+#endif
+ )
+{
+ HV * const pmstash = PmopSTASH(o);
+ if (pmstash && !SvIS_FREED(pmstash)) {
+ MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
+ if (mg) {
+ PMOP **const array = (PMOP**) mg->mg_ptr;
+ U32 count = mg->mg_len / sizeof(PMOP**);
+ U32 i = count;
+
+ while (i--) {
+ if (array[i] == o) {
+ /* Found it. Move the entry at the end to overwrite it. */
+ array[i] = array[--count];
+ mg->mg_len = count * sizeof(PMOP**);
+ /* Could realloc smaller at this point always, but probably
+ not worth it. Probably worth free()ing if we're the
+ last. */
+ if(!count) {
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ }
+ break;
+ }
+ }
+ }
+ }
+ if (PL_curpm == o)
+ PL_curpm = NULL;
+#ifdef USE_ITHREADS
+ if (flags)
+ PmopSTASH_free(o);
+#endif
+}
+
+STATIC void
+S_find_and_forget_pmops(pTHX_ OP *o)
+{
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPo->op_first;
+ while (kid) {
+ switch (kid->op_type) {
+ case OP_SUBST:
+ case OP_PUSHRE:
+ case OP_MATCH:
+ case OP_QR:
+ forget_pmop((PMOP*)kid, 0);
+ }
+ find_and_forget_pmops(kid);
+ kid = kid->op_sibling;
+ }
+ }
+}
+
void
Perl_op_null(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 */
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;
/* fake up C<use attributes $pkg,$rv,@attrs> */
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"
}
#endif
- /* link into pm list */
- if (type != OP_TRANS && PL_curstash) {
- MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
-
- if (!mg) {
- mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
- }
- pmop->op_pmnext = (PMOP*)mg->mg_obj;
- mg->mg_obj = (SV*)pmop;
- PmopSTASH_set(pmop,PL_curstash);
- }
-
return CHECKOP(type, pmop);
}
}
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');
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;
}
}
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;
{
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);
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;
!(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_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
+ && !pm->op_pmreplrootu.op_pmtargetoff
+#else
+ && !pm->op_pmreplrootu.op_pmtargetgv
+#endif
+ ) {
+#ifdef USE_ITHREADS
+ 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;
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
op_other if the match fails.)
*/
-STATIC
-OP *
+STATIC OP *
S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
I32 enter_opcode, I32 leave_opcode,
PADOFFSET entertarg)
[*] possibly surprising
*/
-STATIC
-bool
+STATIC bool
S_looks_like_bool(pTHX_ const OP *o)
{
dVAR;
= (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;
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;
}
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);
}
}
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
}
}
CvGV(cv) = gv;
if (name) {
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
- PL_sub_generation++;
+ mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
CvGV(cv) = gv;
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:
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;
}
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;
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:
o->op_flags |= OPf_SPECIAL;
o->op_type = OP_AELEMFAST;
}
- o->op_opt = 1;
break;
}
op_null(o->op_next);
}
- o->op_opt = 1;
break;
case OP_MAPWHILE:
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 */
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);
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))
{
const char *key = NULL;
STRLEN keylen;
- o->op_opt = 1;
-
if (((BINOP*)o)->op_last->op_type != OP_CONST)
break;
/* make @a = sort @a act in-place */
- o->op_opt = 1;
-
oright = cUNOPx(oright)->op_sibling;
if (!oright)
break;
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
LISTOP *enter, *exlist;
- o->op_opt = 1;
enter = (LISTOP *) o->op_next;
if (!enter)
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;
}
- 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;
projects / p5sagit/p5-mst-13.2.git / blobdiff