Re: [perl #32383] DProf breaks List::Util::shuffle

Message-ID: <20051108190234.GA25953@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@26054

5 files changed, 86 insertions, 45 deletions

diff --git a/ext/List/Util/Util.xs b/ext/List/Util/Util.xs
index 44b8122c41..7d7a154878 100644
--- a/ext/List/Util/Util.xs
+++ b/ext/List/Util/Util.xs
@@ -7,8 +7,6 @@
 #include <perl.h>
 #include <XSUB.h>
 
-#include "multicall.h"
-
 #ifndef PERL_VERSION
 #    include <patchlevel.h>
 #    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 c73b964c00..cfe31f7012 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 &sum;
+
+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<undef> 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 eabb449dc3..935d7ed96a 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 a4c9261530..07377ab340 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 786aaffea6..d82580de6e 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;