This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate change #9108 from maintperl to mainline.
authorJarkko Hietaniemi <jhi@iki.fi>
Mon, 12 Mar 2001 16:04:47 +0000 (16:04 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Mon, 12 Mar 2001 16:04:47 +0000 (16:04 +0000)
fix memory leak in C<sub X { sub {} }> arising from a refcount
loop between the outer sub and the inner prototype anonsub

this also enables closures returned by subroutines that
subsequently get redefined to work without generating coredumps :)

completely removed the free_closures() hack--it shouldn't be
needed anymore

p4raw-link: @9108 on //depot/maint-5.6/perl: 1cf1f64f42eb50a67f2427ff9d6d24023a2b9997

p4raw-id: //depot/perl@9109
p4raw-branched: from //depot/maint-5.6/perl@9107 'branch in'
t/op/anonsub.t
p4raw-integrated: from //depot/maint-5.6/perl@9107 'merge in' sv.c
(@8871..) embed.h (@8886..) pod/perlapi.pod proto.h (@8993..)
embed.pl (@8995..) MANIFEST (@9030..) op.c op.h (@9055..)
pp_ctl.c (@9076..)

MANIFEST
embed.h
embed.pl
op.c
op.h
pod/perlapi.pod
pp_ctl.c
proto.h
sv.c
t/op/anonsub.t [new file with mode: 0755]

index 33ee169..f2671ef 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1538,6 +1538,7 @@ t/lib/tie-substrhash.t    Test for Tie::SubstrHash
 t/lib/timelocal.t      See if Time::Local works
 t/lib/trig.t           See if Math::Trig works
 t/op/64bitint.t                See if 64 bit integers work
+t/op/anonsub.t         See if anonymous subroutines work
 t/op/append.t          See if . works
 t/op/args.t            See if operations on @_ work
 t/op/arith.t           See if arithmetic works
diff --git a/embed.h b/embed.h
index 1255400..44ff2fd 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define dopoptoloop            S_dopoptoloop
 #define dopoptosub             S_dopoptosub
 #define dopoptosub_at          S_dopoptosub_at
-#define free_closures          S_free_closures
 #define save_lines             S_save_lines
 #define doeval                 S_doeval
 #define doopen_pmc             S_doopen_pmc
 #define dopoptoloop(a)         S_dopoptoloop(aTHX_ a)
 #define dopoptosub(a)          S_dopoptosub(aTHX_ a)
 #define dopoptosub_at(a,b)     S_dopoptosub_at(aTHX_ a,b)
-#define free_closures()                S_free_closures(aTHX)
 #define save_lines(a,b)                S_save_lines(aTHX_ a,b)
 #define doeval(a,b)            S_doeval(aTHX_ a,b)
 #define doopen_pmc(a,b)                S_doopen_pmc(aTHX_ a,b)
 #define dopoptosub             S_dopoptosub
 #define S_dopoptosub_at                CPerlObj::S_dopoptosub_at
 #define dopoptosub_at          S_dopoptosub_at
-#define S_free_closures                CPerlObj::S_free_closures
-#define free_closures          S_free_closures
 #define S_save_lines           CPerlObj::S_save_lines
 #define save_lines             S_save_lines
 #define S_doeval               CPerlObj::S_doeval
index f004e2c..4cd8aca 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2357,7 +2357,6 @@ s |I32    |dopoptolabel   |char *label
 s      |I32    |dopoptoloop    |I32 startingblock
 s      |I32    |dopoptosub     |I32 startingblock
 s      |I32    |dopoptosub_at  |PERL_CONTEXT* cxstk|I32 startingblock
-s      |void   |free_closures
 s      |void   |save_lines     |AV *array|SV *sv
 s      |OP*    |doeval         |int gimme|OP** startop
 s      |PerlIO *|doopen_pmc    |const char *name|const char *mode
diff --git a/op.c b/op.c
index cca2310..421dc9e 100644 (file)
--- a/op.c
+++ b/op.c
@@ -4158,14 +4158,19 @@ Perl_cv_undef(pTHX_ CV *cv)
        SAVEVPTR(PL_curpad);
        PL_curpad = 0;
 
-       if (!CvCLONED(cv))
-           op_free(CvROOT(cv));
+       op_free(CvROOT(cv));
        CvROOT(cv) = Nullop;
        LEAVE;
     }
     SvPOK_off((SV*)cv);                /* forget prototype */
     CvGV(cv) = Nullgv;
-    SvREFCNT_dec(CvOUTSIDE(cv));
+    /* Since closure prototypes have the same lifetime as the containing
+     * CV, they don't hold a refcount on the outside CV.  This avoids
+     * the refcount loop between the outer CV (which keeps a refcount to
+     * the closure prototype in the pad entry for pp_anoncode()) and the
+     * closure prototype, and the ensuing memory leak.  --GSAR */
+    if (!CvANON(cv) || CvCLONED(cv))
+       SvREFCNT_dec(CvOUTSIDE(cv));
     CvOUTSIDE(cv) = Nullcv;
     if (CvCONST(cv)) {
        SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
@@ -4279,7 +4284,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     CvFILE(cv)         = CvFILE(proto);
     CvGV(cv)           = CvGV(proto);
     CvSTASH(cv)                = CvSTASH(proto);
-    CvROOT(cv)         = CvROOT(proto);
+    CvROOT(cv)         = OpREFCNT_inc(CvROOT(proto));
     CvSTART(cv)                = CvSTART(proto);
     if (outside)
        CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
@@ -4675,8 +4680,30 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        CvOUTSIDE(PL_compcv) = 0;
        CvPADLIST(cv) = CvPADLIST(PL_compcv);
        CvPADLIST(PL_compcv) = 0;
-       if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
-           CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
+       /* inner references to PL_compcv must be fixed up ... */
+       {
+           AV *padlist = CvPADLIST(cv);
+           AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+           AV *comppad = (AV*)AvARRAY(padlist)[1];
+           SV **namepad = AvARRAY(comppad_name);
+           SV **curpad = AvARRAY(comppad);
+           for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+               SV *namesv = namepad[ix];
+               if (namesv && namesv != &PL_sv_undef
+                   && *SvPVX(namesv) == '&')
+               {
+                   CV *innercv = (CV*)curpad[ix];
+                   if (CvOUTSIDE(innercv) == PL_compcv) {
+                       CvOUTSIDE(innercv) = cv;
+                       if (!CvANON(innercv) || CvCLONED(innercv)) {
+                           (void)SvREFCNT_inc(cv);
+                           SvREFCNT_dec(PL_compcv);
+                       }
+                   }
+               }
+           }
+       }
+       /* ... before we throw it away */
        SvREFCNT_dec(PL_compcv);
     }
     else {
@@ -4779,6 +4806,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
     }
 
+    /* If a potential closure prototype, don't keep a refcount on outer CV.
+     * This is okay as the lifetime of the prototype is tied to the
+     * lifetime of the outer CV.  Avoids memory leak due to reference
+     * loop. --GSAR */
+    if (!name)
+       SvREFCNT_dec(CvOUTSIDE(cv));
+
     if (name || aname) {
        char *s;
        char *tname = (name ? name : aname);
diff --git a/op.h b/op.h
index b1b11a5..6c62942 100644 (file)
--- a/op.h
+++ b/op.h
@@ -413,19 +413,17 @@ struct loop {
 #  define OP_REFCNT_LOCK               MUTEX_LOCK(&PL_op_mutex)
 #  define OP_REFCNT_UNLOCK             MUTEX_UNLOCK(&PL_op_mutex)
 #  define OP_REFCNT_TERM               MUTEX_DESTROY(&PL_op_mutex)
-#  define OpREFCNT_set(o,n)            ((o)->op_targ = (n))
-#  define OpREFCNT_inc(o)              ((o) ? (++(o)->op_targ, (o)) : Nullop)
-#  define OpREFCNT_dec(o)              (--(o)->op_targ)
 #else
 #  define OP_REFCNT_INIT               NOOP
 #  define OP_REFCNT_LOCK               NOOP
 #  define OP_REFCNT_UNLOCK             NOOP
 #  define OP_REFCNT_TERM               NOOP
-#  define OpREFCNT_set(o,n)            NOOP
-#  define OpREFCNT_inc(o)              (o)
-#  define OpREFCNT_dec(o)              0
 #endif
 
+#define OpREFCNT_set(o,n)              ((o)->op_targ = (n))
+#define OpREFCNT_inc(o)                        ((o) ? (++(o)->op_targ, (o)) : Nullop)
+#define OpREFCNT_dec(o)                        (--(o)->op_targ)
+
 /* flags used by Perl_load_module() */
 #define PERL_LOADMOD_DENY              0x1
 #define PERL_LOADMOD_NOIMPORT          0x2
index 1cb3a0c..3454edd 100644 (file)
@@ -1039,7 +1039,7 @@ Tests if some arbitrary number of bytes begins in a valid UTF-8
 character.  Note that an ASCII character is a valid UTF-8 character.
 The actual number of bytes in the UTF-8 character will be returned if
 it is valid, otherwise 0.
+
        STRLEN  is_utf8_char(U8 *p)
 
 =for hackers
@@ -3268,6 +3268,44 @@ Converts the specified character to uppercase.
 =for hackers
 Found in file handy.h
 
+=item utf8n_to_uvchr
+
+Returns the native character value of the first character in the string C<s>
+which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+length, in bytes, of that character.
+
+Allows length and flags to be passed to low level routine.
+
+       UV      utf8n_to_uvchr(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags)
+
+=for hackers
+Found in file utf8.c
+
+=item utf8n_to_uvuni
+
+Bottom level UTF-8 decode routine.
+Returns the unicode code point value of the first character in the string C<s>
+which is assumed to be in UTF8 encoding and no longer than C<curlen>;
+C<retlen> will be set to the length, in bytes, of that character.
+
+If C<s> does not point to a well-formed UTF8 character, the behaviour
+is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
+it is assumed that the caller will raise a warning, and this function
+will silently just set C<retlen> to C<-1> and return zero.  If the
+C<flags> does not contain UTF8_CHECK_ONLY, warnings about
+malformations will be given, C<retlen> will be set to the expected
+length of the UTF-8 character in bytes, and zero will be returned.
+
+The C<flags> can also contain various flags to allow deviations from
+the strict UTF-8 encoding (see F<utf8.h>).
+
+Most code should use utf8_to_uvchr() rather than call this directly.
+
+       UV      utf8n_to_uvuni(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags)
+
+=for hackers
+Found in file utf8.c
+
 =item utf8_distance
 
 Returns the number of UTF8 characters between the UTF-8 pointers C<a>
@@ -3321,56 +3359,69 @@ removed without notice.
 =for hackers
 Found in file utf8.c
 
-=item utf8_to_uv
+=item utf8_to_uvchr
 
-Returns the character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding and no longer than C<curlen>;
-C<retlen> will be set to the length, in bytes, of that character.
-
-If C<s> does not point to a well-formed UTF8 character, the behaviour
-is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
-it is assumed that the caller will raise a warning, and this function
-will silently just set C<retlen> to C<-1> and return zero.  If the
-C<flags> does not contain UTF8_CHECK_ONLY, warnings about
-malformations will be given, C<retlen> will be set to the expected
-length of the UTF-8 character in bytes, and zero will be returned.
+Returns the native character value of the first character in the string C<s>
+which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+length, in bytes, of that character.
 
-The C<flags> can also contain various flags to allow deviations from
-the strict UTF-8 encoding (see F<utf8.h>).
+If C<s> does not point to a well-formed UTF8 character, zero is
+returned and retlen is set, if possible, to -1.
 
-       UV      utf8_to_uv(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags)
+       UV      utf8_to_uvchr(U8 *s, STRLEN* retlen)
 
 =for hackers
 Found in file utf8.c
 
-=item utf8_to_uv_simple
+=item utf8_to_uvuni
 
-Returns the character value of the first character in the string C<s>
+Returns the Unicode code point of the first character in the string C<s>
 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
 length, in bytes, of that character.
 
+This function should only be used when returned UV is considered
+an index into the Unicode semantic tables (e.g. swashes).
+
 If C<s> does not point to a well-formed UTF8 character, zero is
 returned and retlen is set, if possible, to -1.
 
-       UV      utf8_to_uv_simple(U8 *s, STRLEN* retlen)
+       UV      utf8_to_uvuni(U8 *s, STRLEN* retlen)
+
+=for hackers
+Found in file utf8.c
+
+=item uvchr_to_utf8
+
+Adds the UTF8 representation of the Native codepoint C<uv> to the end
+of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
+bytes available. The return value is the pointer to the byte after the
+end of the new character. In other words,
+
+    d = uvchr_to_utf8(d, uv);
+
+is the recommended wide native character-aware way of saying
+
+    *(d++) = uv;
+
+       U8*     uvchr_to_utf8(U8 *d, UV uv)
 
 =for hackers
 Found in file utf8.c
 
-=item uv_to_utf8
+=item uvuni_to_utf8
 
 Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
 of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
 bytes available. The return value is the pointer to the byte after the
-end of the new character. In other words, 
+end of the new character. In other words,
 
-    d = uv_to_utf8(d, uv);
+    d = uvuni_to_utf8(d, uv);
 
 is the recommended Unicode-aware way of saying
 
     *(d++) = uv;
 
-       U8*     uv_to_utf8(U8 *d, UV uv)
+       U8*     uvuni_to_utf8(U8 *d, UV uv)
 
 =for hackers
 Found in file utf8.c
index 8985cca..ede5aba 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1380,41 +1380,6 @@ Perl_dounwind(pTHX_ I32 cxix)
     }
 }
 
-/*
- * Closures mentioned at top level of eval cannot be referenced
- * again, and their presence indirectly causes a memory leak.
- * (Note that the fact that compcv and friends are still set here
- * is, AFAIK, an accident.)  --Chip
- *
- * XXX need to get comppad et al from eval's cv rather than
- * relying on the incidental global values.
- */
-STATIC void
-S_free_closures(pTHX)
-{
-    SV **svp = AvARRAY(PL_comppad_name);
-    I32 ix;
-    for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
-       SV *sv = svp[ix];
-       if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
-           SvREFCNT_dec(sv);
-           svp[ix] = &PL_sv_undef;
-
-           sv = PL_curpad[ix];
-           if (CvCLONE(sv)) {
-               SvREFCNT_dec(CvOUTSIDE(sv));
-               CvOUTSIDE(sv) = Nullcv;
-           }
-           else {
-               SvREFCNT_dec(sv);
-               sv = NEWSV(0,0);
-               SvPADTMP_on(sv);
-               PL_curpad[ix] = sv;
-           }
-       }
-    }
-}
-
 void
 Perl_qerror(pTHX_ SV *err)
 {
@@ -1951,8 +1916,6 @@ PP(pp_return)
        POPEVAL(cx);
        if (CxTRYBLOCK(cx))
            break;
-       if (AvFILLp(PL_comppad_name) >= 0)
-           free_closures();
        lex_end();
        if (optype == OP_REQUIRE &&
            (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
@@ -3507,9 +3470,6 @@ PP(pp_leaveeval)
     }
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
-    if (AvFILLp(PL_comppad_name) >= 0)
-       free_closures();
-
 #ifdef DEBUGGING
     assert(CvDEPTH(PL_compcv) == 1);
 #endif
diff --git a/proto.h b/proto.h
index 7a426be..4e8abe0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1095,7 +1095,6 @@ STATIC I32        S_dopoptolabel(pTHX_ char *label);
 STATIC I32     S_dopoptoloop(pTHX_ I32 startingblock);
 STATIC I32     S_dopoptosub(pTHX_ I32 startingblock);
 STATIC I32     S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock);
-STATIC void    S_free_closures(pTHX);
 STATIC void    S_save_lines(pTHX_ AV *array, SV *sv);
 STATIC OP*     S_doeval(pTHX_ int gimme, OP** startop);
 STATIC PerlIO *        S_doopen_pmc(pTHX_ const char *name, const char *mode);
diff --git a/sv.c b/sv.c
index 0a2c2c0..36735ae 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -8179,7 +8179,10 @@ dup_pvcv:
        }
        else
            CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
-       CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
+       if (!CvANON(sstr) || CvCLONED(sstr))
+           CvOUTSIDE(dstr)     = cv_dup_inc(CvOUTSIDE(sstr));
+       else
+           CvOUTSIDE(dstr)     = cv_dup(CvOUTSIDE(sstr));
        CvFLAGS(dstr)   = CvFLAGS(sstr);
        break;
     default:
diff --git a/t/op/anonsub.t b/t/op/anonsub.t
new file mode 100755 (executable)
index 0000000..17889d9
--- /dev/null
@@ -0,0 +1,93 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = '../lib';
+$Is_VMS = $^O eq 'VMS';
+$Is_MSWin32 = $^O eq 'MSWin32';
+$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "asubtmp000";
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile; } }
+
+for (@prgs){
+    my $switch = "";
+    if (s/^\s*(-\w+)//){
+       $switch = $1;
+    }
+    my($prog,$expected) = split(/\nEXPECT\n/, $_);
+    open TEST, ">$tmpfile";
+    print TEST "$prog\n";
+    close TEST;
+    my $results = $Is_VMS ?
+                  `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
+                     $Is_MSWin32 ?  
+                         `.\\perl -I../lib $switch $tmpfile 2>&1` :
+                             `./perl $switch $tmpfile 2>&1`;
+    my $status = $?;
+    $results =~ s/\n+$//;
+    # allow expected output to be written as if $prog is on STDIN
+    $results =~ s/runltmp\d+/-/g;
+    $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
+    $expected =~ s/\n+$//;
+    if ($results ne $expected) {
+       print STDERR "PROG: $switch\n$prog\n";
+       print STDERR "EXPECTED:\n$expected\n";
+       print STDERR "GOT:\n$results\n";
+       print "not ";
+    }
+    print "ok ", ++$i, "\n";
+}
+
+__END__
+sub X {
+    my $n = "ok 1\n";
+    sub { print $n };
+}
+my $x = X();
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X {
+    my $n = "ok 1\n";
+    sub {
+        my $dummy = $n;        # eval can't close on $n without internal reference
+       eval 'print $n';
+       die $@ if $@;
+    };
+}
+my $x = X();
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X {
+    my $n = "ok 1\n";
+    eval 'sub { print $n }';
+}
+my $x = X();
+die $@ if $@;
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X;
+sub X {
+    my $n = "ok 1\n";
+    eval 'sub Y { my $p = shift; $p->() }';
+    die $@ if $@;
+    Y(sub { print $n });
+}
+X();
+EXPECT
+ok 1