op_free()
*/
+#define dDEFER_OP \
+ SSize_t defer_stack_alloc = 0; \
+ SSize_t defer_ix = -1; \
+ OP **defer_stack = NULL;
+#define DEFER_OP_CLEANUP Safefree(defer_stack)
#define DEFERRED_OP_STEP 100
#define DEFER_OP(o) \
STMT_START { \
} \
defer_stack[++defer_ix] = o; \
} STMT_END
+#define DEFER_REVERSE(count) \
+ STMT_START { \
+ UV cnt = (count); \
+ if (cnt > 1) { \
+ OP **top = defer_stack + defer_ix; \
+ /* top - (cnt) + 1 isn't safe here */ \
+ OP **bottom = top - (cnt - 1); \
+ OP *tmp; \
+ assert(bottom >= defer_stack); \
+ while (top > bottom) { \
+ tmp = *top; \
+ *top-- = *bottom; \
+ *bottom++ = tmp; \
+ } \
+ } \
+ } STMT_END;
#define POP_DEFERRED_OP() (defer_ix >= 0 ? defer_stack[defer_ix--] : (OP *)NULL)
DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", (void*)o, (void*)slab));
gotit:
-#ifdef PERL_OP_PARENT
/* moresib == 0, op_sibling == 0 implies a solitary unattached op */
assert(!o->op_moresib);
assert(!o->op_sibparent);
-#endif
return (void *)o;
}
{
dVAR;
OPCODE type;
- SSize_t defer_ix = -1;
- SSize_t defer_stack_alloc = 0;
- OP **defer_stack = NULL;
+ dDEFER_OP;
do {
PL_op = NULL;
} while ( (o = POP_DEFERRED_OP()) );
- Safefree(defer_stack);
+ DEFER_OP_CLEANUP;
}
/* S_op_clear_gv(): free a GV attached to an OP */
OpMAYBESIB_set(start, insert, NULL);
}
else {
- if (!parent)
- goto no_parent;
+ assert(parent);
cLISTOPx(parent)->op_first = insert;
if (insert)
parent->op_flags |= OPf_KIDS;
Perl_croak_nocontext("panic: op_sibling_splice(): NULL parent");
}
-
-#ifdef PERL_OP_PARENT
-
/*
=for apidoc op_parent
Returns the parent OP of C<o>, if it has a parent. Returns C<NULL> otherwise.
-This function is only available on perls built with C<-DPERL_OP_PARENT>.
=cut
*/
return o->op_sibparent;
}
-#endif
-
-
/* replace the sibling following start with a new UNOP, which becomes
* the parent of the original sibling; e.g.
*
dVAR;
OP *kid;
SV* sv;
- SSize_t defer_stack_alloc = 0;
- SSize_t defer_ix = -1;
- OP **defer_stack = NULL;
OP *o = arg;
+ dDEFER_OP;
PERL_ARGS_ASSERT_SCALARVOID;
}
} while ( (o = POP_DEFERRED_OP()) );
- Safefree(defer_stack);
+ DEFER_OP_CLEANUP;
return arg;
}
STATIC void
S_maybe_multiconcat(pTHX_ OP *o)
{
+ dVAR;
OP *lastkidop; /* the right-most of any kids unshifted onto o */
OP *topop; /* the top-most op in the concat tree (often equals o,
unless there are assign/stringify ops above it */
}
else if ( topop->op_type == OP_CONCAT
&& (topop->op_flags & OPf_STACKED)
- && (cUNOPo->op_first->op_flags & OPf_MOD)
&& (!(topop->op_private & OPpCONCAT_NESTED))
)
{
STATIC void
S_optimize_op(pTHX_ OP* o)
{
- OP *kid;
+ dDEFER_OP;
PERL_ARGS_ASSERT_OPTIMIZE_OP;
- assert(o->op_type != OP_FREED);
+ do {
+ assert(o->op_type != OP_FREED);
- switch (o->op_type) {
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- PL_curcop = ((COP*)o); /* for warnings */
- break;
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+ break;
- case OP_CONCAT:
- case OP_SASSIGN:
- case OP_STRINGIFY:
- case OP_SPRINTF:
- S_maybe_multiconcat(aTHX_ o);
- break;
+ case OP_CONCAT:
+ case OP_SASSIGN:
+ case OP_STRINGIFY:
+ case OP_SPRINTF:
+ S_maybe_multiconcat(aTHX_ o);
+ break;
- case OP_SUBST:
- if (cPMOPo->op_pmreplrootu.op_pmreplroot)
- optimize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
- break;
+ case OP_SUBST:
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+ DEFER_OP(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ break;
- default:
- break;
- }
+ default:
+ break;
+ }
- if (!(o->op_flags & OPf_KIDS))
- return;
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+ IV child_count = 0;
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+ DEFER_OP(kid);
+ ++child_count;
+ }
+ DEFER_REVERSE(child_count);
+ }
+ } while ( ( o = POP_DEFERRED_OP() ) );
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- optimize_op(kid);
+ DEFER_OP_CLEANUP;
}
}
#endif
+/*
+=for apidoc s|OP*|traverse_op_tree|OP* top|OP* o
+
+Return the next op in a depth-first traversal of the op tree,
+returning NULL when the traversal is complete.
+
+The initial call must supply the root of the tree as both top and o.
+
+For now it's static, but it may be exposed to the API in the future.
+
+=cut
+*/
+
+STATIC OP*
+S_traverse_op_tree(pTHX_ OP *top, OP *o) {
+ OP *sib;
+
+ PERL_ARGS_ASSERT_TRAVERSE_OP_TREE;
+
+ if ((o->op_flags & OPf_KIDS) && cUNOPo->op_first) {
+ return cUNOPo->op_first;
+ }
+ else if ((sib = OpSIBLING(o))) {
+ return sib;
+ }
+ else {
+ OP *parent = o->op_sibparent;
+ assert(!(o->op_moresib));
+ while (parent && parent != top) {
+ OP *sib = OpSIBLING(parent);
+ if (sib)
+ return sib;
+ parent = parent->op_sibparent;
+ }
+
+ return NULL;
+ }
+}
STATIC void
S_finalize_op(pTHX_ OP* o)
{
+ OP * const top = o;
PERL_ARGS_ASSERT_FINALIZE_OP;
- assert(o->op_type != OP_FREED);
+ do {
+ assert(o->op_type != OP_FREED);
- switch (o->op_type) {
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- PL_curcop = ((COP*)o); /* for warnings */
- break;
- case OP_EXEC:
- if (OpHAS_SIBLING(o)) {
- OP *sib = OpSIBLING(o);
- if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
- && ckWARN(WARN_EXEC)
- && OpHAS_SIBLING(sib))
- {
+ switch (o->op_type) {
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+ break;
+ case OP_EXEC:
+ if (OpHAS_SIBLING(o)) {
+ OP *sib = OpSIBLING(o);
+ if (( sib->op_type == OP_NEXTSTATE || sib->op_type == OP_DBSTATE)
+ && ckWARN(WARN_EXEC)
+ && OpHAS_SIBLING(sib))
+ {
const OPCODE type = OpSIBLING(sib)->op_type;
if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
const line_t oldline = CopLINE(PL_curcop);
"\t(Maybe you meant system() when you said exec()?)\n");
CopLINE_set(PL_curcop, oldline);
}
- }
- }
- break;
+ }
+ }
+ break;
- case OP_GV:
- if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
- GV * const gv = cGVOPo_gv;
- if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
- /* XXX could check prototype here instead of just carping */
- SV * const sv = sv_newmortal();
- gv_efullname3(sv, gv, NULL);
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
- "%" SVf "() called too early to check prototype",
- SVfARG(sv));
- }
- }
- break;
+ case OP_GV:
+ if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
+ GV * const gv = cGVOPo_gv;
+ if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
+ /* XXX could check prototype here instead of just carping */
+ SV * const sv = sv_newmortal();
+ gv_efullname3(sv, gv, NULL);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+ "%" SVf "() called too early to check prototype",
+ SVfARG(sv));
+ }
+ }
+ break;
- case OP_CONST:
- if (cSVOPo->op_private & OPpCONST_STRICT)
- no_bareword_allowed(o);
+ case OP_CONST:
+ if (cSVOPo->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(o);
#ifdef USE_ITHREADS
- /* FALLTHROUGH */
- case OP_HINTSEVAL:
- op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
+ /* FALLTHROUGH */
+ case OP_HINTSEVAL:
+ op_relocate_sv(&cSVOPo->op_sv, &o->op_targ);
#endif
- break;
+ break;
#ifdef USE_ITHREADS
- /* Relocate all the METHOP's SVs to the pad for thread safety. */
- case OP_METHOD_NAMED:
- case OP_METHOD_SUPER:
- case OP_METHOD_REDIR:
- case OP_METHOD_REDIR_SUPER:
- op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
- break;
+ /* Relocate all the METHOP's SVs to the pad for thread safety. */
+ case OP_METHOD_NAMED:
+ case OP_METHOD_SUPER:
+ case OP_METHOD_REDIR:
+ case OP_METHOD_REDIR_SUPER:
+ op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
+ break;
#endif
- case OP_HELEM: {
- UNOP *rop;
- SVOP *key_op;
- OP *kid;
-
- if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
- break;
+ case OP_HELEM: {
+ UNOP *rop;
+ SVOP *key_op;
+ OP *kid;
- rop = (UNOP*)((BINOP*)o)->op_first;
+ if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
+ break;
- goto check_keys;
+ rop = (UNOP*)((BINOP*)o)->op_first;
- case OP_HSLICE:
- S_scalar_slice_warning(aTHX_ o);
- /* FALLTHROUGH */
+ goto check_keys;
- case OP_KVHSLICE:
- kid = OpSIBLING(cLISTOPo->op_first);
- if (/* I bet there's always a pushmark... */
- OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
- && OP_TYPE_ISNT_NN(kid, OP_CONST))
- {
- break;
- }
+ case OP_HSLICE:
+ S_scalar_slice_warning(aTHX_ o);
+ /* FALLTHROUGH */
- key_op = (SVOP*)(kid->op_type == OP_CONST
- ? kid
- : OpSIBLING(kLISTOP->op_first));
+ case OP_KVHSLICE:
+ kid = OpSIBLING(cLISTOPo->op_first);
+ if (/* I bet there's always a pushmark... */
+ OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
+ && OP_TYPE_ISNT_NN(kid, OP_CONST))
+ {
+ break;
+ }
- rop = (UNOP*)((LISTOP*)o)->op_last;
+ key_op = (SVOP*)(kid->op_type == OP_CONST
+ ? kid
+ : OpSIBLING(kLISTOP->op_first));
- check_keys:
- if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
- rop = NULL;
- S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
- break;
- }
- case OP_NULL:
- if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
- break;
- /* FALLTHROUGH */
- case OP_ASLICE:
- S_scalar_slice_warning(aTHX_ o);
- break;
+ rop = (UNOP*)((LISTOP*)o)->op_last;
- case OP_SUBST: {
- if (cPMOPo->op_pmreplrootu.op_pmreplroot)
- finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
- break;
- }
- default:
- break;
- }
+ check_keys:
+ if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
+ rop = NULL;
+ S_check_hash_fields_and_hekify(aTHX_ rop, key_op);
+ break;
+ }
+ case OP_NULL:
+ if (o->op_targ != OP_HSLICE && o->op_targ != OP_ASLICE)
+ break;
+ /* FALLTHROUGH */
+ case OP_ASLICE:
+ S_scalar_slice_warning(aTHX_ o);
+ break;
- if (o->op_flags & OPf_KIDS) {
- OP *kid;
+ case OP_SUBST: {
+ if (cPMOPo->op_pmreplrootu.op_pmreplroot)
+ finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
+ break;
+ }
+ default:
+ break;
+ }
#ifdef DEBUGGING
- /* check that op_last points to the last sibling, and that
- * the last op_sibling/op_sibparent field points back to the
- * parent, and that the only ops with KIDS are those which are
- * entitled to them */
- U32 type = o->op_type;
- U32 family;
- bool has_last;
-
- if (type == OP_NULL) {
- type = o->op_targ;
- /* ck_glob creates a null UNOP with ex-type GLOB
- * (which is a list op. So pretend it wasn't a listop */
- if (type == OP_GLOB)
- type = OP_NULL;
- }
- family = PL_opargs[type] & OA_CLASS_MASK;
-
- has_last = ( family == OA_BINOP
- || family == OA_LISTOP
- || family == OA_PMOP
- || family == OA_LOOP
- );
- assert( has_last /* has op_first and op_last, or ...
- ... has (or may have) op_first: */
- || family == OA_UNOP
- || family == OA_UNOP_AUX
- || family == OA_LOGOP
- || family == OA_BASEOP_OR_UNOP
- || family == OA_FILESTATOP
- || family == OA_LOOPEXOP
- || family == OA_METHOP
- || type == OP_CUSTOM
- || type == OP_NULL /* new_logop does this */
- );
-
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
-# ifdef PERL_OP_PARENT
- if (!OpHAS_SIBLING(kid)) {
- if (has_last)
- assert(kid == cLISTOPo->op_last);
- assert(kid->op_sibparent == o);
+ if (o->op_flags & OPf_KIDS) {
+ OP *kid;
+
+ /* check that op_last points to the last sibling, and that
+ * the last op_sibling/op_sibparent field points back to the
+ * parent, and that the only ops with KIDS are those which are
+ * entitled to them */
+ U32 type = o->op_type;
+ U32 family;
+ bool has_last;
+
+ if (type == OP_NULL) {
+ type = o->op_targ;
+ /* ck_glob creates a null UNOP with ex-type GLOB
+ * (which is a list op. So pretend it wasn't a listop */
+ if (type == OP_GLOB)
+ type = OP_NULL;
+ }
+ family = PL_opargs[type] & OA_CLASS_MASK;
+
+ has_last = ( family == OA_BINOP
+ || family == OA_LISTOP
+ || family == OA_PMOP
+ || family == OA_LOOP
+ );
+ assert( has_last /* has op_first and op_last, or ...
+ ... has (or may have) op_first: */
+ || family == OA_UNOP
+ || family == OA_UNOP_AUX
+ || family == OA_LOGOP
+ || family == OA_BASEOP_OR_UNOP
+ || family == OA_FILESTATOP
+ || family == OA_LOOPEXOP
+ || family == OA_METHOP
+ || type == OP_CUSTOM
+ || type == OP_NULL /* new_logop does this */
+ );
+
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+ if (!OpHAS_SIBLING(kid)) {
+ if (has_last)
+ assert(kid == cLISTOPo->op_last);
+ assert(kid->op_sibparent == o);
+ }
}
-# else
- if (has_last && !OpHAS_SIBLING(kid))
- assert(kid == cLISTOPo->op_last);
-# endif
}
#endif
-
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid))
- finalize_op(kid);
- }
+ } while (( o = traverse_op_tree(top, o)) != NULL);
}
/*
return o;
}
+/* This function exists solely to provide a scope to limit
+ setjmp/longjmp() messing with auto variables.
+ */
+PERL_STATIC_INLINE int
+S_fold_constants_eval(pTHX) {
+ int ret = 0;
+ dJMPENV;
+
+ JMPENV_PUSH(ret);
+
+ if (ret == 0) {
+ CALLRUNOPS(aTHX);
+ }
+
+ JMPENV_POP;
+
+ return ret;
+}
+
static OP *
S_fold_constants(pTHX_ OP *const o)
{
dVAR;
- OP * volatile curop;
+ OP *curop;
OP *newop;
- volatile I32 type = o->op_type;
+ I32 type = o->op_type;
bool is_stringify;
- SV * volatile sv = NULL;
+ SV *sv = NULL;
int ret = 0;
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
COP not_compiling;
U8 oldwarn = PL_dowarn;
I32 old_cxix;
- dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
- JMPENV_PUSH(ret);
/* Effective $^W=1. */
if ( ! (PL_dowarn & G_WARN_ALL_MASK))
PL_dowarn |= G_WARN_ON;
+ ret = S_fold_constants_eval(aTHX);
+
switch (ret) {
case 0:
- CALLRUNOPS(aTHX);
sv = *(PL_stack_sp--);
if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
pad_swipe(o->op_targ, FALSE);
o->op_next = old_next;
break;
default:
- JMPENV_POP;
/* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
* the stack - eg any nested evals */
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
- JMPENV_POP;
PL_dowarn = oldwarn;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
static OP *
S_newONCEOP(pTHX_ OP *initop, OP *padop)
{
+ dVAR;
const PADOFFSET target = padop->op_targ;
OP *const other = newOP(OP_PADSV,
padop->op_flags
&& o2->op_private & OPpLVAL_INTRO
&& !(o2->op_private & OPpPAD_STATE))
{
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated use of my() in false conditional. "
- "This will be a fatal error in Perl 5.30");
+ Perl_croak(aTHX_ "This use of my() in false conditional is "
+ "no longer allowed");
}
*otherp = NULL;
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LISTOP);
-#ifdef PERL_OP_PARENT
assert(loop->op_last->op_sibparent == (OP*)loop);
OpLASTSIB_set(loop->op_last, (OP*)tmp); /*point back to new parent */
-#endif
S_op_destroy(aTHX_ (OP*)loop);
loop = tmp;
}
else if (!loop->op_slabbed)
{
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
-#ifdef PERL_OP_PARENT
OpLASTSIB_set(loop->op_last, (OP*)loop);
-#endif
}
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
case OP_FLOP:
return TRUE;
+
+ case OP_INDEX:
+ case OP_RINDEX:
+ /* optimised-away (index() != -1) or similar comparison */
+ if (o->op_private & OPpTRUEBOOL)
+ return TRUE;
+ return FALSE;
case OP_CONST:
/* Detect comparisons that have been optimized away */
return TRUE;
else
return FALSE;
-
/* FALLTHROUGH */
default:
return FALSE;
|| SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
)
bad_type_pv(numargs, "array", o, kid);
+ else if (kid->op_type == OP_RV2HV || kid->op_type == OP_PADHV
+ || kid->op_type == OP_RV2GV) {
+ bad_type_pv(1, "array", o, kid);
+ }
else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV) {
yyerror_pv(Perl_form(aTHX_ "Experimental %s on scalar is now forbidden",
PL_op_desc[type]), 0);
/* at this point we're looking for an OP_AELEM, OP_HELEM,
* OP_EXISTS or OP_DELETE */
- /* if something like arybase (a.k.a $[ ) is in scope,
+ /* if a custom array/hash access checker is in scope,
* abandon optimisation attempt */
if ( (o->op_type == OP_AELEM || o->op_type == OP_HELEM)
&& PL_check[o->op_type] != Perl_ck_null)
https://perl5.git.perl.org / perl5.git / blobdiff