This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sort/multicall patch
authorRobin Houston <robin@cpan.org>
Sat, 29 Oct 2005 21:33:07 +0000 (22:33 +0100)
committerH.Merijn Brand <h.m.brand@xs4all.nl>
Wed, 2 Nov 2005 12:49:54 +0000 (12:49 +0000)
Message-ID: <20051029203307.GA8869@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@25953

28 files changed:
AUTHORS
MANIFEST
cop.h
embed.fnc
embedvar.h
ext/List/Util/Util.xs
ext/List/Util/lib/List/Util.pm
ext/List/Util/lib/Scalar/Util.pm
ext/List/Util/t/first.t
ext/List/Util/t/p_first.t
ext/List/Util/t/p_reduce.t
ext/List/Util/t/p_tainted.t
ext/List/Util/t/reduce.t
ext/List/Util/t/refaddr.t
ext/List/Util/t/tainted.t
makedef.pl
op.c
opcode.pl
perlapi.h
pod/perlcall.pod
pod/perldiag.pod
pp_ctl.c
pp_hot.c
pp_sort.c
sv.c
t/op/sort.t
t/op/threads.t
thrdvar.h

diff --git a/AUTHORS b/AUTHORS
index d657439..9aa2d3f 100644 (file)
--- a/AUTHORS
+++ b/AUTHORS
@@ -692,7 +692,7 @@ Robert Partington           <rjp@riffraff.plig.net>
 Robert Sanders                 <Robert.Sanders@linux.org>
 Robert Spier                   <rspier@pobox.com>
 Robin Barker                   <RMBarker@cpan.org>
-Robin Houston                  <robin@kitsite.com>
+Robin Houston                  <robin@cpan.org>
 Rocco Caputo                   <troc@netrus.net>
 Roderick Schertler             <roderick@argon.org>
 Rodger Anderson                        <rodger@boi.hp.com>
index 0d22963..e2ffd04 100644 (file)
--- 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 (file)
--- 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<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||PUSH_MULTICALL
+Opening bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||MULTICALL
+Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||POP_MULTICALL
+Closing bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=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
index 2ee9e07..4202e7a 100644 (file)
--- 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)
index 56fd726..81628be 100644 (file)
 #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)
 #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
index 0c6a14d..44b8122 100644 (file)
@@ -7,6 +7,8 @@
 #include <perl.h>
 #include <XSUB.h>
 
+#include "multicall.h"
+
 #ifndef PERL_VERSION
 #    include <patchlevel.h>
 #    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
 }
index 55696ad..c73b964 100644 (file)
@@ -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;
 
index 36476b3..3655164 100644 (file)
@@ -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;
 }
 
index 784437c..a4c9261 100755 (executable)
@@ -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");
+
+} }
index 2fd67b0..1928ef2 100644 (file)
@@ -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;
index 2fd67b0..1928ef2 100644 (file)
@@ -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;
index 6196729..7b00ebd 100644 (file)
@@ -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";
index 689ff52..786aaff 100755 (executable)
@@ -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");
+
+} }
index d4dfcd7..61a33d3 100755 (executable)
@@ -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);
 }
 
 {
index 2e9c641..09ad330 100644 (file)
@@ -11,6 +11,9 @@ BEGIN {
            exit 0;
        }
     }
+    elsif(!grep {/blib/} @INC) {
+      unshift(@INC, qw(./inc ./blib/arch ./blib/lib));
+    }
 }
 
 use Test::More tests => 4;
index 890f6b0..e8fa48a 100644 (file)
@@ -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 (file)
--- 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)
index 6b01294..4a2aa5a 100755 (executable)
--- 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
index a9c3c25..e3dc42c 100644 (file)
--- 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
index dd520af..fb5ea37 100644 (file)
@@ -1942,6 +1942,51 @@ will be the return value as well (read more about C<eval_pv> in
 L<perlapi/eval_pv>).  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<List::Util> 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<perlxs>, L<perlguts>, L<perlembed>
index 3c16b0d..930a6cb 100644 (file)
@@ -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<perlfunc/goto>.
 
+=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<PERL_ENV_TABLES> (see L<perlvms>) 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<sort { &func } @x> instead of C<sort func @x>.
-
 =item Can't "redo" outside a loop block
 
 (F) A "redo" statement was executed to restart the current block, but
index 8a6c3e5..d5bb802 100644 (file)
--- 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;
                }
index fefec9a..908ee0b 100644 (file)
--- 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 */
 
index 3dda7cc..68ad610 100644 (file)
--- 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 (file)
--- 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 */
 
index bdb4885..7081f21 100755 (executable)
@@ -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");
index b8fb9a6..99e2e5d 100644 (file)
@@ -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);
index bdfb381..e12e85f 100644 (file)
--- 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*)