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 */
+#if defined(USE_ITHREADS) && IVSIZE > U32SIZE
+ /* Work around a goof with alignment on our part. For sparc32 (and
+ possibly other architectures), if built with -Duse64bitint, the IV
+ op_pmoffset in struct pmop should be 8 byte aligned, but the slab
+ allocator is only providing 4 byte alignment. The real fix is to change
+ the IV to a type the same size as a pointer, such as size_t, but we
+ can't do that without breaking the ABI, which is a no-no in a maint
+ release. So instead, simply allocate struct pmop directly, which will be
+ suitably aligned: */
+ if (sz == sizeof(struct pmop))
+ return PerlMemShared_calloc(1, sz);
+#endif
+
+ /* 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);
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;
PERL_ARGS_ASSERT_SLAB_FREE;
if (!o->op_slabbed) {
- PerlMemShared_free(op);
+ if (!o->op_static)
+ PerlMemShared_free(op);
return;
}
)
) {
assert(slot->opslot_op.op_slabbed);
- slab->opslab_refcnt++; /* op_free may free slab */
op_free(&slot->opslot_op);
- if (!--slab->opslab_refcnt) goto free;
+ if (slab->opslab_refcnt == 1) goto free;
}
}
} while ((slab2 = slab2->opslab_next));
#ifdef DEBUGGING
assert(savestack_count == slab->opslab_refcnt-1);
#endif
+ /* Remove the CV’s reference count. */
+ slab->opslab_refcnt--;
return;
}
free:
PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
}
}
+ else if (len == 2 && name[1] == '_' && !is_our)
+ /* 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");
/* allocate a spare slot and store the name in that slot */
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 */
void
#endif
if (still_valid) {
int try_downgrade = SvREFCNT(gv) == 2;
- SvREFCNT_dec(gv);
+ SvREFCNT_dec_NN(gv);
if (try_downgrade)
gv_try_downgrade(gv);
}
if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
op_free(cPMOPo->op_code_list);
cPMOPo->op_code_list = NULL;
- forget_pmop(cPMOPo, 1);
+ forget_pmop(cPMOPo);
cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
/* we use the same protection as the "SAFE" version of the PM_ macros
* here since sv_clean_all might release some PMOPs
STATIC void
S_forget_pmop(pTHX_ PMOP *const o
-#ifdef USE_ITHREADS
- , U32 flags
-#endif
)
{
HV * const pmstash = PmopSTASH(o);
}
if (PL_curpm == o)
PL_curpm = NULL;
-#ifdef USE_ITHREADS
- if (flags)
- PmopSTASH_free(o);
-#endif
}
STATIC void
case OP_PUSHRE:
case OP_MATCH:
case OP_QR:
- forget_pmop((PMOP*)kid, 0);
+ forget_pmop((PMOP*)kid);
}
find_and_forget_pmops(kid);
kid = kid->op_sibling;
PERL_PV_PRETTY_DUMP
| PERL_PV_ESCAPE_NOCLEAR
| PERL_PV_ESCAPE_UNI_DETECT));
- SvREFCNT_dec(dsv);
+ SvREFCNT_dec_NN(dsv);
}
}
else if (SvOK(sv)) {
/* If op_sv is already a PADTMP/MY then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
- SvREADONLY_on(PAD_SVl(ix));
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
else if (o->op_type != OP_METHOD_NAMED
SvPADTMP_on(cSVOPo->op_sv);
PAD_SETSV(ix, cSVOPo->op_sv);
/* XXX I don't know how this isn't readonly already. */
- SvREADONLY_on(PAD_SVl(ix));
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
}
cSVOPo->op_sv = NULL;
o->op_targ = ix;
/* Make the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
+ if ((!SvIsCOW(sv = *svp))
&& SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
0);
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
*svp = lexname;
}
}
break;
}
+
case OP_SUBST: {
if (cPMOPo->op_pmreplrootu.op_pmreplroot)
finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
/* FALL THROUGH */
case OP_ASLICE:
case OP_HSLICE:
- if (type == OP_LEAVESUBLV)
- o->op_private |= OPpMAYBE_LVSUB;
localize = 1;
/* FALL THROUGH */
case OP_AASSIGN:
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
+ /* FALL THROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
{
dVAR;
if (o) {
- if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
+ if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
o->op_type = OP_LEAVE;
o->op_ppaddr = PL_ppaddr[OP_LEAVE];
while (1) {
if (*s && strchr("@$%*", *s) && *++s
- && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
+ && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
s++;
sigil = TRUE;
- while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
+ while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
s++;
while (*s && (strchr(", \t\n", *s)))
s++;
}
static OP *
-S_fold_constants(pTHX_ register OP *o)
+S_fold_constants(pTHX_ OP *o)
{
dVAR;
OP * VOL curop;
case OP_LCFIRST:
case OP_UC:
case OP_LC:
+ case OP_FC:
case OP_SLT:
case OP_SGT:
case OP_SLE:
}
static OP *
-S_gen_constant_list(pTHX_ register OP *o)
+S_gen_constant_list(pTHX_ OP *o)
{
dVAR;
OP *curop;
case MAD_NULL:
break;
case MAD_PV:
- Safefree((char*)mp->mad_val);
+ Safefree(mp->mad_val);
break;
case MAD_OP:
if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
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 */
scalar(o);
LINKLIST(o);
if (cLISTOPo->op_first->op_type == OP_LEAVE) {
- LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
+ LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
/* skip ENTER */
- assert(leave->op_first->op_type == OP_ENTER);
- assert(leave->op_first->op_sibling);
- o->op_next = leave->op_first->op_sibling;
- /* skip LEAVE */
- assert(leave->op_flags & OPf_KIDS);
- assert(leave->op_last->op_next = (OP*)leave);
- leave->op_next = NULL; /* stop on last op */
- op_null((OP*)leave);
+ assert(leaveop->op_first->op_type == OP_ENTER);
+ assert(leaveop->op_first->op_sibling);
+ o->op_next = leaveop->op_first->op_sibling;
+ /* skip leave */
+ assert(leaveop->op_flags & OPf_KIDS);
+ assert(leaveop->op_last->op_next == (OP*)leaveop);
+ leaveop->op_next = NULL; /* stop on last op */
+ op_null((OP*)leaveop);
}
else {
/* skip SCOPE */
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;
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 */
/* handle the implicit sub{} wrapped round the qr/(?{..})/ */
SvREFCNT_inc_simple_void(PL_compcv);
cv = newATTRSUB(floor, 0, NULL, NULL, qr);
- ((struct regexp *)SvANY(re))->qr_anoncv = cv;
+ ReANY(re)->qr_anoncv = cv;
/* attach the anon CV to the pad so that
* pad_fixup_inner_anons() can find it */
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;
* OP_REGCRESET is there to reset taint before executing the
* stacking ops */
- if (pm->op_pmflags & PMf_KEEP || PL_tainting)
- expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
+ if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
+ expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
if (pm->op_pmflags & PMf_HAS_CV) {
/* we have a runtime qr with literal code. This means
}
if (repl) {
- OP *curop;
+ OP *curop = repl;
+ bool konst;
if (pm->op_pmflags & PMf_EVAL) {
- curop = NULL;
if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
}
- else if (repl->op_type == OP_CONST)
- curop = repl;
- else {
- OP *lastop = NULL;
- for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
- if (curop->op_type == OP_SCOPE
- || curop->op_type == OP_LEAVE
- || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
- if (curop->op_type == OP_GV) {
- GV * const gv = cGVOPx_gv(curop);
- repl_has_vars = 1;
- if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
- break;
- }
- else if (curop->op_type == OP_RV2CV)
- break;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
- break;
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY)
- {
- repl_has_vars = 1;
- }
- else if (curop->op_type == OP_PUSHRE)
- NOOP; /* Okay here, dangerous in newASSIGNOP */
- else
- break;
- }
- lastop = curop;
- }
- }
- if (curop == repl
+ /* If we are looking at s//.../e with a single statement, get past
+ the implicit do{}. */
+ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
+ && cUNOPx(curop)->op_first->op_type == OP_SCOPE
+ && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
+ if (kid->op_type == OP_NULL && kid->op_sibling
+ && !kid->op_sibling->op_sibling)
+ curop = kid->op_sibling;
+ }
+ if (curop->op_type == OP_CONST)
+ konst = TRUE;
+ else if (( (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV)
+ && cUNOPx(curop)->op_first
+ && cUNOPx(curop)->op_first->op_type == OP_GV )
+ || curop->op_type == OP_PADSV
+ || curop->op_type == OP_PADAV
+ || curop->op_type == OP_PADHV
+ || curop->op_type == OP_PADANY) {
+ repl_has_vars = 1;
+ konst = TRUE;
+ }
+ else konst = FALSE;
+ if (konst
&& !(repl_has_vars
&& (!PM_GETRE(pm)
+ || !RX_PRELEN(PM_GETRE(pm))
|| RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
{
pm->op_pmflags |= PMf_CONST; /* const for long enough */
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
- pm->op_pmflags |= PMf_MAYBE_CONST;
- }
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_SUBSTCONT;
rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
Constructs, checks, and returns an op of any type that involves an
embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
-must have been allocated using L</PerlMemShared_malloc>; the memory will
+must have been allocated using C<PerlMemShared_malloc>; the memory will
be freed when the op is destroyed.
=cut
}
STATIC I32
-S_is_list_assignment(pTHX_ register const OP *o)
+S_is_list_assignment(pTHX_ const OP *o)
{
unsigned type;
U8 flags;
= MUTABLE_GV(cSVOPx(tmpop)->op_sv);
cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
- pm->op_pmflags |= PMf_ONCE;
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
tmpop->op_sibling = NULL; /* don't free split */
Constructs a state op (COP). The state op is normally a C<nextstate> op,
but will be a C<dbstate> op if debugging is enabled for currently-compiled
-code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
+code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
If I<label> is non-null, it supplies the name of a label to attach to
the state op; this function takes ownership of the memory pointed at by
I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
{
/* Basically turn for($x..$y) into the same as for($x,$y), but we
* set the STACKED flag to indicate that these values are to be
- * treated as min/max values by 'pp_iterinit'.
+ * treated as min/max values by 'pp_enteriter'.
*/
const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
return sv;
}
+static bool
+S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
+ PADNAME * const name, SV ** const const_svp)
+{
+ assert (cv);
+ assert (o || name);
+ assert (const_svp);
+ if ((!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )) {
+ if (CvFLAGS(PL_compcv)) {
+ /* might have had built-in attrs applied */
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
+ {
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ }
+ CvFLAGS(cv) |=
+ (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
+ }
+ return FALSE;
+ }
+
+ /* redundant check for speed: */
+ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
+ const line_t oldline = CopLINE(PL_curcop);
+ SV *namesv = o
+ ? cSVOPo->op_sv
+ : sv_2mortal(newSVpvn_utf8(
+ PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
+ ));
+ if (PL_parser && PL_parser->copline != NOLINE)
+ /* This ensures that warnings are reported at the first
+ line of a redefinition, not the last. */
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+ report_redefined_cv(namesv, cv, const_svp);
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ CopLINE_set(PL_curcop, oldline);
+ }
+#ifdef PERL_MAD
+ if (!PL_minus_c) /* keep old one around for madskills */
+#endif
+ {
+ /* (PL_madskills unset in used file.) */
+ SvREFCNT_dec(cv);
+ }
+ return TRUE;
+}
+
CV *
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
U32 ps_utf8 = 0;
- register CV *cv = NULL;
- register CV *compcv = PL_compcv;
+ CV *cv = NULL;
+ CV *compcv = PL_compcv;
SV *const_sv;
PADNAME *name;
PADOFFSET pax = o->op_targ;
if (PL_parser && PL_parser->error_count) {
op_free(block);
+ SvREFCNT_dec(PL_compcv);
+ PL_compcv = 0;
goto done;
}
cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
/* already defined? */
if (exists) {
- if ((!block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
- )) {
- if (CvFLAGS(compcv)) {
- /* might have had built-in attrs applied */
- const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
- if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl
- && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |=
- (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS
- & ~(CVf_LVALUE * pureperl));
- }
+ if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
+ cv = NULL;
+ else {
if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(compcv);
goto done;
}
- else {
- /* redundant check that avoids creating the extra SV
- most of the time: */
- if (const_sv || ckWARN(WARN_REDEFINE)) {
- const line_t oldline = CopLINE(PL_curcop);
- SV *noamp = sv_2mortal(newSVpvn_utf8(
- PadnamePV(name)+1,PadnameLEN(name)-1,
- PadnameUTF8(name)
- ));
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
- report_redefined_cv(noamp, cv, &const_sv);
- CopLINE_set(PL_curcop, oldline);
- }
-#ifdef PERL_MAD
- if (!PL_minus_c) /* keep old one around for madskills */
-#endif
- {
- /* (PL_madskills unset in used file.) */
- SvREFCNT_dec(cv);
- }
- cv = NULL;
- }
}
else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
cv = NULL;
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
- goto clone;
+ goto setname;
}
/* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
determine whether this sub definition is in the same scope as its
cv = compcv;
*spot = cv;
}
+ setname:
if (!CvNAME_HEK(cv)) {
CvNAME_HEK_set(cv,
hek
0)
);
}
+ if (const_sv) goto clone;
+
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
&PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
if (reusable) cv_clone_into(clonee, *spot);
else *spot = cv_clone(clonee);
- SvREFCNT_dec(clonee);
+ SvREFCNT_dec_NN(clonee);
cv = *spot;
SvPADMY_on(cv);
}
if (ec) {
op_free(block);
+ if (name) SvREFCNT_dec(PL_compcv);
+ else cv = PL_compcv;
+ PL_compcv = 0;
if (name && block) {
const char *s = strrchr(name, ':');
s = s ? s+1 : name;
if (strEQ(s, "BEGIN")) {
- const char not_safe[] =
- "BEGIN not safe after errors--compilation aborted";
if (PL_in_eval & EVAL_KEEPERR)
- Perl_croak(aTHX_ not_safe);
+ Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
else {
+ SV * const errsv = ERRSV;
/* force display of errors found but not reported */
- sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
+ sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
+ Perl_croak_nocontext("%"SVf, SVfARG(errsv));
}
}
}
- cv = PL_compcv;
goto done;
}
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
- if ((!block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
- )) {
- if (CvFLAGS(PL_compcv)) {
- /* might have had built-in attrs applied */
- const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
- if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
- && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |=
- (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
- & ~(CVf_LVALUE * pureperl));
- }
+ if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
+ cv = NULL;
+ else {
if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
}
- if (block
-#ifdef PERL_MAD
- && block->op_type != OP_NULL
-#endif
- ) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE) {
- /* This ensures that warnings are reported at the first
- line of a redefinition, not the last. */
- CopLINE_set(PL_curcop, PL_parser->copline);
- }
- report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
- CopLINE_set(PL_curcop, oldline);
-#ifdef PERL_MAD
- if (!PL_minus_c) /* keep old one around for madskills */
-#endif
- {
- /* (PL_madskills unset in used file.) */
- SvREFCNT_dec(cv);
- }
- cv = NULL;
- }
}
}
if (const_sv) {
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
/* sub Foo::bar { (shift)+1 } */
- mro_method_changed_in(GvSTASH(gv));
+ gv_method_changed(gv);
}
}
if (!CvGV(cv)) {
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ if (!name) SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
+ if (!name) SvREFCNT_inc_simple_void_NN(cv);
}
if (block && has_name) {
PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
}
+ /* Protect sv against leakage caused by fatal warnings. */
+ if (sv) SAVEFREESV(sv);
+
/* file becomes the CvFILE. For an XS, it's usually static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
&sv, XS_DYNAMIC_FILENAME | flags);
- CvXSUBANY(cv).any_ptr = sv;
+ CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
CvCONST_on(cv);
LEAVE;
),
cv, const_svp);
}
- SvREFCNT_dec(cv);
+ SvREFCNT_dec_NN(cv);
cv = NULL;
}
}
GvCV_set(gv,cv);
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
- mro_method_changed_in(GvSTASH(gv)); /* newXS */
+ gv_method_changed(gv); /* newXS */
}
}
if (!name)
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
if (!fake && HvENAME_HEK(GvSTASH(gv)))
- mro_method_changed_in(GvSTASH(gv));
+ gv_method_changed(gv);
CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
#endif
kUNOP->op_first = newop;
}
+ /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
+ * and OP_CHOMP into OP_SCHOMP */
o->op_ppaddr = PL_ppaddr[++o->op_type];
return ck_fun(o);
}
}
OP *
-Perl_ck_rvconst(pTHX_ register OP *o)
+Perl_ck_rvconst(pTHX_ OP *o)
{
dVAR;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
* \ mark - glob - rv2cv
* | \ gv(CORE::GLOBAL::glob)
* |
- * \ null - const(wildcard) - const(ix)
+ * \ null - const(wildcard)
*/
o->op_flags |= OPf_SPECIAL;
o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
- op_append_elem(OP_GLOB, o,
- newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
o = newLISTOP(OP_LIST, 0, o, NULL);
o = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, o,
LEAVE;
}
#endif /* !PERL_EXTERNAL_GLOB */
- gv = newGVgen("main");
+ gv = (GV *)newSV(0);
+ gv_init(gv, 0, "", 0, 0);
gv_IOadd(gv);
-#ifndef PERL_EXTERNAL_GLOB
- sv_setiv(GvSVn(gv),PL_glob_index++);
-#endif
op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
+ SvREFCNT_dec_NN(gv); /* newGVOP increased it */
scalarkids(o);
return o;
}
if (kid)
kid = kid->op_sibling; /* get past "big" */
if (kid && kid->op_type == OP_CONST) {
- const bool save_taint = PL_tainted;
+ const bool save_taint = TAINT_get;
fbm_compile(((SVOP*)kid)->op_sv, 0);
- PL_tainted = save_taint;
+ TAINT_set(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
}
}
return ck_fun(o);
const char * const method = SvPVX_const(sv);
if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
- if (!SvREADONLY(sv) || !SvFAKE(sv)) {
+ if (!SvIsCOW(sv)) {
sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
}
else {
const char *end;
if (was_readonly) {
- if (SvFAKE(sv)) {
- sv_force_normal_flags(sv, 0);
- assert(!SvREADONLY(sv));
- was_readonly = 0;
- } else {
SvREADONLY_off(sv);
- }
}
+ if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
s = SvPVX(sv);
len = SvCUR(sv);
cLISTOPo->op_last = kid; /* There was only one element previously */
}
- if (kid->op_type == OP_CONST && !(kid->op_private & OPpCONST_FOLDED)) {
- SV * const sv = kSVOP->op_sv;
- if (SvPOK(sv) && SvCUR(sv) == 1 && *SvPVX(sv) == ' ')
- o->op_flags |= OPf_SPECIAL;
- }
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
OP * const sibl = kid->op_sibling;
kid->op_sibling = 0;
- kid = pmruntime( newPMOP(OP_MATCH, 0), kid, 0, 0);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
if (cLISTOPo->op_first == cLISTOPo->op_last)
cLISTOPo->op_last = kid;
cLISTOPo->op_first = kid;
{
PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
- SvREADONLY_on(cSVOPo->op_sv);
+ if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
return o;
}
* peep() is called */
void
-Perl_rpeep(pTHX_ register OP *o)
+Perl_rpeep(pTHX_ OP *o)
{
dVAR;
OP* oldop = NULL;
+ OP* oldoldop = NULL;
OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
int defer_base = 0;
int defer_ix = -1;
}
break;
+ case OP_PUSHMARK:
+
+ /* Convert a series of PAD ops for my vars plus support into a
+ * single padrange op. Basically
+ *
+ * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
+ *
+ * becomes, depending on circumstances, one of
+ *
+ * padrange ----------------------------------> (list) -> rest
+ * padrange --------------------------------------------> rest
+ *
+ * where all the pad indexes are sequential and of the same type
+ * (INTRO or not).
+ * We convert the pushmark into a padrange op, then skip
+ * any other pad ops, and possibly some trailing ops.
+ * Note that we don't null() the skipped ops, to make it
+ * easier for Deparse to undo this optimisation (and none of
+ * the skipped ops are holding any resourses). It also makes
+ * it easier for find_uninit_var(), as it can just ignore
+ * padrange, and examine the original pad ops.
+ */
+ {
+ OP *p;
+ OP *followop = NULL; /* the op that will follow the padrange op */
+ U8 count = 0;
+ U8 intro = 0;
+ PADOFFSET base = 0; /* init only to stop compiler whining */
+ U8 gimme = 0; /* init only to stop compiler whining */
+ bool defav = 0; /* seen (...) = @_ */
+ bool reuse = 0; /* reuse an existing padrange op */
+
+ /* look for a pushmark -> gv[_] -> rv2av */
+
+ {
+ GV *gv;
+ OP *rv2av, *q;
+ p = o->op_next;
+ if ( p->op_type == OP_GV
+ && (gv = cGVOPx_gv(p))
+ && GvNAMELEN_get(gv) == 1
+ && *GvNAME_get(gv) == '_'
+ && GvSTASH(gv) == PL_defstash
+ && (rv2av = p->op_next)
+ && rv2av->op_type == OP_RV2AV
+ && !(rv2av->op_flags & OPf_REF)
+ && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
+ && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
+ && o->op_sibling == rv2av /* these two for Deparse */
+ && cUNOPx(rv2av)->op_first == p
+ ) {
+ q = rv2av->op_next;
+ if (q->op_type == OP_NULL)
+ q = q->op_next;
+ if (q->op_type == OP_PUSHMARK) {
+ defav = 1;
+ p = q;
+ }
+ }
+ }
+ if (!defav) {
+ /* To allow Deparse to pessimise this, it needs to be able
+ * to restore the pushmark's original op_next, which it
+ * will assume to be the same as op_sibling. */
+ if (o->op_next != o->op_sibling)
+ break;
+ p = o;
+ }
+
+ /* scan for PAD ops */
+
+ for (p = p->op_next; p; p = p->op_next) {
+ if (p->op_type == OP_NULL)
+ continue;
+
+ if (( p->op_type != OP_PADSV
+ && p->op_type != OP_PADAV
+ && p->op_type != OP_PADHV
+ )
+ /* any private flag other than INTRO? e.g. STATE */
+ || (p->op_private & ~OPpLVAL_INTRO)
+ )
+ break;
+
+ /* let $a[N] potentially be optimised into ALEMFAST_LEX
+ * instead */
+ if ( p->op_type == OP_PADAV
+ && p->op_next
+ && p->op_next->op_type == OP_CONST
+ && p->op_next->op_next
+ && p->op_next->op_next->op_type == OP_AELEM
+ )
+ break;
+
+ /* for 1st padop, note what type it is and the range
+ * start; for the others, check that it's the same type
+ * and that the targs are contiguous */
+ if (count == 0) {
+ intro = (p->op_private & OPpLVAL_INTRO);
+ base = p->op_targ;
+ gimme = (p->op_flags & OPf_WANT);
+ }
+ else {
+ if ((p->op_private & OPpLVAL_INTRO) != intro)
+ break;
+ /* Note that you'd normally expect targs to be
+ * contiguous in my($a,$b,$c), but that's not the case
+ * when external modules start doing things, e.g.
+ i* Function::Parameters */
+ if (p->op_targ != base + count)
+ break;
+ assert(p->op_targ == base + count);
+ /* all the padops should be in the same context */
+ if (gimme != (p->op_flags & OPf_WANT))
+ break;
+ }
+
+ /* for AV, HV, only when we're not flattening */
+ if ( p->op_type != OP_PADSV
+ && gimme != OPf_WANT_VOID
+ && !(p->op_flags & OPf_REF)
+ )
+ break;
+
+ if (count >= OPpPADRANGE_COUNTMASK)
+ break;
+
+ /* there's a biggest base we can fit into a
+ * SAVEt_CLEARPADRANGE in pp_padrange */
+ if (intro && base >
+ (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
+ break;
+
+ /* Success! We've got another valid pad op to optimise away */
+ count++;
+ followop = p->op_next;
+ }
+
+ if (count < 1)
+ break;
+
+ /* pp_padrange in specifically compile-time void context
+ * skips pushing a mark and lexicals; in all other contexts
+ * (including unknown till runtime) it pushes a mark and the
+ * lexicals. We must be very careful then, that the ops we
+ * optimise away would have exactly the same effect as the
+ * padrange.
+ * In particular in void context, we can only optimise to
+ * a padrange if see see the complete sequence
+ * pushmark, pad*v, ...., list, nextstate
+ * which has the net effect of of leaving the stack empty
+ * (for now we leave the nextstate in the execution chain, for
+ * its other side-effects).
+ */
+ assert(followop);
+ if (gimme == OPf_WANT_VOID) {
+ if (followop->op_type == OP_LIST
+ && gimme == (followop->op_flags & OPf_WANT)
+ && ( followop->op_next->op_type == OP_NEXTSTATE
+ || followop->op_next->op_type == OP_DBSTATE))
+ {
+ followop = followop->op_next; /* skip OP_LIST */
+
+ /* consolidate two successive my(...);'s */
+
+ if ( oldoldop
+ && oldoldop->op_type == OP_PADRANGE
+ && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && (oldoldop->op_private & OPpLVAL_INTRO) == intro
+ && !(oldoldop->op_flags & OPf_SPECIAL)
+ ) {
+ U8 old_count;
+ assert(oldoldop->op_next == oldop);
+ assert( oldop->op_type == OP_NEXTSTATE
+ || oldop->op_type == OP_DBSTATE);
+ assert(oldop->op_next == o);
+
+ old_count
+ = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
+ assert(oldoldop->op_targ + old_count == base);
+
+ if (old_count < OPpPADRANGE_COUNTMASK - count) {
+ base = oldoldop->op_targ;
+ count += old_count;
+ reuse = 1;
+ }
+ }
+
+ /* if there's any immediately following singleton
+ * my var's; then swallow them and the associated
+ * nextstates; i.e.
+ * my ($a,$b); my $c; my $d;
+ * is treated as
+ * my ($a,$b,$c,$d);
+ */
+
+ while ( ((p = followop->op_next))
+ && ( p->op_type == OP_PADSV
+ || p->op_type == OP_PADAV
+ || p->op_type == OP_PADHV)
+ && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && (p->op_private & OPpLVAL_INTRO) == intro
+ && p->op_next
+ && ( p->op_next->op_type == OP_NEXTSTATE
+ || p->op_next->op_type == OP_DBSTATE)
+ && count < OPpPADRANGE_COUNTMASK
+ ) {
+ assert(base + count == p->op_targ);
+ count++;
+ followop = p->op_next;
+ }
+ }
+ else
+ break;
+ }
+
+ if (reuse) {
+ assert(oldoldop->op_type == OP_PADRANGE);
+ oldoldop->op_next = followop;
+ oldoldop->op_private = (intro | count);
+ o = oldoldop;
+ oldop = NULL;
+ oldoldop = NULL;
+ }
+ else {
+ /* Convert the pushmark into a padrange.
+ * To make Deparse easier, we guarantee that a padrange was
+ * *always* formerly a pushmark */
+ assert(o->op_type == OP_PUSHMARK);
+ o->op_next = followop;
+ o->op_type = OP_PADRANGE;
+ o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
+ o->op_targ = base;
+ /* bit 7: INTRO; bit 6..0: count */
+ o->op_private = (intro | count);
+ o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
+ | gimme | (defav ? OPf_SPECIAL : 0));
+ }
+ break;
+ }
+
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
}
}
+ oldoldop = oldop;
oldop = o;
}
LEAVE;
}
void
-Perl_peep(pTHX_ register OP *o)
+Perl_peep(pTHX_ OP *o)
{
CALL_RPEEP(o);
}
https://perl5.git.perl.org / perl5.git / blobdiff