From: Robin Houston Date: Tue, 8 Nov 2005 19:02:34 +0000 (+0000) Subject: Re: [perl #32383] DProf breaks List::Util::shuffle X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=82f35e8b14e93ac697812d1b28d2e79e1ad82d84;p=p5sagit%2Fp5-mst-13.2.git Re: [perl #32383] DProf breaks List::Util::shuffle Message-ID: <20051108190234.GA25953@rpc142.cs.man.ac.uk> p4raw-id: //depot/perl@26054 --- diff --git a/cop.h b/cop.h index 47c2375..618da4d 100644 --- a/cop.h +++ b/cop.h @@ -734,13 +734,15 @@ See L. #define dMULTICALL \ SV **newsp; /* set by POPBLOCK */ \ PERL_CONTEXT *cx; \ - CV *cv; \ + CV *multicall_cv; \ OP *multicall_cop; \ bool multicall_oldcatch; \ U8 hasargs = 0 /* used by PUSHSUB */ -#define PUSH_MULTICALL \ +#define PUSH_MULTICALL(the_cv) \ STMT_START { \ + CV *_nOnclAshIngNamE_ = the_cv; \ + CV *cv = _nOnclAshIngNamE_; \ AV* padlist = CvPADLIST(cv); \ ENTER; \ multicall_oldcatch = CATCH_GET; \ @@ -754,6 +756,7 @@ See L. } \ SAVECOMPPAD(); \ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \ + multicall_cv = cv; \ multicall_cop = CvSTART(cv); \ } STMT_END @@ -765,8 +768,8 @@ See L. #define POP_MULTICALL \ STMT_START { \ - LEAVESUB(cv); \ - CvDEPTH(cv)--; \ + LEAVESUB(multicall_cv); \ + CvDEPTH(multicall_cv)--; \ POPBLOCK(cx,PL_curpm); \ CATCH_SET(multicall_oldcatch); \ LEAVE; \ diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs index 44b8122..7d7a154 100644 --- a/ext/List/Util/Util.xs +++ b/ext/List/Util/Util.xs @@ -7,8 +7,6 @@ #include #include -#include "multicall.h" - #ifndef PERL_VERSION # include # if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL))) @@ -19,11 +17,14 @@ # define PERL_SUBVERSION SUBVERSION #endif +#if PERL_VERSION >= 6 +# include "multicall.h" +#endif + #ifndef aTHX # define aTHX # define pTHX #endif - /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc) was not exported. Therefore platforms like win32, VMS etc have problems so we redefine it here -- GMB @@ -230,6 +231,8 @@ CODE: +#ifdef dMULTICALL + void reduce(block,...) SV * block @@ -243,12 +246,13 @@ CODE: HV *stash; I32 gimme = G_SCALAR; SV **args = &PL_stack_base[ax]; + CV *cv; if(items <= 1) { XSRETURN_UNDEF; } cv = sv_2cv(block, &stash, &gv, 0); - PUSH_MULTICALL; + PUSH_MULTICALL(cv); agv = gv_fetchpv("a", TRUE, SVt_PV); bgv = gv_fetchpv("b", TRUE, SVt_PV); SAVESPTR(GvSV(agv)); @@ -277,12 +281,13 @@ CODE: HV *stash; I32 gimme = G_SCALAR; SV **args = &PL_stack_base[ax]; + CV *cv; if(items <= 1) { XSRETURN_UNDEF; } cv = sv_2cv(block, &stash, &gv, 0); - PUSH_MULTICALL; + PUSH_MULTICALL(cv); SAVESPTR(GvSV(PL_defgv)); for(index = 1 ; index < items ; index++) { @@ -298,6 +303,8 @@ CODE: XSRETURN_UNDEF; } +#endif + void shuffle(...) PROTOTYPE: @ @@ -305,6 +312,7 @@ CODE: { dVAR; int index; +#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <1) struct op dmy_op; struct op *old_op = PL_op; @@ -317,6 +325,16 @@ CODE: PL_op = &dmy_op; (void)*(PL_ppaddr[OP_RAND])(aTHX); PL_op = old_op; +#else + /* Initialize Drand01 if rand() or srand() has + not already been called + */ + if (!PL_srand_called) { + (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX)); + PL_srand_called = TRUE; + } +#endif + for (index = items ; index > 1 ; ) { int swap = (int)(Drand01() * (double)(index--)); SV *tmp = ST(swap); diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm index c73b964..cfe31f7 100644 --- a/ext/List/Util/lib/List/Util.pm +++ b/ext/List/Util/lib/List/Util.pm @@ -6,6 +6,8 @@ package List::Util; +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); require Exporter; @ISA = qw(Exporter); @@ -18,23 +20,32 @@ eval { # PERL_DL_NONLAZY must be false, or any errors in loading will just # cause the perl code to be tested local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; - require DynaLoader; - local @ISA = qw(DynaLoader); - bootstrap List::Util $XS_VERSION; - 1 -}; + eval { + require XSLoader; + XSLoader::load('List::Util', $XS_VERSION); + 1; + } or do { + require DynaLoader; + local @ISA = qw(DynaLoader); + bootstrap List::Util $XS_VERSION; + }; +} unless $TESTING_PERL_ONLY; -eval <<'ESQ' unless defined &reduce; # This code is only compiled if the XS did not load +# of for perl < 5.6.0 -use vars qw($a $b); +if (!defined &reduce) { +eval <<'ESQ' sub reduce (&@) { my $code = shift; + no strict 'refs'; return shift unless @_ > 1; + use vars qw($a $b); + my $caller = caller; local(*{$caller."::a"}) = \my $a; local(*{$caller."::b"}) = \my $b; @@ -48,16 +59,6 @@ sub reduce (&@) { $a; } -sub sum (@) { reduce { $a + $b } @_ } - -sub min (@) { reduce { $a < $b ? $a : $b } @_ } - -sub max (@) { reduce { $a > $b ? $a : $b } @_ } - -sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } - -sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } - sub first (&@) { my $code = shift; @@ -68,6 +69,24 @@ sub first (&@) { undef; } +ESQ +} + +# This code is only compiled if the XS did not load +eval <<'ESQ' if !defined ∑ + +use vars qw($a $b); + +sub sum (@) { reduce { $a + $b } @_ } + +sub min (@) { reduce { $a < $b ? $a : $b } @_ } + +sub max (@) { reduce { $a > $b ? $a : $b } @_ } + +sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } + +sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } + sub shuffle (@) { my @a=\(@_); my $n; @@ -201,7 +220,8 @@ Returns the elements of LIST in a random order =item sum LIST -Returns the sum of all the elements in LIST. +Returns the sum of all the elements in LIST. If LIST is empty then +C is returned. $foo = sum 1..10 # 55 $foo = sum 3,9,12 # 24 diff --git a/ext/List/Util/multicall.h b/ext/List/Util/multicall.h index eabb449..935d7ed 100644 --- a/ext/List/Util/multicall.h +++ b/ext/List/Util/multicall.h @@ -86,7 +86,7 @@ multicall_pad_push(pTHX_ AV *padlist, int depth) #define dMULTICALL \ SV **newsp; /* set by POPBLOCK */ \ PERL_CONTEXT *cx; \ - CV *cv; \ + CV *multicall_cv; \ OP *multicall_cop; \ bool multicall_oldcatch; \ U8 hasargs = 0 @@ -109,40 +109,41 @@ multicall_pad_push(pTHX_ AV *padlist, int depth) #else # define PUSHSUB_RETSTACK(cx) cx->blk_sub.retop = Nullop; #endif -#undef PUSHSUB -#define PUSHSUB(cx) \ - cx->blk_sub.cv = cv; \ - cx->blk_sub.olddepth = CvDEPTH(cv); \ - cx->blk_sub.hasargs = hasargs; \ - cx->blk_sub.lval = PL_op->op_private & \ +#define MULTICALL_PUSHSUB(cx, the_cv) \ + cx->blk_sub.cv = the_cv; \ + cx->blk_sub.olddepth = CvDEPTH(the_cv); \ + cx->blk_sub.hasargs = hasargs; \ + cx->blk_sub.lval = PL_op->op_private & \ (OPpLVAL_INTRO|OPpENTERSUB_INARGS); \ PUSHSUB_RETSTACK(cx) \ - if (!CvDEPTH(cv)) { \ - (void)SvREFCNT_inc(cv); \ - (void)SvREFCNT_inc(cv); \ - SAVEFREESV(cv); \ + if (!CvDEPTH(the_cv)) { \ + (void)SvREFCNT_inc(the_cv); \ + (void)SvREFCNT_inc(the_cv); \ + SAVEFREESV(the_cv); \ } -#define PUSH_MULTICALL \ +#define PUSH_MULTICALL(the_cv) \ STMT_START { \ - AV* padlist = CvPADLIST(cv); \ + CV *_nOnclAshIngNamE_ = the_cv; \ + AV* padlist = CvPADLIST(_nOnclAshIngNamE_); \ + multicall_cv = _nOnclAshIngNamE_; \ ENTER; \ multicall_oldcatch = CATCH_GET; \ - SAVESPTR(CvROOT(cv)->op_ppaddr); \ - CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ + SAVESPTR(CvROOT(multicall_cv)->op_ppaddr); \ + CvROOT(multicall_cv)->op_ppaddr = PL_ppaddr[OP_NULL]; \ SAVETMPS; SAVEVPTR(PL_op); \ CATCH_SET(TRUE); \ PUSHSTACKi(PERLSI_SORT); \ PUSHBLOCK(cx, CXt_SUB, PL_stack_sp); \ - PUSHSUB(cx); \ - if (++CvDEPTH(cv) >= 2) { \ + MULTICALL_PUSHSUB(cx, multicall_cv); \ + if (++CvDEPTH(multicall_cv) >= 2) { \ PERL_STACK_OVERFLOW_CHECK(); \ - multicall_pad_push(aTHX_ padlist, CvDEPTH(cv)); \ + multicall_pad_push(aTHX_ padlist, CvDEPTH(multicall_cv)); \ } \ SAVECOMPPAD(); \ - PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(cv)]); \ + PL_comppad = (AV*) (AvARRAY(padlist)[CvDEPTH(multicall_cv)]); \ PL_curpad = AvARRAY(PL_comppad); \ - multicall_cop = CvSTART(cv); \ + multicall_cop = CvSTART(multicall_cv); \ } STMT_END #define MULTICALL \ @@ -153,8 +154,8 @@ multicall_pad_push(pTHX_ AV *padlist, int depth) #define POP_MULTICALL \ STMT_START { \ - CvDEPTH(cv)--; \ - LEAVESUB(cv); \ + CvDEPTH(multicall_cv)--; \ + LEAVESUB(multicall_cv); \ POPBLOCK(cx,PL_curpm); \ POPSTACK; \ CATCH_SET(multicall_oldcatch); \ diff --git a/ext/List/Util/t/first.t b/ext/List/Util/t/first.t index a4c9261..07377ab 100755 --- a/ext/List/Util/t/first.t +++ b/ext/List/Util/t/first.t @@ -100,6 +100,7 @@ SKIP: { # (and more flexibly) in a way that we can't emulate from XS. if (!$::PERL_ONLY) { SKIP: { + $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once skip("Poor man's MULTICALL can't cope", 2) if !$List::Util::REAL_MULTICALL; diff --git a/ext/List/Util/t/reduce.t b/ext/List/Util/t/reduce.t index 786aaff..d82580d 100755 --- a/ext/List/Util/t/reduce.t +++ b/ext/List/Util/t/reduce.t @@ -127,6 +127,7 @@ SKIP: { # (and more flexibly) in a way that we can't emulate from XS. if (!$::PERL_ONLY) { SKIP: { + $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once skip("Poor man's MULTICALL can't cope", 2) if !$List::Util::REAL_MULTICALL; diff --git a/pod/perlcall.pod b/pod/perlcall.pod index 4b77359..7878ef9 100644 --- a/pod/perlcall.pod +++ b/pod/perlcall.pod @@ -1899,14 +1899,12 @@ it. It's also inherently slower.) The pattern of macro calls is like this: - dMULTICALL; /* Declare variables (including 'CV* cv') */ + dMULTICALL; /* Declare local variables */ 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 */ + PUSH_MULTICALL(cv); /* Set up the context for calling cv, + and set local vars appropriately */ /* loop */ { /* set the value(s) af your parameter variables */