From: Vincent Pit <vince@profvince.com>
Date: Tue, 10 Nov 2009 16:38:43 +0000 (+0100)
Subject: Factor the "is this an in-place array operator construct" logic into a new is_inplace... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2f9e2db04087cea7010b80261940c74cde8a04df;p=p5sagit%2Fp5-mst-13.2.git

Factor the "is this an in-place array operator construct" logic into a new is_inplace_av()
---

diff --git a/embed.fnc b/embed.fnc
index ae69dc0..1a15d5a 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -508,6 +508,7 @@ p	|OP*	|jmaybe		|NN OP *o
 pP	|I32	|keyword	|NN const char *name|I32 len|bool all_keywords
 #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
 s	|OP*	|opt_scalarhv	|NN OP* rep_op
+s	|OP*	|is_inplace_av	|NN OP* o|NULLOK OP* oright
 #endif
 Ap	|void	|leave_scope	|I32 base
 : Used in pp_ctl.c, and by Data::Alias
diff --git a/embed.h b/embed.h
index 95c93f4..3e9e702 100644
--- a/embed.h
+++ b/embed.h
@@ -398,6 +398,7 @@
 #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define opt_scalarhv		S_opt_scalarhv
+#define is_inplace_av		S_is_inplace_av
 #endif
 #endif
 #define leave_scope		Perl_leave_scope
@@ -2770,6 +2771,7 @@
 #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
 #define opt_scalarhv(a)		S_opt_scalarhv(aTHX_ a)
+#define is_inplace_av(a,b)	S_is_inplace_av(aTHX_ a,b)
 #endif
 #endif
 #define leave_scope(a)		Perl_leave_scope(aTHX_ a)
diff --git a/op.c b/op.c
index bd783d7..e870a57 100644
--- a/op.c
+++ b/op.c
@@ -8352,6 +8352,78 @@ S_opt_scalarhv(pTHX_ OP *rep_op) {
     return (OP*)unop;
 }                        
 
+/* Checks if o acts as an in-place operator on an array. oright points to the
+ * beginning of the right-hand side. Returns the left-hand side of the
+ * assignment if o acts in-place, or NULL otherwise. */
+
+OP *
+S_is_inplace_av(pTHX_ OP *o, OP *oright) {
+    OP *o2;
+    OP *oleft = NULL;
+
+    PERL_ARGS_ASSERT_IS_INPLACE_AV;
+
+    if (!oright ||
+	(oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+	|| oright->op_next != o
+	|| (oright->op_private & OPpLVAL_INTRO)
+    )
+	return NULL;
+
+    /* o2 follows the chain of op_nexts through the LHS of the
+     * assign (if any) to the aassign op itself */
+    o2 = o->op_next;
+    if (!o2 || o2->op_type != OP_NULL)
+	return NULL;
+    o2 = o2->op_next;
+    if (!o2 || o2->op_type != OP_PUSHMARK)
+	return NULL;
+    o2 = o2->op_next;
+    if (o2 && o2->op_type == OP_GV)
+	o2 = o2->op_next;
+    if (!o2
+	|| (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
+	|| (o2->op_private & OPpLVAL_INTRO)
+    )
+	return NULL;
+    oleft = o2;
+    o2 = o2->op_next;
+    if (!o2 || o2->op_type != OP_NULL)
+	return NULL;
+    o2 = o2->op_next;
+    if (!o2 || o2->op_type != OP_AASSIGN
+	    || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
+	return NULL;
+
+    /* check that the sort is the first arg on RHS of assign */
+
+    o2 = cUNOPx(o2)->op_first;
+    if (!o2 || o2->op_type != OP_NULL)
+	return NULL;
+    o2 = cUNOPx(o2)->op_first;
+    if (!o2 || o2->op_type != OP_PUSHMARK)
+	return NULL;
+    if (o2->op_sibling != o)
+	return NULL;
+
+    /* check the array is the same on both sides */
+    if (oleft->op_type == OP_RV2AV) {
+	if (oright->op_type != OP_RV2AV
+	    || !cUNOPx(oright)->op_first
+	    || cUNOPx(oright)->op_first->op_type != OP_GV
+	    || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+	       cGVOPx_gv(cUNOPx(oright)->op_first)
+	)
+	    return NULL;
+    }
+    else if (oright->op_type != OP_PADAV
+	|| oright->op_targ != oleft->op_targ
+    )
+	return NULL;
+
+    return oleft;
+}
+
 /* 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 */
@@ -8792,62 +8864,8 @@ Perl_peep(pTHX_ register OP *o)
 		oright = cUNOPx(oright)->op_sibling;
 	    }
 
-	    if (!oright ||
-		(oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
-		|| oright->op_next != o
-		|| (oright->op_private & OPpLVAL_INTRO)
-	    )
-		break;
-
-	    /* o2 follows the chain of op_nexts through the LHS of the
-	     * assign (if any) to the aassign op itself */
-	    o2 = o->op_next;
-	    if (!o2 || o2->op_type != OP_NULL)
-		break;
-	    o2 = o2->op_next;
-	    if (!o2 || o2->op_type != OP_PUSHMARK)
-		break;
-	    o2 = o2->op_next;
-	    if (o2 && o2->op_type == OP_GV)
-		o2 = o2->op_next;
-	    if (!o2
-		|| (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
-		|| (o2->op_private & OPpLVAL_INTRO)
-	    )
-		break;
-	    oleft = o2;
-	    o2 = o2->op_next;
-	    if (!o2 || o2->op_type != OP_NULL)
-		break;
-	    o2 = o2->op_next;
-	    if (!o2 || o2->op_type != OP_AASSIGN
-		    || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
-		break;
-
-	    /* check that the sort is the first arg on RHS of assign */
-
-	    o2 = cUNOPx(o2)->op_first;
-	    if (!o2 || o2->op_type != OP_NULL)
-		break;
-	    o2 = cUNOPx(o2)->op_first;
-	    if (!o2 || o2->op_type != OP_PUSHMARK)
-		break;
-	    if (o2->op_sibling != o)
-		break;
-
-	    /* check the array is the same on both sides */
-	    if (oleft->op_type == OP_RV2AV) {
-		if (oright->op_type != OP_RV2AV
-		    || !cUNOPx(oright)->op_first
-		    || cUNOPx(oright)->op_first->op_type != OP_GV
-		    ||  cGVOPx_gv(cUNOPx(oleft)->op_first) !=
-		       	cGVOPx_gv(cUNOPx(oright)->op_first)
-		)
-		    break;
-	    }
-	    else if (oright->op_type != OP_PADAV
-		|| oright->op_targ != oleft->op_targ
-	    )
+	    oleft = is_inplace_av(o, oright);
+	    if (!oleft)
 		break;
 
 	    /* transfer MODishness etc from LHS arg to RHS arg */
diff --git a/proto.h b/proto.h
index 3aa6ca3..5d326b5 100644
--- a/proto.h
+++ b/proto.h
@@ -1431,6 +1431,11 @@ STATIC OP*	S_opt_scalarhv(pTHX_ OP* rep_op)
 #define PERL_ARGS_ASSERT_OPT_SCALARHV	\
 	assert(rep_op)
 
+STATIC OP*	S_is_inplace_av(pTHX_ OP* o, OP* oright)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_IS_INPLACE_AV	\
+	assert(o)
+
 #endif
 PERL_CALLCONV void	Perl_leave_scope(pTHX_ I32 base);
 PERL_CALLCONV void	Perl_lex_end(pTHX);