summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/sort.c431
1 files changed, 83 insertions, 348 deletions
diff --git a/libguile/sort.c b/libguile/sort.c
index fd55cfe3b..7eb6d63ff 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -40,239 +40,25 @@
#include "libguile/vectors.h"
#include "libguile/lang.h"
#include "libguile/async.h"
+#include "libguile/dynwind.h"
#include "libguile/validate.h"
#include "libguile/sort.h"
-/* The routine quicksort was extracted from the GNU C Library qsort.c
- written by Douglas C. Schmidt (schmidt@ics.uci.edu)
- and adapted to guile by adding an extra pointer less
- to quicksort by Roland Orre <orre@nada.kth.se>.
-
- The reason to do this instead of using the library function qsort
- was to avoid dependency of the ANSI-C extensions for local functions
- and also to avoid obscure pool based solutions.
-
- This sorting routine is not much more efficient than the stable
- version but doesn't consume extra memory.
- */
-
-#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)
-
-
-/* Order size using quicksort. This implementation incorporates
- four optimizations discussed in Sedgewick:
-
- 1. Non-recursive, using an explicit stack of pointer that store the next
- array partition to sort. To save time, this maximum amount of space
- required to store an array of MAX_SIZE_T is allocated on the stack.
- Assuming a bit width of 32 bits for size_t, this needs only
- 32 * sizeof (stack_node) == 128 bytes. Pretty cheap, actually.
-
- 2. Chose the pivot element using a median-of-three decision tree. This
- reduces the probability of selecting a bad pivot value and eliminates
- certain extraneous comparisons.
-
- 3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort
- to order the MAX_THRESH items within each partition. This is a big win,
- since insertion sort is faster for small, mostly sorted array segments.
-
- 4. The larger of the two sub-partitions is always pushed onto the
- stack first, with the algorithm then concentrating on the
- smaller partition. This *guarantees* no more than log (n)
- stack size is needed (actually O(1) in this case)! */
-
-
-/* Discontinue quicksort algorithm when partition gets below this size.
- * This particular magic number was chosen to work best on a Sun 4/260. */
-#define MAX_THRESH 4
-
-
-/* Inline stack abstraction: The stack size for quicksorting at most as many
- * elements as can be given by a value of type size_t is, as described above,
- * log (MAX_SIZE_T), which is the number of bits of size_t. More accurately,
- * we would only need ceil (log (MAX_SIZE_T / MAX_THRESH)), but this is
- * ignored below. */
-
-/* Stack node declarations used to store unfulfilled partition obligations. */
-typedef struct {
- size_t lo;
- size_t hi;
-} stack_node;
-
-#define STACK_SIZE (8 * sizeof (size_t)) /* assume 8 bit char */
-#define PUSH(low, high) ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
-#define POP(low, high) ((void) (--top, (low = top->lo), (high = top->hi)))
-#define STACK_NOT_EMPTY (stack < top)
-
-
-static void
-quicksort (SCM *const base_ptr, size_t nr_elems, scm_t_trampoline_2 cmp, SCM less)
-{
- static const char s_buggy_less[] = "buggy less predicate used when sorting";
-
- if (nr_elems == 0)
- /* Avoid lossage with unsigned arithmetic below. */
- return;
-
- if (nr_elems > MAX_THRESH)
- {
- size_t lo = 0;
- size_t hi = nr_elems - 1;
-
- stack_node stack[STACK_SIZE];
- stack_node *top = stack + 1;
-
- while (STACK_NOT_EMPTY)
- {
- size_t left;
- size_t right;
- size_t mid = lo + (hi - lo) / 2;
- SCM pivot;
-
- /* Select median value from among LO, MID, and HI. Rearrange
- LO and HI so the three values are sorted. This lowers the
- probability of picking a pathological pivot value and
- skips a comparison for both the left and right. */
-
- SCM_TICK;
-
- if (scm_is_true ((*cmp) (less, base_ptr[mid], base_ptr[lo])))
- SWAP (base_ptr[mid], base_ptr[lo]);
- if (scm_is_true ((*cmp) (less, base_ptr[hi], base_ptr[mid])))
- SWAP (base_ptr[mid], base_ptr[hi]);
- else
- goto jump_over;
- if (scm_is_true ((*cmp) (less, base_ptr[mid], base_ptr[lo])))
- SWAP (base_ptr[mid], base_ptr[lo]);
- jump_over:;
-
- pivot = base_ptr[mid];
- left = lo + 1;
- right = hi - 1;
-
- /* Here's the famous ``collapse the walls'' section of quicksort.
- Gotta like those tight inner loops! They are the main reason
- that this algorithm runs much faster than others. */
- do
- {
- while (scm_is_true ((*cmp) (less, base_ptr[left], pivot)))
- {
- left++;
- /* The comparison predicate may be buggy */
- if (left > hi)
- scm_misc_error (NULL, s_buggy_less, SCM_EOL);
- }
-
- while (scm_is_true ((*cmp) (less, pivot, base_ptr[right])))
- {
- right--;
- /* The comparison predicate may be buggy */
- if (right < lo)
- scm_misc_error (NULL, s_buggy_less, SCM_EOL);
- }
-
- if (left < right)
- {
- SWAP (base_ptr[left], base_ptr[right]);
- left++;
- right--;
- }
- else if (left == right)
- {
- left++;
- right--;
- break;
- }
- }
- while (left <= right);
-
- /* Set up pointers for next iteration. First determine whether
- left and right partitions are below the threshold size. If so,
- ignore one or both. Otherwise, push the larger partition's
- bounds on the stack and continue sorting the smaller one. */
-
- if ((size_t) (right - lo) <= MAX_THRESH)
- {
- if ((size_t) (hi - left) <= MAX_THRESH)
- /* Ignore both small partitions. */
- POP (lo, hi);
- else
- /* Ignore small left partition. */
- lo = left;
- }
- else if ((size_t) (hi - left) <= MAX_THRESH)
- /* Ignore small right partition. */
- hi = right;
- else if ((right - lo) > (hi - left))
- {
- /* Push larger left partition indices. */
- PUSH (lo, right);
- lo = left;
- }
- else
- {
- /* Push larger right partition indices. */
- PUSH (left, hi);
- hi = right;
- }
- }
- }
-
- /* Once the BASE_PTR array is partially sorted by quicksort the rest is
- completely sorted using insertion sort, since this is efficient for
- partitions below MAX_THRESH size. BASE_PTR points to the beginning of the
- array to sort, and END idexes the very last element in the array (*not*
- one beyond it!). */
+/* We have two quicksort variants: one for contigous vectors and one
+ for vectors with arbitrary increments between elements. Note that
+ increments can be negative.
+*/
- {
- size_t tmp = 0;
- size_t end = nr_elems - 1;
- size_t thresh = min (end, MAX_THRESH);
- size_t run;
-
- /* Find smallest element in first threshold and place it at the
- array's beginning. This is the smallest array element,
- and the operation speeds up insertion sort's inner loop. */
-
- for (run = tmp + 1; run <= thresh; run++)
- if (scm_is_true ((*cmp) (less, base_ptr[run], base_ptr[tmp])))
- tmp = run;
-
- if (tmp != 0)
- SWAP (base_ptr[tmp], base_ptr[0]);
-
- /* Insertion sort, running from left-hand-side up to right-hand-side. */
-
- run = 1;
- while (++run <= end)
- {
- SCM_TICK;
-
- tmp = run - 1;
- while (scm_is_true ((*cmp) (less, base_ptr[run], base_ptr[tmp])))
- {
- /* The comparison predicate may be buggy */
- if (tmp == 0)
- scm_misc_error (NULL, s_buggy_less, SCM_EOL);
-
- tmp--;
- }
-
- tmp++;
- if (tmp != run)
- {
- SCM to_insert = base_ptr[run];
- size_t hi, lo;
-
- for (hi = lo = run; --lo >= tmp; hi = lo)
- base_ptr[hi] = base_ptr[lo];
- base_ptr[hi] = to_insert;
- }
- }
- }
-}
+#define NAME quicksort1
+#define INC_PARAM /* empty */
+#define INC 1
+#include "libguile/quicksort.i.c"
+#define NAME quicksort
+#define INC_PARAM ssize_t inc,
+#define INC inc
+#include "libguile/quicksort.i.c"
static scm_t_trampoline_2
compare_function (SCM less, unsigned int arg_nr, const char* fname)
@@ -283,11 +69,6 @@ compare_function (SCM less, unsigned int arg_nr, const char* fname)
}
-/* Question: Is there any need to make this a more general array sort?
- It is probably enough to manage the vector type. */
-/* endpos equal as for substring, i.e. endpos is not included. */
-/* More natural with length? */
-
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
"Sort the vector @var{vec}, using @var{less} for comparing\n"
@@ -298,19 +79,20 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
- size_t vlen, spos, len;
- SCM *vp;
-
- SCM_VALIDATE_VECTOR (1, vec);
- vp = SCM_WRITABLE_VELTS (vec); /* vector pointer */
- vlen = SCM_VECTOR_LENGTH (vec);
+ size_t vlen, spos, len;
+ ssize_t vinc;
+ scm_t_array_handle handle;
+ SCM *velts;
+ velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
spos = scm_to_unsigned_integer (startpos, 0, vlen);
len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
- quicksort (&vp[spos], len, cmp, less);
- scm_remember_upto_here_1 (vec);
-
+ if (vinc == 1)
+ quicksort1 (velts + spos*vinc, len, cmp, less);
+ else
+ quicksort (velts + spos*vinc, len, vinc, cmp, less);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -330,7 +112,6 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
long len, j; /* list/vector length, temp j */
SCM item, rest; /* rest of items loop variable */
- SCM const *vp;
if (SCM_NULL_OR_NIL_P (items))
return SCM_BOOL_T;
@@ -360,22 +141,24 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
}
else
{
- SCM_VALIDATE_VECTOR (1, items);
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const SCM *elts;
+ SCM result = SCM_BOOL_T;
- vp = SCM_VELTS (items); /* vector pointer */
- len = SCM_VECTOR_LENGTH (items);
- j = len - 1;
- while (j > 0)
+ elts = scm_vector_elements (items, &handle, &len, &inc);
+
+ for (i = 1; i < len; i++, elts += inc)
{
- if (scm_is_true ((*cmp) (less, vp[1], vp[0])))
- return SCM_BOOL_F;
- else
+ if (scm_is_true ((*cmp) (less, elts[inc], elts[0])))
{
- vp++;
- j--;
+ result = SCM_BOOL_F;
+ break;
}
}
- return SCM_BOOL_T;
+
+ return result;
}
return SCM_BOOL_F;
@@ -596,13 +379,12 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, cmp, less, len);
}
- else if (SCM_VECTORP (items))
+ else if (scm_is_vector (items))
{
- len = SCM_VECTOR_LENGTH (items);
scm_restricted_vector_sort_x (items,
less,
scm_from_int (0),
- scm_from_long (len));
+ scm_vector_length (items));
return items;
}
else
@@ -622,29 +404,9 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
return items;
if (scm_is_pair (items))
- {
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
- long len;
-
- SCM_VALIDATE_LIST_COPYLEN (1, items, len);
- items = scm_list_copy (items);
- return scm_merge_list_step (&items, cmp, less, len);
- }
-#if SCM_HAVE_ARRAYS
- /* support ordinary vectors even if arrays not available? */
- else if (SCM_VECTORP (items))
- {
- long len = SCM_VECTOR_LENGTH (items);
- SCM sortvec = scm_make_uve (len, scm_array_prototype (items));
-
- scm_array_copy_x (items, sortvec);
- scm_restricted_vector_sort_x (sortvec,
- less,
- scm_from_int (0),
- scm_from_long (len));
- return sortvec;
- }
-#endif
+ return scm_sort_x (scm_list_copy (items), less);
+ else if (scm_is_vector (items))
+ return scm_sort_x (scm_vector_copy (items), less);
else
SCM_WRONG_TYPE_ARG (1, items);
}
@@ -652,68 +414,62 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
static void
-scm_merge_vector_x (SCM vec,
- SCM * temp,
+scm_merge_vector_x (SCM *vec,
+ SCM *temp,
scm_t_trampoline_2 cmp,
SCM less,
- long low,
- long mid,
- long high)
+ size_t low,
+ size_t mid,
+ size_t high,
+ ssize_t inc)
{
- long it; /* Index for temp vector */
- long i1 = low; /* Index for lower vector segment */
- long i2 = mid + 1; /* Index for upper vector segment */
+ size_t it; /* Index for temp vector */
+ size_t i1 = low; /* Index for lower vector segment */
+ size_t i2 = mid + 1; /* Index for upper vector segment */
+
+#define VEC(i) vec[(i)*inc]
/* Copy while both segments contain more characters */
for (it = low; (i1 <= mid) && (i2 <= high); ++it)
{
- /*
- Every call of LESS might invoke GC. For full correctness, we
- should reset the generation of vecbase and tempbase between
- every call of less.
-
- */
- register SCM *vp = SCM_WRITABLE_VELTS(vec);
-
- if (scm_is_true ((*cmp) (less, vp[i2], vp[i1])))
- temp[it] = vp[i2++];
+ if (scm_is_true ((*cmp) (less, VEC(i2), VEC(i1))))
+ temp[it] = VEC(i2++);
else
- temp[it] = vp[i1++];
+ temp[it] = VEC(i1++);
}
{
- register SCM *vp = SCM_WRITABLE_VELTS(vec);
-
/* Copy while first segment contains more characters */
while (i1 <= mid)
- temp[it++] = vp[i1++];
+ temp[it++] = VEC(i1++);
/* Copy while second segment contains more characters */
while (i2 <= high)
- temp[it++] = vp[i2++];
+ temp[it++] = VEC(i2++);
/* Copy back from temp to vp */
- for (it = low; it <= high; ++it)
- vp[it] = temp[it];
+ for (it = low; it <= high; it++)
+ VEC(it) = temp[it];
}
} /* scm_merge_vector_x */
static void
-scm_merge_vector_step (SCM vp,
- SCM * temp,
+scm_merge_vector_step (SCM *vec,
+ SCM *temp,
scm_t_trampoline_2 cmp,
SCM less,
- long low,
- long high)
+ size_t low,
+ size_t high,
+ ssize_t inc)
{
if (high > low)
{
- long mid = (low + high) / 2;
+ size_t mid = (low + high) / 2;
SCM_TICK;
- scm_merge_vector_step (vp, temp, cmp, less, low, mid);
- scm_merge_vector_step (vp, temp, cmp, less, mid+1, high);
- scm_merge_vector_x (vp, temp, cmp, less, low, mid, high);
+ scm_merge_vector_step (vec, temp, cmp, less, low, mid, inc);
+ scm_merge_vector_step (vec, temp, cmp, less, mid+1, high, inc);
+ scm_merge_vector_x (vec, temp, cmp, less, low, mid, high, inc);
}
} /* scm_merge_vector_step */
@@ -738,19 +494,21 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, cmp, less, len);
}
- else if (SCM_VECTORP (items))
+ else if (scm_is_vector (items))
{
- SCM *temp;
- len = SCM_VECTOR_LENGTH (items);
+ scm_t_array_handle temp_handle, vec_handle;
+ SCM temp, *temp_elts, *vec_elts;
+ size_t len;
+ ssize_t inc;
+
+ vec_elts = scm_vector_writable_elements (items, &vec_handle,
+ &len, &inc);
+ temp = scm_c_make_vector (len, SCM_UNDEFINED);
+ temp_elts = scm_vector_writable_elements (temp, &temp_handle,
+ NULL, NULL);
- /*
- the following array does not contain any new references to
- SCM objects, so we can get away with allocing it on the heap.
- */
- temp = scm_malloc (len * sizeof(SCM));
+ scm_merge_vector_step (vec_elts, temp_elts, cmp, less, 0, len-1, inc);
- scm_merge_vector_step (items, temp, cmp, less, 0, len - 1);
- free(temp);
return items;
}
else
@@ -766,33 +524,10 @@ SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
"This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort
{
- const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
-
- if (SCM_NULL_OR_NIL_P (items))
- return items;
-
if (scm_is_pair (items))
- {
- long len; /* list/vector length */
-
- SCM_VALIDATE_LIST_COPYLEN (1, items, len);
- items = scm_list_copy (items);
- return scm_merge_list_step (&items, cmp, less, len);
- }
-#if SCM_HAVE_ARRAYS
- /* support ordinary vectors even if arrays not available? */
- else if (SCM_VECTORP (items))
- {
- long len = SCM_VECTOR_LENGTH (items);
- SCM *temp = scm_malloc (len * sizeof (SCM));
- SCM retvec = scm_make_uve (len, scm_array_prototype (items));
- scm_array_copy_x (items, retvec);
-
- scm_merge_vector_step (retvec, temp, cmp, less, 0, len - 1);
- free (temp);
- return retvec;
- }
-#endif
+ return scm_stable_sort_x (scm_list_copy (items), less);
+ else if (scm_is_vector (items))
+ return scm_stable_sort_x (scm_vector_copy (items), less);
else
SCM_WRONG_TYPE_ARG (1, items);
}