Hello world,
the attached patch implements the simplification for minloc and maxloc.
I had considered using the existing simplify_transformation_to_array and
simplify_transformation_to_scalar functions, but it turned out
that the special casing required for minloc/maxloc was just too
complex, so I wrote new functions (mostly copying the old ones).
This closes a significant hole in F2003 - with this implemented,
only finalization is left as only partially implemented.
Regression-tested. OK for trunk?
Regards
Thomas
2017-12-31 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/45689
* intrinsic.c (add_function): Add gfc_simplify_maxloc and
gfc_simplify_minloc to maxloc and minloc, respectively.
* intrinsic.h: Add prototypes for gfc_simplify_minloc
and gfc_simplify_maxloc.
* simplify.c (min_max_chose): Adjust prototype. Modify function
to have a return value which indicates if the extremum was found.
(...): Fix typo in comment.
(simplify_minmaxloc_to_scalar): New function.
(simplify_minmaxloc_nodim): New function.
(new_array): New function.
(simplify_minmaxloc_to_array): New function.
(gfc_simplify_minmaxloc): New function.
(simplify_minloc): New function.
(simplify_maxloc): New function.
2017-12-31 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/45689
* gfortran.dg/minloc_4.f90: New test case.
* gfortran.dg/maxloc_4.f90: New test case.
Index: intrinsic.c
===================================================================
--- intrinsic.c (Revision 255788)
+++ intrinsic.c (Arbeitskopie)
@@ -2458,7 +2458,7 @@ add_functions (void)
make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
add_sym_4ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
- gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
+ gfc_check_minloc_maxloc, gfc_simplify_maxloc, gfc_resolve_maxloc,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
@@ -2534,7 +2534,7 @@ add_functions (void)
make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
add_sym_4ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
- gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
+ gfc_check_minloc_maxloc, gfc_simplify_minloc, gfc_resolve_minloc,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
Index: intrinsic.h
===================================================================
--- intrinsic.h (Revision 255788)
+++ intrinsic.h (Arbeitskopie)
@@ -347,8 +347,10 @@ gfc_expr *gfc_simplify_maskr (gfc_expr *, gfc_expr
gfc_expr *gfc_simplify_merge (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_min (gfc_expr *);
+gfc_expr *gfc_simplify_minloc (gfc_expr*, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_minval (gfc_expr *, gfc_expr*, gfc_expr*);
gfc_expr *gfc_simplify_max (gfc_expr *);
+gfc_expr *gfc_simplify_maxloc (gfc_expr*, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_maxval (gfc_expr *, gfc_expr*, gfc_expr*);
gfc_expr *gfc_simplify_maxexponent (gfc_expr *);
gfc_expr *gfc_simplify_minexponent (gfc_expr *);
Index: simplify.c
===================================================================
--- simplify.c (Revision 255788)
+++ simplify.c (Arbeitskopie)
@@ -31,7 +31,7 @@ along with GCC; see the file COPYING3. If not see
/* Prototypes. */
-static void min_max_choose (gfc_expr *, gfc_expr *, int);
+static int min_max_choose (gfc_expr *, gfc_expr *, int);
gfc_expr gfc_bad_expr;
@@ -230,7 +230,7 @@ convert_boz (gfc_expr *x, int kind)
}
-/* Test that the expression is an constant array, simplifying if
+/* Test that the expression is a constant array, simplifying if
we are dealing with a parameter array. */
static bool
@@ -4414,25 +4414,34 @@ gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j,
/* Selects between current value and extremum for simplify_min_max
and simplify_minval_maxval. */
-static void
+static int
min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
{
+ int ret;
+
switch (arg->ts.type)
{
case BT_INTEGER:
- if (mpz_cmp (arg->value.integer,
- extremum->value.integer) * sign > 0)
- mpz_set (extremum->value.integer, arg->value.integer);
+ ret = mpz_cmp (arg->value.integer,
+ extremum->value.integer) * sign;
+ if (ret > 0)
+ mpz_set (extremum->value.integer, arg->value.integer);
break;
case BT_REAL:
- /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
- if (sign > 0)
- mpfr_max (extremum->value.real, extremum->value.real,
- arg->value.real, GFC_RND_MODE);
+ if (mpfr_nan_p (extremum->value.real))
+ {
+ ret = 1;
+ mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
+ }
+ else if (mpfr_nan_p (arg->value.real))
+ ret = -1;
else
- mpfr_min (extremum->value.real, extremum->value.real,
- arg->value.real, GFC_RND_MODE);
+ {
+ ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
+ if (ret > 0)
+ mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
+ }
break;
case BT_CHARACTER:
@@ -4451,8 +4460,8 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum,
LENGTH(extremum) = LENGTH(arg);
free (tmp);
}
-
- if (gfc_compare_string (arg, extremum) * sign > 0)
+ ret = gfc_compare_string (arg, extremum) * sign;
+ if (ret > 0)
{
free (STRING(extremum));
STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
@@ -4469,6 +4478,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum,
default:
gfc_internal_error ("simplify_min_max(): Bad type in arglist");
}
+ return ret;
}
@@ -4581,7 +4591,385 @@ gfc_simplify_maxval (gfc_expr *array, gfc_expr* di
}
+/* Transform minloc or maxloc of an array, according to MASK,
+ to the scalar result. This code is mostly identical to
+ simplify_transformation_to_scalar. */
+
+static gfc_expr *
+simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
+ gfc_expr *extremum, int sign)
+{
+ gfc_expr *a, *m;
+ gfc_constructor *array_ctor, *mask_ctor;
+ mpz_t count;
+
+ mpz_set_si (result->value.integer, 0);
+
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ array_ctor = gfc_constructor_first (array->value.constructor);
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ else
+ mask_ctor = NULL;
+
+ mpz_init_set_si (count, 0);
+ while (array_ctor)
+ {
+ mpz_add_ui (count, count, 1);
+ a = array_ctor->expr;
+ array_ctor = gfc_constructor_next (array_ctor);
+ /* A constant MASK equals .TRUE. here and can be ignored. */
+ if (mask_ctor)
+ {
+ m = mask_ctor->expr;
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ if (!m->value.logical)
+ continue;
+ }
+ if (min_max_choose (a, extremum, sign) > 0)
+ mpz_set (result->value.integer, count);
+ }
+ mpz_clear (count);
+ gfc_free_expr (extremum);
+ return result;
+}
+
+/* Simplify minloc / maxloc in the absence of a dim argument. */
+
+static gfc_expr *
+simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
+ gfc_expr *array, gfc_expr *mask, int sign)
+{
+ ssize_t res[GFC_MAX_DIMENSIONS];
+ int i, n;
+ gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
+ ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+ sstride[GFC_MAX_DIMENSIONS];
+ gfc_expr *a, *m;
+ bool continue_loop;
+ bool ma;
+
+ for (i = 0; i<array->rank; i++)
+ res[i] = -1;
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ goto finish;
+
+ for (i = 0; i < array->rank; i++)
+ {
+ count[i] = 0;
+ sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
+ extent[i] = mpz_get_si (array->shape[i]);
+ if (extent[i] <= 0)
+ goto finish;
+ }
+
+ continue_loop = true;
+ array_ctor = gfc_constructor_first (array->value.constructor);
+ if (mask && mask->rank > 0)
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ else
+ mask_ctor = NULL;
+
+ /* Loop over the array elements (and mask), keeping track of
+ the indices to return. */
+ while (continue_loop)
+ {
+ do
+ {
+ a = array_ctor->expr;
+ if (mask_ctor)
+ {
+ m = mask_ctor->expr;
+ ma = m->value.logical;
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
+ else
+ ma = true;
+
+ if (ma && min_max_choose (a, extremum, sign) > 0)
+ {
+ for (i = 0; i<array->rank; i++)
+ res[i] = count[i];
+ }
+ array_ctor = gfc_constructor_next (array_ctor);
+ count[0] ++;
+ } while (count[0] != extent[0]);
+ n = 0;
+ do
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ n++;
+ if (n >= array->rank)
+ {
+ continue_loop = false;
+ break;
+ }
+ else
+ count[n] ++;
+ } while (count[n] == extent[n]);
+ }
+
+ finish:
+ gfc_free_expr (extremum);
+ result_ctor = gfc_constructor_first (result->value.constructor);
+ for (i = 0; i<array->rank; i++)
+ {
+ gfc_expr *r_expr;
+ r_expr = result_ctor->expr;
+ mpz_set_si (r_expr->value.integer, res[i] + 1);
+ result_ctor = gfc_constructor_next (result_ctor);
+ }
+ return result;
+}
+
+/* Helper function for gfc_simplify_minmaxloc - build an arry
+ expression with n elements. */
+
+static gfc_expr *
+new_array (bt type, int kind, int n, locus *where)
+{
+ gfc_expr *result;
+ int i;
+
+ result = gfc_get_array_expr (type, kind, where);
+ result->rank = 1;
+ result->shape = gfc_get_shape(1);
+ mpz_init_set_si (result->shape[0], n);
+ for (i = 0; i < n; i++)
+ {
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_get_constant_expr (type, kind, where),
+ NULL);
+ }
+
+ return result;
+}
+
+/* Simplify minloc and maxloc. This code is mostly identical to
+ simplify_transformation_to_array. */
+
+static gfc_expr *
+simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
+ gfc_expr *dim, gfc_expr *mask,
+ gfc_expr *extremum, int sign)
+{
+ mpz_t size;
+ int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
+ gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
+ gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
+
+ int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+ sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
+ tmpstride[GFC_MAX_DIMENSIONS];
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ /* Build an indexed table for array element expressions to minimize
+ linked-list traversal. Masked elements are set to NULL. */
+ gfc_array_size (array, &size);
+ arraysize = mpz_get_ui (size);
+ mpz_clear (size);
+
+ arrayvec = XCNEWVEC (gfc_expr*, arraysize);
+
+ array_ctor = gfc_constructor_first (array->value.constructor);
+ mask_ctor = NULL;
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+
+ for (i = 0; i < arraysize; ++i)
+ {
+ arrayvec[i] = array_ctor->expr;
+ array_ctor = gfc_constructor_next (array_ctor);
+
+ if (mask_ctor)
+ {
+ if (!mask_ctor->expr->value.logical)
+ arrayvec[i] = NULL;
+
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ }
+ }
+
+ /* Same for the result expression. */
+ gfc_array_size (result, &size);
+ resultsize = mpz_get_ui (size);
+ mpz_clear (size);
+
+ resultvec = XCNEWVEC (gfc_expr*, resultsize);
+ result_ctor = gfc_constructor_first (result->value.constructor);
+ for (i = 0; i < resultsize; ++i)
+ {
+ resultvec[i] = result_ctor->expr;
+ result_ctor = gfc_constructor_next (result_ctor);
+ }
+
+ gfc_extract_int (dim, &dim_index);
+ dim_index -= 1; /* zero-base index */
+ dim_extent = 0;
+ dim_stride = 0;
+
+ for (i = 0, n = 0; i < array->rank; ++i)
+ {
+ count[i] = 0;
+ tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
+ if (i == dim_index)
+ {
+ dim_extent = mpz_get_si (array->shape[i]);
+ dim_stride = tmpstride[i];
+ continue;
+ }
+
+ extent[n] = mpz_get_si (array->shape[i]);
+ sstride[n] = tmpstride[i];
+ dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
+ n += 1;
+ }
+
+ done = false;
+ base = arrayvec;
+ dest = resultvec;
+ while (!done)
+ {
+ gfc_expr *ex;
+ ex = gfc_copy_expr (extremum);
+ for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
+ {
+ if (*src && min_max_choose (*src, ex, sign) > 0)
+ mpz_set_si ((*dest)->value.integer, n + 1);
+ }
+
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+ gfc_free_expr (ex);
+
+ n = 0;
+ while (!done && count[n] == extent[n])
+ {
+ count[n] = 0;
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+
+ n++;
+ if (n < result->rank)
+ {
+ /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
+ times, we'd warn for the last iteration, because the
+ array index will have already been incremented to the
+ array sizes, and we can't tell that this must make
+ the test against result->rank false, because ranks
+ must not exceed GFC_MAX_DIMENSIONS. */
+ GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ GCC_DIAGNOSTIC_POP
+ }
+ else
+ done = true;
+ }
+ }
+
+ /* Place updated expression in result constructor. */
+ result_ctor = gfc_constructor_first (result->value.constructor);
+ for (i = 0; i < resultsize; ++i)
+ {
+ result_ctor->expr = resultvec[i];
+ result_ctor = gfc_constructor_next (result_ctor);
+ }
+
+ free (arrayvec);
+ free (resultvec);
+ free (extremum);
+ return result;
+}
+
+/* Simplify minloc and maxloc for constant arrays. */
+
gfc_expr *
+gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
+ gfc_expr *kind, int sign)
+{
+ gfc_expr *result;
+ gfc_expr *extremum;
+ int ikind;
+ int init_val;
+
+ if (!is_constant_array_expr (array)
+ || !gfc_is_constant_expr (dim))
+ return NULL;
+
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (kind)
+ {
+ if (gfc_extract_int (kind, &ikind, -1))
+ return NULL;
+ }
+ else
+ ikind = gfc_default_integer_kind;
+
+ if (sign < 0)
+ init_val = INT_MAX;
+ else if (sign > 0)
+ init_val = INT_MIN;
+ else
+ gcc_unreachable();
+
+ extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
+ init_result_expr (extremum, init_val, array);
+
+ if (dim)
+ {
+ result = transformational_result (array, dim, BT_INTEGER,
+ ikind, &array->where);
+ init_result_expr (result, 0, array);
+
+ if (array->rank == 1)
+ return simplify_minmaxloc_to_scalar (result, array, mask, extremum, sign);
+ else
+ return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, sign);
+ }
+ else
+ {
+ result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
+ return simplify_minmaxloc_nodim (result, extremum, array, mask, sign);
+ }
+}
+
+gfc_expr *
+gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind)
+{
+ return gfc_simplify_minmaxloc (array, dim, mask, kind, -1);
+}
+
+gfc_expr *
+gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind)
+{
+ return gfc_simplify_minmaxloc (array, dim, mask, kind, 1);
+}
+
+gfc_expr *
gfc_simplify_maxexponent (gfc_expr *x)
{
int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
! { dg-do run }
! Check that simplifcation of minloc works
program main
implicit none
integer :: d
real, dimension(2), parameter :: a = [1.0, 0.0]
character(len=3), dimension(3), parameter :: c = [ "fgh", "asd", "jkl" ]
integer, parameter :: b = minloc(a,dim=1)
integer, parameter :: b2 = minloc(a,dim=1,mask=[.false.,.false.])
integer, parameter :: b3 = minloc(c,dim=1)
integer, parameter :: b4 = minloc(c,dim=1,mask=[c>"bbb"])
integer, parameter,dimension(2,2) :: i1 = reshape([4,3,2,5],shape(i1))
integer, parameter, dimension(2) :: b5 = minloc(i1)
integer, parameter, dimension(2) :: b6 = minloc(i1,mask=i1>7)
integer, parameter, dimension(2) :: b7 = minloc(i1, mask=i1>2)
integer, parameter, dimension(2) :: b8 = minloc(i1, mask=.true.)
integer, parameter, dimension(2) :: b9 = minloc(i1, mask=.false.)
integer, parameter, dimension(2,3) :: i2 = &
reshape([2, -1, -3, 4, -5, 6], shape(i2))
integer, parameter, dimension(3) :: b10 = minloc(i2, dim=1)
integer, parameter, dimension(2) :: b11 = minloc(i2, dim=2)
integer, parameter, dimension(3) :: b12 = minloc(i2,dim=1,mask=i2>3)
integer, parameter, dimension(2) :: b13 = minloc(i2,dim=2, mask=i2<-10)
if (b /= 2) call abort
if (b2 /= 0) call abort
if (b3 /= 2) call abort
if (b4 /= 1) call abort
if (any(b5 /= [1, 2])) call abort
if (any(b6 /= [0, 0])) call abort
if (any(b7 /= [2, 1])) call abort
if (any(b8 /= [1, 2])) call abort
if (any(b9 /= [0, 0])) call abort
d = 1
if (any(b10 /= minloc(i2,dim=d))) call abort
d = 2
if (any(b11 /= minloc(i2,dim=2))) call abort
d = 1
if (any(b12 /= minloc(i2, dim=d,mask=i2>3))) call abort
if (any(b13 /= 0)) call abort
end program main
! { dg-do run }
! Check that simplifcation of maxloc works
program main
implicit none
integer :: d
real, dimension(2), parameter :: a = [1.0, 0.0]
character(len=3), dimension(3), parameter :: c = [ "fgh", "asd", "jkl" ]
integer, parameter :: b = maxloc(a,dim=1)
integer, parameter :: b2 = maxloc(a,dim=1,mask=[.false.,.false.])
integer, parameter :: b3 = maxloc(c,dim=1)
integer, parameter :: b4 = maxloc(c,dim=1,mask=[c<"iii"])
integer, parameter,dimension(2,2) :: i1 = reshape([4,5,3,2],shape(i1))
integer, parameter, dimension(2) :: b5 = maxloc(i1)
integer, parameter, dimension(2) :: b6 = maxloc(i1,mask=i1>7)
integer, parameter, dimension(2) :: b7 = maxloc(i1, mask=i1<5)
integer, parameter, dimension(2) :: b8 = maxloc(i1, mask=.true.)
integer, parameter, dimension(2) :: b9 = maxloc(i1, mask=.false.)
integer, parameter, dimension(2,3) :: i2 = &
reshape([2, -1, -3, 4, -5, 6], shape(i2))
integer, parameter, dimension(3) :: b10 = maxloc(i2, dim=1)
integer, parameter, dimension(2) :: b11 = maxloc(i2, dim=2)
integer, parameter, dimension(3) :: b12 = maxloc(i2,dim=1,mask=i2<0)
integer, parameter, dimension(2) :: b13 = maxloc(i2,dim=2, mask=i2<-10)
if (b /= 1) call abort
if (b2 /= 0) call abort
if (b3 /= 3) call abort
if (b4 /= 1) call abort
if (any(b5 /= [2,1])) call abort
if (any(b6 /= [0, 0])) call abort
if (any(b7 /= [1,1])) call abort
if (any(b8 /= b5)) call abort
if (any(b9 /= [0, 0])) call abort
d = 1
if (any(b10 /= maxloc(i2,dim=d))) call abort
d = 2
if (any(b11 /= maxloc(i2,dim=2))) call abort
d = 1
if (any(b12 /= maxloc(i2, dim=d,mask=i2<0))) call abort
if (any(b13 /= 0)) call abort
end program main
