o->op_targ = 0;
}
#endif
+ case OP_METHOD:
+#ifdef USE_ITHREADS
+ if (cMETHOPx(o)->op_class_targ) {
+ pad_swipe(cMETHOPx(o)->op_class_targ, 1);
+ cMETHOPx(o)->op_class_targ = 0;
+ }
+#else
+ SvREFCNT_dec(cMETHOPx(o)->op_class_sv);
+ cMETHOPx(o)->op_class_sv = NULL;
+#endif
break;
case OP_CONST:
case OP_HINTSEVAL:
do_kids:
while (kid) {
OP *sib = OP_SIBLING(kid);
- if (sib && kid->op_type != OP_LEAVEWHEN)
+ if (sib && kid->op_type != OP_LEAVEWHEN
+ && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
+ || ( sib->op_targ != OP_NEXTSTATE
+ && sib->op_targ != OP_DBSTATE )))
scalarvoid(kid);
else
scalar(kid);
=cut
*/
+static void
+S_mark_padname_lvalue(pTHX_ PADNAME *pn)
+{
+ CV *cv = PL_compcv;
+ PadnameLVALUE_on(pn);
+ while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
+ cv = CvOUTSIDE(cv);
+ assert(cv);
+ assert(CvPADLIST(cv));
+ pn =
+ PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
+ assert(PadnameLEN(pn));
+ PadnameLVALUE_on(pn);
+ }
+}
+
static bool
S_vivifies(const OPCODE type)
{
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
PAD_COMPNAME_SV(o->op_targ));
+ if (!(o->op_private & OPpLVAL_INTRO)
+ || ( type != OP_SASSIGN && type != OP_AASSIGN
+ && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
+ S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
{
const int retval = PL_savestack_ix;
- PL_compiling.cop_seq = PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ PL_compiling.cop_seq = PL_cop_seqmax;
+ COP_SEQMAX_INC;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
OP *o;
+ /* XXX Is the null PL_parser check necessary here? */
+ assert(PL_parser); /* Let’s find out under debugging builds. */
+ if (PL_parser && PL_parser->parsed_sub) {
+ o = newSTATEOP(0, NULL, NULL);
+ op_null(o);
+ retval = op_append_elem(OP_LINESEQ, retval, o);
+ }
+
CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
LEAVE_SCOPE(floor);
StructCopy(&PL_compiling, ¬_compiling, COP);
PL_curcop = ¬_compiling;
/* The above ensures that we run with all the correct hints of the
- currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ currently compiling COP, but that IN_PERL_RUNTIME is true. */
assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
methop->op_flags = (U8)(flags | OPf_KIDS);
methop->op_u.op_first = dynamic_meth;
methop->op_private = (U8)(1 | (flags >> 8));
+
+#ifdef PERL_OP_PARENT
+ if (!OP_HAS_SIBLING(dynamic_meth))
+ dynamic_meth->op_sibling = (OP*)methop;
+#endif
}
else {
assert(const_meth);
methop->op_next = (OP*)methop;
}
+#ifdef USE_ITHREADS
+ methop->op_class_targ = 0;
+#else
+ methop->op_class_sv = NULL;
+#endif
CHANGE_TYPE(methop, type);
methop = (METHOP*) CHECKOP(type, methop);
return CHECKOP(type, pmop);
}
+static void
+S_set_haseval(pTHX)
+{
+ PADOFFSET i = 1;
+ PL_cv_has_eval = 1;
+ /* Any pad names in scope are potentially lvalues. */
+ for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
+ PADNAME *pn = PAD_COMPNAME_SV(i);
+ if (!pn || !PadnameLEN(pn))
+ continue;
+ if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
+ S_mark_padname_lvalue(aTHX_ pn);
+ }
+}
+
/* Given some sort of match op o, and an expression expr containing a
* pattern, either compile expr into a regex and attach it to o (if it's
* constant), or convert expr into a runtime regcomp op sequence (if it's
rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
- if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
+ if (PL_hints & HINT_RE_EVAL)
+ S_set_haseval(aTHX);
/* establish postfix order */
if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
PL_hints |= HINT_BLOCK_SCOPE;
PL_parser->copline = NOLINE;
- PL_cop_seqmax++; /* Purely for B::*'s benefit */
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
-
+ COP_SEQMAX_INC; /* Purely for B::*'s benefit */
}
/*
}
/*
- Helper function for newASSIGNOP to detection commonality between the
+ Helper function for newASSIGNOP to detect commonality between the
lhs and the rhs. (It is actually called very indirectly. newASSIGNOP
flags the op and the peephole optimizer calls this helper function
if the flag is set.) Marks all variables with PL_generation. If it
const U32 utf8 = flags & SVf_UTF8;
COP *cop;
+ PL_parser->parsed_sub = 0;
+
flags &= ~SVf_UTF8;
NewOp(1101, cop, 1, COP);
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
+ * Can be called in 2 ways:
*
- * !cv
+ * !allow_lex
* look for a single OP_CONST with attached value: return the value
*
- * cv && CvCLONE(cv) && !CvCONST(cv)
+ * allow_lex && !CvCONST(cv);
*
* examine the clone prototype, and if contains only a single
- * OP_CONST referencing a pad const, or a single PADSV referencing
- * an outer lexical, return a non-zero value to indicate the CV is
- * a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- * We have just cloned an anon prototype that was marked as a const
- * candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. In this case we
- * return a newly created *copy* of the value.
+ * OP_CONST, return the value; or if it contains a single PADSV ref-
+ * erencing an outer lexical, turn on CvCONST to indicate the CV is
+ * a candidate for "constizing" at clone time, and return NULL.
*/
-SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+static SV *
+S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
{
SV *sv = NULL;
+ bool padsv = FALSE;
- if (!o)
- return NULL;
-
- if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
- o = OP_SIBLING(cLISTOPo->op_first);
+ assert(o);
+ assert(cv);
for (; o; o = o->op_next) {
const OPCODE type = o->op_type;
- if (sv && o->op_next == o)
- return sv;
- if (o->op_next != o) {
- if (type == OP_NEXTSTATE
- || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+ if (type == OP_NEXTSTATE || type == OP_LINESEQ
+ || type == OP_NULL
|| type == OP_PUSHMARK)
continue;
- if (type == OP_DBSTATE)
+ if (type == OP_DBSTATE)
continue;
- }
- if (type == OP_LEAVESUB || type == OP_RETURN)
+ if (type == OP_LEAVESUB)
break;
if (sv)
return NULL;
sv = newSV(0);
SAVEFREESV(sv);
}
- else if (cv && type == OP_CONST) {
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- if (!sv)
- return NULL;
- }
- else if (cv && type == OP_PADSV) {
- if (CvCONST(cv)) { /* newly cloned anon */
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- /* the candidate should have 1 ref from this pad and 1 ref
- * from the parent */
- if (!sv || SvREFCNT(sv) != 2)
- return NULL;
- sv = newSVsv(sv);
- SvREADONLY_on(sv);
- return sv;
- }
- else {
+ else if (allow_lex && type == OP_PADSV) {
if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ {
sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
+ padsv = TRUE;
+ }
+ else
+ return NULL;
}
else {
return NULL;
}
}
+ if (padsv) {
+ CvCONST_on(cv);
+ return NULL;
+ }
return sv;
}
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
#endif
spot = (CV **)(svspot = &mg->mg_obj);
}
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
+
if (!block || !ps || *ps || attrs
- || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(compcv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
bool special = FALSE;
? (CV *)SvRV(gv)
: NULL;
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(PL_compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
+ && (!isGV(gv) || !GvASSUMECV(gv)))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
if (!block || !ps || *ps || attrs
- || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(PL_compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
- if (isGV(gv)) {
- if (name) GvCV_set(gv, NULL);
+ if (isGV(gv) || CvMETHOD(PL_compcv)) {
+ if (name && isGV(gv))
+ GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
if (!SvROK(gv)) {
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
}
else {
scalar((OP*)kid);
- PL_cv_has_eval = 1;
+ S_set_haseval(aTHX);
}
}
else {
OP * const padop = newOP(OP_PADCV, 0);
padop->op_targ = off;
cUNOPx(firstkid)->op_first = padop;
+#ifdef PERL_OP_PARENT
+ padop->op_sibling = firstkid;
+#endif
op_free(kid);
}
}
case '&':
proto++;
arg++;
- if (o3->op_type != OP_REFGEN && o3->op_type != OP_SREFGEN
- && o3->op_type != OP_UNDEF)
+ if (o3->op_type != OP_SREFGEN
+ || ( cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_ANONCODE
+ && cUNOPx(cUNOPx(o3)->op_first)->op_first->op_type
+ != OP_RV2CV))
bad_type_gv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
namegv, 0, o3);
OP *aop, *cvop;
CV *cv;
GV *namegv;
+ SV *const_class = NULL;
PERL_ARGS_ASSERT_CK_SUBR;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
- if (cvop->op_type == OP_RV2CV) {
- o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
- op_null(cvop);
- } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
- if (aop->op_type == OP_CONST)
- aop->op_private &= ~OPpCONST_STRICT;
- else if (aop->op_type == OP_LIST) {
- OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
- if (sib && sib->op_type == OP_CONST)
- sib->op_private &= ~OPpCONST_STRICT;
- }
+ switch (cvop->op_type) {
+ case OP_RV2CV:
+ o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
+ op_null(cvop);
+ break;
+ case OP_METHOD:
+ case OP_METHOD_NAMED:
+ if (aop->op_type == OP_CONST) {
+ aop->op_private &= ~OPpCONST_STRICT;
+ const_class = cSVOPx(aop)->op_sv;
+ }
+ else if (aop->op_type == OP_LIST) {
+ OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
+ if (sib && sib->op_type == OP_CONST) {
+ sib->op_private &= ~OPpCONST_STRICT;
+ const_class = cSVOPx(sib)->op_sv;
+ }
+ }
+ /* cache const class' name to speedup class method calls */
+ if (const_class) {
+ STRLEN len;
+ SV* shared;
+ const char* str = SvPV(const_class, len);
+ if (len) {
+ shared = newSVpvn_share(
+ str, SvUTF8(const_class) ? -len : len, 0
+ );
+#ifdef USE_ITHREADS
+ op_relocate_sv(&shared, &cMETHOPx(cvop)->op_class_targ);
+#else
+ cMETHOPx(cvop)->op_class_sv = shared;
+#endif
+ }
+ }
+ break;
}
if (!cv) {
https://perl5.git.perl.org / perl5.git / blobdiff