]> git.ipfire.org Git - thirdparty/gcc.git/commitdiff
Make allocate with source work, some more offset fixes for implied this_image().
authorThomas Koenig <tkoenig@gcc.gnu.org>
Sat, 19 Dec 2020 19:49:03 +0000 (20:49 +0100)
committerThomas Koenig <tkoenig@gcc.gnu.org>
Sat, 19 Dec 2020 19:49:03 +0000 (20:49 +0100)
gcc/fortran/ChangeLog:

* options.c (gfc_post_options): Always set flag_debug_aux_vars for
shared coarrays.
* resolve.c (gfc_expr_to_initialize): Set extra dimensions to
DIMEN_THIS_IMAGE.
* trans-array.c (cas_add_strides): Re-introduce.
(cas_add_this_image_offset): Rename add_lbound to
correct_full_offset, use cas_add_strides.

gcc/testsuite/ChangeLog:

* gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90: New test.
* gfortran.dg/caf-shared/cobounds_torture_1.f90: New test.
* gfortran.dg/caf-shared/cobounds_torture_2.f90: New test.
* gfortran.dg/caf-shared/cobounds_torture_3.f90: New test.

gcc/fortran/options.c
gcc/fortran/resolve.c
gcc/fortran/trans-array.c
gcc/testsuite/gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_3.f90 [new file with mode: 0644]

index d844fa93115eef1d50187f809c309227006356fe..9e32ae69dde736a7d74a1c1d3eeacb9cddee68b1 100644 (file)
@@ -485,6 +485,11 @@ gfc_post_options (const char **pfilename)
     gfc_fatal_error ("Maximum subrecord length cannot exceed %d",
                     MAX_SUBRECORD_LENGTH);
 
+  /* For now, we always want to debug auxiliary variables we create
+     for shared coarrays.  */
+  if (flag_coarray == GFC_FCOARRAY_SHARED)
+    flag_debug_aux_vars = 1;
+
   gfc_cpp_post_options ();
 
   if (gfc_option.allow_std & GFC_STD_F2008)
index e359c2083c45803206eaf20b528d14f7b220c572..40a2f6fb2d9045881dd729e7e0f2211f1083b91b 100644 (file)
@@ -7606,17 +7606,34 @@ gfc_expr_to_initialize (gfc_expr *e)
     if (ref->type == REF_ARRAY && ref->next == NULL)
       {
        if (ref->u.ar.dimen == 0
-           && ref->u.ar.as && ref->u.ar.as->corank)
+           && ref->u.ar.as && ref->u.ar.as->corank
+           && flag_coarray != GFC_FCOARRAY_SHARED)
          return result;
 
        ref->u.ar.type = AR_FULL;
 
        for (i = 0; i < ref->u.ar.dimen; i++)
-         ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
-
+         {
+           gfc_free_expr (ref->u.ar.start[i]);
+           gfc_free_expr (ref->u.ar.end[i]);
+           gfc_free_expr (ref->u.ar.stride[i]);
+           ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+         }
        break;
       }
 
+  if (flag_coarray == GFC_FCOARRAY_SHARED)
+    {
+      for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+       {
+         gfc_free_expr (ref->u.ar.start[i]);
+         gfc_free_expr (ref->u.ar.end[i]);
+         gfc_free_expr (ref->u.ar.stride[i]);
+         ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+         ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
+       }
+    }
+
   gfc_free_shape (&result->shape, result->rank);
 
   /* Recalculate rank, shape, etc.  */
index 5fca413cbc55b614d1a1d655cbfb697722c7f3c3..1e3579e554aa2a413eee6376ab144deeb940c84b 100644 (file)
@@ -2940,6 +2940,28 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
       gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
 }
 
+/* Add stride from rank beg to end - 1.  */
+
+static tree
+cas_add_strides (tree expr, tree desc, int beg, int end)
+{
+  int i;
+  tree tmp, stride, lbound;
+  tmp = gfc_index_zero_node;
+  for (i = beg; i < end; i++)
+    {
+      stride = gfc_conv_array_stride (desc, i);
+      lbound = gfc_conv_array_lbound (desc, i);
+      tmp =
+       fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(tmp), tmp,
+                        fold_build2_loc (input_location, MULT_EXPR,
+                                         TREE_TYPE (stride), stride, lbound));
+    }
+  return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(expr),
+                         expr, tmp);
+}
+
+
 /* If the full offset is needed, this function calculates the new offset via
 
      new_offset = offset
@@ -2947,9 +2969,11 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
        + sum (stride[i]*lbound[i]) over remaining codim.  */
 
 static tree
-cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar, bool add_lbound)
+cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar,
+                          bool correct_full_offset)
 {
   tree tmp;
+
   /* Calculate the actual offset.  */
   /* tmp = _gfortran_cas_coarray_this_image (0).  */
   tmp = build_call_expr_loc (input_location, gfor_fndecl_cas_this_image,
@@ -2960,7 +2984,7 @@ cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar, bool add_l
                         build_int_cst (TREE_TYPE (tmp), 1));
 
   /* tmp = _gfortran_cas_coarray_this_image (0) - 1 + lbound[first_codim] */
-  if (add_lbound)
+  if (correct_full_offset)
     tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), tmp,
                           gfc_conv_array_lbound(desc, ar->dimen));
 
@@ -2969,6 +2993,10 @@ cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar, bool add_l
   tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
                         gfc_conv_array_stride (desc, ar->dimen), tmp);
 
+  if (correct_full_offset)
+    tmp = cas_add_strides (tmp, desc, ar->as->rank + 1,
+                          ar->as->rank + ar->as->corank);
+
   return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (offset),
                          offset, tmp);
 }
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/alloc_coarray_with_source_1.f90
new file mode 100644 (file)
index 0000000..6634653
--- /dev/null
@@ -0,0 +1,29 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+
+program coarray_41
+
+  integer, allocatable :: vec(:)[:,:]
+
+  allocate(vec(10)[2,*], source= 37)
+
+  if (.not. allocated(vec)) error stop
+
+  call foo(vec)
+
+  if (any(vec /= 42)) error stop
+
+  deallocate(vec)
+contains
+
+  subroutine foo(gv)
+
+    integer, allocatable, intent(inout) :: gv(:)[:,:]
+    integer, allocatable :: gvin(:)
+
+    allocate(gvin, mold=gv)
+    gvin = 5
+    gv = gv + gvin
+  end subroutine foo
+
+end program coarray_41
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_1.f90 b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_1.f90
new file mode 100644 (file)
index 0000000..2c8b289
--- /dev/null
@@ -0,0 +1,39 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+  implicit none
+  integer, dimension(2) :: ia
+  integer, dimension(3) :: ib
+  integer, dimension(4) :: ic
+  integer :: me
+  integer :: a(2)[77:78,3:*]
+  integer :: b(2)[34:35,2:3,*]
+  integer :: c(2) [-21:-20,2:3,4:5,8:*]
+  character(len=20) :: line1, line2, line3
+  me = this_image()
+  ia = this_image(a)
+  ib = this_image(b)
+  ic = this_image(c)
+  a(:)[ia(1),ia(2)] = me
+  b(:)[ib(1),ib(2),ib(3)] = me + 100
+  c(:)[ic(1),ic(2),ic(3),ic(4)] = me + 200
+!  print '(Z16)',loc(c(1)[ic(1),ic(2),ic(3),ic(4)]) - (this_image() - 1)*8
+  write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+  write (unit=line2,fmt='(*(I4))') a(:)
+  write (unit=line3,fmt='(*(I4))') me, me
+  if (line1 /= line2) stop 1
+  if (line1 /= line3) stop 2
+  write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+  write (unit=line2,fmt='(*(I4))') b(:)
+  write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+  if (line1 /= line2) stop 3
+  if (line1 /= line3) stop 4
+  write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+  write (unit=line2,fmt='(*(I4))') c(:)
+  write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+  if (line1 /= line2) stop 5
+  if (line1 /= line3) stop 6
+end program main
+
+
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_2.f90 b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_2.f90
new file mode 100644 (file)
index 0000000..f7fe5ab
--- /dev/null
@@ -0,0 +1,41 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+  implicit none
+  integer, dimension(2) :: ia
+  integer, dimension(3) :: ib
+  integer, dimension(4) :: ic
+  integer :: me
+  integer, allocatable :: a(:)[:,:]
+  integer, allocatable :: b(:)[:,:,:]
+  integer, allocatable :: c(:) [:,:,:,:]
+  character(len=20) :: line1, line2, line3
+  me = this_image()
+  allocate (a(2)[77:78,3:*])
+  allocate (b(2)[34:35,2:3,*])
+  allocate (c(2) [-21:-20,2:3,4:5,8:*])
+  ia = this_image(a)
+  ib = this_image(b)
+  ic = this_image(c)
+  a(:)[ia(1),ia(2)] = me
+  b(:)[ib(1),ib(2),ib(3)] = me + 100
+  c(:)[ic(1),ic(2),ic(3),ic(4)] = me + 200
+  write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+  write (unit=line2,fmt='(*(I4))') a(:)
+  write (unit=line3,fmt='(*(I4))') me, me
+  if (line1 /= line2) stop 1
+  if (line1 /= line3) stop 2
+  write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+  write (unit=line2,fmt='(*(I4))') b(:)
+  write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+  if (line1 /= line2) stop 3
+  if (line1 /= line3) stop 4
+  write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+  write (unit=line2,fmt='(*(I4))') c(:)
+  write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+  if (line1 /= line2) stop 5
+  if (line1 /= line3) stop 6
+end program main
+
+
diff --git a/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_3.f90 b/gcc/testsuite/gfortran.dg/caf-shared/cobounds_torture_3.f90
new file mode 100644 (file)
index 0000000..4b23795
--- /dev/null
@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+  implicit none
+  integer, dimension(2) :: ia
+  integer, dimension(3) :: ib
+  integer, dimension(4) :: ic
+  integer :: me
+  integer :: a(2)[77:78,3:*]
+  integer :: b(2)[34:35,2:3,*]
+  integer :: c(2) [-21:-20,2:3,4:5,8:*]
+  character(len=20) :: line1, line2, line3
+  me = this_image()
+  ia = this_image(a)
+  ib = this_image(b)
+  ic = this_image(c)
+  a = me
+  b = me + 100
+  c = me + 200
+  write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+  write (unit=line2,fmt='(*(I4))') a(:)
+  write (unit=line3,fmt='(*(I4))') me, me
+  if (line1 /= line2) stop 1
+  if (line1 /= line3) stop 2
+  write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+  write (unit=line2,fmt='(*(I4))') b(:)
+  write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+  if (line1 /= line2) stop 3
+  if (line1 /= line3) stop 4
+  write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+  write (unit=line2,fmt='(*(I4))') c(:)
+  write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+  if (line1 /= line2) stop 5
+  if (line1 /= line3) stop 6
+end program main
+
+