re PR fortran/64771 (ICE(segfault) when passing coarrays around; ICE in gfc_zero_size...

2015-01-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/64771
gcc/fortran/
        * interface.c (check_dummy_characteristics): Fix coarray
        * handling.

testsuite/
        * gfortran.dg/coarray_36.f: New.
        * gfortran.dg/coarray_37.f90: New.

From-SVN: r220136

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index e31db0ce6c584914c39fcef922f5dda073d8b3c2..d73bab2feeacf98d62eb7949b8e39b7b169a8863 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2015-01-26  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/64771
+       * interface.c (check_dummy_characteristics): Fix coarray handling.
+
 2015-01-26  Tobias Burnus  <burnus@net-b.de>
 
        * io.c (gfc_match_inquire): Replace "-1" by a defined constant.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index dd3ad2a0cd217976da13f27209fdd7e983aa7243..0463a58fa7f6fd9c841feac929252c1995a3e8c2 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -63,6 +63,8 @@ along with GCC; see the file COPYING3.  If not see
    formal argument list points to symbols within the same namespace as
    the program unit name.  */
 
+#include <algorithm>  /* For std::max.  */
+
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
@@ -1205,8 +1207,15 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
          return false;
        }
 
+      if (s1->as->corank != s2->as->corank)
+       {
+         snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)",
+                   s1->name, s1->as->corank, s2->as->corank);
+         return false;
+       }
+
       if (s1->as->type == AS_EXPLICIT)
-       for (i = 0; i < s1->as->rank + s1->as->corank; i++)
+       for (i = 0; i < s1->as->rank + std::max(0, s1->as->corank-1); i++)
          {
            shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
                                  gfc_copy_expr (s1->as->lower[i]));
@@ -1220,8 +1229,12 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
              case -1:
              case  1:
              case -3:
-               snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
-                         "argument '%s'", i + 1, s1->name);
+               if (i < s1->as->rank)
+                 snprintf (errmsg, err_len, "Shape mismatch in dimension %i of"
+                           " argument '%s'", i + 1, s1->name);
+               else
+                 snprintf (errmsg, err_len, "Shape mismatch in codimension %i "
+                           "of argument '%s'", i - s1->as->rank + 1, s1->name);
                return false;
 
              case -2:

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 27f11c246371178c8b8735220e446378742c977c..7fabc0396ade023aacc7804446d974bdf087da87 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2015-01-26  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/64771
+       * gfortran.dg/coarray_36.f: New.
+       * gfortran.dg/coarray_37.f90: New.
+
 2015-01-26  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/64230

diff --git a/gcc/testsuite/gfortran.dg/coarray_36.f b/gcc/testsuite/gfortran.dg/coarray_36.f
new file mode 100644 (file)
index 0000000..d06a01e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_36.f
@@ -0,0 +1,347 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=lib" }
+!
+! PR fortran/64771
+!
+! Contributed by Alessandro Fanfarill
+!
+! Reduced version of the full NAS CG benchmark
+!
+
+!-------------------------------------------------------------------------!
+!                                                                         !
+!        N  A  S     P A R A L L E L     B E N C H M A R K S  3.3         !
+!                                                                         !
+!                                   C G                                   !
+!                                                                         !
+!-------------------------------------------------------------------------!
+!                                                                         !
+!    This benchmark is part of the NAS Parallel Benchmark 3.3 suite.      !
+!    It is described in NAS Technical Reports 95-020 and 02-007           !
+!                                                                         !
+!    Permission to use, copy, distribute and modify this software         !
+!    for any purpose with or without fee is hereby granted.  We           !
+!    request, however, that all derived work reference the NAS            !
+!    Parallel Benchmarks 3.3. This software is provided "as is"           !
+!    without express or implied warranty.                                 !
+!                                                                         !
+!    Information on NPB 3.3, including the technical report, the          !
+!    original specifications, source code, results and information        !
+!    on how to submit new results, is available at:                       !
+!                                                                         !
+!           http://www.nas.nasa.gov/Software/NPB/                         !
+!                                                                         !
+!    Send comments or suggestions to  npb@nas.nasa.gov                    !
+!                                                                         !
+!          NAS Parallel Benchmarks Group                                  !
+!          NASA Ames Research Center                                      !
+!          Mail Stop: T27A-1                                              !
+!          Moffett Field, CA   94035-1000                                 !
+!                                                                         !
+!          E-mail:  npb@nas.nasa.gov                                      !
+!          Fax:     (650) 604-3957                                        !
+!                                                                         !
+!-------------------------------------------------------------------------!
+
+
+c---------------------------------------------------------------------
+c
+c Authors: M. Yarrow
+c          C. Kuszmaul
+c          R. F. Van der Wijngaart
+c          H. Jin
+c
+c---------------------------------------------------------------------
+
+
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+      program cg
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+      implicit none
+
+      integer            na, nonzer, niter
+      double precision   shift, rcond
+      parameter(  na=75000,
+     >     nonzer=13,
+     >     niter=75,
+     >     shift=60.,
+     >     rcond=1.0d-1 )
+
+
+
+      integer num_proc_rows, num_proc_cols
+      parameter( num_proc_rows = 2, num_proc_cols = 2)
+      integer    num_procs
+      parameter( num_procs = num_proc_cols * num_proc_rows )
+
+      integer    nz
+      parameter( nz = na*(nonzer+1)/num_procs*(nonzer+1)+nonzer
+     >              + na*(nonzer+2+num_procs/256)/num_proc_cols )
+
+      common / partit_size  /  naa, nzz,
+     >                         npcols, nprows,
+     >                         proc_col, proc_row,
+     >                         firstrow,
+     >                         lastrow,
+     >                         firstcol,
+     >                         lastcol,
+     >                         exch_proc,
+     >                         exch_recv_length,
+     >                         send_start,
+     >                         send_len
+      integer                  naa, nzz,
+     >                         npcols, nprows,
+     >                         proc_col, proc_row,
+     >                         firstrow,
+     >                         lastrow,
+     >                         firstcol,
+     >                         lastcol,
+     >                         exch_proc,
+     >                         exch_recv_length,
+     >                         send_start,
+     >                         send_len
+
+
+      common / main_int_mem /  colidx,     rowstr,
+     >                         iv,         arow,     acol
+      integer                  colidx(nz), rowstr(na+1),
+     >                         iv(2*na+1), arow(nz), acol(nz)
+
+
+c---------------------------------
+c     Coarray Decalarations
+c---------------------------------
+      double precision         v(na+1)[0:*], aelt(nz)[0:*], a(nz)[0:*],
+     >                         x(na/num_proc_rows+2)[0:*],
+     >                         z(na/num_proc_rows+2)[0:*],
+     >                         p(na/num_proc_rows+2)[0:*],
+     >                         q(na/num_proc_rows+2)[0:*],
+     >                         r(na/num_proc_rows+2)[0:*],
+     >                         w(na/num_proc_rows+2)[0:*]
+
+
+      common /urando/          amult, tran
+      double precision         amult, tran
+
+
+
+      integer            l2npcols
+      integer            reduce_exch_proc(num_proc_cols)
+      integer            reduce_send_starts(num_proc_cols)
+      integer            reduce_send_lengths(num_proc_cols)
+      integer            reduce_recv_lengths(num_proc_cols)
+      integer            reduce_rrecv_starts(num_proc_cols)
+c---------------------------------
+c     Coarray Decalarations
+c---------------------------------
+      integer            reduce_recv_starts(num_proc_cols)[0:*]
+
+      integer            i, j, k, it, me, nprocs, root
+
+      double precision   zeta, randlc
+      external           randlc
+      double precision   rnorm
+c---------------------------------
+c     Coarray Decalarations
+c---------------------------------
+      double precision   norm_temp1(2)[0:*], norm_temp2(2)[0:*]
+
+      double precision   t, tmax, mflops
+      double precision   u(1), umax(1)
+      external           timer_read
+      double precision   timer_read
+      character          class
+      logical            verified
+      double precision   zeta_verify_value, epsilon, err
+
+c---------------------------------------------------------------------
+c  Explicit interface for conj_grad, due to coarray args
+c---------------------------------------------------------------------
+      interface
+
+      subroutine conj_grad ( colidx,
+     >                       rowstr,
+     >                       x,
+     >                       z,
+     >                       a,
+     >                       p,
+     >                       q,
+     >                       r,
+     >                       w,
+     >                       rnorm,
+     >                       l2npcols,
+     >                       reduce_exch_proc,
+     >                       reduce_send_starts,
+     >                       reduce_send_lengths,
+     >                       reduce_recv_starts,
+     >                       reduce_recv_lengths,
+     >                       reduce_rrecv_starts )
+
+      common / partit_size  /  naa, nzz,
+     >                         npcols, nprows,
+     >                         proc_col, proc_row,
+     >                         firstrow,
+     >                         lastrow,
+     >                         firstcol,
+     >                         lastcol,
+     >                         exch_proc,
+     >                         exch_recv_length,
+     >                         send_start,
+     >                         send_len
+
+      integer                  naa, nzz,
+     >                         npcols, nprows,
+     >                         proc_col, proc_row,
+     >                         firstrow,
+     >                         lastrow,
+     >                         firstcol,
+     >                         lastcol,
+     >                         exch_proc,
+     >                         exch_recv_length,
+     >                         send_start,
+     >                         send_len
+
+      double precision   x(*),
+     >                   z(*),
+     >                   a(nzz)
+      integer            colidx(nzz), rowstr(naa+1)
+
+      double precision   p(*),
+     >                   q(*)[0:*],
+     >                   r(*)[0:*],
+     >                   w(*)[0:*]        ! used as work temporary
+
+      integer   l2npcols
+      integer   reduce_exch_proc(l2npcols)
+      integer   reduce_send_starts(l2npcols)
+      integer   reduce_send_lengths(l2npcols)
+      integer   reduce_recv_starts(l2npcols)[0:*]
+      integer   reduce_recv_lengths(l2npcols)
+      integer   reduce_rrecv_starts(l2npcols)
+
+      double precision   rnorm
+
+      end subroutine
+
+      end interface
+
+c---------------------------------------------------------------------
+c  The call to the conjugate gradient routine:
+c---------------------------------------------------------------------
+         call conj_grad ( colidx,
+     >                    rowstr,
+     >                    x,
+     >                    z,
+     >                    a,
+     >                    p,
+     >                    q,
+     >                    r,
+     >                    w,
+     >                    rnorm,
+     >                    l2npcols,
+     >                    reduce_exch_proc,
+     >                    reduce_send_starts,
+     >                    reduce_send_lengths,
+     >                    reduce_recv_starts,
+     >                    reduce_recv_lengths,
+     >                    reduce_rrecv_starts ) 
+
+
+      sync all
+
+      end                              ! end main
+
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+      subroutine conj_grad ( colidx,
+     >                       rowstr,
+     >                       x,
+     >                       z,
+     >                       a,
+     >                       p,
+     >                       q,
+     >                       r,
+     >                       w,
+     >                       rnorm,
+     >                       l2npcols,
+     >                       reduce_exch_proc,
+     >                       reduce_send_starts,
+     >                       reduce_send_lengths,
+     >                       reduce_recv_starts,
+     >                       reduce_recv_lengths,
+     >                       reduce_rrecv_starts )
+c---------------------------------------------------------------------
+c---------------------------------------------------------------------
+
+c---------------------------------------------------------------------
+c  Floaging point arrays here are named as in NPB1 spec discussion of
+c  CG algorithm
+c---------------------------------------------------------------------
+
+      implicit none
+
+c      include 'cafnpb.h'
+
+      common / partit_size  /  naa, nzz,
+     >                         npcols, nprows,
+     >                         proc_col, proc_row,
+     >                         firstrow,
+     >                         lastrow,
+     >                         firstcol,
+     >                         lastcol,
+     >                         exch_proc,
+     >                         exch_recv_length,
+     >                         send_start,
+     >                         send_len
+      integer                  naa, nzz,
+     >                         npcols, nprows,
+     >                         proc_col, proc_row,
+     >                         firstrow,
+     >                         lastrow,
+     >                         firstcol,
+     >                         lastcol,
+     >                         exch_proc,
+     >                         exch_recv_length,
+     >                         send_start,
+     >                         send_len
+
+
+
+      double precision   x(*),
+     >                   z(*),
+     >                   a(nzz)
+      integer            colidx(nzz), rowstr(naa+1)
+
+      double precision   p(*),
+     >                   q(*)[0:*],
+     >                   r(*)[0:*],
+     >                   w(*)[0:*]        ! used as work temporary
+
+      integer   l2npcols
+      integer   reduce_exch_proc(l2npcols)
+      integer   reduce_send_starts(l2npcols)
+      integer   reduce_send_lengths(l2npcols)
+      integer   reduce_recv_starts(l2npcols)[0:*]
+      integer   reduce_recv_lengths(l2npcols)
+      integer   reduce_rrecv_starts(l2npcols)
+
+      integer   recv_start_idx, recv_end_idx, send_start_idx,
+     >          send_end_idx, recv_length
+
+      integer   i, j, k, ierr
+      integer   cgit, cgitmax
+
+      double precision, save :: d[0:*], rho[0:*]
+      double precision   sum, rho0, alpha, beta, rnorm
+
+      external         timer_read
+      double precision timer_read
+
+      data      cgitmax / 25 /
+
+
+      return
+      end                       ! end of routine conj_grad
+

diff --git a/gcc/testsuite/gfortran.dg/coarray_37.f90 b/gcc/testsuite/gfortran.dg/coarray_37.f90
new file mode 100644 (file)
index 0000000..6f56c32
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_37.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+      program cg
+        implicit none
+        integer reduce_recv_starts(2)[1,0:*]
+        interface
+          subroutine conj_grad (reduce_recv_starts) ! { dg-warning "Interface mismatch in global procedure 'conj_grad' at \\(1\\): Corank mismatch in argument 'reduce_recv_starts' \\(2/1\\)" }
+            integer   reduce_recv_starts(2)[2, 2:*]
+          end subroutine
+        end interface
+        call conj_grad (reduce_recv_starts) ! Corank mismatch is okay
+      end
+
+      subroutine conj_grad (reduce_recv_starts)
+        implicit none
+        integer reduce_recv_starts(2)[2:*]
+      end