https://gcc.gnu.org/g:5a88e7c7f7d41e15beb1164406b03e397a55d9f7
commit 5a88e7c7f7d41e15beb1164406b03e397a55d9f7
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Mon Jun 9 11:07:30 2025 +0200
Correction partielle régression reduce_1
Diff:
---
libgfortran/intrinsics/reduce.c | 59 ++++++++++++++++++++++++++---------------
1 file changed, 38 insertions(+), 21 deletions(-)
diff --git a/libgfortran/intrinsics/reduce.c b/libgfortran/intrinsics/reduce.c
index 8e1ab3b8c2f7..de0c264323d4 100644
--- a/libgfortran/intrinsics/reduce.c
+++ b/libgfortran/intrinsics/reduce.c
@@ -50,11 +50,12 @@ reduce (parray *ret,
void *buffer;
void *res;
index_type ext0, ext1, ext2;
- index_type spc0, spc1, spc2;
+ index_type aspc0, aspc1, aspc2;
+ index_type rspc0, rspc2;
+ index_type mspc0, mspc1, mspc2;
index_type idx0, idx1, idx2;
- index_type dimen, dimen_m1, off, ext, spc;
+ index_type dimen, dimen_m1, moff, ext, spc;
bool started;
- bool masked = false;
bool dim_present = dim != NULL;
bool mask_present = mask != NULL;
bool identity_present = identity != NULL;
@@ -95,18 +96,20 @@ reduce (parray *ret,
painless by the use of pointer arithmetic throughout (except for MASK,
whose type is known. */
ext0 = ext1 = ext2 = 1;
- spc0 = spc1 = spc2 = elem_len;
+ aspc0 = aspc1 = aspc2 = elem_len;
+ rspc0 = rspc2 = elem_len;
+ mspc0 = mspc1 = mspc2 = sizeof (GFC_LOGICAL_4);
scalar_result = (!dim_present && array_rank > 1) || array_rank == 1;
+ spc = elem_len;
j = 0;
for (i = 0; i < array_rank; i++)
{
/* Obtain the shape of the reshaped ARRAY. */
ext = GFC_DESCRIPTOR_EXTENT (array,i);
- spc = GFC_DESCRIPTOR_SPACING (array,i);
- if (masked && (ext != GFC_DESCRIPTOR_EXTENT (mask, i)))
+ if (mask_present && (ext != GFC_DESCRIPTOR_EXTENT (mask, i)))
{
int mext = (int)GFC_DESCRIPTOR_EXTENT (mask, i);
runtime_error ("shape mismatch between ARRAY and MASK in the REDUCE "
@@ -126,28 +129,39 @@ reduce (parray *ret,
ext2 *= ext;
/* The dimensions of the return array. */
- if (i != (int)dimen_m1)
+ if (!scalar_result && ret->base_addr == NULL && i != (int)dimen_m1)
{
- spc = GFC_DESCRIPTOR_SPACING (array, j);
GFC_DESCRIPTOR_DIMENSION_SET (ret, j, 0, ext - 1, spc);
+ spc *= ext;
j++;
}
}
if (!scalar_result)
{
- spc1 = GFC_DESCRIPTOR_SPACING (array, dimen_m1);
+ aspc1 = GFC_DESCRIPTOR_SPACING (array, dimen_m1);
+ if (mask_present)
+ mspc1 = GFC_DESCRIPTOR_SPACING (mask, dimen_m1);
if (dimen < array_rank)
- spc2 = GFC_DESCRIPTOR_SPACING (array, dimen);
+ {
+ aspc2 = GFC_DESCRIPTOR_SPACING (array, dimen);
+ rspc2 = GFC_DESCRIPTOR_SPACING (ret, dimen_m1);
+ if (mask_present)
+ mspc2 = GFC_DESCRIPTOR_SPACING (mask, dimen);
+ }
else
- spc2 = elem_len;
+ {
+ aspc2 = 1;
+ rspc2 = 1;
+ mspc2 = 1;
+ }
}
/* Allocate the result data, the result buffer and zero. */
if (ret->base_addr == NULL)
{
ret->base_addr = calloc ((size_t)(ext0 * ext2), elem_len);
- GFC_DESCRIPTOR_SPAN (ret) = GFC_DESCRIPTOR_SIZE (ret);
+ GFC_DESCRIPTOR_SPAN (ret) = GFC_DESCRIPTOR_SIZE (ret) = elem_len;
}
buffer = calloc (1, elem_len);
@@ -158,14 +172,16 @@ reduce (parray *ret,
{
for (idx2 = 0; idx2 < ext2; idx2++)
{
- off = idx0 * spc0 + idx2 * spc2;
if (mask_present)
- maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) + (size_t)
off));
+ {
+ moff = idx0 * mspc0 + idx2 * mspc2;
+ maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) + (size_t)
moff));
+ }
started = (mask_present && maskR) || !mask_present;
buffer_ptr = array->base_addr
- + (size_t)(idx0 * spc0 + idx2 * spc2);
+ + (size_t)(idx0 * aspc0 + idx2 * aspc2);
/* Start the iteration over the second dimension of ARRAY. */
for (idx1 = 1; idx1 < ext1; idx1++)
@@ -173,12 +189,14 @@ reduce (parray *ret,
/* If masked, cycle until after first element that is not masked
out. Then set 'started' and cycle so that this becomes the
first element in the reduction. */
- off = idx0 * spc0 + idx1 * spc1 + idx2 * spc2;
if (mask_present)
- maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) +
(size_t) off));
+ {
+ moff = idx0 * mspc0 + idx1 * mspc1 + idx2 * mspc2;
+ maskR = *((GFC_LOGICAL_4 *) (((char*)mask->base_addr) +
(size_t) moff));
+ }
array_ptr = array->base_addr
- + (size_t)(idx0 * spc0 + idx1 * spc1 + idx2 * spc2);
+ + (size_t)(idx0 * aspc0 + idx1 * aspc1 + idx2 *
aspc2);
if (!started)
{
if (mask_present && maskR)
@@ -200,9 +218,8 @@ reduce (parray *ret,
/* Now the result of the iteration is transferred to the returned
result. If this result element is empty emit an error or, if
- available, set to identity. Note that str1 is paired with idx2
- here because the result skips a dimension. */
- res = ret->base_addr + (size_t)(idx0 * spc0 + idx2 * spc1);
+ available, set to identity. */
+ res = ret->base_addr + (size_t)(idx0 * rspc0 + idx2 * rspc2);
if (started)
{
operation (buffer_ptr, NULL, res);
