This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #32383] DProf breaks List::Util::shuffle
authorRobin Houston <robin@cpan.org>
Tue, 8 Nov 2005 19:02:34 +0000 (19:02 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 9 Nov 2005 09:15:04 +0000 (09:15 +0000)
Message-ID: <20051108190234.GA25953@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@26054

cop.h
ext/List/Util/Util.xs
ext/List/Util/lib/List/Util.pm
ext/List/Util/multicall.h
ext/List/Util/t/first.t
ext/List/Util/t/reduce.t
pod/perlcall.pod

diff --git a/cop.h b/cop.h
index 47c2375..618da4d 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -734,13 +734,15 @@ See L<perlcall/Lightweight Callbacks>.
 #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<perlcall/Lightweight Callbacks>.
        }                                                               \
        SAVECOMPPAD();                                                  \
        PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));                       \
+       multicall_cv = cv;                                              \
        multicall_cop = CvSTART(cv);                                    \
     } STMT_END
 
@@ -765,8 +768,8 @@ See L<perlcall/Lightweight Callbacks>.
 
 #define POP_MULTICALL \
     STMT_START {                                                       \
-       LEAVESUB(cv);                                                   \
-       CvDEPTH(cv)--;                                                  \
+       LEAVESUB(multicall_cv);                                         \
+       CvDEPTH(multicall_cv)--;                                        \
        POPBLOCK(cx,PL_curpm);                                          \
        CATCH_SET(multicall_oldcatch);                                  \
        LEAVE;                                                          \
index 44b8122..7d7a154 100644 (file)
@@ -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)))
 #    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);
index c73b964..cfe31f7 100644 (file)
@@ -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
index eabb449..935d7ed 100644 (file)
@@ -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);                                  \
index a4c9261..07377ab 100755 (executable)
@@ -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;
 
index 786aaff..d82580d 100755 (executable)
@@ -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;
 
index 4b77359..7878ef9 100644 (file)
@@ -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 */