Skip Menu |
Report information
Id: 38809
Status: resolved
Priority: 0/
Queue: perl5

Owner: Nobody
Requestors: christian.jaeger [at] sl.ethz.ch
vince [at] midori.profvince.com
Cc:
AdminCc:

Operating System: Linux
PatchStatus: HasPatch
Severity: medium
Type: core
Perl Version: 5.8.8
Fixed In: (no value)



Date: Sat, 25 May 2002 19:10:17 +0200
To: perlbug [...] perl.org
From: Christian Jaeger <christian.jaeger [...] sl.ethz.ch>
Subject: do{} loosing value
Hello When putting a do{} block inside an if statement inside a subroutine, and declaring a lexical variable in it, it will give back 'undef' regardless of the last value inside it. This is bad for me since it prevents autogenerated perl code (output from a perl source code filter) using do{} to encapsulate code pieces from working reliably. Cheers, Christian. use strict; sub DEBUG(){0}; sub mysub { if (1) { # if(){} needed to trigger bug return do{ my $rv= "Hello World"; warn "rv='$rv'" if DEBUG; $rv; #"jhjj"; # Not even this string will make it through when uncommented, # as long as 'my $rv' is there. }; } else { die } } my $value= mysub(); print "Got: '$value'\n" if DEBUG; print defined $value ? "ok\n" : "not ok\n"; __END__ With DEBUG set to 1 this gives: chris@pflanze html > perl -w perl_do_bug.pl rv='Hello World' at perl_do_bug.pl line 7. Use of uninitialized value in concatenation (.) or string at perl_do_bug.pl line 17. Got: '' not ok chris@pflanze html > perl --version This is perl, v5.6.1 built for i386-linux Same result under perl 5.005_03 on linux/ppc.
Date: Sat, 25 May 2002 16:57:08 -0400
From: Michael G Schwern <schwern [...] pobox.com>
Subject: Re: [ID 20020525.001] do{} loosing value
To: Christian Jaeger <christian.jaeger [...] sl.ethz.ch>
Cc: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.5k
On Sat, May 25, 2002 at 07:10:17PM +0200, Christian Jaeger wrote: Show quoted text
> use strict; > sub DEBUG(){0}; > sub mysub { > if (1) { # if(){} needed to trigger bug
Not just if(){}, but it has to be if(CONSTANT){}. Which makes me think something is being optimized away. use strict; sub DEBUG(){1}; my $foo = 1; sub mysub { if (1==1) { return do{ my $rv= "Hello World"; warn "rv='$rv'" if DEBUG; $rv; }; } } my $value= mysub(); print "Got: '$value'\n" if DEBUG; print defined $value ? "ok\n" : "not ok\n"; the above... $ bleadperl ~/tmp/bug.plx rv='Hello World' at /home/schwern/tmp/bug.plx line 8. Got: '' not ok and then this: use strict; sub DEBUG(){1}; my $foo = 1; sub mysub { if ($foo) { return do{ my $rv= "Hello World"; warn "rv='$rv'" if DEBUG; $rv; }; } } my $value= mysub(); print "Got: '$value'\n" if DEBUG; print defined $value ? "ok\n" : "not ok\n"; $ bleadperl ~/tmp/bug.plx rv='Hello World' at /home/schwern/tmp/bug.plx line 8. Got: 'Hello World' ok the only difference being that the if condition is variable. This screams optimizer bug. Oddly enough, with an explicit "return $rv" it works fine. Bug appears in at least 5.004, 5.005_03, 5.6.0, 5.6.1 and bleadperl. -- This sig file temporarily out of order.
Date: Sun, 26 May 2002 03:21:18 +0200
To: perl5-porters [...] perl.org
From: Christian Jaeger <christian.jaeger [...] sl.ethz.ch>
Subject: Re: [ID 20020525.001] do{} loosing value
Download (untitled) / with headers
text/plain 949b
At 16:57 Uhr -0400 25.05.2002, Michael G Schwern wrote: Show quoted text
>On Sat, May 25, 2002 at 07:10:17PM +0200, Christian Jaeger wrote:
>> use strict; >> sub DEBUG(){0};
> > sub mysub {
>> if (1) { # if(){} needed to trigger bug
> >Not just if(){}, but it has to be if(CONSTANT){}. Which makes me think >something is being optimized away.
Hmm, the original code that exposed the bug didn't have a constant there, but instead it was about this: sub somesub { my ($arg)=@_; if ($arg->[3] eq 'Something') { ... return do { my $rv= \ eval { ... return $value }; if ($@) { ... } $$rv } } if (...) { .. } } I can't reproduce it now separatet from the application, like you I see the bug only using a constant, but i'm sure in the app undef was returned from somesub whereas I could confirm that $$rv was a well defined string. Tell me if you would like more info/ to get me to try to separate the code again. Christian.
CC: vince [...] profvince.com
Subject: Bad return value from a block with variable localization
Date: Tue, 28 Mar 2006 19:50:17 +0200 (CEST)
To: perlbug [...] perl.org
From: vince [...] midori.profvince.com
Download (untitled) / with headers
text/plain 4.3k
This is a bug report for perl from vince@midori.profvince.com, generated with the help of perlbug 1.35 running under perl v5.8.8. ----------------------------------------------------------------- [Please enter your report here] Hello, I've run into this strange behaviour when playing with trying to make functions return different values from the number of parameters they were called with. If you test @_, and that you return from a do { ... } block where a variable is localized, the return value is undef if you don't add an else statement. Looks like some parsing bug, but not that I'm good enough to have any real clue about it. Regards, Vincent Pit ################################################################# Test case: (line 1 is #!) #!/usr/bin/perl use strict; use warnings; sub foo { if (@_) { return do { my $dummy; 1; }; } else { return 0; } } # let's just remove the else sub bar { if (@_) { return do { my $dummy; 1; }; } return 0; } print foo().' '.foo('baz')."\n"; # that was expected print bar().' '.bar('baz')."\n"; # undef ################################################################# Expected output: 0 1 0 1 ################################################################# Actual output: 0 1 Use of uninitialized value in concatenation (.) or string at ./bug.pl line 24. 0 ################################################################# Remarks: The name of the localized variable doesn't matter. Moreover, it will actually fail as well for local $_ (or any perl variable). But the my/local itself is important, since do { 1 } returns what it should. [Please do not change anything below this line] ----------------------------------------------------------------- --- Flags: category=core severity=medium --- Site configuration information for perl v5.8.8: Configured by vince at Tue Mar 28 18:29:28 CEST 2006. Summary of my perl5 (revision 5 version 8 subversion 8) configuration: Platform: osname=linux, osvers=2.6.15.1-lfs6.0+cvs-midori.profvince.com, archname=i686-linux uname='linux midori 2.6.15.1-lfs6.0+cvs-midori.profvince.com #1 preempt sun jan 22 15:51:10 cet 2006 i686 athlon-4 i386 gnulinux ' config_args='-ds -e -Dprefix=/usr -Dpager=/usr/bin/less -isR -Dccflags= -march=athlon-xp -m3dnow -msse -mfpmath=sse -mmmx -O3 -pipe -funroll-loops' hint=recommended, useposix=true, d_sigaction=define usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef useperlio=define d_sfio=undef uselargefiles=define usesocks=undef use64bitint=undef use64bitall=undef uselongdouble=undef usemymalloc=n, bincompat5005=undef Compiler: cc='cc', ccflags ='-march=athlon-xp -m3dnow -msse -mfpmath=sse -mmmx -O3 -pipe -funroll-loops -fno-strict-aliasing -Wdeclaration-after-statement -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64', optimize='-O2', cppflags='-march=athlon-xp -m3dnow -msse -mfpmath=sse -mmmx -O3 -pipe -funroll-loops -fno-strict-aliasing -Wdeclaration-after-statement -I/usr/local/include' ccversion='', gccversion='3.4.3', gccosandvers='' intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234 d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12 ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8 alignbytes=4, prototype=define Linker and Libraries: ld='cc', ldflags =' -L/usr/local/lib' libpth=/usr/local/lib /lib /usr/lib libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc libc=/lib/libc-2.3.4.so, so=so, useshrplib=false, libperl=libperl.a gnulibc_version='2.3.4' Dynamic Linking: dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E' cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib' Locally applied patches: --- @INC for perl v5.8.8: /usr/lib/perl5/5.8.8/i686-linux /usr/lib/perl5/5.8.8 /usr/lib/perl5/site_perl/5.8.8/i686-linux /usr/lib/perl5/site_perl/5.8.8 /usr/lib/perl5/site_perl/5.8.6/i686-linux /usr/lib/perl5/site_perl/5.8.6 /usr/lib/perl5/site_perl . --- Environment for perl v5.8.8: HOME=/home/vince LANG=fr_FR.ISO-8859-1 LANGUAGE=fr_FR.ISO-8859-1 LC_ALL=fr_FR.ISO-8859-1 LD_LIBRARY_PATH (unset) LOGDIR (unset) PATH=/usr/local/bin:/usr/bin:/bin:/usr/sbin:/sbin:/home/vince/bin PERL_BADLANG (unset) SHELL=/bin/bash
Subject: [perl #38809][PATCH] loss of stack elements with a do block inside a return
Date: Sat, 30 Aug 2008 17:25:18 +0200
To: perl5-porters [...] perl.org
From: Vincent Pit <perl [...] profvince.com>
Download (untitled) / with headers
text/plain 1016b
This is the bug that makes sub foo { do { return do { 1; 2 } }; 3 } returns undef. The 1 is here to prevent the return do block to be optimized away, and the 3 to ensure that the first statement receives void context. Concise says : 1 <;> nextstate(main 3 -e:1) v 2 <0> enter v 3 <;> nextstate(main 2 -e:1) v 4 <0> pushmark s 5 <0> enter 6 <;> nextstate(main 1 -e:1) v 7 <;> nextstate(main 1 -e:1) v 8 <$> const[IV 2] s 9 <@> leave KP a <@> return K b <@> leave vKP c <;> nextstate(main 3 -e:1) v d <$> const[IV 3] s e <1> leavesub[1 ref] K/REFC,1 The problem is that the enter after the pushmark has no context and hence its associated leave won't drop its return value on the stack. The patch attached is a way better solution compared to the previous one I sent some months ago. In ck_return, it looks at the kids and force list context on NULLs that have the OPf_SPECIAL flag set (which corresponds to do { } blocks, op.h says). Maybe other kids could receive the same treatment. Vincent.
Download perl-rt38809.patch
text/plain 1.1k
--- op.c 2008-06-17 13:25:08.000000000 +0200 +++ op.c 2008-08-30 17:21:16.000000000 +0200 @@ -7561,13 +7561,19 @@ Perl_ck_return(pTHX_ OP *o) { dVAR; + OP *kid; PERL_ARGS_ASSERT_CK_RETURN; + kid = cLISTOPo->op_first->op_sibling; if (CvLVALUE(PL_compcv)) { - OP *kid; - for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); + } else { + for (; kid; kid = kid->op_sibling) { + if (kid->op_type == OP_NULL && kid->op_flags & OPf_SPECIAL) /* do */ + list(kid); + } } return o; } --- t/op/do.t 2007-01-08 22:22:52.000000000 +0100 +++ t/op/do.t 2008-08-30 16:32:00.000000000 +0200 @@ -29,7 +29,7 @@ return $ok; } -print "1..22\n"; +print "1..23\n"; # Test do &sub and proper @_ handling. $_[0] = 0; @@ -92,6 +92,10 @@ push @t, ($u = (do {} . "This should be pushed.")); ok( $#t == 0, "empty do result value" ); +# [perl #38809] +@a = sub { do { return 38, do { 1; 80, 9 } }; 2 }->(); +ok( join('', @a) eq '38809', "do blocks in return should have list context" ); + END { 1 while unlink("$$.16", "$$.17", "$$.18"); }
Subject: Re: [perl #38809][PATCH] loss of stack elements with a do block inside a return
Date: Sun, 31 Aug 2008 16:39:32 +0200
To: perl5-porters [...] perl.org
From: Vincent Pit <perl [...] profvince.com>
Download (untitled) / with headers
text/plain 582b
Show quoted text
> The patch attached is a way better solution compared to the previous one > I sent some months ago. In ck_return, it looks at the kids and force > list context on NULLs that have the OPf_SPECIAL flag set
Except that I realized that this solution would obviously not propagate the caller's context to the block. The only way I found was then to add an private flag for leave ops, turn it on in ck_return for those that are kids of a return op, and in pp_leave use the caller's context instead of the upper block one when the flag is set. Corrected patch attached with more tests.
--- op.c 2008-06-17 13:25:08.000000000 +0200 +++ op.c 2008-08-31 16:29:34.000000000 +0200 @@ -7561,14 +7561,25 @@ Perl_ck_return(pTHX_ OP *o) { dVAR; + OP *kid; PERL_ARGS_ASSERT_CK_RETURN; + kid = cLISTOPo->op_first->op_sibling; if (CvLVALUE(PL_compcv)) { - OP *kid; - for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); + } else { + for (; kid; kid = kid->op_sibling) + if (kid->op_type == OP_NULL && kid->op_flags & OPf_SPECIAL) { + /* This is a do block */ + assert(cUNOPx(kid)->op_first); + assert(cUNOPx(kid)->op_first->op_type == OP_LEAVE); + /* Force the use of the caller's context */ + cUNOPx(kid)->op_first->op_private |= OPpLEAVE_INRETURN; + } } + return o; } --- op.h 2008-06-08 17:41:31.000000000 +0200 +++ op.h 2008-08-31 15:52:26.000000000 +0200 @@ -158,6 +158,9 @@ /* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */ #define OPpREFCOUNTED 64 /* op_targ carries a refcount */ +/* Private for OP_LEAVE */ +#define OPpLEAVE_INRETURN 128 /* Use subroutine context */ + /* Private for OP_AASSIGN */ #define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */ --- pp_hot.c 2008-06-28 23:11:23.000000000 +0200 +++ pp_hot.c 2008-08-31 16:28:44.000000000 +0200 @@ -1860,9 +1860,13 @@ gimme = OP_GIMME(PL_op, -1); if (gimme == -1) { - if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else + if (cxstack_ix >= 0) { + /* If this flag is set, we're just inside a return, so we should + * apply the caller's context */ + gimme = (PL_op->op_private & OPpLEAVE_INRETURN) + ? block_gimme() + : cxstack[cxstack_ix].blk_gimme; + } else gimme = G_SCALAR; } --- t/op/do.t 2007-01-08 22:22:52.000000000 +0100 +++ t/op/do.t 2008-08-31 14:34:36.000000000 +0200 @@ -29,7 +29,7 @@ return $ok; } -print "1..22\n"; +print "1..26\n"; # Test do &sub and proper @_ handling. $_[0] = 0; @@ -92,6 +92,18 @@ push @t, ($u = (do {} . "This should be pushed.")); ok( $#t == 0, "empty do result value" ); +# [perl #38809] +@a = (7, 8); +$x = sub { do { return do { 1; @a } }; 3 }->(); +ok(defined $x && $x == 2, 'return do { } receives caller scalar context'); +@x = sub { do { return do { 1; @a } }; 3 }->(); +ok("@x" eq "7 8", 'return do { } receives caller list context'); +@a = (7, 8, 9); +$x = sub { do { do { 1; return @a } }; 4 }->(); +ok(defined $x && $x == 3, 'do { return } receives caller scalar context'); +@x = sub { do { do { 1; return @a } }; 4 }->(); +ok("@x" eq "7 8 9", 'do { return } receives caller list context'); + END { 1 while unlink("$$.16", "$$.17", "$$.18"); }
Subject: [perl #38809] return do { } : take 3 (or 4...)
Date: Mon, 29 Sep 2008 17:36:09 +0200
To: perl5-porters [...] perl.org
From: Vincent Pit <perl [...] profvince.com>
Download (untitled) / with headers
text/plain 706b
Attached is another patch for 38809. It does essentially two things. - Mark ENTER ops that follows a return as SPECIAL at compile time. - Set the gimme value of those blocks in pp_enter as the caller's one. It's very similar to the previous one, except that it used to look for the caller context in LEAVE instead of ENTER, which made it impossible to handle cases like return do { 1; do { 2; @a } } This is fixed with this version. I'm not feeling that easy by looking at the caller's context in pp_enter, but we need this information to solve the problem, and we need it there, so I'm afraid it's the only way to get over it (besides ignoring the bug :) ). Tests included, ok with blead. Vincent.
--- op.c 2008-09-19 23:04:16.000000000 +0200 +++ op.c 2008-09-29 17:09:05.000000000 +0200 @@ -7625,14 +7625,28 @@ Perl_ck_return(pTHX_ OP *o) { dVAR; + OP *kid; PERL_ARGS_ASSERT_CK_RETURN; + kid = cLISTOPo->op_first->op_sibling; if (CvLVALUE(PL_compcv)) { - OP *kid; - for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); + } else { + for (; kid; kid = kid->op_sibling) + if ((kid->op_type == OP_NULL) + && (kid->op_flags & OPf_SPECIAL)) { + /* This is a do block */ + OP *op = cUNOPx(kid)->op_first; + assert(op && (op->op_type == OP_LEAVE) && (op->op_flags & OPf_KIDS)); + op = cUNOPx(op)->op_first; + assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL)); + /* Force the use of the caller's context */ + op->op_flags |= OPf_SPECIAL; + } } + return o; } --- op.h 2008-09-19 23:04:16.000000000 +0200 +++ op.h 2008-09-29 17:09:05.000000000 +0200 @@ -137,6 +137,7 @@ /* On OP_SMARTMATCH, an implicit smartmatch */ /* On OP_ANONHASH and OP_ANONLIST, create a reference to the new anon hash or array */ + /* On OP_ENTER, store caller context */ /* old names; don't use in new code, but don't break them, either */ #define OPf_LIST OPf_WANT_LIST --- pp_hot.c 2008-09-19 23:04:19.000000000 +0200 +++ pp_hot.c 2008-09-29 17:09:05.000000000 +0200 @@ -1748,9 +1748,13 @@ I32 gimme = OP_GIMME(PL_op, -1); if (gimme == -1) { - if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else + if (cxstack_ix >= 0) { + /* If this flag is set, we're just inside a return, so we should + * store the caller's context */ + gimme = (PL_op->op_flags & OPf_SPECIAL) + ? block_gimme() + : cxstack[cxstack_ix].blk_gimme; + } else gimme = G_SCALAR; } @@ -1858,13 +1862,7 @@ POPBLOCK(cx,newpm); - gimme = OP_GIMME(PL_op, -1); - if (gimme == -1) { - if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; - } + gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); TAINT_NOT; if (gimme == G_VOID) --- t/op/do.t 2008-09-19 23:04:20.000000000 +0200 +++ t/op/do.t 2008-09-29 17:09:41.000000000 +0200 @@ -29,7 +29,7 @@ return $ok; } -print "1..26\n"; +print "1..32\n"; # Test do &sub and proper @_ handling. $_[0] = 0; @@ -104,6 +104,23 @@ $owww = do { 4 if not $zok }; ok( $owww eq '', 'last is if not' ); +# [perl #38809] +@a = (7, 8); +$x = sub { do { return do { 1; @a } }; 3 }->(); +ok(defined $x && $x == 2, 'return do { } receives caller scalar context'); +@x = sub { do { return do { 1; @a } }; 3 }->(); +ok("@x" eq "7 8", 'return do { } receives caller list context'); +@a = (7, 8, 9); +$x = sub { do { do { 1; return @a } }; 4 }->(); +ok(defined $x && $x == 3, 'do { return } receives caller scalar context'); +@x = sub { do { do { 1; return @a } }; 4 }->(); +ok("@x" eq "7 8 9", 'do { return } receives caller list context'); +@a = (7, 8, 9, 10); +$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); +ok(defined $x && $x == 4, 'return do { do { } } receives caller scalar context'); +@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->(); +ok("@x" eq "7 8 9 10", 'return do { do { } } receives caller list context'); + END { 1 while unlink("$$.16", "$$.17", "$$.18"); }
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 852b
On Mon Sep 29 10:59:21 2008, perl@profvince.com wrote: Show quoted text
> Attached is another patch for 38809. It does essentially two things. > - Mark ENTER ops that follows a return as SPECIAL at compile time. > - Set the gimme value of those blocks in pp_enter as the caller's one. > It's very similar to the previous one, except that it used to look for > the caller context in LEAVE instead of ENTER, which made it impossible > to handle cases like > > return do { 1; do { 2; @a } } > > This is fixed with this version. > I'm not feeling that easy by looking at the caller's context in > pp_enter, but we need this information to solve the problem, and we need > it there, so I'm afraid it's the only way to get over it (besides > ignoring the bug :) ). > Tests included, ok with blead. >
Thanks! I've applied this patch as change #34907. Steve Peters
This was fixed in perl 5.12.0 by change 34907/e91684bfbb744fa7e8f.


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org