/* Timsort for sequences.
Copyright (C) 2022-2024 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
/* This is a version of the cpython code implementing the TIMSORT
sorting algorithm described in
https://github.com/python/cpython/blob/main/Objects/listsort.txt.
This algorithm identifies and pushes naturally ordered sublists of
the original list, or "runs", onto a stack, and merges them
periodically according to a merge strategy called "powersort".
State is maintained during the sort in a merge_state structure,
which is passed around as an argument to all the subroutines. A
"stretch" structure includes a pointer to the run BASE of length
LEN along with its POWER (a computed integer used by the powersort
merge strategy that depends on this run and the succeeding run.) */
#include <config.h>
#include "lisp.h"
/* MAX_MERGE_PENDING is the maximum number of entries in merge_state's
pending-stretch stack. For a list with n elements, this needs at most
floor(log2(n)) + 1 entries even if we didn't force runs to a
minimal length. So the number of bits in a ptrdiff_t is plenty large
enough for all cases. */
#define MAX_MERGE_PENDING (sizeof (ptrdiff_t) * 8)
/* Once we get into galloping mode, we stay there as long as both runs
win at least GALLOP_WIN_MIN consecutive times. */
#define GALLOP_WIN_MIN 7
/* A small temp array of size MERGESTATE_TEMP_SIZE is used to avoid
malloc when merging small lists. */
#define MERGESTATE_TEMP_SIZE 256
struct stretch
{
Lisp_Object *base;
ptrdiff_t len;
int power;
};
struct reloc
{
Lisp_Object **src;
Lisp_Object **dst;
ptrdiff_t *size;
int order; /* -1 while in merge_lo; +1 while in merg_hi; 0 otherwise. */
};
typedef struct
{
Lisp_Object *listbase;
ptrdiff_t listlen;
/* PENDING is a stack of N pending stretches yet to be merged.
Stretch #i starts at address base[i] and extends for len[i]
elements. */
int n;
struct stretch pending[MAX_MERGE_PENDING];
/* The variable MIN_GALLOP, initialized to GALLOP_WIN_MIN, controls
when we get *into* galloping mode. merge_lo and merge_hi tend to
nudge it higher for random data, and lower for highly structured
data. */
ptrdiff_t min_gallop;
/* 'A' is temporary storage, able to hold ALLOCED elements, to help
with merges. 'A' initially points to TEMPARRAY, and subsequently
to newly allocated memory if needed. */
Lisp_Object *a;
ptrdiff_t alloced;
specpdl_ref count;
Lisp_Object temparray[MERGESTATE_TEMP_SIZE];
/* If an exception is thrown while merging we might have to relocate
some list elements from temporary storage back into the list.
RELOC keeps track of the information needed to do this. */
struct reloc reloc;
/* PREDICATE is the lisp comparison predicate for the sort. */
Lisp_Object predicate;
} merge_state;
/* Return true iff (PREDICATE A B) is non-nil. */
static inline bool
inorder (const Lisp_Object predicate, const Lisp_Object a, const Lisp_Object b)
{
return !NILP (call2 (predicate, a, b));
}
/* Sort the list starting at LO and ending at HI using a stable binary
insertion sort algorithm. On entry the sublist [LO, START) (with
START between LO and HIGH) is known to be sorted (pass START == LO
if you are unsure). Even in case of error, the output will be some
permutation of the input (nothing is lost or duplicated). */
static void
binarysort (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
Lisp_Object *start)
{
Lisp_Object pred = ms->predicate;
eassume (lo <= start && start <= hi);
if (lo == start)
++start;
for (; start < hi; ++start)
{
Lisp_Object *l = lo;
Lisp_Object *r = start;
Lisp_Object pivot = *r;
eassume (l < r);
do {
Lisp_Object *p = l + ((r - l) >> 1);
if (inorder (pred, pivot, *p))
r = p;
else
l = p + 1;
} while (l < r);
eassume (l == r);
for (Lisp_Object *p = start; p > l; --p)
p[0] = p[-1];
*l = pivot;
}
}
/* Find and return the length of the "run" (the longest
non-decreasing sequence or the longest strictly decreasing
sequence, with the Boolean *DESCENDING set to 0 in the former
case, or to 1 in the latter) beginning at LO, in the slice [LO,
HI) with LO < HI. The strictness of the definition of
"descending" ensures there are no equal elements to get out of
order so the caller can safely reverse a descending sequence
without violating stability. */
static ptrdiff_t
count_run (merge_state *ms, Lisp_Object *lo, const Lisp_Object *hi,
bool *descending)
{
Lisp_Object pred = ms->predicate;
eassume (lo < hi);
*descending = 0;
++lo;
ptrdiff_t n = 1;
if (lo == hi)
return n;
n = 2;
if (inorder (pred, lo[0], lo[-1]))
{
*descending = 1;
for (lo = lo + 1; lo < hi; ++lo, ++n)
{
if (!inorder (pred, lo[0], lo[-1]))
break;
}
}
else
{
for (lo = lo + 1; lo < hi; ++lo, ++n)
{
if (inorder (pred, lo[0], lo[-1]))
break;
}
}
return n;
}
/* Locate and return the proper insertion position of KEY in a sorted
vector: if the vector contains an element equal to KEY, return the
position immediately to the left of the leftmost equal element.
[GALLOP_RIGHT does the same except it returns the position to the
right of the rightmost equal element (if any).]
'A' is a sorted vector of N elements. N must be > 0.
Elements preceding HINT, a non-negative index less than N, are
skipped. The closer HINT is to the final result, the faster this
runs.
The return value is the int k in [0, N] such that
A[k-1] < KEY <= a[k]
pretending that *(A-1) precedes all values and *(A+N) succeeds all
values. In other words, the first k elements of A should precede
KEY, and the last N-k should follow KEY. */
static ptrdiff_t
gallop_left (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
const ptrdiff_t n, const ptrdiff_t hint)
{
Lisp_Object pred = ms->predicate;
eassume (a && n > 0 && hint >= 0 && hint < n);
a += hint;
ptrdiff_t lastofs = 0;
ptrdiff_t ofs = 1;
if (inorder (pred, *a, key))
{
/* When a[hint] < key, gallop right until
a[hint + lastofs] < key <= a[hint + ofs]. */
const ptrdiff_t maxofs = n - hint; /* This is one after the end of a. */
while (ofs < maxofs)
{
if (inorder (pred, a[ofs], key))
{
lastofs = ofs;
eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
ofs = (ofs << 1) + 1;
}
else
break; /* Here key <= a[hint+ofs]. */
}
if (ofs > maxofs)
ofs = maxofs;
/* Translate back to offsets relative to &a[0]. */
lastofs += hint;
ofs += hint;
}
else
{
/* When key <= a[hint], gallop left, until
a[hint - ofs] < key <= a[hint - lastofs]. */
const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */
while (ofs < maxofs)
{
if (inorder (pred, a[-ofs], key))
break;
/* Here key <= a[hint - ofs]. */
lastofs = ofs;
eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
ofs = (ofs << 1) + 1;
}
if (ofs > maxofs)
ofs = maxofs;
/* Translate back to use positive offsets relative to &a[0]. */
ptrdiff_t k = lastofs;
lastofs = hint - ofs;
ofs = hint - k;
}
a -= hint;
eassume (-1 <= lastofs && lastofs < ofs && ofs <= n);
/* Now a[lastofs] < key <= a[ofs], so key belongs somewhere to the
right of lastofs but no farther right than ofs. Do a binary
search, with invariant a[lastofs-1] < key <= a[ofs]. */
++lastofs;
while (lastofs < ofs)
{
ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1);
if (inorder (pred, a[m], key))
lastofs = m + 1; /* Here a[m] < key. */
else
ofs = m; /* Here key <= a[m]. */
}
eassume (lastofs == ofs); /* Then a[ofs-1] < key <= a[ofs]. */
return ofs;
}
/* Locate and return the proper position of KEY in a sorted vector
exactly like GALLOP_LEFT, except that if KEY already exists in
A[0:N] find the position immediately to the right of the rightmost
equal value.
The return value is the int k in [0, N] such that
A[k-1] <= KEY < A[k]. */
static ptrdiff_t
gallop_right (merge_state *ms, const Lisp_Object key, Lisp_Object *a,
const ptrdiff_t n, const ptrdiff_t hint)
{
Lisp_Object pred = ms->predicate;
eassume (a && n > 0 && hint >= 0 && hint < n);
a += hint;
ptrdiff_t lastofs = 0;
ptrdiff_t ofs = 1;
if (inorder (pred, key, *a))
{
/* When key < a[hint], gallop left until
a[hint - ofs] <= key < a[hint - lastofs]. */
const ptrdiff_t maxofs = hint + 1; /* Here &a[0] is lowest. */
while (ofs < maxofs)
{
if (inorder (pred, key, a[-ofs]))
{
lastofs = ofs;
eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
ofs = (ofs << 1) + 1;
}
else /* Here a[hint - ofs] <= key. */
break;
}
if (ofs > maxofs)
ofs = maxofs;
/* Translate back to use positive offsets relative to &a[0]. */
ptrdiff_t k = lastofs;
lastofs = hint - ofs;
ofs = hint - k;
}
else
{
/* When a[hint] <= key, gallop right, until
a[hint + lastofs] <= key < a[hint + ofs]. */
const ptrdiff_t maxofs = n - hint; /* Here &a[n-1] is highest. */
while (ofs < maxofs)
{
if (inorder (pred, key, a[ofs]))
break;
/* Here a[hint + ofs] <= key. */
lastofs = ofs;
eassume (ofs <= (PTRDIFF_MAX - 1) / 2);
ofs = (ofs << 1) + 1;
}
if (ofs > maxofs)
ofs = maxofs;
/* Translate back to use offsets relative to &a[0]. */
lastofs += hint;
ofs += hint;
}
a -= hint;
eassume (-1 <= lastofs && lastofs < ofs && ofs <= n);
/* Now a[lastofs] <= key < a[ofs], so key belongs somewhere to the
right of lastofs but no farther right than ofs. Do a binary
search, with invariant a[lastofs-1] <= key < a[ofs]. */
++lastofs;
while (lastofs < ofs)
{
ptrdiff_t m = lastofs + ((ofs - lastofs) >> 1);
if (inorder (pred, key, a[m]))
ofs = m; /* Here key < a[m]. */
else
lastofs = m + 1; /* Here a[m] <= key. */
}
eassume (lastofs == ofs); /* Now a[ofs-1] <= key < a[ofs]. */
return ofs;
}
static void
merge_init (merge_state *ms, const ptrdiff_t list_size, Lisp_Object *lo,
const Lisp_Object predicate)
{
eassume (ms != NULL);
ms->a = ms->temparray;
ms->alloced = MERGESTATE_TEMP_SIZE;
ms->n = 0;
ms->min_gallop = GALLOP_WIN_MIN;
ms->listlen = list_size;
ms->listbase = lo;
ms->predicate = predicate;
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
}
/* The dynamically allocated memory may hold lisp objects during
merging. MERGE_MARKMEM marks them so they aren't reaped during
GC. */
static void
merge_markmem (void *arg)
{
merge_state *ms = arg;
eassume (ms != NULL);
if (ms->reloc.size != NULL && *ms->reloc.size > 0)
{
eassume (ms->reloc.src != NULL);
mark_objects (*ms->reloc.src, *ms->reloc.size);
}
}
/* Free all temp storage. If an exception occurs while merging,
relocate any lisp elements in temp storage back to the original
array. */
static void
cleanup_mem (void *arg)
{
merge_state *ms = arg;
eassume (ms != NULL);
/* If we have an exception while merging, some of the list elements
might only live in temp storage; we copy everything remaining in
the temp storage back into the original list. This ensures that
the original list has all of the original elements, although
their order is unpredictable. */
if (ms->reloc.order != 0 && *ms->reloc.size > 0)
{
eassume (*ms->reloc.src != NULL && *ms->reloc.dst != NULL);
ptrdiff_t n = *ms->reloc.size;
ptrdiff_t shift = ms->reloc.order == -1 ? 0 : n - 1;
memcpy (*ms->reloc.dst - shift, *ms->reloc.src, n * word_size);
}
/* Free any remaining temp storage. */
xfree (ms->a);
}
/* Allocate enough temp memory for NEED array slots. Any previously
allocated memory is first freed, and a cleanup routine is
registered to free memory at the very end of the sort, or on
exception. */
static void
merge_getmem (merge_state *ms, const ptrdiff_t need)
{
eassume (ms != NULL);
if (ms->a == ms->temparray)
{
/* We only get here if alloc is needed and this is the first
time, so we set up the unwind protection. */
specpdl_ref count = SPECPDL_INDEX ();
record_unwind_protect_ptr_mark (cleanup_mem, ms, merge_markmem);
ms->count = count;
}
else
{
/* We have previously alloced storage. Since we don't care
what's in the block we don't use realloc which would waste
cycles copying the old data. We just free and alloc
again. */
xfree (ms->a);
}
ms->a = xmalloc (need * word_size);
ms->alloced = need;
}
static inline void
needmem (merge_state *ms, ptrdiff_t na)
{
if (na > ms->alloced)
merge_getmem (ms, na);
}
/* Stably merge (in-place) the NA elements starting at SSA with the NB
elements starting at SSB = SSA + NA. NA and NB must be positive.
Require that SSA[NA-1] belongs at the end of the merge, and NA <=
NB. */
static void
merge_lo (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na, Lisp_Object *ssb,
ptrdiff_t nb)
{
Lisp_Object pred = ms->predicate;
eassume (ms && ssa && ssb && na > 0 && nb > 0);
eassume (ssa + na == ssb);
needmem (ms, na);
memcpy (ms->a, ssa, na * word_size);
Lisp_Object *dest = ssa;
ssa = ms->a;
ms->reloc = (struct reloc){&ssa, &dest, &na, -1};
*dest++ = *ssb++;
--nb;
if (nb == 0)
goto Succeed;
if (na == 1)
goto CopyB;
ptrdiff_t min_gallop = ms->min_gallop;
for (;;)
{
ptrdiff_t acount = 0; /* The # of consecutive times A won. */
ptrdiff_t bcount = 0; /* The # of consecutive times B won. */
for (;;)
{
eassume (na > 1 && nb > 0);
if (inorder (pred, *ssb, *ssa))
{
*dest++ = *ssb++ ;
++bcount;
acount = 0;
--nb;
if (nb == 0)
goto Succeed;
if (bcount >= min_gallop)
break;
}
else
{
*dest++ = *ssa++;
++acount;
bcount = 0;
--na;
if (na == 1)
goto CopyB;
if (acount >= min_gallop)
break;
}
}
/* One run is winning so consistently that galloping may be a
huge speedup. We try that, and continue galloping until (if
ever) neither run appears to be winning consistently
anymore. */
++min_gallop;
do {
eassume (na > 1 && nb > 0);
min_gallop -= min_gallop > 1;
ms->min_gallop = min_gallop;
ptrdiff_t k = gallop_right (ms, ssb[0], ssa, na, 0);
acount = k;
if (k)
{
memcpy (dest, ssa, k * word_size);
dest += k;
ssa += k;
na -= k;
if (na == 1)
goto CopyB;
/* While na==0 is impossible for a consistent comparison
function, we shouldn't assume that it is. */
if (na == 0)
goto Succeed;
}
*dest++ = *ssb++ ;
--nb;
if (nb == 0)
goto Succeed;
k = gallop_left (ms, ssa[0], ssb, nb, 0);
bcount = k;
if (k)
{
memmove (dest, ssb, k * word_size);
dest += k;
ssb += k;
nb -= k;
if (nb == 0)
goto Succeed;
}
*dest++ = *ssa++;
--na;
if (na == 1)
goto CopyB;
} while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN);
++min_gallop; /* Apply a penalty for leaving galloping mode. */
ms->min_gallop = min_gallop;
}
Succeed:
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
if (na)
memcpy (dest, ssa, na * word_size);
return;
CopyB:
eassume (na == 1 && nb > 0);
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
/* The last element of ssa belongs at the end of the merge. */
memmove (dest, ssb, nb * word_size);
dest[nb] = ssa[0];
}
/* Stably merge (in-place) the NA elements starting at SSA with the NB
elements starting at SSB = SSA + NA. NA and NB must be positive.
Require that SSA[NA-1] belongs at the end of the merge, and NA >=
NB. */
static void
merge_hi (merge_state *ms, Lisp_Object *ssa, ptrdiff_t na,
Lisp_Object *ssb, ptrdiff_t nb)
{
Lisp_Object pred = ms->predicate;
eassume (ms && ssa && ssb && na > 0 && nb > 0);
eassume (ssa + na == ssb);
needmem (ms, nb);
Lisp_Object *dest = ssb;
dest += nb - 1;
memcpy(ms->a, ssb, nb * word_size);
Lisp_Object *basea = ssa;
Lisp_Object *baseb = ms->a;
ssb = ms->a + nb - 1;
ssa += na - 1;
ms->reloc = (struct reloc){&baseb, &dest, &nb, 1};
*dest-- = *ssa--;
--na;
if (na == 0)
goto Succeed;
if (nb == 1)
goto CopyA;
ptrdiff_t min_gallop = ms->min_gallop;
for (;;) {
ptrdiff_t acount = 0; /* The # of consecutive times A won. */
ptrdiff_t bcount = 0; /* The # of consecutive times B won. */
for (;;) {
eassume (na > 0 && nb > 1);
if (inorder (pred, *ssb, *ssa))
{
*dest-- = *ssa--;
++acount;
bcount = 0;
--na;
if (na == 0)
goto Succeed;
if (acount >= min_gallop)
break;
}
else
{
*dest-- = *ssb--;
++bcount;
acount = 0;
--nb;
if (nb == 1)
goto CopyA;
if (bcount >= min_gallop)
break;
}
}
/* One run is winning so consistently that galloping may be a huge
speedup. Try that, and continue galloping until (if ever)
neither run appears to be winning consistently anymore. */
++min_gallop;
do {
eassume (na > 0 && nb > 1);
min_gallop -= min_gallop > 1;
ms->min_gallop = min_gallop;
ptrdiff_t k = gallop_right (ms, ssb[0], basea, na, na - 1);
k = na - k;
acount = k;
if (k)
{
dest += -k;
ssa += -k;
memmove(dest + 1, ssa + 1, k * word_size);
na -= k;
if (na == 0)
goto Succeed;
}
*dest-- = *ssb--;
--nb;
if (nb == 1)
goto CopyA;
k = gallop_left (ms, ssa[0], baseb, nb, nb - 1);
k = nb - k;
bcount = k;
if (k)
{
dest += -k;
ssb += -k;
memcpy(dest + 1, ssb + 1, k * word_size);
nb -= k;
if (nb == 1)
goto CopyA;
/* While nb==0 is impossible for a consistent comparison
function we shouldn't assume that it is. */
if (nb == 0)
goto Succeed;
}
*dest-- = *ssa--;
--na;
if (na == 0)
goto Succeed;
} while (acount >= GALLOP_WIN_MIN || bcount >= GALLOP_WIN_MIN);
++min_gallop; /* Apply a penalty for leaving galloping mode. */
ms->min_gallop = min_gallop;
}
Succeed:
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
if (nb)
memcpy (dest - nb + 1, baseb, nb * word_size);
return;
CopyA:
eassume (nb == 1 && na > 0);
ms->reloc = (struct reloc){NULL, NULL, NULL, 0};
/* The first element of ssb belongs at the front of the merge. */
memmove (dest + 1 - na, ssa + 1 - na, na * word_size);
dest += -na;
ssa += -na;
dest[0] = ssb[0];
}
/* Merge the two runs at stack indices I and I+1. */
static void
merge_at (merge_state *ms, const ptrdiff_t i)
{
eassume (ms != NULL);
eassume (ms->n >= 2);
eassume (i >= 0);
eassume (i == ms->n - 2 || i == ms->n - 3);
Lisp_Object *ssa = ms->pending[i].base;
ptrdiff_t na = ms->pending[i].len;
Lisp_Object *ssb = ms->pending[i + 1].base;
ptrdiff_t nb = ms->pending[i + 1].len;
eassume (na > 0 && nb > 0);
eassume (ssa + na == ssb);
/* Record the length of the combined runs. The current run i+1 goes
away after the merge. If i is the 3rd-last run now, slide the
last run (which isn't involved in this merge) over to i+1. */
ms->pending[i].len = na + nb;
if (i == ms->n - 3)
ms->pending[i + 1] = ms->pending[i + 2];
--ms->n;
/* Where does b start in a? Elements in a before that can be
ignored (they are already in place). */
ptrdiff_t k = gallop_right (ms, *ssb, ssa, na, 0);
eassume (k >= 0);
ssa += k;
na -= k;
if (na == 0)
return;
/* Where does a end in b? Elements in b after that can be ignored
(they are already in place). */
nb = gallop_left (ms, ssa[na - 1], ssb, nb, nb - 1);
if (nb == 0)
return;
eassume (nb > 0);
/* Merge what remains of the runs using a temp array with size
min(na, nb) elements. */
if (na <= nb)
merge_lo (ms, ssa, na, ssb, nb);
else
merge_hi (ms, ssa, na, ssb, nb);
}
/* Compute the "power" of the first of two adjacent runs beginning at
index S1, with the first having length N1 and the second (starting
at index S1+N1) having length N2. The run has total length N. */
static int
powerloop (const ptrdiff_t s1, const ptrdiff_t n1, const ptrdiff_t n2,
const ptrdiff_t n)
{
eassume (s1 >= 0);
eassume (n1 > 0 && n2 > 0);
eassume (s1 + n1 + n2 <= n);
/* The midpoints a and b are
a = s1 + n1/2
b = s1 + n1 + n2/2 = a + (n1 + n2)/2
These may not be integers because of the "/2", so we work with
2*a and 2*b instead. It makes no difference to the outcome,
since the bits in the expansion of (2*i)/n are merely shifted one
position from those of i/n. */
ptrdiff_t a = 2 * s1 + n1;
ptrdiff_t b = a + n1 + n2;
int result = 0;
/* Emulate a/n and b/n one bit a time, until their bits differ. */
for (;;)
{
++result;
if (a >= n)
{ /* Both quotient bits are now 1. */
eassume (b >= a);
a -= n;
b -= n;
}
else if (b >= n)
{ /* a/n bit is 0 and b/n bit is 1. */
break;
} /* Otherwise both quotient bits are 0. */
eassume (a < b && b < n);
a <<= 1;
b <<= 1;
}
return result;
}
/* Update the state upon identifying a run of length N2. If there's
already a stretch on the stack, apply the "powersort" merge
strategy: compute the topmost stretch's "power" (depth in a
conceptual binary merge tree) and merge adjacent runs on the stack
with greater power. */
static void
found_new_run (merge_state *ms, const ptrdiff_t n2)
{
eassume (ms != NULL);
if (ms->n)
{
eassume (ms->n > 0);
struct stretch *p = ms->pending;
ptrdiff_t s1 = p[ms->n - 1].base - ms->listbase;
ptrdiff_t n1 = p[ms->n - 1].len;
int power = powerloop (s1, n1, n2, ms->listlen);
while (ms->n > 1 && p[ms->n - 2].power > power)
{
merge_at (ms, ms->n - 2);
}
eassume (ms->n < 2 || p[ms->n - 2].power < power);
p[ms->n - 1].power = power;
}
}
/* Unconditionally merge all stretches on the stack until only one
remains. */
static void
merge_force_collapse (merge_state *ms)
{
struct stretch *p = ms->pending;
eassume (ms != NULL);
while (ms->n > 1)
{
ptrdiff_t n = ms->n - 2;
if (n > 0 && p[n - 1].len < p[n + 1].len)
--n;
merge_at (ms, n);
}
}
/* Compute a good value for the minimum run length; natural runs
shorter than this are boosted artificially via binary insertion.
If N < 64, return N (it's too small to bother with fancy stuff).
Otherwise if N is an exact power of 2, return 32. Finally, return
an int k, 32 <= k <= 64, such that N/k is close to, but strictly
less than, an exact power of 2. */
static ptrdiff_t
merge_compute_minrun (ptrdiff_t n)
{
ptrdiff_t r = 0; /* r will become 1 if any non-zero bits are
shifted off. */
eassume (n >= 0);
while (n >= 64)
{
r |= n & 1;
n >>= 1;
}
return n + r;
}
static void
reverse_vector (Lisp_Object *s, const ptrdiff_t n)
{
for (ptrdiff_t i = 0; i < n >> 1; i++)
{
Lisp_Object tem = s[i];
s[i] = s[n - i - 1];
s[n - i - 1] = tem;
}
}
/* Sort the array SEQ with LENGTH elements in the order determined by
PREDICATE. */
void
tim_sort (Lisp_Object predicate, Lisp_Object *seq, const ptrdiff_t length)
{
if (SYMBOLP (predicate))
{
/* Attempt to resolve the function as far as possible ahead of time,
to avoid having to do it for each call. */
Lisp_Object fun = XSYMBOL (predicate)->u.s.function;
if (SYMBOLP (fun))
/* Function was an alias; use slow-path resolution. */
fun = indirect_function (fun);
/* Don't resolve to an autoload spec; that would be very slow. */
if (!NILP (fun) && !(CONSP (fun) && EQ (XCAR (fun), Qautoload)))
predicate = fun;
}
merge_state ms;
Lisp_Object *lo = seq;
merge_init (&ms, length, lo, predicate);
/* March over the array once, left to right, finding natural runs,
and extending short natural runs to minrun elements. */
const ptrdiff_t minrun = merge_compute_minrun (length);
ptrdiff_t nremaining = length;
do {
bool descending;
/* Identify the next run. */
ptrdiff_t n = count_run (&ms, lo, lo + nremaining, &descending);
if (descending)
reverse_vector (lo, n);
/* If the run is short, extend it to min(minrun, nremaining). */
if (n < minrun)
{
const ptrdiff_t force = nremaining <= minrun ?
nremaining : minrun;
binarysort (&ms, lo, lo + force, lo + n);
n = force;
}
eassume (ms.n == 0 || ms.pending[ms.n - 1].base +
ms.pending[ms.n - 1].len == lo);
found_new_run (&ms, n);
/* Push the new run on to the stack. */
eassume (ms.n < MAX_MERGE_PENDING);
ms.pending[ms.n].base = lo;
ms.pending[ms.n].len = n;
++ms.n;
/* Advance to find the next run. */
lo += n;
nremaining -= n;
} while (nremaining);
merge_force_collapse (&ms);
eassume (ms.n == 1);
eassume (ms.pending[0].len == length);
lo = ms.pending[0].base;
if (ms.a != ms.temparray)
unbind_to (ms.count, Qnil);
}