From a9ec0cfc364b811d25bf8c84ad47e4d85f9a4766 Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Tue, 2 Jan 2018 17:51:26 +0000 Subject: [PATCH] re PR fortran/45689 ([F03] Missing transformational intrinsic in the trans_func_f2003 list) 2018-01-02 Thomas Koenig PR fortran/45689 PR fortran/83650 * simplify.c (gfc_simplify_cshift): Re-implement to allow full range of arguments. 2018-01-02 Thomas Koenig PR fortran/45689 PR fortran/83650 * gfortran.dg/simplify_cshift_1.f90: Correct erroneous case. * gfortran.dg/simplify_cshift_4.f90: New test. From-SVN: r256084 --- gcc/fortran/ChangeLog | 7 + gcc/fortran/simplify.c | 232 +++++++++++++----- gcc/testsuite/ChangeLog | 7 + .../gfortran.dg/simplify_cshift_1.f90 | 4 +- .../gfortran.dg/simplify_cshift_4.f90 | 37 +++ 5 files changed, 229 insertions(+), 58 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/simplify_cshift_4.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ad2ff35b610..61b41675413 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2018-01-02 Thomas Koenig + + PR fortran/45689 + PR fortran/83650 + * simplify.c (gfc_simplify_cshift): Re-implement to allow full + range of arguments. + 2018-01-01 Paul Thomas PR fortran/83076 diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7c3fefe60f9..22a486418f7 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1950,92 +1950,212 @@ gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind) simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL); } +/* Simplification routine for cshift. This works by copying the array + expressions into a one-dimensional array, shuffling the values into another + one-dimensional array and creating the new array expression from this. The + shuffling part is basically taken from the library routine. */ gfc_expr * gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) { - gfc_expr *a, *result; - int dm; + gfc_expr *result; + int which; + gfc_expr **arrayvec, **resultvec; + gfc_expr **rptr, **sptr; + mpz_t size; + size_t arraysize, shiftsize, i; + gfc_constructor *array_ctor, *shift_ctor; + ssize_t *shiftvec, *hptr; + ssize_t shift_val, len; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + hs_ex[GFC_MAX_DIMENSIONS], + hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS], + a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS], + h_extent[GFC_MAX_DIMENSIONS], + ss_ex[GFC_MAX_DIMENSIONS]; + ssize_t rsoffset; + int d, n; + bool continue_loop; + gfc_expr **src, **dest; + + if (!is_constant_array_expr (array)) + return NULL; + + if (shift->rank > 0) + gfc_simplify_expr (shift, 1); - /* DIM is only useful for rank > 1, but deal with it here as one can - set DIM = 1 for rank = 1. */ + if (!gfc_is_constant_expr (shift)) + return NULL; + + /* Make dim zero-based. */ if (dim) { if (!gfc_is_constant_expr (dim)) return NULL; - dm = mpz_get_si (dim->value.integer); + which = mpz_get_si (dim->value.integer) - 1; } else - dm = 1; + which = 0; - /* Copy array into 'a', simplify it, and then test for a constant array. */ - a = gfc_copy_expr (array); - gfc_simplify_expr (a, 0); - if (!is_constant_array_expr (a)) - { - gfc_free_expr (a); - return NULL; - } + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); - if (a->rank == 1) - { - gfc_constructor *ca, *cr; - mpz_t size; - int i, j, shft, sz; + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + result->shape = gfc_copy_shape (array->shape, array->rank); + result->rank = array->rank; + result->ts.u.derived = array->ts.u.derived; - if (!gfc_is_constant_expr (shift)) - { - gfc_free_expr (a); - return NULL; - } + if (arraysize == 0) + return result; - shft = mpz_get_si (shift->value.integer); + arrayvec = XCNEWVEC (gfc_expr *, arraysize); + array_ctor = gfc_constructor_first (array->value.constructor); + for (i = 0; i < arraysize; i++) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + } - /* Case (i): If ARRAY has rank one, element i of the result is - ARRAY (1 + MODULO (i + SHIFT - 1, SIZE (ARRAY))). */ + resultvec = XCNEWVEC (gfc_expr *, arraysize); - mpz_init (size); - gfc_array_size (a, &size); - sz = mpz_get_si (size); - mpz_clear (size); + extent[0] = 1; + count[0] = 0; - /* Adjust shft to deal with right or left shifts. */ - shft = shft < 0 ? 1 - shft : shft; + for (d=0; d < array->rank; d++) + { + a_extent[d] = mpz_get_si (array->shape[d]); + a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; + } - /* Special case: Shift to the original order! */ - if (sz == 0 || shft % sz == 0) - return a; + if (shift->rank > 0) + { + gfc_array_size (shift, &size); + shiftsize = mpz_get_ui (size); + mpz_clear (size); + shiftvec = XCNEWVEC (ssize_t, shiftsize); + shift_ctor = gfc_constructor_first (shift->value.constructor); + for (d = 0; d < shift->rank; d++) + { + h_extent[d] = mpz_get_si (shift->shape[d]); + hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1]; + } + } + else + shiftvec = NULL; + + /* Shut up compiler */ + len = 1; + rsoffset = 1; - result = gfc_copy_expr (a); - cr = gfc_constructor_first (result->value.constructor); - for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr)) + n = 0; + for (d=0; d < array->rank; d++) + { + if (d == which) + { + rsoffset = a_stride[d]; + len = a_extent[d]; + } + else { - j = (i + shft) % sz; - ca = gfc_constructor_first (a->value.constructor); - while (j-- > 0) - ca = gfc_constructor_next (ca); - cr->expr = gfc_copy_expr (ca->expr); + count[n] = 0; + extent[n] = a_extent[d]; + sstride[n] = a_stride[d]; + ss_ex[n] = sstride[n] * extent[n]; + if (shiftvec) + hs_ex[n] = hstride[n] * extent[n]; + n++; } + } - gfc_free_expr (a); - return result; + if (shiftvec) + { + for (i = 0; i < shiftsize; i++) + { + ssize_t val; + val = mpz_get_si (shift_ctor->expr->value.integer); + val = val % len; + if (val < 0) + val += len; + shiftvec[i] = val; + shift_ctor = gfc_constructor_next (shift_ctor); + } + shift_val = 0; } else { - /* FIXME: Deal with rank > 1 arrays. For now, don't leak memory. */ + shift_val = mpz_get_si (shift->value.integer); + shift_val = shift_val % len; + if (shift_val < 0) + shift_val += len; + } - /* GCC bootstrap is too stupid to realize that the above code for dm - is correct. First, dim can be specified for a rank 1 array. It is - not needed in this nor used here. Second, the code is simply waiting - for someone to implement rank > 1 simplification. For now, add a - pessimization to the code that has a zero valid reason to be here. */ - if (dm > array->rank) - gcc_unreachable (); + continue_loop = true; + d = array->rank; + rptr = resultvec; + sptr = arrayvec; + hptr = shiftvec; - gfc_free_expr (a); + while (continue_loop) + { + ssize_t sh; + if (shiftvec) + sh = *hptr; + else + sh = shift_val; + + src = &sptr[sh * rsoffset]; + dest = rptr; + for (n = 0; n < len - sh; n++) + { + *dest = *src; + dest += rsoffset; + src += rsoffset; + } + src = sptr; + for ( n = 0; n < sh; n++) + { + *dest = *src; + dest += rsoffset; + src += rsoffset; + } + rptr += sstride[0]; + sptr += sstride[0]; + if (shiftvec) + hptr += hstride[0]; + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + count[n] = 0; + rptr -= ss_ex[n]; + sptr -= ss_ex[n]; + if (shiftvec) + hptr -= hs_ex[n]; + n++; + if (n >= d - 1) + { + continue_loop = false; + break; + } + else + { + count[n]++; + rptr += sstride[n]; + sptr += sstride[n]; + if (shiftvec) + hptr += hstride[n]; + } + } } - return NULL; + for (i = 0; i < arraysize; i++) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (resultvec[i]), + NULL); + } + return result; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b8dbee01f92..b77e73f8bbc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-01-02 Thomas Koenig + + PR fortran/45689 + PR fortran/83650 + * gfortran.dg/simplify_cshift_1.f90: Correct erroneous case. + * gfortran.dg/simplify_cshift_4.f90: New test. + 2018-01-02 Marek Polacek PR c++/81860 diff --git a/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 b/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 index dbe67f4c8e9..4bc8374eea7 100644 --- a/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 +++ b/gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 @@ -23,12 +23,12 @@ program foo v = cshift(c, 2) if (any(b /= v)) call abort - ! Special cases shift = 0, size(a), 1-size(a) + ! Special cases shift = 0, size(a), -size(a) b = cshift([1, 2, 3, 4, 5], 0) if (any(b /= a)) call abort b = cshift([1, 2, 3, 4, 5], size(a)) if (any(b /= a)) call abort - b = cshift([1, 2, 3, 4, 5], 1-size(a)) + b = cshift([1, 2, 3, 4, 5], -size(a)) if (any(b /= a)) call abort ! simplification of array arg. diff --git a/gcc/testsuite/gfortran.dg/simplify_cshift_4.f90 b/gcc/testsuite/gfortran.dg/simplify_cshift_4.f90 new file mode 100644 index 00000000000..bbbe2a53941 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/simplify_cshift_4.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +program main + implicit none + integer :: i + integer, parameter, dimension(3,3) :: a = & + reshape([1,2,3,4,5,6,7,8,9], shape(a)) + integer, dimension(3,3) :: b + integer, parameter, dimension(3,4,5) :: c = & + reshape([(i**2,i=1,3*4*5)],shape(c)) + integer, dimension(3,4,5) :: d + integer, dimension(4,5), parameter :: sh1 =& + reshape([(i**3-12*i**2,i=1,4*5)],shape(sh1)) + integer, dimension(3,5), parameter :: sh2 = & + reshape([(i**3-7*i**2,i=1,3*5)], shape(sh2)) + integer, dimension(3,4), parameter :: sh3 = & + reshape([(i**3-3*i**2,i=1,3*4)], shape(sh3)) + integer, parameter, dimension(3,4,5) :: c1 = cshift(c,shift=sh1,dim=1) + integer, parameter, dimension(3,4,5) :: c2 = cshift(c,shift=sh2,dim=2) + integer, parameter, dimension(3,4,5) :: c3 = cshift(c,shift=sh3,dim=3) + + b = a + if (any(cshift(a,1) /= cshift(b,1))) call abort + if (any(cshift(a,2) /= cshift(b,2))) call abort + if (any(cshift(a,1,dim=2) /= cshift(b,1,dim=2))) call abort + d = c + if (any(cshift(c,1) /= cshift(d,1))) call abort + if (any(cshift(c,2) /= cshift(d,2))) call abort + if (any(cshift(c,3) /= cshift(d,3))) call abort + + if (any(cshift(c,1,dim=2) /= cshift(d,1,dim=2))) call abort + if (any(cshift(c,2,dim=2) /= cshift(d,2,dim=2))) call abort + if (any(cshift(c,3,dim=3) /= cshift(d,3,dim=3))) call abort + + if (any(cshift(d,shift=sh1,dim=1) /= c1)) call abort + if (any(cshift(d,shift=sh2,dim=2) /= c2)) call abort + if (any(cshift(d,shift=sh3,dim=3) /= c3)) call abort +end program main -- 2.30.2