This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make sv_clear() iterate over AVs
authorDavid Mitchell <davem@iabyn.com>
Fri, 8 Oct 2010 15:22:42 +0000 (16:22 +0100)
committerDavid Mitchell <davem@iabyn.com>
Sun, 10 Oct 2010 23:41:17 +0000 (00:41 +0100)
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.

embed.fnc
proto.h
sv.c

index fe70aa9..5741ef0 100644 (file)
--- a/embed.fnc
+++ b/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
diff --git a/proto.h b/proto.h
index aaa7c5c..bb89272 100644 (file)
--- a/proto.h
+++ b/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);
diff --git a/sv.c b/sv.c
index 84f3ab1..b25992e 100644 (file)
--- a/sv.c
+++ b/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,9 +6052,12 @@ 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]);
@@ -6039,6 +6065,64 @@ Perl_sv_clear(pTHX_ register SV *const sv)
     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 */
 }
 
 /*