From b25affbdc1fab885366de251e04e2e56d0b4f6cc Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Mon, 26 Jan 2015 22:12:19 +0100 Subject: [PATCH] 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 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 --- gcc/fortran/ChangeLog | 5 + gcc/fortran/interface.c | 19 +- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gfortran.dg/coarray_36.f | 347 +++++++++++++++++++++++ gcc/testsuite/gfortran.dg/coarray_37.f90 | 18 ++ 5 files changed, 392 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/coarray_36.f create mode 100644 gcc/testsuite/gfortran.dg/coarray_37.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e31db0ce6c5..d73bab2feea 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2015-01-26 Tobias Burnus + + PR fortran/64771 + * interface.c (check_dummy_characteristics): Fix coarray handling. + 2015-01-26 Tobias Burnus * io.c (gfc_match_inquire): Replace "-1" by a defined constant. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index dd3ad2a0cd2..0463a58fa7f 100644 --- 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 /* 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 27f11c24637..7fabc0396ad 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2015-01-26 Tobias Burnus + + PR fortran/64771 + * gfortran.dg/coarray_36.f: New. + * gfortran.dg/coarray_37.f90: New. + 2015-01-26 Janus Weil 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 index 00000000000..d06a01ec6bc --- /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 index 00000000000..6f56c323d2e --- /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 -- 2.30.2