make recursive part of peephole optimiser hookable

New variable PL_rpeepp makes it possible for extensions to hook
the per-op-chain part of the peephole optimiser (which recurses into
side chains).  The existing variable PL_peepp still allows hooking the
per-sub part of the peephole optimiser, maintaining perfect backward
compatibility.

8 files changed, 29 insertions, 11 deletions

diff --git a/embed.fnc b/embed.fnc
index 63bbcd8940..47ca611a49 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -887,8 +887,9 @@ sd	|void	|pad_reset
 #endif
 : Used in op.c
 pd	|void	|pad_swipe	|PADOFFSET po|bool refadjust
-: FIXME
+: peephole optimiser
 p	|void	|peep		|NULLOK OP* o
+p	|void	|rpeep		|NULLOK OP* o
 : Defined in doio.c, used only in pp_hot.c
 dopM	|PerlIO*|start_glob	|NN SV *tmpglob|NN IO *io
 #if defined(USE_REENTRANT_API)
diff --git a/embed.h b/embed.h
index 9cde4db639..ae8478b58c 100644
--- a/embed.h
+++ b/embed.h
@@ -706,6 +706,7 @@
 #ifdef PERL_CORE
 #define pad_swipe		Perl_pad_swipe
 #define peep			Perl_peep
+#define rpeep			Perl_rpeep
 #endif
 #if defined(USE_REENTRANT_API)
 #define reentrant_size		Perl_reentrant_size
@@ -3152,6 +3153,7 @@
 #ifdef PERL_CORE
 #define pad_swipe(a,b)		Perl_pad_swipe(aTHX_ a,b)
 #define peep(a)			Perl_peep(aTHX_ a)
+#define rpeep(a)		Perl_rpeep(aTHX_ a)
 #endif
 #if defined(USE_REENTRANT_API)
 #define reentrant_size()	Perl_reentrant_size(aTHX)
diff --git a/embedvar.h b/embedvar.h
index 587bc94863..e57eed9d7f 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -258,6 +258,7 @@
 #define PL_replgv		(vTHX->Ireplgv)
 #define PL_restartjmpenv	(vTHX->Irestartjmpenv)
 #define PL_restartop		(vTHX->Irestartop)
+#define PL_rpeepp		(vTHX->Irpeepp)
 #define PL_rs			(vTHX->Irs)
 #define PL_runops		(vTHX->Irunops)
 #define PL_savebegin		(vTHX->Isavebegin)
@@ -589,6 +590,7 @@
 #define PL_Ireplgv		PL_replgv
 #define PL_Irestartjmpenv	PL_restartjmpenv
 #define PL_Irestartop		PL_restartop
+#define PL_Irpeepp		PL_rpeepp
 #define PL_Irs			PL_rs
 #define PL_Irunops		PL_runops
 #define PL_Isavebegin		PL_savebegin
diff --git a/intrpvar.h b/intrpvar.h
index 21fb933254..503d9d666f 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -172,7 +172,9 @@ PERLVARI(Irehash_seed_set, bool, FALSE)	/* 582 hash initialized? */
 PERLVARA(Icolors,6,	char *)		/* from regcomp.c */
 
 PERLVARI(Ipeepp,	peep_t, MEMBER_TO_FPTR(Perl_peep))
-					/* Pointer to peephole optimizer */
+				/* Pointer to per-sub peephole optimizer */
+PERLVARI(Irpeepp,	peep_t, MEMBER_TO_FPTR(Perl_rpeep))
+				/* Pointer to recursive peephole optimizer */
 
 /*
 =for apidoc Amn|Perl_ophook_t|PL_opfreehook
diff --git a/op.c b/op.c
index 0979fc1fc2..3699674118 100644
--- a/op.c
+++ b/op.c
@@ -104,6 +104,7 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 #include "keywords.h"
 
 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
+#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
 
 #if defined(PL_OP_SLAB_ALLOC)
@@ -2668,7 +2669,7 @@ S_gen_constant_list(pTHX_ register OP *o)
     o->op_ppaddr = PL_ppaddr[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 peep() */
+    o->op_opt = 0;		/* needs to be revisited in rpeep() */
     curop = ((UNOP*)o)->op_first;
     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
 #ifdef PERL_MAD
@@ -8843,7 +8844,7 @@ S_is_inplace_av(pTHX_ OP *o, OP *oright) {
  * peep() is called */
 
 void
-Perl_peep(pTHX_ register OP *o)
+Perl_rpeep(pTHX_ register OP *o)
 {
     dVAR;
     register OP* oldop = NULL;
@@ -8936,7 +8937,7 @@ Perl_peep(pTHX_ register OP *o)
 		PL_curcop = ((COP*)o);
 	    }
 	    /* XXX: We avoid setting op_seq here to prevent later calls
-	       to peep() from mistakenly concluding that optimisation
+	       to rpeep() from mistakenly concluding that optimisation
 	       has already occurred. This doesn't fix the real problem,
 	       though (See 20010220.007). AMS 20010719 */
 	    /* op_seq functionality is now replaced by op_opt */
@@ -9042,7 +9043,7 @@ Perl_peep(pTHX_ register OP *o)
             sop = fop->op_sibling;
 	    while (cLOGOP->op_other->op_type == OP_NULL)
 		cLOGOP->op_other = cLOGOP->op_other->op_next;
-	    peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+	    CALL_RPEEP(cLOGOP->op_other);
           
           stitch_keys:	    
 	    o->op_opt = 1;
@@ -9093,20 +9094,20 @@ Perl_peep(pTHX_ register OP *o)
 	case OP_ONCE:
 	    while (cLOGOP->op_other->op_type == OP_NULL)
 		cLOGOP->op_other = cLOGOP->op_other->op_next;
-	    peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+	    CALL_RPEEP(cLOGOP->op_other);
 	    break;
 
 	case OP_ENTERLOOP:
 	case OP_ENTERITER:
 	    while (cLOOP->op_redoop->op_type == OP_NULL)
 		cLOOP->op_redoop = cLOOP->op_redoop->op_next;
-	    peep(cLOOP->op_redoop);
+	    CALL_RPEEP(cLOOP->op_redoop);
 	    while (cLOOP->op_nextop->op_type == OP_NULL)
 		cLOOP->op_nextop = cLOOP->op_nextop->op_next;
-	    peep(cLOOP->op_nextop);
+	    CALL_RPEEP(cLOOP->op_nextop);
 	    while (cLOOP->op_lastop->op_type == OP_NULL)
 		cLOOP->op_lastop = cLOOP->op_lastop->op_next;
-	    peep(cLOOP->op_lastop);
+	    CALL_RPEEP(cLOOP->op_lastop);
 	    break;
 
 	case OP_SUBST:
@@ -9115,7 +9116,7 @@ Perl_peep(pTHX_ register OP *o)
 		   cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
 		cPMOP->op_pmstashstartu.op_pmreplstart
 		    = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
-	    peep(cPMOP->op_pmstashstartu.op_pmreplstart);
+	    CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
 	    break;
 
 	case OP_EXEC:
@@ -9491,6 +9492,12 @@ Perl_peep(pTHX_ register OP *o)
     LEAVE;
 }
 
+void
+Perl_peep(pTHX_ register OP *o)
+{
+    CALL_RPEEP(o);
+}
+
 const char*
 Perl_custom_op_name(pTHX_ const OP* o)
 {
diff --git a/perlapi.h b/perlapi.h
index 869d5123d7..cb0aa05dd7 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -552,6 +552,8 @@ END_EXTERN_C
 #define PL_restartjmpenv	(*Perl_Irestartjmpenv_ptr(aTHX))
 #undef  PL_restartop
 #define PL_restartop		(*Perl_Irestartop_ptr(aTHX))
+#undef  PL_rpeepp
+#define PL_rpeepp		(*Perl_Irpeepp_ptr(aTHX))
 #undef  PL_rs
 #define PL_rs			(*Perl_Irs_ptr(aTHX))
 #undef  PL_runops
diff --git a/proto.h b/proto.h
index 034f67344a..2c5df53f8f 100644
--- a/proto.h
+++ b/proto.h
@@ -2572,6 +2572,7 @@ STATIC void	S_pad_reset(pTHX);
 #endif
 PERL_CALLCONV void	Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust);
 PERL_CALLCONV void	Perl_peep(pTHX_ OP* o);
+PERL_CALLCONV void	Perl_rpeep(pTHX_ OP* o);
 PERL_CALLCONV PerlIO*	Perl_start_glob(pTHX_ SV *tmpglob, IO *io)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
diff --git a/sv.c b/sv.c
index 56bf8b11f5..3a0cf893d1 100644
--- a/sv.c
+++ b/sv.c
@@ -12740,6 +12740,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* Pluggable optimizer */
     PL_peepp		= proto_perl->Ipeepp;
+    PL_rpeepp		= proto_perl->Irpeepp;
     /* op_free() hook */
     PL_opfreehook	= proto_perl->Iopfreehook;