#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
+/* Used to avoid recursion through the op tree in scalarvoid() and
+ op_free()
+*/
+
+#define DEFERRED_OP_STEP 100
+#define DEFER_OP(o) \
+ STMT_START { \
+ if (UNLIKELY(defer_ix == (defer_stack_alloc-1))) { \
+ defer_stack_alloc += DEFERRED_OP_STEP; \
+ assert(defer_stack_alloc > 0); \
+ Renew(defer_stack, defer_stack_alloc, OP *); \
+ } \
+ defer_stack[++defer_ix] = o; \
+ } STMT_END
+
+#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
+
/* remove any leading "empty" ops from the op_next chain whose first
* node's address is stored in op_p. Store the updated address of the
* first node in op_p.
void
Perl_op_free(pTHX_ OP *o)
{
-#ifdef USE_ITHREADS
dVAR;
-#endif
OPCODE type;
+ SSize_t defer_ix = -1;
+ SSize_t defer_stack_alloc = 0;
+ OP **defer_stack = NULL;
- /* Though ops may be freed twice, freeing the op after its slab is a
- big no-no. */
- assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
- /* During the forced freeing of ops after compilation failure, kidops
- may be freed before their parents. */
- if (!o || o->op_type == OP_FREED)
- return;
+ do {
- type = o->op_type;
+ /* Though ops may be freed twice, freeing the op after its slab is a
+ big no-no. */
+ assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
+ /* During the forced freeing of ops after compilation failure, kidops
+ may be freed before their parents. */
+ if (!o || o->op_type == OP_FREED)
+ continue;
- /* an op should only ever acquire op_private flags that we know about.
- * If this fails, you may need to fix something in regen/op_private */
- assert(!(o->op_private & ~PL_op_private_valid[type]));
+ type = o->op_type;
- if (o->op_private & OPpREFCOUNTED) {
- switch (type) {
- case OP_LEAVESUB:
- case OP_LEAVESUBLV:
- case OP_LEAVEEVAL:
- case OP_LEAVE:
- case OP_SCOPE:
- case OP_LEAVEWRITE:
- {
- PADOFFSET refcnt;
- OP_REFCNT_LOCK;
- refcnt = OpREFCNT_dec(o);
- OP_REFCNT_UNLOCK;
- 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;
- }
- }
+ /* an op should only ever acquire op_private flags that we know about.
+ * If this fails, you may need to fix something in regen/op_private */
+ if (o->op_ppaddr == PL_ppaddr[o->op_type]) {
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+ }
- /* Call the op_free hook if it has been set. Do it now so that it's called
- * at the right time for refcounted ops, but still before all of the kids
- * are freed. */
- CALL_OPFREEHOOK(o);
+ if (o->op_private & OPpREFCOUNTED) {
+ switch (type) {
+ case OP_LEAVESUB:
+ case OP_LEAVESUBLV:
+ case OP_LEAVEEVAL:
+ case OP_LEAVE:
+ case OP_SCOPE:
+ case OP_LEAVEWRITE:
+ {
+ PADOFFSET refcnt;
+ OP_REFCNT_LOCK;
+ refcnt = OpREFCNT_dec(o);
+ OP_REFCNT_UNLOCK;
+ if (refcnt) {
+ /* Need to find and remove any pattern match ops from the list
+ we maintain for reset(). */
+ find_and_forget_pmops(o);
+ continue;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ }
- if (o->op_flags & OPf_KIDS) {
- OP *kid, *nextkid;
- for (kid = cUNOPo->op_first; kid; kid = nextkid) {
- nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
- op_free(kid);
- }
- }
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
+ /* Call the op_free hook if it has been set. Do it now so that it's called
+ * at the right time for refcounted ops, but still before all of the kids
+ * are freed. */
+ CALL_OPFREEHOOK(o);
+
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid, *nextkid;
+ for (kid = cUNOPo->op_first; kid; kid = nextkid) {
+ nextkid = OP_SIBLING(kid); /* Get before next freeing kid */
+ if (!kid || kid->op_type == OP_FREED)
+ /* During the forced freeing of ops after
+ compilation failure, kidops may be freed before
+ their parents. */
+ continue;
+ if (!(kid->op_flags & OPf_KIDS))
+ /* If it has no kids, just free it now */
+ op_free(kid);
+ else
+ DEFER_OP(kid);
+ }
+ }
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
- if (o->op_slabbed)
- Slab_to_rw(OpSLAB(o));
+ if (o->op_slabbed)
+ Slab_to_rw(OpSLAB(o));
- /* COP* is not cleared by op_clear() so that we may track line
- * numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
- cop_free((COP*)o);
- }
+ /* COP* is not cleared by op_clear() so that we may track line
+ * numbers etc even after null() */
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
+ cop_free((COP*)o);
+ }
- op_clear(o);
- FreeOp(o);
+ op_clear(o);
+ FreeOp(o);
#ifdef DEBUG_LEAKING_SCALARS
- if (PL_op == o)
- PL_op = NULL;
+ if (PL_op == o)
+ PL_op = NULL;
#endif
+ } while ( (o = POP_DEFERRED_OP()) );
+
+ Safefree(defer_stack);
}
void
return;
op_clear(o);
o->op_targ = o->op_type;
- o->op_type = OP_NULL;
- o->op_ppaddr = PL_ppaddr[OP_NULL];
+ CHANGE_TYPE(o, OP_NULL);
}
void
LOGOP *
S_alloc_LOGOP(pTHX_ I32 type, OP *first, OP* other)
{
+ dVAR;
LOGOP *logop;
OP *kid = first;
NewOp(1101, logop, 1, LOGOP);
- logop->op_type = (OPCODE)type;
+ CHANGE_TYPE(logop, type);
logop->op_first = first;
logop->op_other = other;
logop->op_flags = OPf_KIDS;
switch (o->op_type) {
case OP_REPEAT:
scalar(cBINOPo->op_first);
+ if (o->op_private & OPpREPEAT_DOLIST) {
+ kid = cLISTOPx(cUNOPo->op_first)->op_first;
+ assert(kid->op_type == OP_PUSHMARK);
+ if (OP_HAS_SIBLING(kid) && !OP_HAS_SIBLING(OP_SIBLING(kid))) {
+ op_null(cLISTOPx(cUNOPo->op_first)->op_first);
+ o->op_private &=~ OPpREPEAT_DOLIST;
+ }
+ }
break;
case OP_OR:
case OP_AND:
}
OP *
-Perl_scalarvoid(pTHX_ OP *o)
+Perl_scalarvoid(pTHX_ OP *arg)
{
dVAR;
OP *kid;
- SV *useless_sv = NULL;
- const char* useless = NULL;
SV* sv;
U8 want;
+ SSize_t defer_stack_alloc = 0;
+ SSize_t defer_ix = -1;
+ OP **defer_stack = NULL;
+ OP *o = arg;
PERL_ARGS_ASSERT_SCALARVOID;
- if (o->op_type == OP_NEXTSTATE
- || o->op_type == OP_DBSTATE
- || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
- || o->op_targ == OP_DBSTATE)))
- PL_curcop = (COP*)o; /* for warning below */
+ do {
+ SV *useless_sv = NULL;
+ const char* useless = NULL;
+
+ if (o->op_type == OP_NEXTSTATE
+ || o->op_type == OP_DBSTATE
+ || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
+ || o->op_targ == OP_DBSTATE)))
+ PL_curcop = (COP*)o; /* for warning below */
+
+ /* assumes no premature commitment */
+ want = o->op_flags & OPf_WANT;
+ if ((want && want != OPf_WANT_SCALAR)
+ || (PL_parser && PL_parser->error_count)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
+ {
+ continue;
+ }
- /* assumes no premature commitment */
- want = o->op_flags & OPf_WANT;
- if ((want && want != OPf_WANT_SCALAR)
- || (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
- {
- return o;
- }
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
+ {
+ /* newASSIGNOP has already applied scalar context, which we
+ leave, as if this op is inside SASSIGN. */
+ continue;
+ }
- if ((o->op_private & OPpTARGET_MY)
- && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
- {
- return scalar(o); /* As if inside SASSIGN */
- }
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+ switch (o->op_type) {
+ default:
+ if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
+ break;
+ /* FALLTHROUGH */
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ goto func_ops;
+ case OP_SUBSTR:
+ if (o->op_private == 4)
+ break;
+ /* FALLTHROUGH */
+ case OP_WANTARRAY:
+ case OP_GV:
+ case OP_SMARTMATCH:
+ case OP_AV2ARYLEN:
+ case OP_REF:
+ case OP_REFGEN:
+ case OP_SREFGEN:
+ case OP_DEFINED:
+ case OP_HEX:
+ case OP_OCT:
+ case OP_LENGTH:
+ case OP_VEC:
+ case OP_INDEX:
+ case OP_RINDEX:
+ case OP_SPRINTF:
+ case OP_KVASLICE:
+ case OP_KVHSLICE:
+ case OP_UNPACK:
+ case OP_PACK:
+ case OP_JOIN:
+ case OP_LSLICE:
+ case OP_ANONLIST:
+ case OP_ANONHASH:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_RANGE:
+ case OP_FLIP:
+ case OP_FLOP:
+ case OP_CALLER:
+ case OP_FILENO:
+ case OP_EOF:
+ case OP_TELL:
+ case OP_GETSOCKNAME:
+ case OP_GETPEERNAME:
+ case OP_READLINK:
+ case OP_TELLDIR:
+ case OP_GETPPID:
+ case OP_GETPGRP:
+ case OP_GETPRIORITY:
+ case OP_TIME:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_GHBYNAME:
+ case OP_GHBYADDR:
+ case OP_GHOSTENT:
+ case OP_GNBYNAME:
+ case OP_GNBYADDR:
+ case OP_GNETENT:
+ case OP_GPBYNAME:
+ case OP_GPBYNUMBER:
+ case OP_GPROTOENT:
+ case OP_GSBYNAME:
+ case OP_GSBYPORT:
+ case OP_GSERVENT:
+ case OP_GPWNAM:
+ case OP_GPWUID:
+ case OP_GGRNAM:
+ case OP_GGRGID:
+ case OP_GETLOGIN:
+ case OP_PROTOTYPE:
+ case OP_RUNCV:
+ func_ops:
+ useless = OP_DESC(o);
+ break;
- switch (o->op_type) {
- default:
- if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
- break;
- /* FALLTHROUGH */
- case OP_REPEAT:
- if (o->op_flags & OPf_STACKED)
- break;
- goto func_ops;
- case OP_SUBSTR:
- if (o->op_private == 4)
- break;
- /* FALLTHROUGH */
- case OP_GVSV:
- case OP_WANTARRAY:
- case OP_GV:
- case OP_SMARTMATCH:
- case OP_PADSV:
- case OP_PADAV:
- case OP_PADHV:
- case OP_PADANY:
- case OP_AV2ARYLEN:
- case OP_REF:
- case OP_REFGEN:
- case OP_SREFGEN:
- case OP_DEFINED:
- case OP_HEX:
- case OP_OCT:
- case OP_LENGTH:
- case OP_VEC:
- case OP_INDEX:
- case OP_RINDEX:
- case OP_SPRINTF:
- case OP_AELEM:
- case OP_AELEMFAST:
- case OP_AELEMFAST_LEX:
- case OP_ASLICE:
- case OP_KVASLICE:
- case OP_HELEM:
- case OP_HSLICE:
- case OP_KVHSLICE:
- case OP_UNPACK:
- case OP_PACK:
- case OP_JOIN:
- case OP_LSLICE:
- case OP_ANONLIST:
- case OP_ANONHASH:
- case OP_SORT:
- case OP_REVERSE:
- case OP_RANGE:
- case OP_FLIP:
- case OP_FLOP:
- case OP_CALLER:
- case OP_FILENO:
- case OP_EOF:
- case OP_TELL:
- case OP_GETSOCKNAME:
- case OP_GETPEERNAME:
- case OP_READLINK:
- case OP_TELLDIR:
- case OP_GETPPID:
- case OP_GETPGRP:
- case OP_GETPRIORITY:
- case OP_TIME:
- case OP_TMS:
- case OP_LOCALTIME:
- case OP_GMTIME:
- case OP_GHBYNAME:
- case OP_GHBYADDR:
- case OP_GHOSTENT:
- case OP_GNBYNAME:
- case OP_GNBYADDR:
- case OP_GNETENT:
- case OP_GPBYNAME:
- case OP_GPBYNUMBER:
- case OP_GPROTOENT:
- case OP_GSBYNAME:
- case OP_GSBYPORT:
- case OP_GSERVENT:
- case OP_GPWNAM:
- case OP_GPWUID:
- case OP_GGRNAM:
- case OP_GGRGID:
- case OP_GETLOGIN:
- case OP_PROTOTYPE:
- case OP_RUNCV:
- func_ops:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
- /* Otherwise it's "Useless use of grep iterator" */
- useless = OP_DESC(o);
- break;
+ case OP_GVSV:
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+ case OP_PADANY:
+ case OP_AELEM:
+ case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
+ case OP_ASLICE:
+ case OP_HELEM:
+ case OP_HSLICE:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
+ /* Otherwise it's "Useless use of grep iterator" */
+ useless = OP_DESC(o);
+ break;
- case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE
- && !kid->op_targ
- && !(o->op_flags & OPf_STACKED)
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE
+ && !kid->op_targ
+ && !(o->op_flags & OPf_STACKED)
#ifdef USE_ITHREADS
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
#else
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
#endif
- useless = OP_DESC(o);
- break;
+ )
+ useless = OP_DESC(o);
+ break;
- case OP_NOT:
- kid = cUNOPo->op_first;
- if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
- kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
- goto func_ops;
- }
- useless = "negative pattern binding (!~)";
- break;
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
- case OP_SUBST:
- if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
- useless = "non-destructive substitution (s///r)";
- break;
+ case OP_SUBST:
+ if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
+ useless = "non-destructive substitution (s///r)";
+ break;
- case OP_TRANSR:
- useless = "non-destructive transliteration (tr///r)";
- break;
+ case OP_TRANSR:
+ useless = "non-destructive transliteration (tr///r)";
+ break;
- case OP_RV2GV:
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
- (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
- useless = "a variable";
- break;
+ case OP_RV2GV:
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
+ (!OP_HAS_SIBLING(o) || OP_SIBLING(o)->op_type != OP_READLINE))
+ useless = "a variable";
+ break;
- case OP_CONST:
- sv = cSVOPo_sv;
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
- else {
- if (ckWARN(WARN_VOID)) {
- NV nv;
- /* don't warn on optimised away booleans, eg
- * use constant Foo, 5; Foo || print; */
- if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = NULL;
- /* the constants 0 and 1 are permitted as they are
- conventionally used as dummies in constructs like
- 1 while some_condition_with_side_effects; */
- else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
- useless = NULL;
- else if (SvPOK(sv)) {
- SV * const dsv = newSVpvs("");
- useless_sv
- = Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, SvPVX_const(sv),
- SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP
- | PERL_PV_ESCAPE_NOCLEAR
- | PERL_PV_ESCAPE_UNI_DETECT));
- SvREFCNT_dec_NN(dsv);
- }
- else if (SvOK(sv)) {
- useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
- }
- else
- useless = "a constant (undef)";
- }
- }
- op_null(o); /* don't execute or even remember it */
- break;
+ case OP_CONST:
+ sv = cSVOPo_sv;
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
+ else {
+ if (ckWARN(WARN_VOID)) {
+ NV nv;
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = NULL;
+ /* the constants 0 and 1 are permitted as they are
+ conventionally used as dummies in constructs like
+ 1 while some_condition_with_side_effects; */
+ else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))
+ useless = NULL;
+ else if (SvPOK(sv)) {
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, SvPVX_const(sv),
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
+ SvREFCNT_dec_NN(dsv);
+ }
+ else if (SvOK(sv)) {
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", SVfARG(sv));
+ }
+ else
+ useless = "a constant (undef)";
+ }
+ }
+ op_null(o); /* don't execute or even remember it */
+ break;
- case OP_POSTINC:
- o->op_type = OP_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREINC];
- break;
+ case OP_POSTINC:
+ CHANGE_TYPE(o, OP_PREINC); /* pre-increment is faster */
+ break;
- case OP_POSTDEC:
- o->op_type = OP_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREDEC];
- break;
+ case OP_POSTDEC:
+ CHANGE_TYPE(o, OP_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_I_POSTINC:
- o->op_type = OP_I_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
- break;
+ case OP_I_POSTINC:
+ CHANGE_TYPE(o, OP_I_PREINC); /* pre-increment is faster */
+ break;
- case OP_I_POSTDEC:
- o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
- break;
+ case OP_I_POSTDEC:
+ CHANGE_TYPE(o, OP_I_PREDEC); /* pre-decrement is faster */
+ break;
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
- refgen = (UNOP *)((BINOP *)o)->op_first;
+ refgen = (UNOP *)((BINOP *)o)->op_first;
- if (!refgen || (refgen->op_type != OP_REFGEN
- && refgen->op_type != OP_SREFGEN))
- break;
+ if (!refgen || (refgen->op_type != OP_REFGEN
+ && refgen->op_type != OP_SREFGEN))
+ break;
- exlist = (LISTOP *)refgen->op_first;
- if (!exlist || exlist->op_type != OP_NULL
- || exlist->op_targ != OP_LIST)
- break;
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
- if (exlist->op_first->op_type != OP_PUSHMARK
- && exlist->op_first != exlist->op_last)
- break;
+ if (exlist->op_first->op_type != OP_PUSHMARK
+ && exlist->op_first != exlist->op_last)
+ break;
- rv2cv = (UNOP*)exlist->op_last;
+ rv2cv = (UNOP*)exlist->op_last;
- if (rv2cv->op_type != OP_RV2CV)
- break;
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
- assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
- assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
- assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
- break;
- }
+ break;
+ }
- case OP_AASSIGN: {
- inplace_aassign(o);
- break;
- }
+ case OP_AASSIGN: {
+ inplace_aassign(o);
+ break;
+ }
- case OP_OR:
- case OP_AND:
- kid = cLOGOPo->op_first;
- if (kid->op_type == OP_NOT
- && (kid->op_flags & OPf_KIDS)) {
- if (o->op_type == OP_AND) {
- o->op_type = OP_OR;
- o->op_ppaddr = PL_ppaddr[OP_OR];
- } else {
- o->op_type = OP_AND;
- o->op_ppaddr = PL_ppaddr[OP_AND];
- }
- op_null(kid);
- }
- /* FALLTHROUGH */
+ case OP_OR:
+ case OP_AND:
+ kid = cLOGOPo->op_first;
+ if (kid->op_type == OP_NOT
+ && (kid->op_flags & OPf_KIDS)) {
+ if (o->op_type == OP_AND) {
+ CHANGE_TYPE(o, OP_OR);
+ } else {
+ CHANGE_TYPE(o, OP_AND);
+ }
+ op_null(kid);
+ }
+ /* FALLTHROUGH */
+
+ case OP_DOR:
+ case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
+ for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
- case OP_DOR:
- case OP_COND_EXPR:
- case OP_ENTERGIVEN:
- case OP_ENTERWHEN:
- for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
+ case OP_NULL:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ /* FALLTHROUGH */
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ case OP_ENTERTRY:
+ case OP_ENTER:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* FALLTHROUGH */
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LEAVELOOP:
+ case OP_LINESEQ:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
+ kids:
+ for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
+ if (!(kid->op_flags & OPf_KIDS))
+ scalarvoid(kid);
+ else
+ DEFER_OP(kid);
+ break;
+ case OP_LIST:
+ /* If the first kid after pushmark is something that the padrange
+ optimisation would reject, then null the list and the pushmark.
+ */
+ if ((kid = cLISTOPo->op_first)->op_type == OP_PUSHMARK
+ && ( !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO
+ || !(kid = OP_SIBLING(kid))
+ || ( kid->op_type != OP_PADSV
+ && kid->op_type != OP_PADAV
+ && kid->op_type != OP_PADHV)
+ || kid->op_private & ~OPpLVAL_INTRO)
+ ) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
+ goto kids;
+ case OP_ENTEREVAL:
+ scalarkids(o);
+ break;
+ case OP_SCALAR:
+ scalar(o);
+ break;
+ }
- case OP_NULL:
- if (o->op_flags & OPf_STACKED)
- break;
- /* FALLTHROUGH */
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- case OP_ENTERTRY:
- case OP_ENTER:
- if (!(o->op_flags & OPf_KIDS))
- break;
- /* FALLTHROUGH */
- case OP_SCOPE:
- case OP_LEAVE:
- case OP_LEAVETRY:
- case OP_LEAVELOOP:
- case OP_LINESEQ:
- case OP_LIST:
- case OP_LEAVEGIVEN:
- case OP_LEAVEWHEN:
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid))
- scalarvoid(kid);
- break;
- case OP_ENTEREVAL:
- scalarkids(o);
- break;
- case OP_SCALAR:
- return scalar(o);
- }
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ SVfARG(sv_2mortal(useless_sv)));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
+ } while ( (o = POP_DEFERRED_OP()) );
- if (useless_sv) {
- /* mortalise it, in case warnings are fatal. */
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %"SVf" in void context",
- SVfARG(sv_2mortal(useless_sv)));
- }
- else if (useless) {
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
- "Useless use of %s in void context",
- useless);
- }
- return o;
+ Safefree(defer_stack);
+
+ return arg;
}
static OP *
switch (o->op_type) {
case OP_FLOP:
- case OP_REPEAT:
list(cBINOPo->op_first);
break;
+ case OP_REPEAT:
+ if (o->op_private & OPpREPEAT_DOLIST
+ && !(o->op_flags & OPf_STACKED))
+ {
+ list(cBINOPo->op_first);
+ kid = cBINOPo->op_last;
+ if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)
+ && SvIVX(kSVOP_sv) == 1)
+ {
+ op_null(o); /* repeat */
+ op_null(cUNOPx(cBINOPo->op_first)->op_first);/* pushmark */
+ /* const (rhs): */
+ op_free(op_sibling_splice(o, cBINOPo->op_first, 1, NULL));
+ }
+ }
+ break;
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
list(cBINOPo->op_first);
return gen_constant_list(o);
}
+ listkids(o);
+ break;
case OP_LIST:
listkids(o);
+ if (cLISTOPo->op_first->op_type == OP_PUSHMARK) {
+ op_null(cUNOPo->op_first); /* NULL the pushmark */
+ op_null(o); /* NULL the list */
+ }
break;
case OP_LEAVE:
case OP_LEAVETRY:
=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)
{
static void
S_lvref(pTHX_ OP *o, I32 type)
{
+ dVAR;
OP *kid;
switch (o->op_type) {
case OP_COND_EXPR:
o->op_flags |= OPf_STACKED;
if (o->op_flags & OPf_PARENS) {
if (o->op_private & OPpLVAL_INTRO) {
- /* diag_listed_as: Can't modify %s in %s */
yyerror(Perl_form(aTHX_ "Can't modify reference to "
"localized parenthesized array in list assignment"));
return;
}
slurpy:
- o->op_type = OP_LVAVREF;
- o->op_ppaddr = PL_ppaddr[OP_LVAVREF];
+ CHANGE_TYPE(o, OP_LVAVREF);
o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
o->op_flags |= OPf_MOD|OPf_REF;
return;
case OP_RV2HV:
if (o->op_flags & OPf_PARENS) {
parenhash:
- /* diag_listed_as: Can't modify %s in %s */
yyerror(Perl_form(aTHX_ "Can't modify reference to "
"parenthesized hash in list assignment"));
return;
break;
case OP_ASLICE:
case OP_HSLICE:
- o->op_type = OP_LVREFSLICE;
- o->op_ppaddr = PL_ppaddr[OP_LVREFSLICE];
+ CHANGE_TYPE(o, OP_LVREFSLICE);
o->op_private &= OPpLVAL_INTRO|OPpLVREF_ELEM;
return;
case OP_NULL:
/* FALLTHROUGH */
default:
badref:
- /* diag_listed_as: Can't modify %s in %s */
+ /* diag_listed_as: Can't modify reference to %s in %s assignment */
yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
? "do block"
PL_op_desc[type]));
return;
}
- o->op_type = OP_LVREF;
- o->op_ppaddr = PL_ppaddr[OP_LVREF];
+ CHANGE_TYPE(o, OP_LVREF);
o->op_private &=
OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
if (type == OP_ENTERLOOP)
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
- o->op_type = OP_RV2CV; /* entersub => rv2cv */
- o->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
case OP_MULTIPLY:
case OP_DIVIDE:
case OP_MODULO:
- case OP_REPEAT:
case OP_ADD:
case OP_SUBTRACT:
case OP_CONCAT:
PL_modcount++;
break;
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED) {
+ PL_modcount++;
+ break;
+ }
+ if (!(o->op_private & OPpREPEAT_DOLIST))
+ goto nomod;
+ else {
+ const I32 mods = PL_modcount;
+ modkids(cBINOPo->op_first, type);
+ if (type != OP_AASSIGN)
+ goto nomod;
+ kid = cBINOPo->op_last;
+ if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
+ const IV iv = SvIV(kSVOP_sv);
+ if (PL_modcount != RETURN_UNLIMITED_NUMBER)
+ PL_modcount =
+ mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
+ }
+ else
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
+ }
+ break;
+
case OP_COND_EXPR:
localize = 1;
for (kid = OP_SIBLING(cUNOPo->op_first); kid; kid = OP_SIBLING(kid))
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 U8 ec = PL_parser ? PL_parser->error_count : 0;
S_lvref(aTHX_ kid, type);
if (!PL_parser || PL_parser->error_count == ec) {
- if (!FEATURE_LVREF_IS_ENABLED)
+ if (!FEATURE_REFALIASING_IS_ENABLED)
Perl_croak(aTHX_
- "Experimental lvalue references not enabled");
+ "Experimental aliasing via reference not enabled");
Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
- "Lvalue references are experimental");
+ packWARN(WARN_EXPERIMENTAL__REFALIASING),
+ "Aliasing via reference is experimental");
}
}
if (o->op_type == OP_REFGEN)
op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
op_null(o);
return o;
+
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE &&
+ ( kid->op_targ
+ || o->op_flags & OPf_STACKED
+#ifdef USE_ITHREADS
+ || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
+#else
+ || ((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
+#endif
+ )) {
+ /* This is actually @array = split. */
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
+ break;
+ }
+ goto nomod;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
case OP_ENTERSUB:
if ((type == OP_EXISTS || type == OP_DEFINED) &&
!(o->op_flags & OPf_STACKED)) {
- o->op_type = OP_RV2CV; /* entersub => rv2cv */
- o->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ CHANGE_TYPE(o, OP_RV2CV); /* entersub => rv2cv */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
/* Fake up a method call to import */
meth = newSVpvs_share("import");
- imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
+ imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, pack, list(arg)),
+ op_prepend_elem(OP_LIST, pack, arg),
newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
/* Combine the ops. */
right->op_targ = 0;
right->op_private &= ~OPpTARGET_MY;
}
- if (!(right->op_flags & OPf_STACKED) && ismatchop) {
- OP *newleft;
-
- right->op_flags |= OPf_STACKED;
- if (rtype != OP_MATCH && rtype != OP_TRANSR &&
+ if (!(right->op_flags & OPf_STACKED) && !right->op_targ && ismatchop) {
+ if (left->op_type == OP_PADSV
+ && !(left->op_private & OPpLVAL_INTRO))
+ {
+ right->op_targ = left->op_targ;
+ op_free(left);
+ o = right;
+ }
+ else {
+ right->op_flags |= OPf_STACKED;
+ if (rtype != OP_MATCH && rtype != OP_TRANSR &&
! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL) &&
! (rtype == OP_SUBST &&
(cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
- newleft = op_lvalue(left, rtype);
- else
- newleft = left;
- if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
- o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
- else
- o = op_prepend_elem(rtype, scalar(newleft), right);
+ left = op_lvalue(left, rtype);
+ if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
+ o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
+ else
+ o = op_prepend_elem(rtype, scalar(left), right);
+ }
if (type == OP_NOT)
return newUNOP(OP_NOT, 0, scalar(o));
return o;
if (o) {
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];
+ CHANGE_TYPE(o, OP_LEAVE);
}
else if (o->op_type == OP_LINESEQ) {
OP *kid;
- o->op_type = OP_SCOPE;
- o->op_ppaddr = PL_ppaddr[OP_SCOPE];
+ CHANGE_TYPE(o, OP_SCOPE);
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
op_null(kid);
return o;
}
+/*
+=for apidoc Am|int|block_start|int full
+
+Handles compile-time scope entry.
+Arranges for hints to be restored on block
+exit and also handles pad sequence numbers to make lexical variables scope
+right. Returns a savestack index for use with C<block_end>.
+
+=cut
+*/
+
int
Perl_block_start(pTHX_ int full)
{
const int retval = PL_savestack_ix;
+ PL_compiling.cop_seq = PL_cop_seqmax;
+ COP_SEQMAX_INC;
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+ SAVEI32(PL_compiling.cop_seq);
+ PL_compiling.cop_seq = 0;
CALL_BLOCK_HOOKS(bhk_start, full);
return retval;
}
+/*
+=for apidoc Am|OP *|block_end|I32 floor|OP *seq
+
+Handles compile-time scope exit. I<floor>
+is the savestack index returned by
+C<block_start>, and I<seq> is the body of the block. Returns the block,
+possibly modified.
+
+=cut
+*/
+
OP*
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
}
-STATIC OP *
-S_newDEFSVOP(pTHX)
-{
- const PADOFFSET offset = pad_findmy_pvs("$_", 0);
- if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
- return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
- }
- else {
- OP * const o = newOP(OP_PADSV, 0);
- o->op_targ = offset;
- return o;
- }
-}
-
void
Perl_newPROG(pTHX_ OP *o)
{
if (o->op_type == OP_LIST) {
OP * const o2
= newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
- o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
+ o = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
}
return o;
}
OP * VOL curop;
OP *newop;
VOL I32 type = o->op_type;
+ bool folded;
SV * VOL sv = NULL;
int ret = 0;
I32 oldscope;
if (ret)
goto nope;
+ folded = cBOOL(o->op_folded);
op_free(o);
assert(sv);
if (type == OP_STRINGIFY) SvPADTMP_off(sv);
else
{
newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
- if (type != OP_STRINGIFY) newop->op_folded = 1;
+ /* OP_STRINGIFY and constant folding are used to implement qq.
+ Here the constant folding is an implementation detail that we
+ want to hide. If the stringify op is itself already marked
+ folded, however, then it is actually a folded join. */
+ if (type != OP_STRINGIFY || folded) newop->op_folded = 1;
}
return newop;
Perl_pp_anonlist(aTHX);
PL_tmps_floor = oldtmps_floor;
- o->op_type = OP_RV2AV;
- o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ CHANGE_TYPE(o, OP_RV2AV);
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
return list(o);
}
-/* convert o (and any siblings) into a list if not already, then
- * convert the parent OP_LIST to type 'type', and CHECKOP() and fold it
- */
-
-OP *
-Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
-{
- dVAR;
- if (type < 0) type = -type, flags |= OPf_SPECIAL;
- if (!o || o->op_type != OP_LIST)
- o = force_list(o, 0);
- else
- o->op_flags &= ~OPf_WANT;
-
- if (!(PL_opargs[type] & OA_MARK))
- op_null(cLISTOPo->op_first);
- else {
- OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
- if (kid2 && kid2->op_type == OP_COREARGS) {
- op_null(cLISTOPo->op_first);
- kid2->op_private |= OPpCOREARGS_PUSHMARK;
- }
- }
-
- o->op_type = (OPCODE)type;
- o->op_ppaddr = PL_ppaddr[type];
- o->op_flags |= flags;
-
- o = CHECKOP(type, o);
- if (o->op_type != (unsigned)type)
- return o;
-
- return fold_constants(op_integerize(op_std_init(o)));
-}
-
/*
=head1 Optree Manipulation Functions
*/
return newLISTOP(type, 0, first, last);
}
+/*
+=for apidoc Am|OP *|op_convert_list|I32 type|I32 flags|OP *o
+
+Converts I<o> into a list op if it is not one already, and then converts it
+into the specified I<type>, calling its check function, allocating a target if
+it needs one, and folding constants.
+
+A list-type op is usually constructed one kid at a time via C<newLISTOP>,
+C<op_prepend_elem> and C<op_append_elem>. Then finally it is passed to
+C<op_convert> to make it the right type.
+
+=cut
+*/
+
+OP *
+Perl_op_convert_list(pTHX_ I32 type, I32 flags, OP *o)
+{
+ dVAR;
+ if (type < 0) type = -type, flags |= OPf_SPECIAL;
+ if (!o || o->op_type != OP_LIST)
+ o = force_list(o, 0);
+ else
+ o->op_flags &= ~OPf_WANT;
+
+ if (!(PL_opargs[type] & OA_MARK))
+ op_null(cLISTOPo->op_first);
+ else {
+ OP * const kid2 = OP_SIBLING(cLISTOPo->op_first);
+ if (kid2 && kid2->op_type == OP_COREARGS) {
+ op_null(cLISTOPo->op_first);
+ kid2->op_private |= OPpCOREARGS_PUSHMARK;
+ }
+ }
+
+ CHANGE_TYPE(o, type);
+ o->op_flags |= flags;
+
+ o = CHECKOP(type, o);
+ if (o->op_type != (unsigned)type)
+ return o;
+
+ return fold_constants(op_integerize(op_std_init(o)));
+}
+
/* Constructors */
NewOp(1101, listop, 1, LISTOP);
- listop->op_type = (OPCODE)type;
- listop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(listop, type);
if (first || last)
flags |= OPf_KIDS;
listop->op_flags = (U8)flags;
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, o, 1, OP);
- o->op_type = (OPCODE)type;
- o->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(o, type);
o->op_flags = (U8)flags;
o->op_next = o;
first = force_list(first, 1);
NewOp(1101, unop, 1, UNOP);
- unop->op_type = (OPCODE)type;
- unop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(unop, type);
unop->op_first = first;
unop->op_flags = (U8)(flags | OPf_KIDS);
unop->op_private = (U8)(1 | (flags >> 8));
=for apidoc Am|OP *|newMETHOP|I32 type|I32 flags|OP *first
Constructs, checks, and returns an op of method type with a method name
-evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
+evaluated at runtime. I<type> is the opcode. I<flags> gives the eight
bits of C<op_flags>, except that C<OPf_KIDS> will be set automatically,
and, shifted up eight bits, the eight bits of C<op_private>, except that
-the bit with value 1 is automatically set. I<dynamic_meth> supplies an
+the bit with value 1 is automatically set. I<dynamic_meth> supplies an
op which evaluates method name; it is consumed by this function and
become part of the constructed op tree.
Supported optypes: OP_METHOD.
methop->op_next = (OP*)methop;
}
- methop->op_type = (OPCODE)type;
- methop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(methop, type);
methop = (METHOP*) CHECKOP(type, methop);
if (methop->op_next) return (OP*)methop;
=for apidoc Am|OP *|newMETHOP_named|I32 type|I32 flags|SV *const_meth
Constructs, checks, and returns an op of method type with a constant
-method name. I<type> is the opcode. I<flags> gives the eight bits of
+method name. I<type> is the opcode. I<flags> gives the eight bits of
C<op_flags>, and, shifted up eight bits, the eight bits of
-C<op_private>. I<const_meth> supplies a constant method name;
+C<op_private>. I<const_meth> supplies a constant method name;
it must be a shared COW string.
Supported optypes: OP_METHOD_NAMED.
if (!first)
first = newOP(OP_NULL, 0);
- binop->op_type = (OPCODE)type;
- binop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(binop, type);
binop->op_first = first;
binop->op_flags = (U8)(flags | OPf_KIDS);
if (!last) {
UV tfirst = 1;
UV tlast = 0;
IV tdiff;
+ STRLEN tcount = 0;
UV rfirst = 1;
UV rlast = 0;
IV rdiff;
+ STRLEN rcount = 0;
IV diff;
I32 none = 0;
U32 max = 0;
/* now see which range will peter our first, if either. */
tdiff = tlast - tfirst;
rdiff = rlast - rfirst;
+ tcount += tdiff + 1;
+ rcount += rdiff + 1;
if (tdiff <= rdiff)
diff = tdiff;
(void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
newSVuv((UV)final), 0);
- if (grows)
- o->op_private |= OPpTRANS_GROWS;
-
Safefree(tsave);
Safefree(rsave);
- op_free(expr);
- op_free(repl);
- return o;
+ tlen = tcount;
+ rlen = rcount;
+ if (r < rend)
+ rlen++;
+ else if (rlast == 0xffffffff)
+ rlen = 0;
+
+ goto warnins;
}
tbl = (short*)PerlMemShared_calloc(
}
}
+ warnins:
if(del && rlen == tlen) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
} else if(rlen > tlen && !complement) {
assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
NewOp(1101, pmop, 1, PMOP);
- pmop->op_type = (OPCODE)type;
- pmop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(pmop, type);
pmop->op_flags = (U8)flags;
pmop->op_private = (U8)(0 | (flags >> 8));
}
#endif
- return CHECKOP(type, pmop);
+ 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
* ------ -------------------
* pushmark (for regcomp)
* pushmark (for entersub)
- * pushmark (for refgen)
* anoncode
- * refgen
+ * srefgen
* entersub
* regcreset regcreset
* pushmark pushmark
}
rcop = S_alloc_LOGOP(aTHX_ OP_REGCOMP, scalar(expr), o);
- rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
| (reglist ? OPf_STACKED : 0);
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) {
}
else {
rcop = S_alloc_LOGOP(aTHX_ OP_SUBSTCONT, scalar(repl), o);
- rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
rcop->op_private = 1;
/* establish postfix order */
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
NewOp(1101, svop, 1, SVOP);
- svop->op_type = (OPCODE)type;
- svop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(svop, type);
svop->op_sv = sv;
svop->op_next = (OP*)svop;
svop->op_flags = (U8)flags;
return CHECKOP(type, svop);
}
+/*
+=for apidoc Am|OP *|newDEFSVOP|
+
+Constructs and returns an op to access C<$_>, either as a lexical
+variable (if declared as C<my $_>) in the current scope, or the
+global C<$_>.
+
+=cut
+*/
+
+OP *
+Perl_newDEFSVOP(pTHX)
+{
+ const PADOFFSET offset = pad_findmy_pvs("$_", 0);
+ if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
+ return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+ }
+ else {
+ OP * const o = newOP(OP_PADSV, 0);
+ o->op_targ = offset;
+ return o;
+ }
+}
+
#ifdef USE_ITHREADS
/*
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
NewOp(1101, padop, 1, PADOP);
- padop->op_type = (OPCODE)type;
- padop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(padop, type);
padop->op_padix =
pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
NewOp(1101, pvop, 1, PVOP);
- pvop->op_type = (OPCODE)type;
- pvop->op_ppaddr = PL_ppaddr[type];
+ CHANGE_TYPE(pvop, type);
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
pvop->op_flags = (U8)flags;
/* Fake up a method call to VERSION */
meth = newSVpvs_share("VERSION");
- veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
+ veop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, pack, list(version)),
+ op_prepend_elem(OP_LIST, pack, version),
newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
}
}
/* Fake up a method call to import/unimport */
meth = aver
? newSVpvs_share("import") : newSVpvs_share("unimport");
- imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
+ imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, pack, list(arg)),
- newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
+ op_prepend_elem(OP_LIST, pack, arg),
+ newMETHOP_named(OP_METHOD_NAMED, 0, meth)
+ ));
}
/* Fake up the BEGIN {}, which does its thing immediately. */
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 */
}
/*
OP *curop;
for (curop = cUNOPo->op_first; curop; curop = OP_SIBLING(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
- if (curop->op_type == OP_GV || curop->op_type == OP_GVSV) {
+ if (curop->op_type == OP_GV || curop->op_type == OP_GVSV
+ || curop->op_type == OP_AELEMFAST) {
GV *gv = cGVOPx_gv(curop);
if (gv == PL_defgv
|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
+ curop->op_type == OP_AELEMFAST_LEX ||
curop->op_type == OP_PADANY)
{
padcheck:
else
return TRUE;
}
+ else if (PL_opargs[curop->op_type] & OA_TARGLEX
+ && curop->op_private & OPpTARGET_MY)
+ goto padcheck;
if (curop->op_flags & OPf_KIDS) {
if (aassign_common_vars(curop))
if ((curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY)
+ curop->op_type == OP_AELEMFAST_LEX ||
+ curop->op_type == OP_PADANY ||
+ ( PL_opargs[curop->op_type] & OA_TARGLEX
+ && curop->op_private & OPpTARGET_MY ))
&& PAD_COMPNAME_GEN(curop->op_targ) == PERL_INT_MAX)
return TRUE;
lop->op_type == OP_PADHV ||
lop->op_type == OP_PADANY) {
if (!(lop->op_private & OPpLVAL_INTRO))
- {
maybe_common_vars = TRUE;
- break;
- }
if (lop->op_private & OPpPAD_STATE) {
if (left->op_private & OPpLVAL_INTRO) {
} else {
/* Other ops in the list. */
maybe_common_vars = TRUE;
- break;
}
lop = OP_SIBLING(lop);
}
if (right && right->op_type == OP_SPLIT
&& !(right->op_flags & OPf_STACKED)) {
OP* tmpop = ((LISTOP*)right)->op_first;
- if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
- PMOP * const pm = (PMOP*)tmpop;
- if (
+ PMOP * const pm = (PMOP*)tmpop;
+ assert (tmpop && (tmpop->op_type == OP_PUSHRE));
+ if (
#ifdef USE_ITHREADS
!pm->op_pmreplrootu.op_pmtargetoff
#else
}
}
}
- }
}
}
return o;
NewOp(1101, cop, 1, COP);
if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
- cop->op_type = OP_DBSTATE;
- cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
+ CHANGE_TYPE(cop, OP_DBSTATE);
}
else {
- cop->op_type = OP_NEXTSTATE;
- cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
+ CHANGE_TYPE(cop, OP_NEXTSTATE);
}
cop->op_flags = (U8)flags;
CopHINTS_set(cop, PL_hints);
-#ifdef NATIVE_HINTS
- cop->op_private |= NATIVE_HINTS;
-#endif
#ifdef VMS
if (VMSISH_HUSHED) cop->op_private |= OPpHUSH_VMSISH;
#endif
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
logop = S_alloc_LOGOP(aTHX_ type, first, LINKLIST(other));
- logop->op_ppaddr = PL_ppaddr[type];
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
return live;
}
logop = S_alloc_LOGOP(aTHX_ OP_COND_EXPR, first, LINKLIST(trueop));
- logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
logop->op_flags |= (U8)flags;
logop->op_private = (U8)(1 | (flags >> 8));
logop->op_next = LINKLIST(falseop);
PERL_ARGS_ASSERT_NEWRANGE;
range = S_alloc_LOGOP(aTHX_ OP_RANGE, left, LINKLIST(right));
- range->op_ppaddr = PL_ppaddr[OP_RANGE];
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_private = (U8)(1 | (flags >> 8));
left->op_next = flip;
right->op_next = flop;
- range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);
+ range->op_targ =
+ pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);
sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
- flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);;
+ flip->op_targ =
+ pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK|padadd_STATE, 0, 0);;
sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
SvPADTMP_on(PAD_SV(flip->op_targ));
if (!loop) {
NewOp(1101,loop,1,LOOP);
- loop->op_type = OP_ENTERLOOP;
- loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
+ CHANGE_TYPE(loop, OP_ENTERLOOP);
loop->op_private = 0;
loop->op_next = (OP*)loop;
}
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
- sv->op_type = OP_RV2GV;
- sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
+ CHANGE_TYPE(sv, OP_RV2GV);
/* The op_type check is needed to prevent a possible segfault
* if the loop variable is undeclared and 'strict vars' is in
expr = op_lvalue(force_list(expr, 1), OP_GREPSTART);
}
- loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
+ loop = (LOOP*)list(op_convert_list(OP_ENTERITER, iterflags,
op_append_elem(OP_LIST, expr, scalar(sv))));
assert(!loop->op_next);
/* for my $x () sets OPpLVAL_INTRO;
PERL_ARGS_ASSERT_NEWGIVWHENOP;
enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL);
- enterop->op_ppaddr = PL_ppaddr[enter_opcode];
enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
enterop->op_private = 0;
}
/* 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
PERL_ARGS_ASSERT_NEWMYSUB;
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);
CvXSUB(cv) = const_sv_xsub;
CvCONST_on(cv);
CvISXSUB_on(cv);
+ PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(compcv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
CvFLAGS(compcv) | preserved_flags;
CvOUTSIDE(cv) = CvOUTSIDE(compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
- CvPADLIST(cv) = CvPADLIST(compcv);
+ CvPADLIST_set(cv, CvPADLIST(compcv));
CvOUTSIDE(compcv) = temp_cv;
- CvPADLIST(compcv) = temp_padl;
+ CvPADLIST_set(compcv, temp_padl);
CvSTART(cv) = CvSTART(compcv);
CvSTART(compcv) = cvstart;
CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
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
itself has a refcount. */
CvSLABBED_off(cv);
OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+#ifdef PERL_DEBUG_READONLY_OPS
+ slab = (OPSLAB *)CvSTART(cv);
+#endif
+ 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>. */
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
+#ifdef PERL_DEBUG_READONLY_OPS
+ if (slab)
+ Slab_to_ro(slab);
+#endif
if (o) op_free(o);
return cv;
}
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);
CvXSUB(cv) = const_sv_xsub;
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)) {
| CvNAMED(cv);
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
- CvPADLIST(cv) = CvPADLIST(PL_compcv);
+ CvPADLIST_set(cv,CvPADLIST(PL_compcv));
CvOUTSIDE(PL_compcv) = temp_cv;
- CvPADLIST(PL_compcv) = temp_av;
+ CvPADLIST_set(PL_compcv, temp_av);
CvSTART(cv) = CvSTART(PL_compcv);
CvSTART(PL_compcv) = cvstart;
CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
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>. */
LEAVE_SCOPE(floor);
#ifdef PERL_DEBUG_READONLY_OPS
/* Watch out for BEGIN blocks */
- if (!special) Slab_to_ro(slab);
+ if (!special && slab)
+ Slab_to_ro(slab);
#endif
return cv;
}
return cv;
}
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
+static storage, as it is used directly as CvFILE(), without a copy being made.
+
+=cut
+*/
+
+CV *
+Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
+{
+ PERL_ARGS_ASSERT_NEWXS;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
+ );
+}
+
CV *
Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
const char *const filename, const char *const proto,
}
CV *
+Perl_newXS_deffile(pTHX_ const char *name, XSUBADDR_t subaddr)
+{
+ PERL_ARGS_ASSERT_NEWXS_DEFFILE;
+ return newXS_len_flags(
+ name, name ? strlen(name) : 0, subaddr, NULL, NULL, NULL, 0
+ );
+}
+
+CV *
Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
XSUBADDR_t subaddr, const char *const filename,
const char *const proto, SV **const_svp,
bool interleave = FALSE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
-
+ if (!subaddr)
+ Perl_croak_nocontext("panic: no address for '%s' in '%s'",
+ name, filename ? filename : PL_xsubfilename);
{
GV * const gv = gv_fetchpvn(
name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
name ? len : PL_curstash ? sizeof("__ANON__") - 1:
sizeof("__ANON__::__ANON__") - 1,
GV_ADDMULTI | flags, SVt_PVCV);
-
- if (!subaddr)
- Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
+
if ((cv = (name ? GvCV(gv) : NULL))) {
if (GvCVGEN(gv)) {
/* just a cached method */
gv_method_changed(gv); /* newXS */
}
}
- if (!name)
- CvANON_on(cv);
+
CvGV_set(cv, gv);
- (void)gv_fetchfile(filename);
- CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
- an external constant string */
- assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if(filename) {
+ (void)gv_fetchfile(filename);
+ assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+ if (flags & XS_DYNAMIC_FILENAME) {
+ CvDYNFILE_on(cv);
+ CvFILE(cv) = savepv(filename);
+ } else {
+ /* NOTE: not copied, as it is expected to be an external constant string */
+ CvFILE(cv) = (char *)filename;
+ }
+ } else {
+ assert((flags & XS_DYNAMIC_FILENAME) == 0 && PL_xsubfilename);
+ CvFILE(cv) = (char*)PL_xsubfilename;
+ }
CvISXSUB_on(cv);
CvXSUB(cv) = subaddr;
-
+#ifndef PERL_IMPLICIT_CONTEXT
+ CvHSCXT(cv) = &PL_stack_sp;
+#else
+ PoisonPADLIST(cv);
+#endif
+
if (name)
process_special_blocks(0, name, gv, cv);
- }
+ else
+ CvANON_on(cv);
+ } /* <- not a conditional branch */
+
- if (flags & XS_DYNAMIC_FILENAME) {
- CvFILE(cv) = savepv(filename);
- CvDYNFILE_on(cv);
- }
sv_setpv(MUTABLE_SV(cv), proto);
if (interleave) LEAVE;
return cv;
return cv;
}
-/*
-=for apidoc U||newXS
-
-Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
-static storage, as it is used directly as CvFILE(), without a copy being made.
-
-=cut
-*/
-
-CV *
-Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
-{
- PERL_ARGS_ASSERT_NEWXS;
- return newXS_len_flags(
- name, name ? strlen(name) : 0, subaddr, filename, NULL, NULL, 0
- );
-}
-
void
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
OP *
Perl_newANONLIST(pTHX_ OP *o)
{
- return convert(OP_ANONLIST, OPf_SPECIAL, o);
+ return op_convert_list(OP_ANONLIST, OPf_SPECIAL, o);
}
OP *
Perl_newANONHASH(pTHX_ OP *o)
{
- return convert(OP_ANONHASH, OPf_SPECIAL, o);
+ return op_convert_list(OP_ANONHASH, OPf_SPECIAL, o);
}
OP *
switch (o->op_type) {
case OP_PADSV:
case OP_PADHV:
- o->op_type = OP_PADAV;
- o->op_ppaddr = PL_ppaddr[OP_PADAV];
+ CHANGE_TYPE(o, OP_PADAV);
return ref(o, OP_RV2AV);
case OP_RV2SV:
case OP_RV2HV:
- o->op_type = OP_RV2AV;
- o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ CHANGE_TYPE(o, OP_RV2AV);
ref(o, OP_RV2AV);
break;
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
- o->op_type = OP_PADHV;
- o->op_ppaddr = PL_ppaddr[OP_PADHV];
+ CHANGE_TYPE(o, OP_PADHV);
return ref(o, OP_RV2HV);
case OP_RV2SV:
case OP_RV2AV:
- o->op_type = OP_RV2HV;
- o->op_ppaddr = PL_ppaddr[OP_RV2HV];
+ CHANGE_TYPE(o, OP_RV2HV);
ref(o, OP_RV2HV);
break;
PERL_ARGS_ASSERT_NEWAVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADAV;
- o->op_ppaddr = PL_ppaddr[OP_PADAV];
+ CHANGE_TYPE(o, OP_PADAV);
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
PERL_ARGS_ASSERT_NEWHVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADHV;
- o->op_ppaddr = PL_ppaddr[OP_PADHV];
+ CHANGE_TYPE(o, OP_PADHV);
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
{
if (o->op_type == OP_PADANY) {
dVAR;
- o->op_type = OP_PADCV;
- o->op_ppaddr = PL_ppaddr[OP_PADCV];
+ CHANGE_TYPE(o, OP_PADCV);
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
PERL_ARGS_ASSERT_NEWSVREF;
if (o->op_type == OP_PADANY) {
- o->op_type = OP_PADSV;
- o->op_ppaddr = PL_ppaddr[OP_PADSV];
+ CHANGE_TYPE(o, OP_PADSV);
return o;
}
return newUNOP(OP_RV2SV, 0, scalar(o));
op_free(o);
enter = S_alloc_LOGOP(aTHX_ OP_ENTERTRY, NULL, NULL);
- enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
/* establish postfix order */
enter->op_next = (OP*)enter;
o = op_prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
- o->op_type = OP_LEAVETRY;
- o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
+ CHANGE_TYPE(o, OP_LEAVETRY);
enter->op_other = o;
return o;
}
else {
scalar((OP*)kid);
- PL_cv_has_eval = 1;
+ S_set_haseval(aTHX);
}
}
else {
&& SvTYPE(SvRV(gv)) != SVt_PVCV)
gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV);
}
- kid->op_type = OP_GV;
+ CHANGE_TYPE(kid, OP_GV);
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
kid->op_sv = SvREFCNT_inc_simple_NN(gv);
#endif
kid->op_private = 0;
- kid->op_ppaddr = PL_ppaddr[OP_GV];
/* FAKE globs in the symbol table cause weird bugs (#77810) */
SvFAKE_off(gv);
}
PERL_ARGS_ASSERT_CK_GREP;
- o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
/* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
if (o->op_flags & OPf_STACKED) {
kid = kUNOP->op_first;
gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid));
- gwop->op_ppaddr = PL_ppaddr[type];
kid->op_next = (OP*)gwop;
offset = pad_findmy_pvs("$_", 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
/* Implicitly take a reference to a regular expression */
if (first->op_type == OP_MATCH) {
- first->op_type = OP_QR;
- first->op_ppaddr = PL_ppaddr[OP_QR];
+ CHANGE_TYPE(first, OP_QR);
}
if (second->op_type == OP_MATCH) {
- second->op_type = OP_QR;
- second->op_ppaddr = PL_ppaddr[OP_QR];
+ CHANGE_TYPE(second, OP_QR);
}
}
}
-OP *
-Perl_ck_sassign(pTHX_ OP *o)
+static OP *
+S_maybe_targlex(pTHX_ OP *o)
{
dVAR;
OP * const kid = cLISTOPo->op_first;
-
- PERL_ARGS_ASSERT_CK_SASSIGN;
-
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
&& !(kid->op_flags & OPf_STACKED)
/* Can just relocate the target. */
if (kkid && kkid->op_type == OP_PADSV
- && !(kkid->op_private & OPpLVAL_INTRO))
+ && (!(kkid->op_private & OPpLVAL_INTRO)
+ || kkid->op_private & OPpPAD_STATE))
{
kid->op_targ = kkid->op_targ;
kkid->op_targ = 0;
/* Now we do not need PADSV and SASSIGN.
- * first replace the PADSV with OP_SIBLING(o), then
- * detach kid and OP_SIBLING(o) from o */
- op_sibling_splice(o, kid, 1, OP_SIBLING(o));
- op_sibling_splice(o, NULL, -1, NULL);
+ * Detach kid and free the rest. */
+ op_sibling_splice(o, NULL, 1, NULL);
op_free(o);
- op_free(kkid);
kid->op_private |= OPpTARGET_MY; /* Used for context settings */
return kid;
}
}
+ return o;
+}
+
+OP *
+Perl_ck_sassign(pTHX_ OP *o)
+{
+ dVAR;
+ OP * const kid = cLISTOPo->op_first;
+
+ PERL_ARGS_ASSERT_CK_SASSIGN;
+
if (OP_HAS_SIBLING(kid)) {
OP *kkid = OP_SIBLING(kid);
- /* For state variable assignment, kkid is a list op whose op_last
- is a padsv. */
+ /* For state variable assignment with attributes, kkid is a list op
+ whose op_last is a padsv. */
if ((kkid->op_type == OP_PADSV ||
(OP_TYPE_IS_OR_WAS(kkid, OP_LIST) &&
(kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
)
)
- && (kkid->op_private & OPpLVAL_INTRO)
- && SvPAD_STATE(PAD_COMPNAME_SV(kkid->op_targ))) {
+ && (kkid->op_private & (OPpLVAL_INTRO|OPpPAD_STATE))
+ == (OPpLVAL_INTRO|OPpPAD_STATE)) {
const PADOFFSET target = kkid->op_targ;
OP *const other = newOP(OP_PADSV,
kkid->op_flags
| ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
OP *const first = newOP(OP_NULL, 0);
- OP *const nullop = newCONDOP(0, first, o, other);
+ OP *const nullop =
+ newCONDOP(0, first, S_maybe_targlex(aTHX_ o), other);
OP *const condop = first->op_next;
- condop->op_type = OP_ONCE;
- condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+ CHANGE_TYPE(condop, OP_ONCE);
other->op_targ = target;
/* Store the initializedness of state vars in a separate
return nullop;
}
}
- return o;
+ return S_maybe_targlex(aTHX_ o);
}
OP *
{
OP * const right = cLISTOPo->op_first;
OP * const left = OP_SIBLING(right);
- OP * const varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
+ OP *varop = cUNOPx(cUNOPx(left)->op_first)->op_first;
bool stacked = 0;
PERL_ARGS_ASSERT_CK_REFASSIGN;
assert (left);
assert (left->op_type == OP_SREFGEN);
+ o->op_private = varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
+
switch (varop->op_type) {
case OP_PADAV:
- o->op_private = OPpLVREF_AV;
+ o->op_private |= OPpLVREF_AV;
goto settarg;
case OP_PADHV:
- o->op_private = OPpLVREF_HV;
+ o->op_private |= OPpLVREF_HV;
case OP_PADSV:
settarg:
o->op_targ = varop->op_targ;
PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
break;
case OP_RV2AV:
- o->op_private = OPpLVREF_AV;
+ o->op_private |= OPpLVREF_AV;
goto checkgv;
case OP_RV2HV:
- o->op_private = OPpLVREF_HV;
+ o->op_private |= OPpLVREF_HV;
case OP_RV2SV:
checkgv:
if (cUNOPx(varop)->op_first->op_type != OP_GV) goto bad;
- goto null_and_stack;
+ detach_and_stack:
+ /* Point varop to its GV kid, detached. */
+ varop = op_sibling_splice(varop, NULL, -1, NULL);
+ stacked = TRUE;
+ break;
case OP_RV2CV: {
- OP * const kid =
- cUNOPx(cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling)
- ->op_first;
- o->op_private = OPpLVREF_CV;
- if (kid->op_type == OP_GV) goto null_and_stack;
+ OP * const kidparent =
+ cUNOPx(cUNOPx(varop)->op_first)->op_first->op_sibling;
+ OP * const kid = cUNOPx(kidparent)->op_first;
+ o->op_private |= OPpLVREF_CV;
+ if (kid->op_type == OP_GV) {
+ varop = kidparent;
+ goto detach_and_stack;
+ }
if (kid->op_type != OP_PADCV) goto bad;
o->op_targ = kid->op_targ;
kid->op_targ = 0;
}
case OP_AELEM:
case OP_HELEM:
- o->op_private = OPpLVREF_ELEM;
- null_and_stack:
+ o->op_private |= OPpLVREF_ELEM;
op_null(varop);
- op_null(left);
stacked = TRUE;
+ /* Detach varop. */
+ op_sibling_splice(cUNOPx(left)->op_first, NULL, -1, NULL);
break;
default:
bad:
- /* diag_listed_as: Can't modify %s in %s */
+ /* diag_listed_as: Can't modify reference to %s in %s assignment */
yyerror(Perl_form(aTHX_ "Can't modify reference to %s in scalar "
"assignment",
OP_DESC(varop)));
return o;
}
- if (!FEATURE_LVREF_IS_ENABLED)
+ if (!FEATURE_REFALIASING_IS_ENABLED)
Perl_croak(aTHX_
- "Experimental lvalue references not enabled");
+ "Experimental aliasing via reference not enabled");
Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__LVALUE_REFS),
- "Lvalue references are experimental");
- o->op_private |= varop->op_private & (OPpLVAL_INTRO|OPpPAD_STATE);
- if (stacked) o->op_flags |= OPf_STACKED;
+ packWARN(WARN_EXPERIMENTAL__REFALIASING),
+ "Aliasing via reference is experimental");
+ if (stacked) {
+ o->op_flags |= OPf_STACKED;
+ op_sibling_splice(o, right, 1, varop);
+ }
else {
o->op_flags &=~ OPf_STACKED;
op_sibling_splice(o, right, 1, NULL);
- op_free(left);
}
+ op_free(left);
return o;
}
if (cBINOPo->op_first->op_flags & OPf_PARENS) {
OP* kids;
o->op_private |= OPpREPEAT_DOLIST;
- kids = op_sibling_splice(o, NULL, -1, NULL); /* detach all kids */
- kids = force_list(kids, 1); /* promote them to a list */
+ kids = op_sibling_splice(o, NULL, 1, NULL); /* detach first kid */
+ kids = force_list(kids, 1); /* promote it to a list */
op_sibling_splice(o, NULL, 0, kids); /* and add back */
- if (cBINOPo->op_last == kids) cBINOPo->op_last = NULL;
}
else
scalar(o);
if (o->op_flags & OPf_KIDS) {
kid = OP_SIBLING(cLISTOPo->op_first); /* get past pushmark */
if (kid && OP_HAS_SIBLING(kid)) {
- o->op_type = OP_SSELECT;
- o->op_ppaddr = PL_ppaddr[OP_SSELECT];
+ CHANGE_TYPE(o, OP_SSELECT);
o = ck_fun(o);
return fold_constants(op_integerize(op_std_init(o)));
}
kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0);
op_sibling_splice(o, NULL, 0, kid);
}
-
- kid->op_type = OP_PUSHRE;
- kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
+ CHANGE_TYPE(kid, OP_PUSHRE);
scalar(kid);
if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
}
OP *
+Perl_ck_stringify(pTHX_ OP *o)
+{
+ OP * const kid = OP_SIBLING(cUNOPo->op_first);
+ PERL_ARGS_ASSERT_CK_STRINGIFY;
+ if (kid->op_type == OP_JOIN || kid->op_type == OP_QUOTEMETA
+ || kid->op_type == OP_LC || kid->op_type == OP_LCFIRST
+ || kid->op_type == OP_UC || kid->op_type == OP_UCFIRST)
+ {
+ assert(!OP_HAS_SIBLING(kid));
+ op_sibling_splice(o, cUNOPo->op_first, -1, NULL);
+ op_free(o);
+ return kid;
+ }
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_join(pTHX_ OP *o)
{
- const OP * const kid = OP_SIBLING(cLISTOPo->op_first);
+ OP * const kid = OP_SIBLING(cLISTOPo->op_first);
PERL_ARGS_ASSERT_CK_JOIN;
SVfARG(msg), SVfARG(msg));
}
}
+ if (kid
+ && (kid->op_type == OP_CONST /* an innocent, unsuspicious separator */
+ || (kid->op_type == OP_PADSV && !(kid->op_private & OPpLVAL_INTRO))
+ || ( kid->op_type==OP_RV2SV && kUNOP->op_first->op_type == OP_GV
+ && !(kid->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))))
+ {
+ const OP * const bairn = OP_SIBLING(kid); /* the list */
+ if (bairn && !OP_HAS_SIBLING(bairn) /* single-item list */
+ && PL_opargs[bairn->op_type] & OA_RETSCALAR)
+ {
+ OP * const ret = op_convert_list(OP_STRINGIFY, 0,
+ op_sibling_splice(o, kid, 1, NULL));
+ op_free(o);
+ ret->op_folded = 1;
+ return ret;
+ }
+ }
+
return ck_fun(o);
}
? newPVOP(OP_RUNCV,0,NULL)
: newOP(opnum,0);
default:
- return convert(opnum,0,aop);
+ return op_convert_list(opnum,0,aop);
}
}
assert(0);
#define IS_OR_OP(o) (o->op_type == OP_OR)
-STATIC void
-S_null_listop_in_list_context(pTHX_ OP *o)
-{
- OP *kid;
-
- PERL_ARGS_ASSERT_NULL_LISTOP_IN_LIST_CONTEXT;
-
- /* This is an OP_LIST in list context. That means we
- * can ditch the OP_LIST and the OP_PUSHMARK within. */
-
- kid = cLISTOPo->op_first;
- /* Find the end of the chain of OPs executed within the OP_LIST. */
- while (kid->op_next != o)
- kid = kid->op_next;
-
- kid->op_next = o->op_next; /* patch list out of exec chain */
- op_null(cUNOPo->op_first); /* NULL the pushmark */
- op_null(o); /* NULL the list */
-}
-
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
break;
}
+ redo:
/* By default, this op has now been optimised. A couple of cases below
clear this again. */
o->op_opt = 1;
PL_op = o;
- /* The following will have the OP_LIST and OP_PUSHMARK
- * patched out later IF the OP_LIST is in list context.
- * So in that case, we can set the this OP's op_next
- * to skip to after the OP_PUSHMARK:
- * a THIS -> b
- * d list -> e
- * b pushmark -> c
- * c whatever -> d
- * e whatever
- * will eventually become:
- * a THIS -> c
- * - ex-list -> -
- * - ex-pushmark -> -
- * c whatever -> e
- * e whatever
- */
- {
- OP *sibling;
- OP *other_pushmark;
- if (OP_TYPE_IS(o->op_next, OP_PUSHMARK)
- && (sibling = OP_SIBLING(o))
- && sibling->op_type == OP_LIST
- /* This KIDS check is likely superfluous since OP_LIST
- * would otherwise be an OP_STUB. */
- && sibling->op_flags & OPf_KIDS
- && (sibling->op_flags & OPf_WANT) == OPf_WANT_LIST
- && (other_pushmark = cLISTOPx(sibling)->op_first)
- /* Pointer equality also effectively checks that it's a
- * pushmark. */
- && other_pushmark == o->op_next)
- {
- o->op_next = other_pushmark->op_next;
- null_listop_in_list_context(sibling);
- }
- }
-
switch (o->op_type) {
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
if ( OP_TYPE_IS(next, OP_PUSHMARK)
&& OP_TYPE_IS(sibling, OP_RETURN)
&& OP_TYPE_IS(sibling->op_next, OP_LINESEQ)
- && OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ && ( OP_TYPE_IS(sibling->op_next->op_next, OP_LEAVESUB)
+ ||OP_TYPE_IS(sibling->op_next->op_next,
+ OP_LEAVESUBLV))
&& cUNOPx(sibling)->op_first == next
&& OP_HAS_SIBLING(next) && OP_SIBLING(next)->op_next
&& next->op_next
nextop = nextop->op_next;
if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
- COP *firstcop = (COP *)o;
- COP *secondcop = (COP *)nextop;
- /* We want the COP pointed to by o (and anything else) to
- become the next COP down the line. */
- cop_free(firstcop);
-
- firstcop->op_next = secondcop->op_next;
-
- /* Now steal all its pointers, and duplicate the other
- data. */
- firstcop->cop_line = secondcop->cop_line;
-#ifdef USE_ITHREADS
- firstcop->cop_stashoff = secondcop->cop_stashoff;
- firstcop->cop_file = secondcop->cop_file;
-#else
- firstcop->cop_stash = secondcop->cop_stash;
- firstcop->cop_filegv = secondcop->cop_filegv;
-#endif
- firstcop->cop_hints = secondcop->cop_hints;
- firstcop->cop_seq = secondcop->cop_seq;
- firstcop->cop_warnings = secondcop->cop_warnings;
- firstcop->cop_hints_hash = secondcop->cop_hints_hash;
-
-#ifdef USE_ITHREADS
- secondcop->cop_stashoff = 0;
- secondcop->cop_file = NULL;
-#else
- secondcop->cop_stash = NULL;
- secondcop->cop_filegv = NULL;
-#endif
- secondcop->cop_warnings = NULL;
- secondcop->cop_hints_hash = NULL;
-
- /* If we use op_null(), and hence leave an ex-COP, some
- warnings are misreported. For example, the compile-time
- error in 'use strict; no strict refs;' */
- secondcop->op_type = OP_NULL;
- secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
+ op_null(o);
+ if (oldop)
+ oldop->op_next = nextop;
+ /* Skip (old)oldop assignment since the current oldop's
+ op_next already points to the next op. */
+ continue;
}
}
break;
case OP_PUSHMARK:
+ /* Given
+ 5 repeat/DOLIST
+ 3 ex-list
+ 1 pushmark
+ 2 scalar or const
+ 4 const[0]
+ convert repeat into a stub with no kids.
+ */
+ if (o->op_next->op_type == OP_CONST
+ || ( o->op_next->op_type == OP_PADSV
+ && !(o->op_next->op_private & OPpLVAL_INTRO))
+ || ( o->op_next->op_type == OP_GV
+ && o->op_next->op_next->op_type == OP_RV2SV
+ && !(o->op_next->op_next->op_private
+ & (OPpLVAL_INTRO|OPpOUR_INTRO))))
+ {
+ const OP *kid = o->op_next->op_next;
+ if (o->op_next->op_type == OP_GV)
+ kid = kid->op_next;
+ /* kid is now the ex-list. */
+ if (kid->op_type == OP_NULL
+ && (kid = kid->op_next)->op_type == OP_CONST
+ /* kid is now the repeat count. */
+ && kid->op_next->op_type == OP_REPEAT
+ && kid->op_next->op_private & OPpREPEAT_DOLIST
+ && (kid->op_next->op_flags & OPf_WANT) == OPf_WANT_LIST
+ && SvIOK(kSVOP_sv) && SvIVX(kSVOP_sv) == 0)
+ {
+ o = kid->op_next; /* repeat */
+ assert(oldop);
+ oldop->op_next = o;
+ op_free(cBINOPo->op_first);
+ op_free(cBINOPo->op_last );
+ o->op_flags &=~ OPf_KIDS;
+ /* stub is a baseop; repeat is a binop */
+ assert(sizeof(OP) <= sizeof(BINOP));
+ CHANGE_TYPE(o, OP_STUB);
+ o->op_private = 0;
+ break;
+ }
+ }
+
/* Convert a series of PAD ops for my vars plus support into a
* single padrange op. Basically
*
/* 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)) && isGV(gv)
- && GvNAMELEN_get(gv) == 1
- && *GvNAME_get(gv) == '_'
- && GvSTASH(gv) == PL_defstash
+ && cGVOPx_gv(p) == PL_defgv
&& (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)
- && OP_SIBLING(o) == rv2av /* these two for Deparse */
- && cUNOPx(rv2av)->op_first == p
) {
q = rv2av->op_next;
if (q->op_type == OP_NULL)
}
}
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 != OP_SIBLING(o))
- break;
p = o;
}
followop = p->op_next;
}
- if (count < 1)
+ if (count < 1 || (count == 1 && !defav))
break;
/* pp_padrange in specifically compile-time void context
* 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).
+ * pushmark, pad*v, ...., list
+ * which has the net effect of of leaving the markstack as it
+ * was. Not pushing on to the stack (whereas padsv does touch
+ * the stack) makes no difference in void context.
*/
assert(followop);
if (gimme == OPf_WANT_VOID) {
- if (OP_TYPE_IS_OR_WAS(followop, OP_LIST)
+ 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 */
* *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];
+ CHANGE_TYPE(o, OP_PADRANGE);
o->op_targ = base;
/* bit 7: INTRO; bit 6..0: count */
o->op_private = (intro | count);
}
case OP_PADAV:
+ case OP_PADSV:
+ case OP_PADHV:
+ /* Skip over state($x) in void context. */
+ if (oldop && o->op_private == (OPpPAD_STATE|OPpLVAL_INTRO)
+ && (o->op_flags & OPf_WANT) == OPf_WANT_VOID)
+ {
+ oldop->op_next = o->op_next;
+ goto redo_nextstate;
+ }
+ if (o->op_type != OP_PADAV)
+ break;
+ /* FALLTHROUGH */
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
OP* const pop = (o->op_type == OP_PADAV) ?
else
o->op_type = OP_AELEMFAST_LEX;
}
- break;
+ if (o->op_type != OP_GV)
+ break;
}
- if (o->op_next->op_type == OP_RV2SV) {
+ /* Remove $foo from the op_next chain in void context. */
+ if (oldop
+ && ( o->op_next->op_type == OP_RV2SV
+ || o->op_next->op_type == OP_RV2AV
+ || o->op_next->op_type == OP_RV2HV )
+ && (o->op_next->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && !(o->op_next->op_private & OPpLVAL_INTRO))
+ {
+ oldop->op_next = o->op_next->op_next;
+ /* Reprocess the previous op if it is a nextstate, to
+ allow double-nextstate optimisation. */
+ redo_nextstate:
+ if (oldop->op_type == OP_NEXTSTATE) {
+ oldop->op_opt = 0;
+ o = oldop;
+ oldop = oldoldop;
+ oldoldop = NULL;
+ goto redo;
+ }
+ o = oldop;
+ }
+ else if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
op_null(o->op_next);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
- o->op_type = OP_GVSV;
- o->op_ppaddr = PL_ppaddr[OP_GVSV];
+ CHANGE_TYPE(o, OP_GVSV);
}
}
else if (o->op_next->op_type == OP_READLINE
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
/* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
- o->op_type = OP_RCATLINE;
+ CHANGE_TYPE(o, OP_RCATLINE);
o->op_flags |= OPf_STACKED;
- o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
op_null(o->op_next->op_next);
op_null(o->op_next);
}
break;
case OP_RUNCV:
- if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
+ && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
+ {
SV *sv;
if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
sv_rvweaken(sv);
SvREADONLY_on(sv);
}
- o->op_type = OP_CONST;
- o->op_ppaddr = PL_ppaddr[OP_CONST];
+ CHANGE_TYPE(o, OP_CONST);
o->op_flags |= OPf_SPECIAL;
cSVOPo->op_sv = sv;
}
break;
case OP_SASSIGN:
- if (OP_GIMME(o,0) == G_VOID) {
+ if (OP_GIMME(o,0) == G_VOID
+ || ( o->op_next->op_type == OP_LINESEQ
+ && ( o->op_next->op_next->op_type == OP_LEAVESUB
+ || ( o->op_next->op_next->op_type == OP_RETURN
+ && !CvLVALUE(PL_compcv)))))
+ {
OP *right = cBINOP->op_first;
if (right) {
/* sassign
/* We do the common-vars check here, rather than in newASSIGNOP
(as formerly), so that all lexical vars that get aliased are
marked as such before we do the check. */
+ /* There can’t be common vars if the lhs is a stub. */
+ if (OP_SIBLING(cLISTOPx(cBINOPo->op_last)->op_first)
+ == cLISTOPx(cBINOPo->op_last)->op_last
+ && cLISTOPx(cBINOPo->op_last)->op_last->op_type == OP_STUB)
+ {
+ o->op_private &=~ OPpASSIGN_COMMON;
+ break;
+ }
if (o->op_private & OPpASSIGN_COMMON) {
/* See the comment before S_aassign_common_vars concerning
PL_generation sorcery. */
}
return o;
default:
- o = convert(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
+ o = op_convert_list(opnum,OPf_SPECIAL*(opnum == OP_GLOB),argop);
if (is_handle_constructor(o, 2))
argop->op_private |= OPpCOREARGS_DEREF2;
if (opnum == OP_SUBSTR) {
https://perl5.git.perl.org / perl5.git / blobdiff