simplify sort sub return arg processing

This commit:

1) makes the  gimme of sort blocks, as specified by the pushed cx_gimme,
be G_SCALAR. Formerly it was likely to be G_ARRAY, as it inherited
whatever sort() was called as, and sort doesn't bother calling a sort
block unless sort was called in list context.

This change is largely cosmetic, as
    a) the sort block is already compiled in scalar context; and
    b) the code in S_sortcv() etc does its own return arg context
       processing anyway, and assumes scalar context.
But it makes it consistent with sort SUB, which *does* set gimme to
G_SCALAR.

2) Makes use of the fact that a sort sub or block will always be
called as the first context in a new stackinfo, and such stackinfos always
have PL_stack_base[0] set to &PL_sv_undef as a guard.
So handling scalar context return (where zero args returned needs to be
converted into 1 PL_sv_undef arg) can be simplified by just always
accessing the last arg, *PL_stack_sp, regardless of whether 0,1,2+ args
were returned.
Note that some code making use of MULTICALL (e.g. List::Util) has already
been (possibly inadvertently) relying on this fact.

3) Remove the "Sort subroutine didn't return single value" fatal error.
This croak was removed from the sort BLOCK and sort NON-XS-SUB variants
in v5.15.5-82-g1715fa6, but the croak was left for XS sort subs.
That commit incorrectly asserted that for "sort BLOCK" and "sort
NON-XS-SUB", more than 1 arg could never be returned, but:

    $ perl -e'sub f { return (1,2) } @a = sort f 1,2,3'
    perl: pp_sort.c:1789: S_sortcv: Assertion `PL_stack_sp ==
        PL_stack_base' failed.

That has been fixed by (2) above. By removing the croak from the XS branch
too, we make things consistent. This means that an XS sub which returns
more than 1 arg will just gets its return args be evaluated in scalar
context (so @return_args[-1] will be used), rather than being handled
specially.

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 0adabf5..ab94d59 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -5438,11 +5438,6 @@ overhauled.
 (F) An ancient error message that almost nobody ever runs into anymore.
 But before sort was a keyword, people sometimes used it as a filehandle.
 
-=item Sort subroutine didn't return single value
-
-(F) A sort comparison subroutine written in XS must return exactly one
-item.  See L<perlfunc/sort>.
-
 =item Source filters apply only to byte streams
 
 (F) You tried to activate a source filter (usually by loading a

diff --git a/pp_ctl.c b/pp_ctl.c
index eafd9ed..211f0bf 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2424,8 +2424,12 @@ PP(pp_return)
                                     * sort block, which is a CXt_NULL
                                     * not a CXt_SUB */
            dounwind(0);
-           PL_stack_base[1] = *PL_stack_sp;
-           PL_stack_sp = PL_stack_base + 1;
+            /* if we were in list context, we would have to splice out
+             * any junk before the return args, like we do in the general
+             * pp_return case, e.g.
+             *   sub f { for (junk1, junk2) { return arg1, arg2 }}
+             */
+            assert(cxstack[0].blk_gimme == G_SCALAR);
            return 0;
        }
        else

diff --git a/pp_sort.c b/pp_sort.c
index 3203f4c..be7922f 100644 (file)
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -1661,10 +1661,10 @@ PP(pp_sort)
                SAVESPTR(GvSV(PL_secondgv));
            }
 
+            gimme = G_SCALAR;
            PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
            if (!(flags & OPf_SPECIAL)) {
                cx->cx_type = CXt_SUB;
-               cx->blk_gimme = G_SCALAR;
                /* If our comparison routine is already active (CvDEPTH is
                 * is not 0),  then PUSHSUB does not increase the refcount,
                 * so we have to do it ourselves, because the LEAVESUB fur-
@@ -1782,12 +1782,10 @@ S_sortcv(pTHX_ SV *const a, SV *const b)
     PL_op = PL_sortcop;
     CALLRUNOPS(aTHX);
     PL_curcop = cop;
-    if (PL_stack_sp != PL_stack_base + 1) {
-       assert(PL_stack_sp == PL_stack_base);
-       result = SvIV(&PL_sv_undef);
-    }
-    else
-        result = SvIV(*PL_stack_sp);
+    /* entry zero of a stack is always PL_sv_undef, which
+     * simplifies converting a '()' return into undef in scalar context */
+    assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
+    result = SvIV(*PL_stack_sp);
 
     while (PL_scopestack_ix > oldscopeix) {
        LEAVE;
@@ -1835,12 +1833,10 @@ S_sortcv_stacked(pTHX_ SV *const a, SV *const b)
     PL_op = PL_sortcop;
     CALLRUNOPS(aTHX);
     PL_curcop = cop;
-    if (PL_stack_sp != PL_stack_base + 1) {
-       assert(PL_stack_sp == PL_stack_base);
-       result = SvIV(&PL_sv_undef);
-    }
-    else
-        result = SvIV(*PL_stack_sp);
+    /* entry zero of a stack is always PL_sv_undef, which
+     * simplifies converting a '()' return into undef in scalar context */
+    assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
+    result = SvIV(*PL_stack_sp);
 
     while (PL_scopestack_ix > oldscopeix) {
        LEAVE;
@@ -1869,9 +1865,11 @@ S_sortcv_xsub(pTHX_ SV *const a, SV *const b)
     *++SP = b;
     PUTBACK;
     (void)(*CvXSUB(cv))(aTHX_ cv);
-    if (PL_stack_sp != PL_stack_base + 1)
-       Perl_croak(aTHX_ "Sort subroutine didn't return single value");
+    /* entry zero of a stack is always PL_sv_undef, which
+     * simplifies converting a '()' return into undef in scalar context */
+    assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
     result = SvIV(*PL_stack_sp);
+
     while (PL_scopestack_ix > oldscopeix) {
        LEAVE;
     }

diff --git a/t/op/sort.t b/t/op/sort.t
index 4909474..01227e3 100644 (file)
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 use warnings;
-plan( tests => 183 );
+plan(tests => 190);
 
 # these shouldn't hang
 {
@@ -1018,3 +1018,29 @@ package deletions {
     @_=sort { delete $deletions::{a}; delete $deletions::{b}; 3 } 1..3;
 }
 pass "no crash when sort block deletes *a and *b";
+
+# make sure return args are always evaluated in scalar context
+
+{
+    package Ret;
+    no warnings 'void';
+    sub f0 { }
+    sub f1 { $b <=> $a, $a <=> $b }
+    sub f2 { return ($b <=> $a, $a <=> $b) }
+    sub f3 { for ($b <=> $a) { return ($b <=> $a, $a <=> $b) } }
+
+    {
+        no warnings 'uninitialized';
+        ::is (join('-', sort { () } 3,1,2,4), '3-1-2-4', "Ret: null blk");
+    }
+    ::is (join('-', sort { $b <=> $a, $a <=> $b } 3,1,2,4), '1-2-3-4', "Ret: blk");
+    ::is (join('-', sort { for($b <=> $a) { return ($b <=> $a, $a <=> $b) } }
+                            3,1,2,4), '1-2-3-4', "Ret: blk ret");
+    {
+        no warnings 'uninitialized';
+        ::is (join('-', sort f0 3,1,2,4), '3-1-2-4', "Ret: f0");
+    }
+    ::is (join('-', sort f1 3,1,2,4), '1-2-3-4', "Ret: f1");
+    ::is (join('-', sort f2 3,1,2,4), '1-2-3-4', "Ret: f2");
+    ::is (join('-', sort f3 3,1,2,4), '1-2-3-4', "Ret: f3");
+}