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 . +/* We have two quicksort variants: one for contigous vectors and one + for vectors with arbitrary increments between elements. Note that + increments can be negative. +*/ - 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!). */ - - { - 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); }