In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/35a2929bb8afc786379fa44c650f7c35377c74f7?hp=614f2ce4f49414577dec90f8c9bd3f0404bf2ebf>
- Log ----------------------------------------------------------------- commit 35a2929bb8afc786379fa44c650f7c35377c74f7 Author: David Mitchell <[email protected]> Date: Thu Sep 29 16:03:05 2016 +0100 OP_SASSIGN: make op_first==op_last for UNOP Occasionally (e.g. $x ||= 1) an OP_SASSIGN operator only has a single arg. The previous two commits made OP_SASSIGN always be allocated as a BINOP, and if necessary, set op_last to NULL when there's only s single arg. This commit instead sets op_last equal to op_first for this case (similar to how a LISTOP with a single arg is handled). This removes the need for special handling in S_finalize_op(). M op.c commit 354eabfa08c1e2f5d83c116c6f072a4e1f3a62ff Author: Reini Urban <[email protected]> Date: Thu Sep 29 16:20:52 2016 +0100 sassign was used as UNOP, optimize {or,and,dor}assign [ DAPM: To clarify: OP_SASSIGN normally has two args, and is allocated as a BINOP. However, in something like $x ||= 1, the optree looks like: 4 <|> orassign(other->5) vK/1 ->7 - <1> ex-rv2sv sKRM/1 ->4 3 <#> gvsv[*x] s ->4 6 <1> sassign sK/BKWARD,1 ->7 5 <$> const[IV 1] s ->6 Here the sassign only has a single arg, since the other arg is already left on the stack after orassign has executed. In this case, perl was allocating the op as a UNOP, which causes problems with any code which assumes op_last contains a valid pointer. This commit changes it so that the op is always allocated as a BINOP, even when it only has one arg. In that case, it sets op_last to NULL (but see the next commit). Setting OPpASSIGN_BACKWARDS earlier is just a simplification of the code. ] In newASSIGNOP with {or,and,dor}assign, the rhs was wrongly compiled as UNOP sassign. It caused DEBUGGING corruption in the op finalizer for sassign (first not pointing to last without sibling) and added random chunk to the last field. It was never used though, as only {or,and,dor}assign used this op_other op. {or,and,dor}assign needs the sassign with OPpASSIGN_BACKWARDS, set it directly, not later in the LOGOP. finalize_op needs a special case for it, as the last is empty there. M op.c M pp_hot.c commit 1257c0814cb385a65f4175daa8be8b51e151e4ec Author: Reini Urban <[email protected]> Date: Thu Sep 29 14:30:27 2016 +0100 sassign is wrongly declared as BASEOP, not BINOP. [ DAPM: To clarify: OP_SASSIGN is always allocated as a BINOP (or occasionally as a UNOP - see the next commit), but is listed as a BASEOP in regen/opcodes. Because of this, various bits of code that rely on e.g. PL_opargs[] have to be special-cased for OP_SASSIGN. This commit changes the entry in regen/opcodes to list it as BINOP, and removes the special-casing. I've also added a temporary workaround marked by XXX to make the commit work under PERL_OP_PARENT, which is the default now. This will be removed in a couple if commits' time. ] This was wrong from the very beginning: added with 79072805bf lwall perl 5.0 alpha 2 1993 with class s, not 0, but missing the 2 S S args, which are present in aassign. Changed to BASEOP with db173bac9b6de7d by mbeattie in 1997. The '# sassign is special-cased for op class' comment is suspicious. Fix it in ck_sassign also, it is created as BINOP in newASSIGNOP. In 202206897 dapm 2014 complained about it also. Remove some special cases where it should be a BINOP but was not. M op.c M opcode.h M regen/opcodes ----------------------------------------------------------------------- Summary of changes: op.c | 12 ++++-------- opcode.h | 2 +- pp_hot.c | 2 +- regen/opcodes | 3 +-- 4 files changed, 7 insertions(+), 12 deletions(-) diff --git a/op.c b/op.c index 0fbee48..5621d07 100644 --- a/op.c +++ b/op.c @@ -2648,8 +2648,6 @@ S_finalize_op(pTHX_ OP* o) || family == OA_FILESTATOP || family == OA_LOOPEXOP || family == OA_METHOP - /* I don't know why SASSIGN is tagged as OA_BASEOP - DAPM */ - || type == OP_SASSIGN || type == OP_CUSTOM || type == OP_NULL /* new_logop does this */ ); @@ -5121,7 +5119,7 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) BINOP *binop; ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP - || type == OP_SASSIGN || type == OP_NULL || type == OP_CUSTOM); + || type == OP_NULL || type == OP_CUSTOM); NewOp(1101, binop, 1, BINOP); @@ -6508,9 +6506,10 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (optype) { if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { + right = scalar(right); return newLOGOP(optype, 0, op_lvalue(scalar(left), optype), - newUNOP(OP_SASSIGN, 0, scalar(right))); + newBINOP(OP_SASSIGN, OPpASSIGN_BACKWARDS<<8, right, right)); } else { return newBINOP(optype, OPf_STACKED, @@ -6985,9 +6984,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } - if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) - other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ - /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT && (first->op_flags & OPf_KIDS) @@ -10497,7 +10493,7 @@ OP * Perl_ck_sassign(pTHX_ OP *o) { dVAR; - OP * const kid = cLISTOPo->op_first; + OP * const kid = cBINOPo->op_first; PERL_ARGS_ASSERT_CK_SASSIGN; diff --git a/opcode.h b/opcode.h index 1f2674f..565cc9f 100644 --- a/opcode.h +++ b/opcode.h @@ -1831,7 +1831,7 @@ EXTCONST U32 PL_opargs[] = { 0x00000304, /* substcont */ 0x00001804, /* trans */ 0x00001804, /* transr */ - 0x00000004, /* sassign */ + 0x00011204, /* sassign */ 0x00022208, /* aassign */ 0x00002b0d, /* chop */ 0x00009b8c, /* schop */ diff --git a/pp_hot.c b/pp_hot.c index 35cc4da..3c07674 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -130,7 +130,7 @@ PP(pp_sassign) */ SV *left = POPs; SV *right = TOPs; - if (PL_op->op_private & OPpASSIGN_BACKWARDS) { + if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */ SV * const temp = left; left = right; right = temp; } diff --git a/regen/opcodes b/regen/opcodes index 57dd363..6ad9c62 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -94,9 +94,8 @@ trans transliteration (tr///) ck_match is" S transr transliteration (tr///) ck_match is" S # Lvalue operators. -# sassign is special-cased for op class -sassign scalar assignment ck_sassign s0 +sassign scalar assignment ck_sassign s2 S S aassign list assignment ck_null t2 L L chop chop ck_spair mts% L -- Perl5 Master Repository
