make sv_clear() iterate over AVs

In sv_clear(), rather than calling av_undef(), iterate over the AV's
elements. This is the first stage in making sv_clear() non-recursive,
and thus non-stack-blowing when freeing deeply nested structures.

Since we no longer have the stack to maintain the chain of AVs currently
being iterated over, we instead store a pointer to the previous AV in the
AvARRAY[AvMAX] slot of the currently-being-iterated AV. Since our first
action is to pop the first SV, that slot is guaranteed to be free, and
(in theory) nothing should be messing with the AV while we iterate over
its elements, so that slot should remain undisturbed.

Author: iabyn

embed.fnc

@@ -1160,7 +1160,7 @@ Apd	|void	|sv_chop	|NN SV *const sv|NULLOK const char *const ptr
 pd	|I32	|sv_clean_all
 : Used only in perl.c
 pd	|void	|sv_clean_objs
-Apd	|void	|sv_clear	|NN SV *const sv
+Apd	|void	|sv_clear	|NN SV *const orig_sv
 Apd	|I32	|sv_cmp		|NULLOK SV *const sv1|NULLOK SV *const sv2
 Apd	|I32	|sv_cmp_flags	|NULLOK SV *const sv1|NULLOK SV *const sv2|const I32 flags
 Apd	|I32	|sv_cmp_locale	|NULLOK SV *const sv1|NULLOK SV *const sv2

proto.h

@@ -3897,10 +3897,10 @@ PERL_CALLCONV void	Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
 
 PERL_CALLCONV I32	Perl_sv_clean_all(pTHX);
 PERL_CALLCONV void	Perl_sv_clean_objs(pTHX);
-PERL_CALLCONV void	Perl_sv_clear(pTHX_ SV *const sv)
+PERL_CALLCONV void	Perl_sv_clear(pTHX_ SV *const orig_sv)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_CLEAR	\
-	assert(sv)
+	assert(orig_sv)
 
 PERL_CALLCONV I32	Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2);
 PERL_CALLCONV I32	Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const I32 flags);

sv.c

@@ -5814,15 +5814,26 @@ instead.
 */
 
 void
-Perl_sv_clear(pTHX_ register SV *const sv)
+Perl_sv_clear(pTHX_ SV *const orig_sv)
 {
     dVAR;
-    const U32 type = SvTYPE(sv);
-    const struct body_details *const sv_type_details
-	= bodies_by_type + type;
     HV *stash;
+    U32 type;
+    const struct body_details *sv_type_details;
+    SV* iter_sv = NULL;
+    SV* next_sv = NULL;
+    register SV *sv = orig_sv;
 
     PERL_ARGS_ASSERT_SV_CLEAR;
+
+    /* within this loop, sv is the SV currently being freed, and
+     * iter_sv is the most recent AV or whatever that's being iterated
+     * over to provide more SVs */
+
+    while (sv) {
+
+    type = SvTYPE(sv);
+
     assert(SvREFCNT(sv) == 0);
     assert(SvTYPE(sv) != SVTYPEMASK);
 
@@ -5833,7 +5844,7 @@ Perl_sv_clear(pTHX_ register SV *const sv)
 	    goto free_rv;
 	SvFLAGS(sv) &= SVf_BREAK;
 	SvFLAGS(sv) |= SVTYPEMASK;
-	return;
+	goto free_head;
     }
 
     if (SvOBJECT(sv)) {
@@ -5885,7 +5896,7 @@ Perl_sv_clear(pTHX_ register SV *const sv)
 		    Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
 			  HvNAME_get(stash));
 		/* DESTROY gave object new lease on life */
-		return;
+		goto get_next_sv;
 	    }
 	}
 
@@ -5942,11 +5953,23 @@ Perl_sv_clear(pTHX_ register SV *const sv)
 	hv_undef(MUTABLE_HV(sv));
 	break;
     case SVt_PVAV:
-	if (PL_comppad == MUTABLE_AV(sv)) {
-	    PL_comppad = NULL;
-	    PL_curpad = NULL;
+	{
+	    AV* av = MUTABLE_AV(sv);
+	    if (PL_comppad == av) {
+		PL_comppad = NULL;
+		PL_curpad = NULL;
+	    }
+	    if (AvREAL(av) && AvFILLp(av) > -1) {
+		next_sv = AvARRAY(av)[AvFILLp(av)--];
+		/* save old iter_sv in top-most slot of AV,
+		 * and pray that it doesn't get wiped in the meantime */
+		AvARRAY(av)[AvMAX(av)] = iter_sv;
+		iter_sv = sv;
+		goto get_next_sv; /* process this new sv */
+	    }
+	    Safefree(AvALLOC(av));
 	}
-	av_undef(MUTABLE_AV(sv));
+
 	break;
     case SVt_PVLV:
 	if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
@@ -6029,16 +6052,77 @@ Perl_sv_clear(pTHX_ register SV *const sv)
 	break;
     }
 
+  free_body:
+
     SvFLAGS(sv) &= SVf_BREAK;
     SvFLAGS(sv) |= SVTYPEMASK;
 
+    sv_type_details = bodies_by_type + type;
     if (sv_type_details->arena) {
 	del_body(((char *)SvANY(sv) + sv_type_details->offset),
 		 &PL_body_roots[type]);
     }
     else if (sv_type_details->body_size) {
 	safefree(SvANY(sv));
     }
+
+      free_head:
+	/* caller is responsible for freeing the head of the original sv */
+	if (sv != orig_sv && !SvREFCNT(sv))
+	    del_SV(sv);
+
+	/* grab and free next sv, if any */
+      get_next_sv:
+	while (1) {
+	    sv = NULL;
+	    if (next_sv) {
+		sv = next_sv;
+		next_sv = NULL;
+	    }
+	    else if (!iter_sv) {
+		break;
+	    } else if (SvTYPE(iter_sv) == SVt_PVAV) {
+		AV *const av = (AV*)iter_sv;
+		if (AvFILLp(av) > -1) {
+		    sv = AvARRAY(av)[AvFILLp(av)--];
+		}
+		else { /* no more elements of current AV to free */
+		    sv = iter_sv;
+		    type = SvTYPE(sv);
+		    /* restore previous value, squirrelled away */
+		    iter_sv = AvARRAY(av)[AvMAX(av)];
+		    Safefree(AvALLOC(av));
+		    goto free_body;
+		}
+	    }
+
+	    /* unrolled SvREFCNT_dec and sv_free2 follows: */
+
+	    if (!sv)
+		continue;
+	    if (!SvREFCNT(sv)) {
+		sv_free(sv);
+		continue;
+	    }
+	    if (--(SvREFCNT(sv)))
+		continue;
+    #ifdef DEBUGGING
+	    if (SvTEMP(sv)) {
+		Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+			 "Attempt to free temp prematurely: SV 0x%"UVxf
+			 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+		continue;
+	    }
+    #endif
+	    if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
+		/* make sure SvREFCNT(sv)==0 happens very seldom */
+		SvREFCNT(sv) = (~(U32)0)/2;
+		continue;
+	    }
+	    break;
+	} /* while 1 */
+
+    } /* while sv */
 }
 
 /*