sort/multicall patch

Message-ID: <20051029203307.GA8869@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@25953

28 files changed, 540 insertions, 178 deletions

diff --git a/AUTHORS b/AUTHORS
index d657439bf0..9aa2d3fb51 100644
--- 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>
diff --git a/MANIFEST b/MANIFEST
index 0d22963b7d..e2ffd04c21 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 6672a53923..f2e4463a19 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<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
diff --git a/embed.fnc b/embed.fnc
index 2ee9e07351..4202e7a6a4 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 56fd726dba..81628be99d 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 0c6a14dd8e..44b8122c41 100644
--- a/ext/List/Util/Util.xs
+++ b/ext/List/Util/Util.xs
@@ -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
 }
diff --git a/ext/List/Util/lib/List/Util.pm b/ext/List/Util/lib/List/Util.pm
index 55696ad279..c73b964c00 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 36476b3479..3655164eb4 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 784437cb64..a4c9261530 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 2fd67b0a99..1928ef2a8f 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 2fd67b0a99..1928ef2a8f 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 6196729daf..7b00ebd984 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 689ff52120..786aaffea6 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 d4dfcd70f1..61a33d32ea 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 2e9c641e02..09ad330684 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 890f6b05fe..e8fa48a1dc 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 02c1fe846d..2eefa1d1eb 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 6b0129490f..4a2aa5a896 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 a9c3c2524a..e3dc42c489 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 dd520afcaa..fb5ea37f0f 100644
--- a/pod/perlcall.pod
+++ b/pod/perlcall.pod
@@ -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>
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 3c16b0d2b6..930a6cbdcc 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<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
diff --git a/pp_ctl.c b/pp_ctl.c
index 8a6c3e5745..d5bb802bdc 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 fefec9a5fb..908ee0b3c5 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 3dda7cc67e..68ad610f10 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 f29434f00b..00aa612c43 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 bdb48856b9..7081f21b01 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 b8fb9a6abd..99e2e5d9d4 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 bdfb381cf6..e12e85f317 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*)