From 9850bf21fc4ed69d8ddb0293df59411f891c62df Mon Sep 17 00:00:00 2001 From: Robin Houston Date: Sat, 29 Oct 2005 22:33:07 +0100 Subject: [PATCH] sort/multicall patch Message-ID: <20051029203307.GA8869@rpc142.cs.man.ac.uk> p4raw-id: //depot/perl@25953 --- AUTHORS | 2 +- MANIFEST | 1 + cop.h | 66 ++++++++++++++++++ embed.fnc | 2 +- embedvar.h | 2 - ext/List/Util/Util.xs | 96 ++++++++++---------------- ext/List/Util/lib/List/Util.pm | 2 +- ext/List/Util/lib/Scalar/Util.pm | 11 ++- ext/List/Util/t/first.t | 68 ++++++++++++++++++- ext/List/Util/t/p_first.t | 1 + ext/List/Util/t/p_reduce.t | 1 + ext/List/Util/t/p_tainted.t | 31 +-------- ext/List/Util/t/reduce.t | 71 +++++++++++++++++++- ext/List/Util/t/refaddr.t | 5 +- ext/List/Util/t/tainted.t | 3 + makedef.pl | 3 - op.c | 3 - opcode.pl | 2 +- perlapi.h | 2 - pod/perlcall.pod | 45 +++++++++++++ pod/perldiag.pod | 12 ++-- pp_ctl.c | 27 ++++---- pp_hot.c | 6 ++ pp_sort.c | 63 ++++++++++------- sv.c | 13 ---- t/op/sort.t | 141 ++++++++++++++++++++++++++++++++++++--- t/op/threads.t | 38 ++++++++++- thrdvar.h | 1 - 28 files changed, 540 insertions(+), 178 deletions(-) diff --git a/AUTHORS b/AUTHORS index d657439..9aa2d3f 100644 --- a/AUTHORS +++ b/AUTHORS @@ -692,7 +692,7 @@ Robert Partington Robert Sanders Robert Spier Robin Barker -Robin Houston +Robin Houston Rocco Caputo Roderick Schertler Rodger Anderson diff --git a/MANIFEST b/MANIFEST index 0d22963..e2ffd04 100644 --- a/MANIFEST +++ b/MANIFEST @@ -706,6 +706,7 @@ ext/List/Util/Changes Util extension ext/List/Util/lib/List/Util.pm List::Util ext/List/Util/lib/Scalar/Util.pm Scalar::Util ext/List/Util/Makefile.PL Util extension +ext/List/Util/multicall.h Util extension ext/List/Util/README Util extension ext/List/Util/t/blessed.t Scalar::Util ext/List/Util/t/dualvar.t Scalar::Util diff --git a/cop.h b/cop.h index 6672a53..f2e4463 100644 --- a/cop.h +++ b/cop.h @@ -541,6 +541,10 @@ struct context { #define CXt_BLOCK 5 #define CXt_FORMAT 6 +/* private flags for CXt_SUB and CXt_NULL */ +#define CXp_MULTICALL 0x00000400 /* part of a multicall (so don't + tear down context on exit). */ + /* private flags for CXt_EVAL */ #define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */ #define CXp_TRYBLOCK 0x00000200 /* eval{}, not eval'' or similar */ @@ -555,6 +559,8 @@ struct context { #endif #define CxTYPE(c) ((c)->cx_type & CXTYPEMASK) +#define CxMULTICALL(c) (((c)->cx_type & CXp_MULTICALL) \ + == CXp_MULTICALL) #define CxREALEVAL(c) (((c)->cx_type & (CXt_EVAL|CXp_REAL)) \ == (CXt_EVAL|CXp_REAL)) #define CxTRYBLOCK(c) (((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK)) \ @@ -700,3 +706,63 @@ typedef struct stackinfo PERL_SI; #define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #define IN_PERL_RUNTIME (PL_curcop != &PL_compiling) +/* +=head1 Multicall Functions + +=for apidoc Ams||dMULTICALL +Declare local variables for a multicall. See L. + +=for apidoc Ams||PUSH_MULTICALL +Opening bracket for a lightweight callback. +See L. + +=for apidoc Ams||MULTICALL +Make a lightweight callback. See L. + +=for apidoc Ams||POP_MULTICALL +Closing bracket for a lightweight callback. +See L. + +=cut +*/ + +#define dMULTICALL \ + SV **newsp; /* set by POPBLOCK */ \ + PERL_CONTEXT *cx; \ + CV *cv; \ + OP *multicall_cop; \ + bool multicall_oldcatch; \ + U8 hasargs = 0 /* used by PUSHSUB */ + +#define PUSH_MULTICALL \ + STMT_START { \ + AV* padlist = CvPADLIST(cv); \ + ENTER; \ + multicall_oldcatch = CATCH_GET; \ + SAVETMPS; SAVEVPTR(PL_op); \ + CATCH_SET(TRUE); \ + PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp); \ + PUSHSUB(cx); \ + if (++CvDEPTH(cv) >= 2) { \ + PERL_STACK_OVERFLOW_CHECK(); \ + Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ + } \ + SAVECOMPPAD(); \ + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ + multicall_cop = CvSTART(cv); \ + } STMT_END + +#define MULTICALL \ + STMT_START { \ + PL_op = multicall_cop; \ + CALLRUNOPS(aTHX); \ + } STMT_END + +#define POP_MULTICALL \ + STMT_START { \ + LEAVESUB(cv); \ + CvDEPTH(cv)--; \ + POPBLOCK(cx,PL_curpm); \ + CATCH_SET(multicall_oldcatch); \ + LEAVE; \ + } STMT_END diff --git a/embed.fnc b/embed.fnc index 2ee9e07..4202e7a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1436,7 +1436,7 @@ pd |void |pad_tidy |padtidy_type type pd |void |do_dump_pad |I32 level|NN PerlIO *file|NULLOK PADLIST *padlist|int full pd |void |pad_fixup_inner_anons|NN PADLIST *padlist|NN CV *old_cv|NN CV *new_cv -pd |void |pad_push |NN PADLIST *padlist|int depth +pdX |void |pad_push |NN PADLIST *padlist|int depth pR |HV* |pad_compname_type|const PADOFFSET po #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT) diff --git a/embedvar.h b/embedvar.h index 56fd726..81628be 100644 --- a/embedvar.h +++ b/embedvar.h @@ -138,7 +138,6 @@ #define PL_screamnext (vTHX->Tscreamnext) #define PL_secondgv (vTHX->Tsecondgv) #define PL_sortcop (vTHX->Tsortcop) -#define PL_sortcxix (vTHX->Tsortcxix) #define PL_sortstash (vTHX->Tsortstash) #define PL_stack_base (vTHX->Tstack_base) #define PL_stack_max (vTHX->Tstack_max) @@ -861,7 +860,6 @@ #define PL_Tscreamnext PL_screamnext #define PL_Tsecondgv PL_secondgv #define PL_Tsortcop PL_sortcop -#define PL_Tsortcxix PL_sortcxix #define PL_Tsortstash PL_sortstash #define PL_Tstack_base PL_stack_base #define PL_Tstack_max PL_stack_max diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs index 0c6a14d..44b8122 100644 --- a/ext/List/Util/Util.xs +++ b/ext/List/Util/Util.xs @@ -7,6 +7,8 @@ #include #include +#include "multicall.h" + #ifndef PERL_VERSION # include # if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) @@ -127,6 +129,10 @@ sv_tainted(SV *sv) #define dVAR dNOOP #endif +#ifndef GvSVn +# define GvSVn GvSV +#endif + MODULE=List::Util PACKAGE=List::Util void @@ -230,52 +236,32 @@ reduce(block,...) PROTOTYPE: &@ CODE: { - dVAR; + dVAR; dMULTICALL; SV *ret = sv_newmortal(); int index; GV *agv,*bgv,*gv; HV *stash; - CV *cv; - OP *reducecop; - PERL_CONTEXT *cx; - SV** newsp; I32 gimme = G_SCALAR; - U8 hasargs = 0; - bool oldcatch = CATCH_GET; + SV **args = &PL_stack_base[ax]; if(items <= 1) { XSRETURN_UNDEF; } + cv = sv_2cv(block, &stash, &gv, 0); + PUSH_MULTICALL; agv = gv_fetchpv("a", TRUE, SVt_PV); bgv = gv_fetchpv("b", TRUE, SVt_PV); SAVESPTR(GvSV(agv)); SAVESPTR(GvSV(bgv)); GvSV(agv) = ret; - cv = sv_2cv(block, &stash, &gv, 0); - reducecop = CvSTART(cv); - SAVESPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; -#ifdef PAD_SET_CUR - PAD_SET_CUR(CvPADLIST(cv),1); -#else - SAVESPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); -#endif - SAVETMPS; - SAVESPTR(PL_op); - SvSetSV(ret, ST(1)); - CATCH_SET(TRUE); - PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB(cx); + SvSetSV(ret, args[1]); for(index = 2 ; index < items ; index++) { - GvSV(bgv) = ST(index); - PL_op = reducecop; - CALLRUNOPS(aTHX); + GvSV(bgv) = args[index]; + MULTICALL; SvSetSV(ret, *PL_stack_sp); } + POP_MULTICALL; ST(0) = ret; - POPBLOCK(cx,PL_curpm); - CATCH_SET(oldcatch); XSRETURN(1); } @@ -285,51 +271,30 @@ first(block,...) PROTOTYPE: &@ CODE: { - dVAR; + dVAR; dMULTICALL; int index; GV *gv; HV *stash; - CV *cv; - OP *reducecop; - PERL_CONTEXT *cx; - SV** newsp; I32 gimme = G_SCALAR; - U8 hasargs = 0; - bool oldcatch = CATCH_GET; + SV **args = &PL_stack_base[ax]; if(items <= 1) { XSRETURN_UNDEF; } - SAVESPTR(GvSV(PL_defgv)); cv = sv_2cv(block, &stash, &gv, 0); - reducecop = CvSTART(cv); - SAVESPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; -#ifdef PAD_SET_CUR - PAD_SET_CUR(CvPADLIST(cv),1); -#else - SAVESPTR(PL_curpad); - PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]); -#endif - SAVETMPS; - SAVESPTR(PL_op); - CATCH_SET(TRUE); - PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB(cx); + PUSH_MULTICALL; + SAVESPTR(GvSV(PL_defgv)); for(index = 1 ; index < items ; index++) { - GvSV(PL_defgv) = ST(index); - PL_op = reducecop; - CALLRUNOPS(aTHX); + GvSV(PL_defgv) = args[index]; + MULTICALL; if (SvTRUE(*PL_stack_sp)) { + POP_MULTICALL; ST(0) = ST(index); - POPBLOCK(cx,PL_curpm); - CATCH_SET(oldcatch); XSRETURN(1); } } - POPBLOCK(cx,PL_curpm); - CATCH_SET(oldcatch); + POP_MULTICALL; XSRETURN_UNDEF; } @@ -538,14 +503,20 @@ CODE: BOOT: { + HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE); + GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE); + SV *rmcsv; #if !defined(SvWEAKREF) || !defined(SvVOK) - HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE); - GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE); + HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE); + GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE); AV *varav; if (SvTYPE(vargv) != SVt_PVGV) - gv_init(vargv, stash, "Scalar::Util", 12, TRUE); + gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE); varav = GvAVn(vargv); #endif + if (SvTYPE(rmcgv) != SVt_PVGV) + gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE); + rmcsv = GvSVn(rmcgv); #ifndef SvWEAKREF av_push(varav, newSVpv("weaken",6)); av_push(varav, newSVpv("isweak",6)); @@ -553,4 +524,9 @@ BOOT: #ifndef SvVOK av_push(varav, newSVpv("isvstring",9)); #endif +#ifdef REAL_MULTICALL + sv_setsv(rmcsv, &PL_sv_yes); +#else + sv_setsv(rmcsv, &PL_sv_no); +#endif } diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm index 55696ad..c73b964 100644 --- a/ext/List/Util/lib/List/Util.pm +++ b/ext/List/Util/lib/List/Util.pm @@ -10,7 +10,7 @@ require Exporter; @ISA = qw(Exporter); @EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.17"; +$VERSION = "1.18"; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/ext/List/Util/lib/Scalar/Util.pm b/ext/List/Util/lib/Scalar/Util.pm index 36476b3..3655164 100644 --- a/ext/List/Util/lib/Scalar/Util.pm +++ b/ext/List/Util/lib/Scalar/Util.pm @@ -11,7 +11,7 @@ require List::Util; # List::Util loads the XS @ISA = qw(Exporter); @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); -$VERSION = "1.17"; +$VERSION = "1.18"; $VERSION = eval $VERSION; sub export_fail { @@ -67,10 +67,15 @@ sub blessed ($) { sub refaddr($) { my $pkg = ref($_[0]) or return undef; - bless $_[0], 'Scalar::Util::Fake'; + if (blessed($_[0])) { + bless $_[0], 'Scalar::Util::Fake'; + } + else { + $pkg = undef; + } "$_[0]" =~ /0x(\w+)/; my $i = do { local $^W; hex $1 }; - bless $_[0], $pkg; + bless $_[0], $pkg if defined $pkg; $i; } diff --git a/ext/List/Util/t/first.t b/ext/List/Util/t/first.t index 784437c..a4c9261 100755 --- a/ext/List/Util/t/first.t +++ b/ext/List/Util/t/first.t @@ -13,8 +13,9 @@ BEGIN { } } -use Test::More tests => 8; use List::Util qw(first); +use Test::More; +plan tests => ($::PERL_ONLY ? 15 : 17); my $v; ok(defined &first, 'defined'); @@ -45,4 +46,69 @@ sub foobar { first { !defined(wantarray) || wantarray } "not ","not ","not " } ($v) = foobar(); is($v, undef, 'wantarray'); +# Can we leave the sub with 'return'? +$v = first {return ($_>6)} 2,4,6,12; +is($v, 12, 'return'); +# ... even in a loop? +$v = first {while(1) {return ($_>6)} } 2,4,6,12; +is($v, 12, 'return from loop'); + +# Does it work from another package? +{ package Foo; + ::is(List::Util::first(sub{$_>4},(1..4,24)), 24, 'other package'); +} + +# Can we undefine a first sub while it's running? +sub self_immolate {undef &self_immolate; 1} +eval { $v = first \&self_immolate, 1,2; }; +like($@, qr/^Can't undef active subroutine/, "undef active sub"); + +# Redefining an active sub should not fail, but whether the +# redefinition takes effect immediately depends on whether we're +# running the Perl or XS implementation. + +sub self_updating { local $^W; *self_updating = sub{1} ;1} +eval { $v = first \&self_updating, 1,2; }; +is($@, '', 'redefine self'); + +{ my $failed = 0; + + sub rec { my $n = shift; + if (!defined($n)) { # No arg means we're being called by first() + return 1; } + if ($n<5) { rec($n+1); } + else { $v = first \&rec, 1,2; } + $failed = 1 if !defined $n; + } + + rec(1); + ok(!$failed, 'from active sub'); +} + +# Calling a sub from first should leave its refcount unchanged. +SKIP: { + skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT; + sub huge {$_>1E6} + my $refcnt = &Internals::SvREFCNT(\&huge); + $v = first \&huge, 1..6; + is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged"); +} + +# The remainder of the tests are only relevant for the XS +# implementation. The Perl-only implementation behaves differently +# (and more flexibly) in a way that we can't emulate from XS. +if (!$::PERL_ONLY) { SKIP: { + + skip("Poor man's MULTICALL can't cope", 2) + if !$List::Util::REAL_MULTICALL; + + # Can we goto a label from the 'first' sub? + eval {()=first{goto foo} 1,2; foo: 1}; + like($@, qr/^Can't "goto" out of a pseudo block/, "goto label"); + + # Can we goto a subroutine? + eval {()=first{goto sub{}} 1,2;}; + like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); + +} } diff --git a/ext/List/Util/t/p_first.t b/ext/List/Util/t/p_first.t index 2fd67b0..1928ef2 100644 --- a/ext/List/Util/t/p_first.t +++ b/ext/List/Util/t/p_first.t @@ -4,4 +4,5 @@ sub List::Util::bootstrap {} (my $f = __FILE__) =~ s/p_//; +$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once! do $f; diff --git a/ext/List/Util/t/p_reduce.t b/ext/List/Util/t/p_reduce.t index 2fd67b0..1928ef2 100644 --- a/ext/List/Util/t/p_reduce.t +++ b/ext/List/Util/t/p_reduce.t @@ -4,4 +4,5 @@ sub List::Util::bootstrap {} (my $f = __FILE__) =~ s/p_//; +$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once! do $f; diff --git a/ext/List/Util/t/p_tainted.t b/ext/List/Util/t/p_tainted.t index 6196729..7b00ebd 100644 --- a/ext/List/Util/t/p_tainted.t +++ b/ext/List/Util/t/p_tainted.t @@ -3,32 +3,5 @@ # force perl-only version to be tested sub List::Util::bootstrap {} -BEGIN { - unless (-d 'blib') { - chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; - keys %Config; # Silence warning - if ($Config{extensions} !~ /\bList\/Util\b/) { - print "1..0 # Skip: List::Util was not built\n"; - exit 0; - } - } -} - -use Test::More tests => 4; - -use Scalar::Util qw(tainted); - -ok( !tainted(1), 'constant number'); - -my $var = 2; - -ok( !tainted($var), 'known variable'); - -my $key = (keys %ENV)[0]; - -ok( tainted($ENV{$key}), 'environment variable'); - -$var = $ENV{$key}; -ok( tainted($var), 'copy of environment variable'); +(my $f = __FILE__) =~ s/p_//; +do "./$f"; diff --git a/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t index 689ff52..786aaff 100755 --- a/ext/List/Util/t/reduce.t +++ b/ext/List/Util/t/reduce.t @@ -15,7 +15,8 @@ BEGIN { use List::Util qw(reduce min); -use Test::More tests => 14; +use Test::More; +plan tests => ($::PERL_ONLY ? 21 : 23); my $v = reduce {}; @@ -70,3 +71,71 @@ $a = 8; $b = 9; $v = reduce { $a * $b } 1,2,3; is( $a, 8, 'restore $a'); is( $b, 9, 'restore $b'); + +# Can we leave the sub with 'return'? +$v = reduce {return $a+$b} 2,4,6; +is($v, 12, 'return'); + +# ... even in a loop? +$v = reduce {while(1) {return $a+$b} } 2,4,6; +is($v, 12, 'return from loop'); + +# Does it work from another package? +{ package Foo; + $a = $b; + ::is((List::Util::reduce {$a*$b} (1..4)), 24, 'other package'); +} + +# Can we undefine a reduce sub while it's running? +sub self_immolate {undef &self_immolate; 1} +eval { $v = reduce \&self_immolate, 1,2; }; +like($@, qr/^Can't undef active subroutine/, "undef active sub"); + +# Redefining an active sub should not fail, but whether the +# redefinition takes effect immediately depends on whether we're +# running the Perl or XS implementation. + +sub self_updating { local $^W; *self_updating = sub{1} ;1 } +eval { $v = reduce \&self_updating, 1,2; }; +is($@, '', 'redefine self'); + +{ my $failed = 0; + + sub rec { my $n = shift; + if (!defined($n)) { # No arg means we're being called by reduce() + return 1; } + if ($n<5) { rec($n+1); } + else { $v = reduce \&rec, 1,2; } + $failed = 1 if !defined $n; + } + + rec(1); + ok(!$failed, 'from active sub'); +} + +# Calling a sub from reduce should leave its refcount unchanged. +SKIP: { + skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT; + sub mult {$a*$b} + my $refcnt = &Internals::SvREFCNT(\&mult); + $v = reduce \&mult, 1..6; + is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged"); +} + +# The remainder of the tests are only relevant for the XS +# implementation. The Perl-only implementation behaves differently +# (and more flexibly) in a way that we can't emulate from XS. +if (!$::PERL_ONLY) { SKIP: { + + skip("Poor man's MULTICALL can't cope", 2) + if !$List::Util::REAL_MULTICALL; + + # Can we goto a label from the reduction sub? + eval {()=reduce{goto foo} 1,2; foo: 1}; + like($@, qr/^Can't "goto" out of a pseudo block/, "goto label"); + + # Can we goto a subroutine? + eval {()=reduce{goto sub{}} 1,2;}; + like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); + +} } diff --git a/ext/List/Util/t/refaddr.t b/ext/List/Util/t/refaddr.t index d4dfcd7..61a33d3 100755 --- a/ext/List/Util/t/refaddr.t +++ b/ext/List/Util/t/refaddr.t @@ -14,7 +14,7 @@ BEGIN { } -use Test::More tests => 19; +use Test::More tests => 29; use Scalar::Util qw(refaddr); use vars qw($t $y $x *F $v $r); @@ -32,10 +32,13 @@ foreach $r ({}, \$t, [], \*F, sub {}) { my $n = "$r"; $n =~ /0x(\w+)/; my $addr = do { local $^W; hex $1 }; + my $before = ref($r); is( refaddr($r), $addr, $n); + is( ref($r), $before, $n); my $obj = bless $r, 'FooBar'; is( refaddr($r), $addr, "blessed with overload $n"); + is( ref($r), 'FooBar', $n); } { diff --git a/ext/List/Util/t/tainted.t b/ext/List/Util/t/tainted.t index 2e9c641..09ad330 100644 --- a/ext/List/Util/t/tainted.t +++ b/ext/List/Util/t/tainted.t @@ -11,6 +11,9 @@ BEGIN { exit 0; } } + elsif(!grep {/blib/} @INC) { + unshift(@INC, qw(./inc ./blib/arch ./blib/lib)); + } } use Test::More tests => 4; diff --git a/makedef.pl b/makedef.pl index 890f6b0..e8fa48a 100644 --- a/makedef.pl +++ b/makedef.pl @@ -250,7 +250,6 @@ if ($PLATFORM eq 'win32') { PL_linestart PL_modcount PL_pending_ident - PL_sortcxix PL_sublex_info PL_timesbuf main @@ -308,7 +307,6 @@ if ($PLATFORM eq 'wince') { PL_linestart PL_modcount PL_pending_ident - PL_sortcxix PL_sublex_info PL_timesbuf PL_collation_ix @@ -509,7 +507,6 @@ elsif ($PLATFORM eq 'netware') { PL_linestart PL_modcount PL_pending_ident - PL_sortcxix PL_sublex_info PL_timesbuf main diff --git a/op.c b/op.c index 02c1fe8..2eefa1d 100644 --- a/op.c +++ b/op.c @@ -4345,9 +4345,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREESV(PL_compcv); goto done; } - /* ahem, death to those who redefine active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) - Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); if (block) { if (ckWARN(WARN_REDEFINE) || (CvCONST(cv) diff --git a/opcode.pl b/opcode.pl index 6b01294..4a2aa5a 100755 --- a/opcode.pl +++ b/opcode.pl @@ -726,7 +726,7 @@ push push ck_fun imsT@ A L pop pop ck_shift s% A? shift shift ck_shift s% A? unshift unshift ck_fun imsT@ A L -sort sort ck_sort m@ C? L +sort sort ck_sort dm@ C? L reverse reverse ck_fun mt@ L grepstart grep ck_grep dm@ C L diff --git a/perlapi.h b/perlapi.h index a9c3c25..e3dc42c 100644 --- a/perlapi.h +++ b/perlapi.h @@ -910,8 +910,6 @@ END_EXTERN_C #define PL_secondgv (*Perl_Tsecondgv_ptr(aTHX)) #undef PL_sortcop #define PL_sortcop (*Perl_Tsortcop_ptr(aTHX)) -#undef PL_sortcxix -#define PL_sortcxix (*Perl_Tsortcxix_ptr(aTHX)) #undef PL_sortstash #define PL_sortstash (*Perl_Tsortstash_ptr(aTHX)) #undef PL_stack_base diff --git a/pod/perlcall.pod b/pod/perlcall.pod index dd520af..fb5ea37 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -1942,6 +1942,51 @@ will be the return value as well (read more about C in L). Once this code reference is in hand, it can be mixed in with all the previous examples we've shown. +=head1 LIGHTWEIGHT CALLBACKS + +Sometimes you need to invoke the same subroutine repeatedly. +This usually happens with a function that acts on a list of +values, such as Perl's built-in sort(). You can pass a +comparison function to sort(), which will then be invoked +for every pair of values that needs to be compared. The first() +and reduce() functions from L follow a similar +pattern. + +In this case it is possible to speed up the routine (often +quite substantially) by using the lightweight callback API. +The idea is that the calling context only needs to be +created and destroyed once, and the sub can be called +arbitrarily many times in between. + +It is usual to pass parameters using global variables -- typically +$_ for one parameter, or $a and $b for two parameters -- rather +than via @_. (It is possible to use the @_ mechanism if you know +what you're doing, though there is as yet no supported API for +it. It's also inherently slower.) + +The pattern of macro calls is like this: + + dMULTICALL; /* Declare variables (including 'CV* cv') */ + I32 gimme = G_SCALAR; /* context of the call: G_SCALAR, + * G_LIST, or G_VOID */ + + /* Here you must arrange for 'cv' to be set to the CV of + * the sub you want to call. */ + + PUSH_MULTICALL; /* Set up the calling context */ + + /* loop */ { + /* set the value(s) af your parameter variables */ + MULTICALL; /* Make the actual call */ + } /* end of loop */ + + POP_MULTICALL; /* Tear down the calling context */ + +For some concrete examples, see the implementation of the +first() and reduce() functions of List::Util 1.18. There you +will also find a header file that emulates the multicall API +on older versions of perl. + =head1 SEE ALSO L, L, L diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 3c16b0d..930a6cb 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -761,6 +761,11 @@ a block, except that it isn't a proper block. This usually occurs if you tried to jump out of a sort() block or subroutine, which is a no-no. See L. +=item Can't goto subroutine from a sort sub (or similar callback) +(F) The "goto subroutine" call can't be used to jump out of the +comparison sub for a sort(), or from a similar callback (such +as the reduce() function in List::Util). + =item Can't goto subroutine from an eval-%s (F) The "goto subroutine" call can't be used to jump out of an eval @@ -954,13 +959,6 @@ missing. You need to figure out where your CRTL misplaced its environ or define F (see L) so that environ is not searched. -=item Can't redefine active sort subroutine %s - -(F) Perl optimizes the internal handling of sort subroutines and keeps -pointers into them. You tried to redefine one such sort subroutine when -it was currently active, which is not allowed. If you really want to do -this, you should write C instead of C. - =item Can't "redo" outside a loop block (F) A "redo" statement was executed to restart the current block, but diff --git a/pp_ctl.c b/pp_ctl.c index 8a6c3e5..d5bb802 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1943,24 +1943,23 @@ PP(pp_return) SV *sv; OP *retop; - if (PL_curstackinfo->si_type == PERLSI_SORT) { - if (cxstack_ix == PL_sortcxix - || dopoptosub(cxstack_ix) <= PL_sortcxix) - { - if (cxstack_ix > PL_sortcxix) - dounwind(PL_sortcxix); - AvARRAY(PL_curstack)[1] = *SP; - PL_stack_sp = PL_stack_base + 1; + cxix = dopoptosub(cxstack_ix); + if (cxix < 0) { + if (CxMULTICALL(cxstack)) { /* In this case we must be in a + * sort block, which is a CXt_NULL + * not a CXt_SUB */ + dounwind(0); return 0; } + else + DIE(aTHX_ "Can't return outside a subroutine"); } - - cxix = dopoptosub(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't return outside a subroutine"); if (cxix < cxstack_ix) dounwind(cxix); + if (CxMULTICALL(&cxstack[cxix])) + return 0; + POPBLOCK(cx,newpm); switch (CxTYPE(cx)) { case CXt_SUB: @@ -2311,6 +2310,8 @@ PP(pp_goto) else DIE(aTHX_ "Can't goto subroutine from an eval-block"); } + else if (CxMULTICALL(cx)) + DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; @@ -2523,7 +2524,7 @@ PP(pp_goto) gotoprobe = PL_main_root; break; case CXt_SUB: - if (CvDEPTH(cx->blk_sub.cv)) { + if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { gotoprobe = CvROOT(cx->blk_sub.cv); break; } diff --git a/pp_hot.c b/pp_hot.c index fefec9a..908ee0b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2331,6 +2331,9 @@ PP(pp_leavesub) register PERL_CONTEXT *cx; SV *sv; + if (CxMULTICALL(&cxstack[cxstack_ix])) + return 0; + POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ @@ -2391,6 +2394,9 @@ PP(pp_leavesublv) register PERL_CONTEXT *cx; SV *sv; + if (CxMULTICALL(&cxstack[cxstack_ix])) + return 0; + POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ diff --git a/pp_sort.c b/pp_sort.c index 3dda7cc..68ad610 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1542,14 +1542,8 @@ PP(pp_sort) if (is_xsub) PL_sortcop = (OP*)cv; - else { + else PL_sortcop = CvSTART(cv); - SAVEVPTR(CvROOT(cv)->op_ppaddr); - CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; - - SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); - } } } else { @@ -1574,6 +1568,10 @@ PP(pp_sort) } } else { + if (SvREADONLY(av)) + Perl_croak(aTHX_ PL_no_modify); + else + SvREADONLY_on(av); p1 = p2 = AvARRAY(av); sorting_av = 1; } @@ -1645,13 +1643,12 @@ PP(pp_sort) CATCH_SET(TRUE); PUSHSTACKi(PERLSI_SORT); if (!hasargs && !is_xsub) { - if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) { - SAVESPTR(PL_firstgv); - SAVESPTR(PL_secondgv); - PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); - PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); - PL_sortstash = stash; - } + SAVESPTR(PL_firstgv); + SAVESPTR(PL_secondgv); + SAVESPTR(PL_sortstash); + PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV); + PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV); + PL_sortstash = stash; SAVESPTR(GvSV(PL_firstgv)); SAVESPTR(GvSV(PL_secondgv)); } @@ -1661,23 +1658,39 @@ PP(pp_sort) cx->cx_type = CXt_SUB; cx->blk_gimme = G_SCALAR; PUSHSUB(cx); - } - PL_sortcxix = cxstack_ix; + if (!is_xsub) { + AV* padlist = CvPADLIST(cv); + + if (++CvDEPTH(cv) >= 2) { + PERL_STACK_OVERFLOW_CHECK(); + pad_push(padlist, CvDEPTH(cv)); + } + SAVECOMPPAD(); + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); - if (hasargs && !is_xsub) { - /* This is mostly copied from pp_entersub */ - AV *av = (AV*)PAD_SVl(0); + if (hasargs) { + /* This is mostly copied from pp_entersub */ + AV *av = (AV*)PAD_SVl(0); - cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); - CX_CURPAD_SAVE(cx->blk_sub); - cx->blk_sub.argarray = av; + cx->blk_sub.savearray = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); + CX_CURPAD_SAVE(cx->blk_sub); + cx->blk_sub.argarray = av; + } + + } } + cx->cx_type |= CXp_MULTICALL; start = p1 - max; sortsvp(aTHX_ start, max, is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv); + if (!(flags & OPf_SPECIAL)) { + LEAVESUB(cv); + if (!is_xsub) + CvDEPTH(cv)--; + } POPBLOCK(cx,PL_curpm); PL_stack_sp = newsp; POPSTACK; @@ -1706,7 +1719,9 @@ PP(pp_sort) } } } - if (av && !sorting_av) { + if (sorting_av) + SvREADONLY_off(av); + else if (av && !sorting_av) { /* simulate pp_aassign of tied AV */ SV** const base = ORIGMARK+1; for (i=0; i < max; i++) { diff --git a/sv.c b/sv.c index f29434f..00aa612 100644 --- a/sv.c +++ b/sv.c @@ -3760,11 +3760,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ } - /* ahem, death to those who redefine active sort subs */ - else if (PL_curstackinfo->si_type == PERLSI_SORT - && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) - Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", - GvNAME(dstr)); #ifdef GV_UNIQUE_CHECK if (GvUNIQUE((GV*)dstr)) { @@ -3867,13 +3862,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { - /* ahem, death to those who redefine - * active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && - PL_sortcop == CvSTART(cv)) - Perl_croak(aTHX_ - "Can't redefine active sort subroutine %s", - GvENAME((GV*)dstr)); /* Redefining a sub - warning is mandatory if it was a const and its value changed. */ if (ckWARN(WARN_REDEFINE) @@ -11525,7 +11513,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sortstash = hv_dup(proto_perl->Tsortstash, param); PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); - PL_sortcxix = proto_perl->Tsortcxix; PL_efloatbuf = Nullch; /* reinits on demand */ PL_efloatsize = 0; /* reinits on demand */ diff --git a/t/op/sort.t b/t/op/sort.t index bdb4885..7081f21 100755 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } use warnings; -print "1..129\n"; +print "1..141\n"; # these shouldn't hang { @@ -18,6 +18,7 @@ print "1..129\n"; sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub Backwards_other { $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -114,12 +115,12 @@ print "# x = '@b'\n"; print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); print "# x = '@b'\n"; -# redefining sort sub inside the sort sub should fail -sub twoface { *twoface = sub { $a <=> $b }; &twoface } +# redefining sort sub inside the sort sub should not fail +sub twoface { no warnings 'redefine'; *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); +print ($@ eq '' ? "ok 17\n" : "not ok 17\n"); -# redefining sort subs outside the sort should not fail +# redefining sort subs outside the sort should also not fail eval { no warnings 'redefine'; *twoface = sub { &Backwards } }; print $@ ? "not ok 18\n" : "ok 18\n"; @@ -128,21 +129,22 @@ print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); { no warnings 'redefine'; - *twoface = sub { *twoface = *Backwards; $a <=> $b }; + *twoface = sub { *twoface = *Backwards_other; $a <=> $b }; } -eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); +# The redefinition should not take effect during the sort +eval { @b = sort twoface 4,1,9,5 }; +print (($@ eq "" && "@b" eq "1 4 5 9") ? "ok 20\n" : "not ok 20 # $@|@b\n"); { no warnings 'redefine'; *twoface = sub { eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); + die($@ eq "" ? "ok 21\n" : "not ok 21\n"); $a <=> $b; }; } eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 21\n"; +print($@ ? "$@" : "not ok 21 # $@\n"); eval <<'CODE'; my @result = sort main'Backwards 'one', 'two'; @@ -670,3 +672,122 @@ ok "@output", "0 C B A", 'reversed sort with trailing argument'; @output = reverse (0, sort(qw(C A B))); ok "@output", "C B A 0", 'reversed sort with leading argument'; + +eval { @output = sort {goto sub {}} 1,2; }; +print(($@ =~ /^Can't goto subroutine outside a subroutine/ ? + "ok " : + "not ok "), + $test++, " # $@"); + +sub goto_sub {goto sub{}} +eval { @output = sort goto_sub 1,2; }; +print(($@ =~ /^Can't goto subroutine from a sort sub/ ? + "ok " : + "not ok "), + $test++, " # $@"); + +eval { @output = sort {goto label} 1,2; }; +print(($@ =~ /^Can't "goto" out of a pseudo block/ ? + "ok " : + "not ok "), + $test++, " # $@"); + +sub goto_label {goto label} +label: eval { @output = sort goto_label 1,2; }; +print(($@ =~ /^Can't "goto" out of a pseudo block/ ? + "ok " : + "not ok "), + $test++, " # $@"); + +sub self_immolate {undef &self_immolate; $a<=>$b} +eval { @output = sort self_immolate 1,2,3 }; +print(($@ =~ /^Can't undef active subroutine/ ? + "ok " : + "not ok "), + $test++, " # $@"); + +{ + my $failed = 0; + + sub rec { + my $n = shift; + if (!defined($n)) { # No arg means we're being called by sort() + return 1; + } + if ($n<5) { rec($n+1); } + else { () = sort rec 1,2; } + + $failed = 1 if !defined $n; + } + + rec(1); + print((!$failed ? "ok " : "not ok "), $test++, " - sort from active sub\n"); +} + +# $a and $b are set in the package the sort() is called from, +# *not* the package the sort sub is in. This is longstanding +# de facto behaviour that shouldn't be broken. +package main; +my $answer = "ok "; +() = sort OtherPack::foo 1,2,3,4; + +{package OtherPack; sub foo { + $answer = "not ok " if + defined($a) || defined($b) || !defined($main::a) || !defined($main::b); + $main::a <=> $main::b; +}} + +print $answer, $test++, "\n"; + + +# Bug 36430 - sort called in package2 while a +# sort in package1 is active should set $package2::a/b. + +$answer = "ok "; +my @list = sort { A::min(@$a) <=> A::min(@$b) } + [3, 1, 5], [2, 4], [0]; + +print $answer, $test++, "\n"; + +package A; +sub min { + my @list = sort { + $answer = "not ok " if !defined($a) || !defined($b); + $a <=> $b; + } @_; + $list[0]; +} + +# Bug 7567 - an array shouldn't be modifiable while it's being +# sorted in-place. +eval { @a=(1..8); @a = sort { @a = (0) } @a; }; + +print(($@ =~ /^Modification of a read-only value attempted/ ? + "ok " : + "not ok "), + $test++, " # $@"); + +# Sorting shouldn't increase the refcount of a sub +sub foo {(1+$a) <=> (1+$b)} +my $refcnt = &Internals::SvREFCNT(\&foo); +@output = sort foo 3,7,9; +package Foo; +ok($refcnt, &Internals::SvREFCNT(\&foo), "sort sub refcnt"); + +# Sorting a read-only array in-place shouldn't be allowed +my @readonly = (1..10); +Internals::SvREADONLY(@readonly, 1); +eval { @readonly = sort @readonly; }; +print(($@ =~ /^Modification of a read-only value attempted/ ? + "ok " : + "not ok "), + $test++, " # $@"); + +# Using return() should be okay even in a deeper context +@b = sort {while (1) {return ($a <=> $b)} } 1..10; +ok("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop"); + +# Clearing the array we're sorting should be okay. +@a = (1..10); +@b = sort {@a=(); ($a+1)<=>($b+1)} @a; +ok("@b", "1 2 3 4 5 6 7 8 9 10", "clear array being sorted"); diff --git a/t/op/threads.t b/t/op/threads.t index b8fb9a6..99e2e5d 100644 --- a/t/op/threads.t +++ b/t/op/threads.t @@ -17,7 +17,7 @@ BEGIN { print "1..0 # Skip: no dynamic loading on miniperl, no threads\n"; exit 0; } - plan(3); + plan(4); } use threads; @@ -59,3 +59,39 @@ weaken $ref; threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems print "ok"; EOI + +#PR30333 - sort() crash with threads +sub mycmp { length($b) <=> length($a) } + +sub do_sort_one_thread { + my $kid = shift; + print "# kid $kid before sort\n"; + my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z', + 'hello', 's', 'thisisalongname', '1', '2', '3', + 'abc', 'xyz', '1234567890', 'm', 'n', 'p' ); + + for my $j (1..99999) { + for my $k (sort mycmp @list) {} + } + print "# kid $kid after sort, sleeping 1\n"; + sleep(1); + print "# kid $kid exit\n"; +} + +sub do_sort_threads { + my $nthreads = shift; + my @kids = (); + for my $i (1..$nthreads) { + my $t = threads->new(\&do_sort_one_thread, $i); + print "# parent $$: continue\n"; + push(@kids, $t); + } + for my $t (@kids) { + print "# parent $$: waiting for join\n"; + $t->join(); + print "# parent $$: thread exited\n"; + } +} + +do_sort_threads(2); # crashes +ok(1); diff --git a/thrdvar.h b/thrdvar.h index bdfb381..e12e85f 100644 --- a/thrdvar.h +++ b/thrdvar.h @@ -147,7 +147,6 @@ PERLVAR(Tsortcop, OP *) /* user defined sort routine */ PERLVAR(Tsortstash, HV *) /* which is in some package or other */ PERLVAR(Tfirstgv, GV *) /* $a */ PERLVAR(Tsecondgv, GV *) /* $b */ -PERLVAR(Tsortcxix, I32) /* from pp_ctl.c */ /* float buffer */ PERLVAR(Tefloatbuf, char*) -- 2.7.4