From: Jarkko Hietaniemi Date: Mon, 12 Mar 2001 16:04:47 +0000 (+0000) Subject: Integrate change #9108 from maintperl to mainline. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=282f25c977e1960e4e088425df8229fa6a4a7563;p=p5sagit%2Fp5-mst-13.2.git Integrate change #9108 from maintperl to mainline. fix memory leak in C 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..) --- diff --git a/MANIFEST b/MANIFEST index 33ee169..f2671ef 100644 --- 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 --- a/embed.h +++ b/embed.h @@ -982,7 +982,6 @@ #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 @@ -2465,7 +2464,6 @@ #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) @@ -4806,8 +4804,6 @@ #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 diff --git a/embed.pl b/embed.pl index f004e2c..4cd8aca 100755 --- 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 --- 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 --- 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 diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 1cb3a0c..3454edd 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -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 +which is assumed to be in UTF8 encoding; C 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 +which is assumed to be in UTF8 encoding and no longer than C; +C will be set to the length, in bytes, of that character. + +If C does not point to a well-formed UTF8 character, the behaviour +is dependent on the value of C: if it contains UTF8_CHECK_ONLY, +it is assumed that the caller will raise a warning, and this function +will silently just set C to C<-1> and return zero. If the +C does not contain UTF8_CHECK_ONLY, warnings about +malformations will be given, C will be set to the expected +length of the UTF-8 character in bytes, and zero will be returned. + +The C can also contain various flags to allow deviations from +the strict UTF-8 encoding (see F). + +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 @@ -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 -which is assumed to be in UTF8 encoding and no longer than C; -C will be set to the length, in bytes, of that character. - -If C does not point to a well-formed UTF8 character, the behaviour -is dependent on the value of C: if it contains UTF8_CHECK_ONLY, -it is assumed that the caller will raise a warning, and this function -will silently just set C to C<-1> and return zero. If the -C does not contain UTF8_CHECK_ONLY, warnings about -malformations will be given, C 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 +which is assumed to be in UTF8 encoding; C will be set to the +length, in bytes, of that character. -The C can also contain various flags to allow deviations from -the strict UTF-8 encoding (see F). +If C 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 +Returns the Unicode code point of the first character in the string C which is assumed to be in UTF8 encoding; C 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 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 to the end +of the string C; C should be have at least C 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 to the end of the string C; C should be have at least C 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 diff --git a/pp_ctl.c b/pp_ctl.c index 8985cca..ede5aba 100644 --- 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 --- 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 --- 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 index 0000000..17889d9 --- /dev/null +++ b/t/op/anonsub.t @@ -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", ; +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