Skip to content

R
riscv-gcc-1
Commit b25affbd by Tobias Burnus Committed by Tobias Burnus
Options

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

re PR fortran/64771 (ICE(segfault) when passing coarrays around; ICE in gfc_zero_size_array in arith.c:1637)

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
parent c123c5ba
Showing with 392 additions and 3 deletions
gcc/fortran/ChangeLog
2015-01-26 Tobias Burnus <burnus@net-b.de> 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. * io.c (gfc_match_inquire): Replace "-1" by a defined constant.
2015-01-26 Janus Weil <janus@gcc.gnu.org> 2015-01-26 Janus Weil <janus@gcc.gnu.org>
......
gcc/fortran/interface.c
...@@ -63,6 +63,8 @@ along with GCC; see the file COPYING3. If not see ...@@ -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 formal argument list points to symbols within the same namespace as
the program unit name. */ the program unit name. */
#include <algorithm> /* For std::max. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include "coretypes.h" #include "coretypes.h"
...@@ -1205,8 +1207,15 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, ...@@ -1205,8 +1207,15 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
return false; 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) 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]), shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
gfc_copy_expr (s1->as->lower[i])); gfc_copy_expr (s1->as->lower[i]));
...@@ -1220,8 +1229,12 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2, ...@@ -1220,8 +1229,12 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
case -1: case -1:
case 1: case 1:
case -3: case -3:
snprintf (errmsg, err_len, "Shape mismatch in dimension %i of " if (i < s1->as->rank)
"argument '%s'", i + 1, s1->name); 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; return false;
case -2: case -2:
......
gcc/testsuite/ChangeLog
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> 2015-01-26 Janus Weil <janus@gcc.gnu.org>
PR fortran/64230 PR fortran/64230
......
gcc/testsuite/gfortran.dg/coarray_36.f 0 → 100644
! { 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
gcc/testsuite/gfortran.dg/coarray_37.f90 0 → 100644
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment