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.

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 2c1ebbf..bf93317 100644 (file)
--- 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 (file)
--- 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();