[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 13/13: Support typed arrays in some sort functions
|
From: |
Daniel Llorens |
|
Subject: |
[Guile-commits] 13/13: Support typed arrays in some sort functions |
|
Date: |
Tue, 12 Jul 2016 07:30:52 +0000 (UTC) |
lloda pushed a commit to branch lloda-squash0
in repository guile.
commit 9e06cd733d02e40d3a6bee508051ef737009e552
Author: Daniel Llorens <address@hidden>
Date: Tue Jul 5 17:20:47 2016 +0200
Support typed arrays in some sort functions
* libguile/sort.c (sort!, sort, restricted-vector-sort!, sorted?):
Support arrays of rank 1, whatever the type.
* libguile/quicksort.i.c: Fix accessors to handle typed arrays.
* test-suite/tests/sort.test: Test also with typed arrays.
---
libguile/quicksort.i.c | 47 +++++++-------
libguile/sort.c | 150 ++++++++++++++++++++++++++++----------------
test-suite/tests/sort.test | 38 +++++++++--
3 files changed, 152 insertions(+), 83 deletions(-)
diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c
index 4e39f82..d3a0f93 100644
--- a/libguile/quicksort.i.c
+++ b/libguile/quicksort.i.c
@@ -11,7 +11,7 @@
version but doesn't consume extra memory.
*/
-#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)
+#define SWAP(a, b) do { const SCM _tmp = GET(a); SET(a, GET(b)); SET(b, _tmp);
} while (0)
/* Order using quicksort. This implementation incorporates four
@@ -54,8 +54,7 @@
#define STACK_NOT_EMPTY (stack < top)
static void
-NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
- SCM less)
+NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
{
/* Stack node declarations used to store unfulfilled partition obligations.
*/
typedef struct {
@@ -65,8 +64,6 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
static const char s_buggy_less[] = "buggy less predicate used when sorting";
-#define ELT(i) base_ptr[(i)*INC]
-
if (nr_elems == 0)
/* Avoid lossage with unsigned arithmetic below. */
return;
@@ -92,18 +89,18 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
skips a comparison for both the left and right. */
SCM_TICK;
-
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
- if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
- SWAP (ELT(mid), ELT(hi));
+
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
+ if (scm_is_true (scm_call_2 (less, GET(hi), GET(mid))))
+ SWAP (mid, hi);
else
goto jump_over;
- if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
- SWAP (ELT(mid), ELT(lo));
+ if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo))))
+ SWAP (mid, lo);
jump_over:;
- pivot = ELT(mid);
+ pivot = GET(mid);
left = lo + 1;
right = hi - 1;
@@ -112,7 +109,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
that this algorithm runs much faster than others. */
do
{
- while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
+ while (scm_is_true (scm_call_2 (less, GET(left), pivot)))
{
left += 1;
/* The comparison predicate may be buggy */
@@ -120,7 +117,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
}
- while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
+ while (scm_is_true (scm_call_2 (less, pivot, GET(right))))
{
right -= 1;
/* The comparison predicate may be buggy */
@@ -130,7 +127,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
if (left < right)
{
- SWAP (ELT(left), ELT(right));
+ SWAP (left, right);
left += 1;
right -= 1;
}
@@ -192,11 +189,11 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
and the operation speeds up insertion sort's inner loop. */
for (run = tmp + 1; run <= thresh; run += 1)
- if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run;
if (tmp != 0)
- SWAP (ELT(tmp), ELT(0));
+ SWAP (tmp, 0);
/* Insertion sort, running from left-hand-side up to right-hand-side. */
@@ -206,7 +203,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
SCM_TICK;
tmp = run - 1;
- while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
+ while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{
/* The comparison predicate may be buggy */
if (tmp == 0)
@@ -218,12 +215,12 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
tmp += 1;
if (tmp != run)
{
- SCM to_insert = ELT(run);
+ SCM to_insert = GET(run);
size_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo)
- ELT(hi) = ELT(lo);
- ELT(hi) = to_insert;
+ SET(hi, GET(lo));
+ SET(hi, to_insert);
}
}
}
@@ -235,9 +232,9 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
#undef PUSH
#undef POP
#undef STACK_NOT_EMPTY
-#undef ELT
+#undef GET
+#undef SET
#undef NAME
#undef INC_PARAM
-#undef INC
-
+#undef VEC_PARAM
diff --git a/libguile/sort.c b/libguile/sort.c
index 9373fb8..9a65362 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -51,23 +51,25 @@
#include "libguile/validate.h"
#include "libguile/sort.h"
-/* We have two quicksort variants: one for contigous vectors and one
- for vectors with arbitrary increments between elements. Note that
- increments can be negative.
+/* We have two quicksort variants: one for SCM (#t) arrays and one for
+ typed arrays.
*/
-#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
+#define VEC_PARAM SCM * ra,
+#define GET(i) ra[(i)*inc]
+#define SET(i, val) ra[(i)*inc] = val
#include "libguile/quicksort.i.c"
+#define NAME quicksorta
+#define INC_PARAM
+#define VEC_PARAM scm_t_array_handle * const ra,
+#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i))
+#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i),
val)
+#include "libguile/quicksort.i.c"
-SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
+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"
"the vector elements. @var{startpos} (inclusively) and\n"
@@ -76,22 +78,38 @@ SCM_DEFINE (scm_restricted_vector_sort_x,
"restricted-vector-sort!", 4, 0, 0,
"is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
- size_t vlen, spos, len;
- ssize_t vinc;
+ ssize_t spos = scm_to_ssize_t (startpos);
+ size_t epos = scm_to_ssize_t (endpos);
+
scm_t_array_handle handle;
- SCM *velts;
+ scm_array_get_handle (vec, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
- 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;
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec,
SCM_EOL);
+ }
+ if (spos < dims[0].lbnd)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
+ vec, scm_list_1(startpos));
+ }
+ if (epos > dims[0].ubnd+1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
+ vec, scm_list_1(endpos));
+ }
- if (vinc == 1)
- quicksort1 (velts + spos*vinc, len, less);
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ quicksort (scm_array_handle_writable_elements (&handle) +
(spos-dims[0].lbnd) * dims[0].inc,
+ epos-spos, dims[0].inc, less);
else
- quicksort (velts + spos*vinc, len, vinc, less);
+ quicksorta (&handle, epos-spos, less);
scm_array_handle_release (&handle);
-
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -140,29 +158,48 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
}
else
{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const SCM *elts;
SCM result = SCM_BOOL_T;
- elts = scm_vector_elements (items, &handle, &len, &inc);
-
- for (i = 1; i < len; i++, elts += inc)
- {
- if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
+ scm_t_array_handle handle;
+ scm_array_get_handle (items, &handle);
+ scm_t_array_dim const * dims = scm_array_handle_dims (&handle);
+
+ if (scm_array_handle_rank(&handle) != 1)
+ {
+ scm_array_handle_release (&handle);
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items,
SCM_EOL);
+ }
+
+ if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
+ {
+ ssize_t inc = dims[0].inc;
+ const SCM *elts = scm_array_handle_elements (&handle);
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i,
elts += inc)
+ {
+ if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
+ else
+ {
+ for (ssize_t i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i)
+ {
+ if (scm_is_true (scm_call_2 (less,
+ scm_array_handle_ref (&handle,
scm_array_handle_pos_1 (&handle, i)),
+ scm_array_handle_ref (&handle,
scm_array_handle_pos_1 (&handle, i-1)))))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+ }
scm_array_handle_release (&handle);
-
return result;
}
-
- return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -172,7 +209,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
and returns a new list in which the elements of a and b have been stably
interleaved so that (sorted? (merge a b less?) less?).
Note: this does _not_ accept vectors. */
-SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
+SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"Merge two already sorted lists into one.\n"
"Given two lists @var{alist} and @var{blist}, such that\n"
@@ -236,7 +273,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
#undef FUNC_NAME
-static SCM
+static SCM
scm_merge_list_x (SCM alist, SCM blist,
long alen, long blen,
SCM less)
@@ -288,7 +325,7 @@ scm_merge_list_x (SCM alist, SCM blist,
} /* scm_merge_list_x */
-SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
+SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"Takes two lists @var{alist} and @var{blist} such that\n"
"@code{(sorted? alist less?)} and @code{(sorted? blist less?)}
and\n"
@@ -319,7 +356,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
scsh's merge-sort but that algorithm showed to not be stable, even
though it claimed to be.
*/
-static SCM
+static SCM
scm_merge_list_step (SCM * seq, SCM less, long n)
{
SCM a, b;
@@ -359,7 +396,7 @@ scm_merge_list_step (SCM * seq, SCM less, long n)
} /* scm_merge_list_step */
-SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
+SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n"
@@ -391,7 +428,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
+SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n"
@@ -404,7 +441,13 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
- return scm_sort_x (scm_vector_copy (items), less);
+ {
+ if (scm_c_array_rank (items) != 1)
+ scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items,
SCM_EOL);
+ SCM copy = scm_make_typed_array (scm_array_type (items),
SCM_UNSPECIFIED, scm_array_dimensions (items));
+ scm_array_copy_x (items, copy);
+ return scm_sort_x (copy, less);
+ }
else
SCM_WRONG_TYPE_ARG (1, items);
}
@@ -470,7 +513,7 @@ scm_merge_vector_step (SCM *vec,
} /* scm_merge_vector_step */
-SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
+SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n"
@@ -495,14 +538,15 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
SCM temp, *temp_elts, *vec_elts;
size_t len;
ssize_t inc;
-
+
vec_elts = scm_vector_writable_elements (items, &vec_handle,
&len, &inc);
- if (len == 0) {
- scm_array_handle_release (&vec_handle);
- return items;
- }
-
+ if (len == 0)
+ {
+ scm_array_handle_release (&vec_handle);
+ return items;
+ }
+
temp = scm_c_make_vector (len, SCM_UNDEFINED);
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
NULL, NULL);
@@ -520,7 +564,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
+SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n"
@@ -554,7 +598,7 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
+SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
(SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. This is a stable sort.")
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 9209b53..f37dbbf 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -1,16 +1,16 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011 Free Software Foundation, Inc.
-;;;;
+;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
@@ -31,22 +31,51 @@
exception:wrong-num-args
(sort '(1 2) (lambda (x y z) z)))
- (pass-if "sort!"
+ (pass-if "sort of vector"
+ (let* ((v (randomize-vector! (make-vector 1000) 1000))
+ (w (vector-copy v)))
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort of typed array"
+ (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))
+ (w (make-typed-array 'f64 *unspecified* 99)))
+ (array-copy! v w)
+ (and (sorted? (sort v <) <)
+ (equal? w v))))
+
+ (pass-if "sort! of vector"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (sort! v <) <)))
+ (pass-if "sort! of typed array"
+ (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of non-contigous vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of non-contigous typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "sort! of negative-increment vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (sort! v <) <)))
+ (pass-if "sort! of negative-increment typed array"
+ (let* ((a (make-typed-array 'f64 0 99 3))
+ (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
+ (randomize-vector! v 99)
+ (sorted? (sort! v <) <)))
+
(pass-if "stable-sort!"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (stable-sort! v <) <)))
@@ -79,4 +108,3 @@
;; behavior (integer underflow) leading to crashes.
(pass-if "empty vector"
(equal? '#() (stable-sort '#() <))))
-
- [Guile-commits] branch lloda-squash0 created (now 9e06cd7), Daniel Llorens, 2016/07/12
- [Guile-commits] 02/13: Fix compilation of rank 0 typed array literals, Daniel Llorens, 2016/07/12
- [Guile-commits] 01/13: Compile in C99 mode, Daniel Llorens, 2016/07/12
- [Guile-commits] 07/13: Remove deprecated array functions, Daniel Llorens, 2016/07/12
- [Guile-commits] 08/13: Do not use array handles in scm_vector, Daniel Llorens, 2016/07/12
- [Guile-commits] 04/13: Avoid unneeded internal use of array handles, Daniel Llorens, 2016/07/12
- [Guile-commits] 13/13: Support typed arrays in some sort functions,
Daniel Llorens <=
- [Guile-commits] 03/13: Remove scm_from_contiguous_array, array 'contiguous' flag, Daniel Llorens, 2016/07/12
- [Guile-commits] 10/13: Special case for array-map! with three arguments, Daniel Llorens, 2016/07/12
- [Guile-commits] 12/13: Remove uniform-array-read!, uniform-array-write from the manual, Daniel Llorens, 2016/07/12
- [Guile-commits] 05/13: Reuse SCM_BYTEVECTOR_TYPED_LENGTH in scm_array_get_handle, Daniel Llorens, 2016/07/12
- [Guile-commits] 06/13: New functions array-from, array-from*, array-set-from!, Daniel Llorens, 2016/07/12
- [Guile-commits] 09/13: Speed up for multi-arg cases of scm_ramap functions, Daniel Llorens, 2016/07/12
- [Guile-commits] 11/13: New functions (array-for-each-cell, array-for-each-cell-in-order), Daniel Llorens, 2016/07/12