Avoid creating lots of mortals in B::walkoptree()

When calling out to the user-supplied method, re-use the same reference and
object where possible. Only create a new one if the user supplied method
modified the reference or object passed to it.

The previous implementation had a comment "Use the same opsv. Rely on methods
not to mess it up." but it was actually generating a new reference for every
call, and also a new object for every recursive call. So massive churn of
objects, and large accumulation of mortals on the temp stack.

1 files changed, 28 insertions, 17 deletions

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 2c1ebbfe78..bf9331755e 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -477,40 +477,51 @@ cchar(pTHX_ SV *sv)
 #  define PMOP_pmdynflags(o)      o->op_pmdynflags
 #endif
 
-static void
-walkoptree(pTHX_ SV *opsv, const char *method)
+static SV *
+walkoptree(pTHX_ OP *o, const char *method, SV *ref)
 {
     dSP;
-    OP *o, *kid;
+    OP *kid;
+    SV *object;
+    const char *const classname = cc_opclassname(aTHX_ o);
     dMY_CXT;
 
-    if (!SvROK(opsv))
-	croak("opsv is not a reference");
-    opsv = sv_mortalcopy(opsv);
-    o = INT2PTR(OP*,SvIV((SV*)SvRV(opsv)));
+    /* Check that no-one has changed our reference, or is holding a reference
+       to it.  */
+    if (SvREFCNT(ref) == 1 && SvROK(ref) && SvTYPE(ref) == SVt_RV
+	&& (object = SvRV(ref)) && SvREFCNT(object) == 1
+	&& SvTYPE(object) == SVt_PVMG && SvIOK_only(object)
+	&& !SvMAGICAL(object) && !SvMAGIC(object) && SvSTASH(object)) {
+	/* Looks good, so rebless it for the class we need:  */
+	sv_bless(ref, gv_stashpv(classname, GV_ADD));
+    } else {
+	/* Need to make a new one. */
+	ref = sv_newmortal();
+	object = newSVrv(ref, classname);
+    }
+    sv_setiv(object, PTR2IV(o));
+
     if (walkoptree_debug) {
 	PUSHMARK(sp);
-	XPUSHs(opsv);
+	XPUSHs(ref);
 	PUTBACK;
 	perl_call_method("walkoptree_debug", G_DISCARD);
     }
     PUSHMARK(sp);
-    XPUSHs(opsv);
+    XPUSHs(ref);
     PUTBACK;
     perl_call_method(method, G_DISCARD);
     if (o && (o->op_flags & OPf_KIDS)) {
 	for (kid = ((UNOP*)o)->op_first; kid; kid = kid->op_sibling) {
-	    /* Use the same opsv. Rely on methods not to mess it up. */
-	    sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
-	    walkoptree(aTHX_ opsv, method);
+	    ref = walkoptree(aTHX_ kid, method, ref);
 	}
     }
     if (o && (cc_opclass(aTHX_ o) == OPc_PMOP) && o->op_type != OP_PUSHRE
            && (kid = PMOP_pmreplroot(cPMOPo)))
     {
-	sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ kid)), PTR2IV(kid));
-	walkoptree(aTHX_ opsv, method);
+	ref = walkoptree(aTHX_ kid, method, ref);
     }
+    return ref;
 }
 
 static SV **
@@ -716,11 +727,11 @@ sub_generation()
 	RETVAL
 
 void
-walkoptree(opsv, method)
-	SV *	opsv
+walkoptree(op, method)
+	B::OP op
 	const char *	method
     CODE:
-	walkoptree(aTHX_ opsv, method);
+	(void) walkoptree(aTHX_ op, method, &PL_sv_undef);
 
 int
 walkoptree_debug(...)