stop map,grep leaking temps [perl #48004]

The former behaviour of map and grep was to never free any temps.
Thus for large lists (and even worse, nested maps), the tmps stack could
grow very large. For all cases expect list-context map, the fix is easy:
just do a FREETMPS at the end of each iteration.

The list-context map however, needs to accumulate a list of temporaries
over the course of the iterations, and finally return that list to the
caller (which is responsible for freeing them). We get round this by, at
the end of each iteration, directly manipulating the tmps stack to free
everything *except* the values to be returned. To make this efficient,
we splice in the returned tmp items at the base of the stack frame, move
PL_tmps_floor above them, then do a FREETMPS (so they may appear twice on
the temps stack, but initially only get freed once).

3 files changed, 83 insertions, 3 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index 63a5f22d64..20a070150f 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1113,8 +1113,41 @@ PP(pp_mapwhile)
 	/* copy the new items down to the destination list */
 	dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
 	if (gimme == G_ARRAY) {
-	    while (items-- > 0)
-		*dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+	    /* add returned items to the collection (making mortal copies
+	     * if necessary), then clear the current temps stack frame
+	     * *except* for those items. We do this splicing the items
+	     * into the start of the tmps frame (so some items may be on
+	     * the tmps stack twice), then moving PL_stack_floor above
+	     * them, then freeing the frame. That way, the only tmps that
+	     * accumulate over iterations are the return values for map.
+	     * We have to do to this way so that everything gets correctly
+	     * freed if we die during the map.
+	     */
+	    I32 tmpsbase;
+	    I32 i = items;
+	    /* make space for the slice */
+	    EXTEND_MORTAL(items);
+	    tmpsbase = PL_tmps_floor + 1;
+	    Move(PL_tmps_stack + tmpsbase,
+		 PL_tmps_stack + tmpsbase + items,
+		 PL_tmps_ix - PL_tmps_floor,
+		 SV*);
+	    PL_tmps_ix += items;
+
+	    while (i-- > 0) {
+		SV *sv = POPs;
+		if (!SvTEMP(sv))
+		    sv = sv_mortalcopy(sv);
+		*dst-- = sv;
+		PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
+	    }
+	    /* clear the stack frame except for the items */
+	    PL_tmps_floor += items;
+	    FREETMPS;
+	    /* FREETMPS may have cleared the TEMP flag on some of the items */
+	    i = items;
+	    while (i-- > 0)
+		SvTEMP_on(PL_tmps_stack[--tmpsbase]);
 	}
 	else {
 	    /* scalar context: we don't care about which values map returns
@@ -1124,8 +1157,12 @@ PP(pp_mapwhile)
 		(void)POPs;
 		*dst-- = &PL_sv_undef;
 	    }
+	    FREETMPS;
 	}
     }
+    else {
+	FREETMPS;
+    }
     LEAVE_with_name("grep_item");					/* exit inner scope */
 
     /* All done yet? */
diff --git a/pp_hot.c b/pp_hot.c
index 4db0e23914..34542c27f5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2461,6 +2461,7 @@ PP(pp_grepwhile)
     if (SvTRUEx(POPs))
 	PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
     ++*PL_markstack_ptr;
+    FREETMPS;
     LEAVE_with_name("grep_item");					/* exit inner scope */
 
     /* All done yet? */
diff --git a/t/op/svleak.t b/t/op/svleak.t
index 07c2efcb71..542bcdcfcc 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -13,7 +13,7 @@ BEGIN {
 	or skip_all("XS::APItest not available");
 }
 
-plan tests => 5;
+plan tests => 17;
 
 # run some code N times. If the number of SVs at the end of loop N is
 # greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -71,3 +71,45 @@ sub STORE	{ $_[0]->[$_[1]] = $_[2] }
 # [perl #74484]  repeated tries leaked SVs on the tmps stack
 
 leak_expr(5, 0, q{"YYYYYa" =~ /.+?(a(.+?)|b)/ }, "trie leak");
+
+# [perl #48004] map/grep didn't free tmps till the end
+
+{
+    # qr/1/ just creates tmps that are hopefully freed per iteration
+
+    my $s;
+    my @a;
+    my @count = (0) x 4; # pre-allocate
+
+    grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
+    is(@count[3] - @count[0], 0, "void   grep expr:  no new tmps per iter");
+    grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
+    is(@count[3] - @count[0], 0, "void   grep block: no new tmps per iter");
+
+    $s = grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
+    is(@count[3] - @count[0], 0, "scalar grep expr:  no new tmps per iter");
+    $s = grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
+    is(@count[3] - @count[0], 0, "scalar grep block: no new tmps per iter");
+
+    @a = grep qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
+    is(@count[3] - @count[0], 0, "list   grep expr:  no new tmps per iter");
+    @a = grep { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
+    is(@count[3] - @count[0], 0, "list   grep block: no new tmps per iter");
+
+
+    map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
+    is(@count[3] - @count[0], 0, "void   map expr:  no new tmps per iter");
+    map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
+    is(@count[3] - @count[0], 0, "void   map block: no new tmps per iter");
+
+    $s = map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
+    is(@count[3] - @count[0], 0, "scalar map expr:  no new tmps per iter");
+    $s = map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
+    is(@count[3] - @count[0], 0, "scalar map block: no new tmps per iter");
+
+    @a = map qr/1/ && ($count[$_] = sv_count()) && 99,  0..3;
+    is(@count[3] - @count[0], 3, "list   map expr:  one new tmp per iter");
+    @a = map { qr/1/ && ($count[$_] = sv_count()) && 99 }  0..3;
+    is(@count[3] - @count[0], 3, "list   map block: one new tmp per iter");
+
+}