Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Bad return value from a block with variable localization #8384

Closed
p5pRT opened this issue Mar 28, 2006 · 16 comments
Closed

Bad return value from a block with variable localization #8384

p5pRT opened this issue Mar 28, 2006 · 16 comments

Comments

@p5pRT
Copy link

p5pRT commented Mar 28, 2006

Migrated from rt.perl.org#38809 (status was 'resolved')

Searchable as RT38809$

@p5pRT
Copy link
Author

p5pRT commented May 25, 2002

From christian.jaeger@sl.ethz.ch

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.

@p5pRT
Copy link
Author

p5pRT commented May 25, 2002

From @schwern

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.

  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.

@p5pRT
Copy link
Author

p5pRT commented May 25, 2002

From [Unknown Contact. See original ticket]

At 16​:57 Uhr -0400 25.05.2002, Michael G Schwern wrote​:

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.

@p5pRT
Copy link
Author

p5pRT commented Mar 28, 2006

From vince@midori.profvince.com

Created by vince@midori.profvince.com

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.

Perl Info

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

@p5pRT
Copy link
Author

p5pRT commented May 16, 2008

p5p@spam.wizbit.be - Status changed from 'new' to 'stalled'

@p5pRT
Copy link
Author

p5pRT commented Aug 30, 2008

From perl@profvince.com

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.

@p5pRT
Copy link
Author

p5pRT commented Aug 30, 2008

From perl@profvince.com

perl-rt38809.patch
--- 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");
 }

@p5pRT
Copy link
Author

p5pRT commented Aug 30, 2008

The RT System itself - Status changed from 'stalled' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Aug 31, 2008

From perl@profvince.com

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.

@p5pRT
Copy link
Author

p5pRT commented Aug 31, 2008

From perl@profvince.com

perl-rt38809-take2.patch
--- 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");
 }

@p5pRT
Copy link
Author

p5pRT commented Sep 29, 2008

From perl@profvince.com

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.

@p5pRT
Copy link
Author

p5pRT commented Sep 29, 2008

From perl@profvince.com

perl-rt38809-take4.patch
--- 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");
 }

@p5pRT
Copy link
Author

p5pRT commented Nov 25, 2008

From @smpeters

On Mon Sep 29 10​:59​:21 2008, perl@​profvince.com wrote​:

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; @&#8203;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

@p5pRT
Copy link
Author

p5pRT commented Nov 25, 2008

@smpeters - Status changed from 'open' to 'resolved'

@p5pRT p5pRT closed this as completed Nov 25, 2008
@p5pRT
Copy link
Author

p5pRT commented Sep 29, 2010

From @cpansprout

This was fixed in perl 5.12.0 by change 34907/e91684bfbb744fa7e8f.

@p5pRT
Copy link
Author

p5pRT commented Sep 29, 2010

@cpansprout - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant