Recursive comparison routine can cause segfault in sort #8162
Comments
From houstorx@rpc142.cs.man.ac.ukCreated by houstorx@rpc142.cs.man.ac.ukThe following code causes a segfault on my machine, with every print sort foo (1..2); Presumably it's caused by the fact that pp_sort overwrites the Robin Perl Info |
From @iabynOn Sat, Oct 22, 2005 at 04:37:02PM -0700, houstorx @ rpc142. cs. man. ac. uk wrote:
Yes, the current behaviour is deeply unsatisfactory. It's also not -- |
|
The RT System itself - Status changed from 'new' to 'open' |
From maddingue@free.fr
FWIW, it doesn't crash on my default Perl: $ perl -l rt-37508.pl $ perl -V Characteristics of this binary (from libperl): -- Close the world, txEn eht nepO. |
From @iabynOn Sun, Oct 23, 2005 at 01:13:36PM +0100, Robin Houston wrote:
That still doesn't solve the threads problem, namely that the same op -- |
From @hvdsDave Mitchell <davem@iabyn.com> wrote: Would it be possible to mitigate that by: I think this would allow zero-cost to normal sub execution and shifts Hugo |
From maddingue@free.frRobin Houston <robin@cpan.org> wrote:
I increased the values to, respectively, 1_000_000 and 1_000 but Note that this is a Perl 5.8.5 packaged by Rafael Garcia-Suarez for -- Close the world, txEn eht nepO. |
From robin@cpan.orgOn Sun, Oct 23, 2005 at 01:46:13PM +0100, Dave Mitchell wrote:
No, it doesn't. That would be really hard. :-) Could we / should we document the fact that, if you want to safely sort {my_cmp($a,$b)} @foo; instead of sort my_cmp @foo; ? We could even issue a warning in the latter case, I imagine. Robin |
From robin@cpan.orgOn Sun, Oct 23, 2005 at 01:55:20PM +0100, Robin Houston wrote:
Indeed we can. Patch below. It seems to be the case that (PL_main_root->op_targ > 1) just Robin Inline Patch--- ./pod/perldiag.pod.1 2005-10-23 15:30:21.000000000 +0100
+++ ./pod/perldiag.pod 2005-10-23 15:37:04.000000000 +0100
@@ -3219,6 +3219,22 @@
really meant to write this, disable the warning, or, better, put the
parentheses explicitly and write C<$x & ($y == 0)>).
+=item Possible race condition in sort
+
+(W threads) If you call the sort() function with a custom comparison
+function, as
+
+ @result = sort my_cmp @input;
+
+the Perl interpreter will temporarily modify the internal representation
+of the my_cmp() function. If another thread calls my_cmp() during the
+sort, Perl's internal stack will become corrupt and your program will
+crash or otherwise misbehave. The solution is to rewrite the above as
+
+ @result = sort { &mycmp } @input;
+
+which avoids the problem (but is a little slower).
+
=item Possible unintended interpolation of %s in string
(W ambiguous) You said something like `@foo' in a double-quoted string
--- ./t/op/threads.t.1 2005-10-23 15:38:07.000000000 +0100
+++ ./t/op/threads.t 2005-10-23 16:07:00.000000000 +0100
@@ -17,7 +17,7 @@
print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
exit 0;
}
- plan(3);
+ plan(8);
}
use threads;
@@ -59,3 +59,42 @@
threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
print "ok";
EOI
+
+# test that sort() warns when it's used in a thread-unsafe way
+# (and doesn't when it isn't)
+use warnings FATAL => 'threads';
+sub my_cmp {$a <=> $b}
+my @result;
+eval {
+ @result = sort my_cmp (1..10);
+};
+ok($@ eq "", "No sort warning with a single thread", $@);
+
+my $th = threads->new(sub{1});
+eval {
+ @result = sort my_cmp (1..10);
+};
+ok($@ =~ /^Possible race condition/,
+ "Sort warning with multiple threads");
+
+eval {
+ @result = sort {&my_cmp} (1..10);
+};
+ok($@ eq "", "But no warning when called indirectly", $@);
+
+$th->join();
+
+eval {
+ @result = sort my_cmp (1..10);
+};
+ok($@ eq "", "No sort warning with a single thread, again", $@);
+
+my $th = threads->new(sub{1});
+$th->detach();
+eval {
+ @result = sort my_cmp (1..10);
+};
+ok($@ =~ /^Possible race condition/,
+ "Sort warning even when thread is detached");
+
+threads->yield(); # Give the detached thread a chance to finish
--- ./pp_sort.c.1 2005-10-23 15:07:19.000000000 +0100
+++ ./pp_sort.c 2005-10-23 15:28:53.000000000 +0100
@@ -1552,6 +1552,11 @@
else {
OP *o;
+#ifdef USE_ITHREADS
+ if (PL_main_root->op_targ > 1 && ckWARN(WARN_THREADS))
+ Perl_warner(aTHX_ packWARN(WARN_THREADS),
+ "Possible race condition in sort");
+#endif
PL_sortcop = CvSTART(cv);
SAVEVPTR(CvROOT(cv)->op_ppaddr);
CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; |
From robin@cpan.orgDave Mitchell wrote:
I can think of a different fix that doesn't slow down normal Patch is below. I've also fixed #7579. Note that this patch introduces the informal convention that, List::Util also has the same problems. I'll patch that too, Robin Inline Patch--- ./pod/perldiag.pod.orig 2005-10-23 12:15:17.000000000 +0100
+++ ./pod/perldiag.pod 2005-10-23 12:58:57.000000000 +0100
@@ -491,6 +491,20 @@
(F) Only hard references may be blessed. This is how Perl "enforces"
encapsulation of objects. See L<perlobj>.
+=item Can't call a comparison function recursively
+
+(F) A comparison routine used by the sort() function is not
+allowed to call itself, either directly or indirectly. You
+can, of course, call a recursive function I<from> a comparison
+routine, so you can sort with a recursive comparison using
+the following idiom:
+
+ sub recursive_cmp { ... }
+ sort {recursive_cmp($a,$b)} @list;
+
+(That might be useful if you're sorting binary trees, for
+example.)
+
=item Can't call method "%s" in empty package "%s"
(F) You called a method correctly, and it correctly indicated a package
@@ -761,6 +775,11 @@
you tried to jump out of a sort() block or subroutine, which is a no-no.
See L<perlfunc/goto>.
+=item Can't goto subroutine from a comparison function
+
+(F) The "goto subroutine" call can't be used to jump out of a
+comparison routine used by the sort() function.
+
=item Can't goto subroutine from an eval-%s
(F) The "goto subroutine" call can't be used to jump out of an eval
--- ./t/op/sort.t.orig 2005-10-23 12:01:41.000000000 +0100
+++ ./t/op/sort.t 2005-10-23 12:56:43.000000000 +0100
@@ -5,7 +5,7 @@
@INC = '../lib';
}
use warnings;
-print "1..129\n";
+print "1..131\n";
# these shouldn't hang
{
@@ -670,3 +670,25 @@
@output = reverse (0, sort(qw(C A B)));
ok "@output", "C B A 0", 'reversed sort with leading argument';
+
+# Bug #37508
+$x = 0;
+sub recursive {
+ recursive() if !$x++;
+ $a <=> $b;
+}
+
+eval { @output = sort recursive (1..5) };
+print(($@ =~ /^Can't call a comparison function recursively/
+ ? "ok "
+ : "not ok "),
+ $test++, " - Can't call a comparison function recursively\n");
+
+# Bug #7579
+sub going_away { goto &gone_away }
+sub gone_away {$a <=> $b}
+eval { @output = sort going_away (1..5) };
+print(($@ =~ /^Can't goto subroutine from a comparison function/
+ ? "ok "
+ : "not ok "),
+ $test++, " - Can't goto subroutine from a comparison function\n");
--- ./pp_sort.c.orig 2005-10-23 11:18:09.000000000 +0100
+++ ./pp_sort.c 2005-10-23 11:29:16.000000000 +0100
@@ -1477,6 +1477,13 @@
sortsvp(aTHX_ array, nmemb, cmp, 1);
}
+static
+OP *
+S_pp_sort_no_recurse(pTHX)
+{
+ DIE(aTHX_ "Can't call a comparison function recursively");
+}
+
#define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK))
#define SvSIOK(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK)
#define SvNSIV(sv) ( SvNOK(sv) ? SvNVX(sv) : ( SvSIOK(sv) ? SvIVX(sv) : sv_2nv(sv) ) )
@@ -1543,10 +1550,24 @@
if (is_xsub)
PL_sortcop = (OP*)cv;
else {
+ OP *o;
+
PL_sortcop = CvSTART(cv);
SAVEVPTR(CvROOT(cv)->op_ppaddr);
CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+ /* This prevents the comparison routine
+ from being called recursively. (Bug #37508) */
+ NewOp(1101, o, 1, OP);
+ SAVEFREEOP(o);
+ o->op_type = OP_NULL;
+ o->op_ppaddr = &S_pp_sort_no_recurse;
+ o->op_flags = 0;
+ o->op_private = 0;
+
+ SAVEVPTR(CvSTART(cv));
+ CvSTART(cv) = o;
+
SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
}
--- ./op.c.orig 2005-10-23 11:39:49.000000000 +0100
+++ ./op.c 2005-10-23 11:40:51.000000000 +0100
@@ -4355,7 +4355,8 @@
goto done;
}
/* ahem, death to those who redefine active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
+ if (PL_curstackinfo->si_type == PERLSI_SORT
+ && CvSTART(cv)->op_type == OP_NULL)
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
if (block) {
if (ckWARN(WARN_REDEFINE)
--- ./sv.c.orig 2005-10-23 11:39:52.000000000 +0100
+++ ./sv.c 2005-10-23 11:58:14.000000000 +0100
@@ -3868,7 +3868,7 @@
}
/* ahem, death to those who redefine active sort subs */
else if (PL_curstackinfo->si_type == PERLSI_SORT
- && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
+ && GvCV(dstr) && CvSTART(GvCV(dstr))->op_type == OP_NULL)
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
@@ -3976,7 +3976,7 @@
/* ahem, death to those who redefine
* active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT &&
- PL_sortcop == CvSTART(cv))
+ CvSTART(cv)->op_type == OP_NULL)
Perl_croak(aTHX_
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
--- ./pp_ctl.c.orig 2005-10-23 12:33:05.000000000 +0100
+++ ./pp_ctl.c 2005-10-23 12:56:15.000000000 +0100
@@ -2337,6 +2337,12 @@
else
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
+ /* Ban goto from comparison routine: see bug #7579 */
+ else if (CxTYPE(cx) == CXt_SUB &&
+ CvSTART(cx->blk_sub.cv) &&
+ CvSTART(cx->blk_sub.cv)->op_type == OP_NULL)
+ DIE(aTHX_ "Can't goto subroutine from a comparison function");
+
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
/* put @_ back onto stack */
AV* av = cx->blk_sub.argarray; |
From robin@cpan.orgDave Mitchell wrote:
It looks as though pp_return already has an explicit check for sort: if (PL_curstackinfo->si_type == PERLSI_SORT) { so the vast majority of sub exits are *already* being slowed down by Other modules that pull the same trick (in particular List::Util) could Does this sound reasonable? Robin |
From robin@cpan.orgSébastien Aperghis-Tramoni wrote:
I guess you're just "lucky": I'm sure 5.8.5 has the same bug. I now have a patch for this, which I'll send through as soon as Robin |
From @iabynOn Sun, Oct 23, 2005 at 08:41:00PM +0100, Robin Houston wrote:
Mostly. Personally I'd like to see new macros/functions added to the API that { ... Then this same API can be used by pp_sort, List::Util, and anyone else Since the sort sub is no longer being messed with, it may no longer be a I don't recommend using the PL_curstackinfo->si_type == PERLSI_SORT test -- |
From robin@cpan.orgOn Sun, Oct 23, 2005 at 09:57:52PM +0100, Dave Mitchell wrote:
That's an interesting idea! Probably true.
I think there's a lot of unused space in cx_type. It's a 32-bit We could then get rid of PL_sortcxix entirely. I like your idea of defining a proper API for lightweight callbacks. Robin PS. Do you know why sort does a PUSHSTACK, by the way? I must confess PPS. Other relevant bugs include 7579 and 30333. |
From @iabynOn Sun, Oct 23, 2005 at 10:48:03PM +0100, Robin Houston wrote:
There's also two U8s, meaning there's probably 16 bits wasted due to
Hopefully.
As I understand it, it's needed whenever realloc()ing the stack during dSP; As to why sort needs a new stack, I don't know. -- |
From robin@cpan.orgOn Sun, Oct 23, 2005 at 11:47:41PM +0100, Dave Mitchell wrote:
Oh I see! Presumably sort needs it for exactly the same reason: i.e. the This sounds a lot like a rather difficult-to-trigger bug in Robin |
From @iabynOn Mon, Oct 24, 2005 at 12:11:12AM +0100, Robin Houston wrote:
Except in this case, the stack reallocation isn't unexpected; all pp_foo -- |
From robin@cpan.orgOn Mon, Oct 24, 2005 at 07:45:45AM +0100, Dave Mitchell wrote:
Sure. I was thinking of the fact that Perl_pp_sort() itself Robin |
From @cpansproutResolved by 9850bf2 (and even documented in perl5100delta). |
|
@cpansprout - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#37508 (status was 'resolved')
Searchable as RT37508$
The text was updated successfully, but these errors were encountered: