mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
In scm_ramapc, only check unrolled axes for emptiness
* libguile/array-map.c: (scm_ramapc)
- Don't check emptiness while preparing ra0, but only after kroll is known,
and only before kroll. len = 0 will be caught by the unrolled loop.
- Use ra0 axis length in unroll check depth for rest args, not ra1's.
- Recover early exit feature when cproc returns 0.
This commit is contained in:
Daniel Llorens
Andy Wingo
parent
3ee4c76453
commit
ce6fce6af3
1 changed files with 50 additions and 69 deletions
|
|
@ -113,74 +113,58 @@ cindk (SCM ra, ssize_t *ve, int kend)
|
||||||
int
|
int
|
||||||
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
||||||
{
|
{
|
||||||
SCM z, vra0, lvra, *plvra;
|
|
||||||
ssize_t *vi;
|
|
||||||
int k, kmax, kroll;
|
|
||||||
int (*cproc) () = cproc_ptr;
|
int (*cproc) () = cproc_ptr;
|
||||||
int empty = 0;
|
SCM z, va0, lva, *plva;
|
||||||
|
int k, kmax, kroll;
|
||||||
|
ssize_t *vi, inc;
|
||||||
|
size_t len;
|
||||||
|
|
||||||
/* Prepare reference argument. */
|
/* Prepare reference argument. */
|
||||||
if (SCM_I_ARRAYP (ra0))
|
if (SCM_I_ARRAYP (ra0))
|
||||||
{
|
{
|
||||||
k = kmax = SCM_I_ARRAY_NDIM (ra0)-1;
|
kmax = SCM_I_ARRAY_NDIM (ra0)-1;
|
||||||
vra0 = make1array (SCM_I_ARRAY_V (ra0), SCM_I_ARRAY_DIMS (ra0)[kmax].inc);
|
inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
|
||||||
|
va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
|
||||||
|
|
||||||
/* Find unroll depth */
|
/* Find unroll depth */
|
||||||
if (k > 0)
|
for (kroll = max(0, kmax); kroll > 0; --kroll)
|
||||||
{
|
{
|
||||||
ssize_t inc = SCM_I_ARRAY_DIMS (ra0)[k].inc;
|
inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
|
||||||
do {
|
if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
|
||||||
ssize_t dim = (UBND (ra0, k) - LBND (ra0, k) + 1);
|
break;
|
||||||
empty = empty || (0 == dim);
|
|
||||||
inc *= dim;
|
|
||||||
--k;
|
|
||||||
} while (k >= 0 && inc == SCM_I_ARRAY_DIMS (ra0)[k].inc);
|
|
||||||
kroll = k+1;
|
|
||||||
}
|
}
|
||||||
else
|
|
||||||
kroll = 0;
|
|
||||||
|
|
||||||
/* Check emptiness of not-unrolled axes. */
|
|
||||||
for (; k>=0; --k)
|
|
||||||
empty = empty || (0 == (UBND (ra0, k) - LBND (ra0, k) + 1));
|
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
kroll = kmax = 0;
|
kroll = kmax = 0;
|
||||||
vra0 = ra0 = make1array (ra0, 1);
|
va0 = ra0 = make1array (ra0, 1);
|
||||||
empty = (0 == (UBND (ra0, 0) - LBND (ra0, 0) + 1));
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Prepare rest arguments. */
|
/* Prepare rest arguments. */
|
||||||
lvra = SCM_EOL;
|
lva = SCM_EOL;
|
||||||
plvra = &lvra;
|
plva = &lva;
|
||||||
for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
|
for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
|
||||||
{
|
{
|
||||||
SCM ra1 = SCM_CAR (z);
|
SCM va1, ra1 = SCM_CAR (z);
|
||||||
SCM vra1;
|
|
||||||
if (SCM_I_ARRAYP (ra1))
|
if (SCM_I_ARRAYP (ra1))
|
||||||
{
|
{
|
||||||
if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
|
if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
|
||||||
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
||||||
vra1 = make1array (SCM_I_ARRAY_V (ra1), SCM_I_ARRAY_DIMS (ra1)[kmax].inc);
|
inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
|
||||||
|
va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
|
||||||
|
|
||||||
/* Check unroll depth. */
|
/* Check unroll depth. */
|
||||||
k = kmax;
|
for (k = kmax; k > kroll; --k)
|
||||||
if (k > kroll)
|
|
||||||
{
|
{
|
||||||
ssize_t inc = SCM_I_ARRAY_DIMS (ra1)[k].inc;
|
ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
|
||||||
do {
|
if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
|
||||||
ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
|
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
||||||
ssize_t l1 = LBND (ra1, k), u1 = UBND (ra1, k);
|
inc *= (u0 - l0 + 1);
|
||||||
--k;
|
if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
|
||||||
if (l0 == l1 && u0 == u1)
|
{
|
||||||
inc *= (u1 - l1 + 1);
|
kroll = k;
|
||||||
else if (l0 >= l1 && u0 <= u1)
|
|
||||||
break;
|
break;
|
||||||
else
|
}
|
||||||
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
|
||||||
} while (k >= kroll && inc == SCM_I_ARRAY_DIMS (ra1)[k].inc);
|
|
||||||
kroll = k + 1;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
/* Check matching of not-unrolled axes. */
|
/* Check matching of not-unrolled axes. */
|
||||||
|
|
@ -192,27 +176,26 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
||||||
{
|
{
|
||||||
if (kmax != 0)
|
if (kmax != 0)
|
||||||
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
||||||
vra1 = make1array (ra1, 1);
|
va1 = make1array (ra1, 1);
|
||||||
|
|
||||||
if (LBND (ra0, 0) < LBND (vra1, 0) || UBND (ra0, 0) > UBND (vra1, 0))
|
if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
|
||||||
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
|
||||||
}
|
}
|
||||||
*plvra = scm_cons (vra1, SCM_EOL);
|
*plva = scm_cons (va1, SCM_EOL);
|
||||||
plvra = SCM_CDRLOC (*plvra);
|
plva = SCM_CDRLOC (*plva);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* Check emptiness of not-unrolled axes. */
|
||||||
|
for (k = 0; k < kroll; ++k)
|
||||||
|
if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
|
||||||
|
return 1;
|
||||||
|
|
||||||
/* Set unrolled size. */
|
/* Set unrolled size. */
|
||||||
if (empty)
|
for (len = 1; k <= kmax; ++k)
|
||||||
return 1;
|
len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
|
||||||
else
|
UBND (va0, 0) = len - 1;
|
||||||
{
|
for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
|
||||||
size_t len = 1;
|
UBND (SCM_CAR (z), 0) = len - 1;
|
||||||
for (k = kroll; k <= kmax; ++k)
|
|
||||||
len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
|
|
||||||
UBND (vra0, 0) = len - 1;
|
|
||||||
for (z = lvra; !scm_is_null (z); z = SCM_CDR (z))
|
|
||||||
UBND (SCM_CAR (z), 0) = len - 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Set starting indices and go. */
|
/* Set starting indices and go. */
|
||||||
vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
|
vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
|
||||||
|
|
@ -223,24 +206,22 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
|
||||||
if (k == kroll)
|
if (k == kroll)
|
||||||
{
|
{
|
||||||
SCM y = lra;
|
SCM y = lra;
|
||||||
SCM_I_ARRAY_BASE (vra0) = cindk (ra0, vi, kroll);
|
SCM_I_ARRAY_BASE (va0) = cindk (ra0, vi, kroll);
|
||||||
for (z = lvra; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
|
for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
|
||||||
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cindk (SCM_CAR (y), vi, kroll);
|
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cindk (SCM_CAR (y), vi, kroll);
|
||||||
if (SCM_UNBNDP (data))
|
if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
|
||||||
cproc (vra0, lvra);
|
return 0;
|
||||||
else
|
--k;
|
||||||
cproc (vra0, data, lvra);
|
|
||||||
k--;
|
|
||||||
}
|
}
|
||||||
else if (vi[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
|
else if (vi[k] < UBND (ra0, k))
|
||||||
{
|
{
|
||||||
vi[k]++;
|
++vi[k];
|
||||||
k++;
|
++k;
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
vi[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
|
vi[k] = LBND (ra0, k) - 1;
|
||||||
k--;
|
--k;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
while (k >= 0);
|
while (k >= 0);
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue