develooper Front page | perl.perl5.porters | Postings from March 2003

[PATCH] Re: [PATCH] Re: [perl #21614] 5.8.0 Unbalanced string table refcount

Thread Previous | Thread Next
From:
Nicholas Clark
Date:
March 26, 2003 15:05
Subject:
[PATCH] Re: [PATCH] Re: [perl #21614] 5.8.0 Unbalanced string table refcount
Message ID:
20030326230145.GC279@Bagpuss.unfortu.net
On Wed, Mar 26, 2003 at 11:30:05PM +0100, Rafael Garcia-Suarez wrote:
> Nicholas Clark wrote:
> > 
> > I think that the appended works. The test fails on 5.8.0 and unpatched blead.
> > It passes on blead with and without COW. It doubt that the sv.c patch will
> > apply to maint because the code's been moved around quite a bit.
> 
> Anyway, thanks, applied as #19069 to bleadperl.

Oh er erk. I've been working on a better one, which is tested, and I don't
have time to resync to 19069 and then retry. Would it be possible to revert
19069 and apply the appended to blead. The first two hunks (readline.t and
pp_hot.c apply to maint. Without the pp_hot.c fix maint goes:

$ PERL_DESTRUCT_LEVEL=2 ./perl /stuff/blead/19055-g/t/op/readline.t
1..11
ok 1 - [perl \#19566]
ok 2 - \#21628 - $a .= <A> , A eof
ok 3 - \#21628 - $a .= <A> , A closed
not ok 4 - [perl \#21614] for length 1
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
#      got 'endUnbalanced string table refcount: (1) for "k" during global destruction.
# '
# expected 'end'
not ok 5 - [perl \#21614] for length 82
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
#      got 'endUnbalanced string table refcount: (1) for "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk" during global destruction.
# '
# expected 'end'
not ok 6 - rcatline to shared sv for length 4
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
#      got 'perl rulesUnbalanced string table refcount: (1) for "perl" during global destruction.
# '
# expected 'perl rules'
not ok 7 - rcatline to shared sv for length 84
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
#      got 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rulesUnbalanced string table refcount: (1) for "perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl" during global destruction.
# '
# expected 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules'
ok 8 - catline to COW sv for length 1
ok 9 - catline to COW sv for length 82
ok 10 - rcatline to COW sv for length 4
ok 11 - rcatline to COW sv for length 84

Without the patch, blead with COW looks like this:
$ PERL_DESTRUCT_LEVEL=2 ./perl /stuff/blead/19055-g/t/op/readline.t
1..11
ok 1 - [perl \#19566]
ok 2 - \#21628 - $a .= <A> , A eof
ok 3 - \#21628 - $a .= <A> , A closed
Segmentation fault - core dumped
not ok 4 - [perl \#21614] for length 1
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
#      got ''
# expected 'end'
Segmentation fault - core dumped
not ok 5 - [perl \#21614] for length 82
# Failed at /stuff/blead/19055-g/t/op/readline.t line 28
#      got ''
# expected 'end'
Segmentation fault - core dumped
not ok 6 - rcatline to shared sv for length 4
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
#      got ''
# expected 'perl rules'
Segmentation fault - core dumped
not ok 7 - rcatline to shared sv for length 84
# Failed at /stuff/blead/19055-g/t/op/readline.t line 37
#      got ''
# expected 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules'
ok 8 - catline to COW sv for length 1
ok 9 - catline to COW sv for length 82
not ok 10 - rcatline to COW sv for length 4
# Failed at /stuff/blead/19055-g/t/op/readline.t line 54
#      got 'catl rules
# '
# expected 'perl rules
# '
not ok 11 - rcatline to COW sv for length 84
# Failed at /stuff/blead/19055-g/t/op/readline.t line 54
#      got '# expected \'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules
# '
# expected 'perlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperlperl rules
# '

)

> BTW I notice that SvIsCOW is not documented in perlapi.pod. That's un-nice.

I won't manage that tonight - I'm about to go to bed.

Nicholas Clark

--- t/op/readline.t.orig	Thu Mar 20 23:53:46 2003
+++ t/op/readline.t	Wed Mar 26 21:28:07 2003
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 3;
+plan tests => 11;
 
 eval { for (\2) { $_ = <FH> } };
 like($@, 'Modification of a read-only value attempted', '[perl #19566]');
@@ -18,3 +18,43 @@ like($@, 'Modification of a read-only va
   is($a .= <A>, 4, '#21628 - $a .= <A> , A closed');
   unlink "a";
 }
+
+# 82 is chosen to exceed the length for sv_grow in do_readline (80)
+foreach my $k ('k', 'k'x82) {
+  my $result
+    = runperl (switches => '-l', stdin => '', stderr => 1,
+	       prog => "%a = qw($k v); \$_ = <> foreach keys %a; print qw(end)",
+	      );
+  is ($result, "end", '[perl #21614] for length ' . length $k);
+}
+
+
+foreach my $k ('perl', 'perl'x21) {
+  my $result
+    = runperl (switches => '-l', stdin => ' rules', stderr => 1,
+	       prog => "%a = qw($k v); foreach (keys %a) {\$_ .= <>; print}",
+	      );
+  is ($result, "$k rules", 'rcatline to shared sv for length ' . length $k);
+}
+
+foreach my $l (1, 82) {
+  my $k = $l;
+  $k = 'k' x $k;
+  my $copy = $k;
+  $k = <DATA>;
+  is ($k, "moo\n", 'catline to COW sv for length ' . length $copy);
+}
+
+
+foreach my $l (1, 21) {
+  my $k = $l;
+  $k = 'perl' x $k;
+  my $perl = $k;
+  $k .= <DATA>;
+  is ($k, "$perl rules\n", 'rcatline to COW sv for length ' . length $perl);
+}
+__DATA__
+moo
+moo
+ rules
+ rules
--- pp_hot.c.orig	Thu Mar 20 23:53:46 2003
+++ pp_hot.c	Wed Mar 26 22:08:59 2003
@@ -1509,7 +1509,7 @@ Perl_do_readline(pTHX)
 	    sv_unref(sv);
 	(void)SvUPGRADE(sv, SVt_PV);
 	tmplen = SvLEN(sv);	/* remember if already alloced */
-	if (!tmplen)
+	if (!tmplen && !SvREADONLY(sv))
 	    Sv_Grow(sv, 80);	/* try short-buffering it */
 	offset = 0;
 	if (type == OP_RCATLINE && SvOK(sv)) {
--- sv.c.orig	Wed Mar 12 12:11:43 2003
+++ sv.c	Wed Mar 26 22:09:47 2003
@@ -4448,11 +4448,11 @@ Perl_sv_force_normal_flags(pTHX_ registe
 	    char *pvx = SvPVX(sv);
 	    STRLEN len = SvCUR(sv);
             U32 hash   = SvUVX(sv);
+	    SvFAKE_off(sv);
+	    SvREADONLY_off(sv);
 	    SvGROW(sv, len + 1);
 	    Move(pvx,SvPVX(sv),len,char);
 	    *SvEND(sv) = '\0';
-	    SvFAKE_off(sv);
-	    SvREADONLY_off(sv);
 	    unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
 	}
 	else if (PL_curcop != &PL_compiling)
@@ -6289,7 +6289,8 @@ Perl_sv_gets(pTHX_ register SV *sv, regi
     I32 rspara = 0;
     I32 recsize;
 
-    SV_CHECK_THINKFIRST_COW_DROP(sv);
+    if (SvTHINKFIRST(sv))
+	sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
     /* XXX. If you make this PVIV, then copy on write can copy scalars read
        from <>.
        However, perlbench says it's slower, because the existing swipe code

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About