Commit 3e4117b58c for perl
commit 3e4117b58caec8763a7a2284fe30cfc8e9929ed3
Author: Richard Leach <rich+perl@hyphen-dash-hyphen.info>
Date: Tue Oct 13 21:51:37 2026 +0000
pp_sort: don't leave duplicate SV*s on the stack
`pp_sort` performs a "shuffle" loop in which SV*s on the stack may be
_copied_ down a place, taking a spot previously occupied by an optional
sort subroutine or by a NULL pointer.
However, the pointer at the original position was not cleared, so
unless it was overwritten by a subsequent `SV*` being moved down, the
stack would contain more than one pointer to the same SV. `pp_sort`
also did not adjust `PL_stack_sp` at the completion of this "shuffle",
so the duplicate pointers were live on the stack.
`pp_sort` itself would then sort only the "live" stack values and upon
successful completion, `PL_stack_sp` gets the correct adjustment.
In the event of a fatalized warning being thrown, or some other kind
of unhappy situation, unwinding of the stack on `RC_STACK` builds would
see any duplicate SV pointers and double decrement the SV's refcount.
In GH #24961 this caused the `SV` attached to an OP_CONST
to be freed prior to the optree being freed:
```
8 <@> sort lKS ->9
4 <0> pushmark s ->5
- <1> null lK/1 ->6
5 <$> const[PV "yarn"] s/BARE ->6
6 <$> const[IV 1] sM ->7
7 <$> const[IV 2] sM ->8
```
Prior to the shuffle:
```
ORIGMARK ...
MARK/p1 SV* [PV "yarn"]
p2 SV* [IV 1]
PL_stack_sp: SV* [IV 2]
```
After the shuffle:
```
ORIGMARK ...
MARK SV* [IV 1]
SV* [IV 2]
PL_stack_sp/p1 SV* [IV 2]
p2 ...
```
As the stack was unwound, the refcount on `SV* [IV 2]` dropped to zero,
causing it to be freed. The SV head would then be recycled, possibly
more than once, including by `pp_caller`. During global destruction and
freeing of the optree, freeing the `OP_CONST` for `[IV 2]` would try
to free the associated SV - which had, of course, already been freed.
diff --git a/pp_sort.c b/pp_sort.c
index cabfc09147..dd5dedb017 100644
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -877,7 +877,7 @@ PP(pp_sort)
copytmps = cBOOL(PL_sortcop);
for (i=max; i > 0 ; i--) {
- SV *sv = *p2++;
+ SV *sv = *p2;
if (sv) { /* Weed out nulls. */
if (copytmps && SvPADTMP(sv)) {
SV *nsv = sv_mortalcopy(sv);
@@ -909,12 +909,25 @@ PP(pp_sort)
if (SvAMAGIC(sv))
overloading = 1;
}
+ /* Stack unwinding, following a fatalized warning or other
+ * fatal event, should not encounter the same SV* in its
+ * new position and - if not overwritten - its old position.
+ * In RC_STACK builds, that would result in the SV having
+ * its refcount decremented twice over instead of once.
+ * See GH #24961 for one such example. */
+ if (p1 != p2)
+ *p2 = NULL;
*p1++ = sv;
}
else
max--;
+ p2++;
}
+ /* Adjust PL_stack_sp to point to the top of live SV*s.
+ * (The shuffle above could have left a run of NULLs.) */
+ PL_stack_sp = p1 - 1;
+
if (max > 1) {
SV **start;
if (PL_sortcop) {
diff --git a/t/op/sort.t b/t/op/sort.t
index cdc050f422..d7ec093f04 100644
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -7,7 +7,7 @@ BEGIN {
set_up_inc('../lib');
}
use warnings;
-plan(tests => 206);
+plan(tests => 210);
use Tie::Array; # we need to test sorting tied arrays
# these shouldn't hang
@@ -1247,3 +1247,15 @@ SKIP:
my sub lexcmp { $a <=> $b }
is join('', sort lexcmp 3,4,1,2), "1234", "lexical sort sub" ;
+
+# GH #24961: Stack unwinding does not double-decrement SV*s
+# [Needs: -DPERL_RC_STACK -DDEBUGGING -DDEBUG_LEAKING_SCALARS]
+{
+ use warnings FATAL => 'all';
+ my @x; $x[0]=4; $x[2]=3; $x[3]="z";
+ eval { @x = sort { $a <=> $b } @x };
+ is $x[0], 4, 'GH #24961: $x[0] is still alive';
+ is $x[1], undef, 'GH #24961: $x[1] is undef';
+ is $x[2], 3, 'GH #24961: $x[2] is still alive';
+ is $x[3], "z", 'GH #24961: $x[3] is still alive';
+}