From 20f7624e3fd0a2888bfc8c1fd98f11e603f108e9 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Fri, 5 Nov 2010 13:51:46 +0000
Subject: [PATCH] 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.
---
 ext/B/B.xs           | 45 ++++++++++++++++++++++++++++-----------------
 ext/B/t/walkoptree.t | 25 +++++++++++++++++++++++++
 2 files changed, 53 insertions(+), 17 deletions(-)

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 2c1ebbf..bf93317 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(...)
diff --git a/ext/B/t/walkoptree.t b/ext/B/t/walkoptree.t
index 9757f88..fbdc50f 100644
--- a/ext/B/t/walkoptree.t
+++ b/ext/B/t/walkoptree.t
@@ -57,4 +57,29 @@ foreach (qw(substcont pushre split leavesub)) {
 }
 is_deeply (\%debug, \%seen, 'walkoptree_debug was called correctly');
 
+my %seen2;
+
+# Now try to exercise the code in walkoptree that decides that it can't re-use
+# the object and reference.
+sub B::OP::fiddle {
+    my $name = $_[0]->name;
+    ++$seen2{$name};
+    if ($name =~ /^s/) {
+	# Take another reference to the reference
+	push @::junk, \$_[0];
+    } elsif ($name =~ /^p/) {
+	# Take another reference to the object
+	push @::junk, \${$_[0]};
+    } elsif ($name =~ /^l/) {
+	undef $_[0];
+    } elsif ($name =~ /g/) {
+	${$_[0]} = "Muhahahahaha!";
+    } elsif ($name =~ /^c/) {
+	bless \$_[0];
+    }
+}
+
+B::walkoptree(B::svref_2object($victim)->ROOT, "fiddle");
+is_deeply (\%seen2, \%seen, 'everything still seen');
+
 done_testing();
-- 
2.7.4