[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 21/21: Fix a corner case with empty arrays in (array-for
From: |
Daniel Llorens |
Subject: |
[Guile-commits] 21/21: Fix a corner case with empty arrays in (array-for-each-cell) |
Date: |
Wed, 25 May 2016 17:05:10 +0000 (UTC) |
lloda pushed a commit to branch lloda-array-support
in repository guile.
commit 7b441d2d6c30dfc28138e8be75479b581fa47847
Author: Daniel Llorens <address@hidden>
Date: Thu Apr 21 17:38:49 2016 +0200
Fix a corner case with empty arrays in (array-for-each-cell)
* libguile/array-map.c (scm_array_for_each_cell): Bail out early if any
of the sizes is zero. Pack ais at the end of the fake stack.
* test-suite/tests/array-map.test: Add regression test.
---
libguile/array-map.c | 325 +++++++++++++++++++++++++++++++--------
test-suite/tests/array-map.test | 14 +-
2 files changed, 278 insertions(+), 61 deletions(-)
diff --git a/libguile/array-map.c b/libguile/array-map.c
index 0bbc095..dde1276 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -651,76 +651,265 @@ scm_i_array_rebase (SCM a, size_t base)
return b;
}
+/* SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, */
+/* (SCM frame_rank, SCM op, SCM args), */
+/* "Apply @var{op} to each of the cells of rank
rank(@var{arg})address@hidden" */
+/* "of the arrays @var{args}, in unspecified order. The first\n" */
+/* "@var{frame_rank} dimensions of each @var{arg} must match.\n" */
+/* "Rank-0 cells are passed as rank-0 arrays.\n\n" */
+/* "The value returned is unspecified.\n\n" */
+/* "For example:\n" */
+/* "@lisp\n" */
+/* ";; Sort the rows of rank-2 array A.\n\n" */
+/* "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n" */
+/* "\n" */
+/* ";; Compute the arguments of the (x y) vectors in the rows of
rank-2\n" */
+/* ";; array XYS and store them in rank-1 array ANGLES. Inside
OP,\n" */
+/* ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1)
array.\n\n" */
+/* "(array-for-each-cell 1 \n" */
+/* " (lambda (xy angle)\n" */
+/* " (array-set! angle (atan (array-ref xy 1) (array-ref xy
0))))\n" */
+/* " xys angles)\n" */
+/* "@end lisp") */
+/* #define FUNC_NAME s_scm_array_for_each_cell */
+/* { */
+/* int const N = scm_ilength (args); */
+/* int const frank = scm_to_int (frame_rank); */
+
+/* // wish C had better stack support */
+
+/* size_t stack_size = 0; */
+/* stack_size += N*sizeof (scm_t_array_handle); */
+/* stack_size += N*sizeof (SCM); */
+/* stack_size += N*sizeof (scm_t_array_dim *); */
+/* stack_size += N*sizeof (int); */
+
+/* stack_size += frank*sizeof (ssize_t); */
+/* stack_size += N*sizeof (SCM); */
+/* stack_size += N*sizeof (SCM *); */
+/* stack_size += frank*sizeof (ssize_t); */
+
+/* stack_size += frank*sizeof (int); */
+/* stack_size += N*sizeof (size_t); */
+/* char * stack = scm_gc_malloc_pointerless (stack_size, "stack"); */
+
+/* #define AFIC_ALLOC_ADVANCE(stack, count, type, name) \ */
+/* type * name = (void *)stack; \ */
+/* stack += count*sizeof (type); */
+
+/* char * stack0 = stack; */
+/* AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah); */
+/* AFIC_ALLOC_ADVANCE (stack, N, SCM, args_); */
+/* AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as); */
+/* AFIC_ALLOC_ADVANCE (stack, N, int, rank); */
+
+/* AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s); */
+/* AFIC_ALLOC_ADVANCE (stack, N, SCM, ai); */
+/* AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs); */
+/* AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i); */
+
+/* AFIC_ALLOC_ADVANCE (stack, frank, int, order); */
+/* AFIC_ALLOC_ADVANCE (stack, N, size_t, base); */
+/* assert((stack0+stack_size==stack) && "internal error"); */
+/* #undef AFIC_ALLOC_ADVANCE */
+
+/* for (int n=0; scm_is_pair(args); args=scm_cdr(args), ++n) */
+/* { */
+/* args_[n] = scm_car(args); */
+/* scm_array_get_handle(args_[n], ah+n); */
+/* as[n] = scm_array_handle_dims(ah+n); */
+/* rank[n] = scm_array_handle_rank(ah+n); */
+/* } */
+/* // checks. */
+/* char const * msg = NULL; */
+/* if (frank<0) */
+/* { */
+/* msg = "bad frame rank"; */
+/* } else */
+/* { */
+/* for (int n=0; n!=N; ++n) */
+/* { */
+/* if (rank[n]<frank) */
+/* { */
+/* msg = "frame too large for arguments"; */
+/* goto check_msg; */
+/* } */
+/* for (int k=0; k!=frank; ++k) */
+/* { */
+/* if (as[n][k].lbnd!=0) */
+/* { */
+/* msg = "non-zero base index is not supported"; */
+/* goto check_msg; */
+/* } */
+/* if (as[0][k].ubnd!=as[n][k].ubnd) */
+/* { */
+/* msg = "mismatched frames"; */
+/* goto check_msg; */
+/* } */
+/* s[k] = as[n][k].ubnd + 1; */
+
+/* // this check is needed if the array cannot be entirely */
+/* // unrolled, because the step loop will be run before */
+/* // checking the dimensions of the frame. */
+/* if (s[k]==0) */
+/* { */
+/* goto end; */
+/* } */
+/* } */
+/* } */
+/* } */
+/* check_msg: ; */
+/* if (msg!=NULL) */
+/* { */
+/* for (int n=0; n!=N; ++n) { */
+/* scm_array_handle_release(ah+n); */
+/* } */
+/* scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank,
args)); */
+/* } */
+/* // prepare moving cells. */
+/* for (int n=0; n!=N; ++n) */
+/* { */
+/* ai[n] = scm_i_make_array(rank[n]-frank); */
+/* SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n])); */
+/* // FIXME scm_array_handle_base (ah+n) should be in Guile */
+/* SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base); */
+/* scm_t_array_dim * ais = SCM_I_ARRAY_DIMS(ai[n]); */
+/* for (int k=frank; k!=rank[n]; ++k) */
+/* { */
+/* ais[k-frank] = as[n][k]; */
+/* } */
+/* } */
+/* // prepare rest list for callee. */
+/* SCM dargs_ = SCM_EOL; */
+/* { */
+/* SCM *p = &dargs_; */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL); */
+/* dargs[n] = SCM_CARLOC (*p); */
+/* p = SCM_CDRLOC (*p); */
+/* } */
+/* } */
+/* // special case for rank 0. */
+/* if (frank==0) */
+/* { */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* *dargs[n] = ai[n]; */
+/* } */
+/* scm_apply_0(op, dargs_); */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* scm_array_handle_release(ah+n); */
+/* } */
+/* return SCM_UNSPECIFIED; */
+/* } */
+/* // FIXME determine best looping order. */
+/* for (int k=0; k!=frank; ++k) */
+/* { */
+/* i[k] = 0; */
+/* order[k] = frank-1-k; */
+/* } */
+/* // find outermost compact dim. */
+/* ssize_t step = s[order[0]]; */
+/* int ocd = 1; */
+/* for (; ocd<frank; step *= s[order[ocd]], ++ocd) */
+/* { */
+/* for (int n=0; n!=N; ++n) */
+/* { */
+/* if (step*as[n][order[0]].inc!=as[n][order[ocd]].inc) */
+/* { */
+/* goto ocd_reached; */
+/* } */
+/* } */
+/* } */
+/* ocd_reached: ; */
+/* // rank loop. */
+/* for (int n=0; n!=N; ++n) */
+/* { */
+/* base[n] = SCM_I_ARRAY_BASE(ai[n]); */
+/* } */
+/* for (;;) */
+/* { */
+/* for (ssize_t z=0; z!=step; ++z) */
+/* { */
+/* // we are forced to create fresh array descriptors for each */
+/* // call since we don't know whether the callee will keep them, */
+/* // and Guile offers no way to copy the descriptor (since */
+/* // descriptors are immutable). Yet another reason why this */
+/* // should be in Scheme. */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* *dargs[n] = scm_i_array_rebase(ai[n], base[n]); */
+/* base[n] += as[n][order[0]].inc; */
+/* } */
+/* scm_apply_0(op, dargs_); */
+/* } */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* base[n] -= step*as[n][order[0]].inc; */
+/* } */
+/* for (int k=ocd; ; ++k) */
+/* { */
+/* if (k==frank) */
+/* { */
+/* goto end; */
+/* } */
+/* else if (i[order[k]]<s[order[k]]-1) */
+/* { */
+/* ++i[order[k]]; */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* base[n] += as[n][order[k]].inc; */
+/* } */
+/* break; */
+/* } */
+/* else */
+/* { */
+/* i[order[k]] = 0; */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* base[n] += as[n][order[k]].inc*(1-s[order[k]]); */
+/* } */
+/* } */
+/* } */
+/* } */
+/* end:; */
+/* for (int n=0; n<N; ++n) */
+/* { */
+/* scm_array_handle_release(ah+n); */
+/* } */
+/* return SCM_UNSPECIFIED; */
+/* } */
+/* #undef FUNC_NAME */
+
SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1,
- (SCM frame_rank, SCM op, SCM args),
- "Apply @var{op} to each of the cells of rank
rank(@var{arg})address@hidden"
- "of the arrays @var{args}, in unspecified order. The first\n"
- "@var{frame_rank} dimensions of each @var{arg} must match.\n"
- "Rank-0 cells are passed as rank-0 arrays.\n\n"
+ (SCM frank_, SCM op, SCM a_),
+ "Apply op to each of the rank (-frank) cells of the arguments,\n"
+ "in unspecified order. The first frank dimensions of the\n"
+ "arguments must match. Rank-0 cells are passed as such.\n\n"
"The value returned is unspecified.\n\n"
"For example:\n"
"@lisp\n"
- ";; Sort the rows of rank-2 array A.\n\n"
- "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n"
- "\n"
- ";; Compute the arguments of the (x y) vectors in the rows of
rank-2\n"
- ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n"
- ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1)
array.\n\n"
- "(array-for-each-cell 1 \n"
- " (lambda (xy angle)\n"
- " (array-set! angle (atan (array-ref xy 1) (array-ref xy
0))))\n"
- " xys angles)\n"
"@end lisp")
#define FUNC_NAME s_scm_array_for_each_cell
{
- int const N = scm_ilength (args);
- int const frank = scm_to_int (frame_rank);
-
- // wish C had better stack support
-
- size_t stack_size = 0;
- stack_size += N*sizeof (scm_t_array_handle);
- stack_size += N*sizeof (SCM);
- stack_size += N*sizeof (scm_t_array_dim *);
- stack_size += N*sizeof (int);
- stack_size += frank*sizeof (ssize_t);
-
- stack_size += N*sizeof (SCM);
- stack_size += N*sizeof (SCM *);
- stack_size += frank*sizeof (ssize_t);
- stack_size += frank*sizeof (int);
-
- stack_size += N*sizeof (size_t);
- char * stack = scm_gc_malloc_pointerless (stack_size, "stack");
-
-#define AFIC_ALLOC_ADVANCE(stack, count, type, name) \
- type * name = (void *)stack; \
- stack += count*sizeof (type);
-
- char * stack0 = stack;
- AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_handle, ah);
- AFIC_ALLOC_ADVANCE (stack, N, SCM, args_);
- AFIC_ALLOC_ADVANCE (stack, N, scm_t_array_dim *, as);
- AFIC_ALLOC_ADVANCE (stack, N, int, rank);
- AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, s);
-
- AFIC_ALLOC_ADVANCE (stack, N, SCM, ai);
- AFIC_ALLOC_ADVANCE (stack, N, SCM *, dargs);
- AFIC_ALLOC_ADVANCE (stack, frank, ssize_t, i);
- AFIC_ALLOC_ADVANCE (stack, frank, int, order);
-
- AFIC_ALLOC_ADVANCE(stack, N, size_t, base);
- assert((stack0+stack_size==stack) && "internal error");
-#undef AFIC_ALLOC_ADVANCE
-
- for (int n=0; scm_is_pair(args); args=scm_cdr(args), ++n)
+ // FIXME replace stack by scm_gc_malloc_pointerless()
+ int const N = scm_ilength(a_);
+ int const frank = scm_to_int(frank_);
+ scm_t_array_handle ah[N];
+ SCM a[N];
+ scm_t_array_dim * as[N];
+ int rank[N];
+ for (int n=0; scm_is_pair(a_); a_=scm_cdr(a_), ++n)
{
- args_[n] = scm_car(args);
- scm_array_get_handle(args_[n], ah+n);
+ a[n] = scm_car(a_);
+ scm_array_get_handle(a[n], ah+n);
as[n] = scm_array_handle_dims(ah+n);
rank[n] = scm_array_handle_rank(ah+n);
}
// checks.
+ ssize_t s[frank];
char const * msg = NULL;
if (frank<0)
{
@@ -742,6 +931,17 @@ SCM_DEFINE (scm_array_for_each_cell,
"array-for-each-cell", 2, 0, 1,
goto check_msg;
}
s[k] = as[n][k].ubnd + 1;
+ // this check is needed if the array cannot be entirely
+ // unrolled, because the step loop will be run before
+ // checking the dimensions of the frame.
+ if (s[k]==0)
+ {
+ for (int n=0; n<N; ++n)
+ {
+ scm_array_handle_release(ah+n);
+ }
+ return SCM_UNSPECIFIED;
+ }
}
}
}
@@ -751,14 +951,15 @@ SCM_DEFINE (scm_array_for_each_cell,
"array-for-each-cell", 2, 0, 1,
for (int n=0; n!=N; ++n) {
scm_array_handle_release(ah+n);
}
- scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank,
args));
+ scm_misc_error("array-for-each-cell", msg, scm_cons_star(frank_, a_));
}
// prepare moving cells.
+ SCM ai[N];
scm_t_array_dim * ais[N];
for (int n=0; n!=N; ++n)
{
ai[n] = scm_i_make_array(rank[n]-frank);
- SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(args_[n]));
+ SCM_I_ARRAY_SET_V (ai[n], scm_shared_array_root(a[n]));
// FIXME scm_array_handle_base (ah+n) should be in Guile
SCM_I_ARRAY_SET_BASE (ai[n], ah[n].base);
ais[n] = SCM_I_ARRAY_DIMS(ai[n]);
@@ -768,6 +969,7 @@ SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell",
2, 0, 1,
}
// prepare rest list for callee.
SCM dargs_ = SCM_EOL;
+ SCM * dargs[N];
{
SCM *p = &dargs_;
for (int n=0; n<N; ++n) {
@@ -791,6 +993,8 @@ SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell",
2, 0, 1,
return SCM_UNSPECIFIED;
}
// FIXME determine best looping order.
+ ssize_t i[frank];
+ int order[frank];
for (int k=0; k!=frank; ++k)
{
i[k] = 0;
@@ -809,6 +1013,7 @@ SCM_DEFINE (scm_array_for_each_cell,
"array-for-each-cell", 2, 0, 1,
}
ocd_reached: ;
// rank loop.
+ size_t base[N];
for (int n=0; n!=N; ++n)
{
base[n] = SCM_I_ARRAY_BASE(ai[n]);
diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test
index f5487ba..cefe7b7 100644
--- a/test-suite/tests/array-map.test
+++ b/test-suite/tests/array-map.test
@@ -525,4 +525,16 @@
(let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))
(y (f64vector 99 99)))
(array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0)
(array-ref x 1)))) y x)
- y)))
+ y))
+
+ (pass-if-equal "regression: zero-sized frame loop without unrolling"
+ 99
+ (let* ((x 99)
+ (o (make-array 0. 0 3 2)))
+ (array-for-each-cell 2
+ (lambda (o a0 a1)
+ (set! x 0))
+ o
+ (make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3)
+ (make-array 2. 0 3))
+ x)))
- [Guile-commits] 03/21: Unuse array 'contiguous' flag, (continued)
- [Guile-commits] 03/21: Unuse array 'contiguous' flag, Daniel Llorens, 2016/05/25
- [Guile-commits] 07/21: Tests & doc for array-from, array-from*, array-set-from!, Daniel Llorens, 2016/05/25
- [Guile-commits] 18/21: Special case for array-map! with three arguments, Daniel Llorens, 2016/05/25
- [Guile-commits] 02/21: Remove scm_from_contiguous_array, Daniel Llorens, 2016/05/25
- [Guile-commits] 17/21: New export (array-for-each-cell-in-order), Daniel Llorens, 2016/05/25
- [Guile-commits] 01/21: Avoid unneeded internal use of array handles, Daniel Llorens, 2016/05/25
- [Guile-commits] 15/21: Draft of (array-for-each-cell), Daniel Llorens, 2016/05/25
- [Guile-commits] 16/21: Draft documentation for (array-for-each-cell), Daniel Llorens, 2016/05/25
- [Guile-commits] 09/21: Don't use array handles in scm_c_array_rank, Daniel Llorens, 2016/05/25
- [Guile-commits] 12/21: Speed up for multi-arg cases of scm_ramap functions, Daniel Llorens, 2016/05/25
- [Guile-commits] 21/21: Fix a corner case with empty arrays in (array-for-each-cell),
Daniel Llorens <=
- [Guile-commits] 19/21: Avoid variable stack use in scm_array_for_each_cell(), Daniel Llorens, 2016/05/25
- [Guile-commits] 11/21: Remove deprecated array functions, Daniel Llorens, 2016/05/25
- [Guile-commits] 05/21: Compile in C99 mode, Daniel Llorens, 2016/05/25
- [Guile-commits] 08/21: Rename array-set-from!, scm_array_set_from_x to array-amend!, scm_array_amend_x, Daniel Llorens, 2016/05/25
- [Guile-commits] 20/21: Clean up (array-for-each-cell), Daniel Llorens, 2016/05/25
- [Guile-commits] 06/21: New functions array-from, array-from*, array-set-from!, Daniel Llorens, 2016/05/25
- [Guile-commits] 04/21: Reuse SCM_BYTEVECTOR_TYPED_LENGTH in scm_array_get_handle, Daniel Llorens, 2016/05/25