From patchwork Sat Jan 24 17:13:04 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 432432 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id C57FD1402B0 for ; Sun, 25 Jan 2015 04:13:32 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=yWREWQnQc05yqIsRGEFKdwP9GK2q+fNeiLa893VcqgW4gn fZL6JiPUH43eGEtcyMnYKlL+Xcd5tHD9QxLcVeGsuPMdaNdkxgyHZ5b2wwOO9pM8 lWRu2zVfl4UYGODOlpRsHmPxZFfJpdOyAu34EMRARFPvJFH2+8tUbAlWbA/R0= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=RdvxjUHTMeIjf7s0N2f2HzySte8=; b=hZnMYeuK0p5hIO7NqZn0 fYaTZ2L/TFI9Sl9xeAMyVRmqd/8LnbiRr5oOKBDeScREr5norUhxoX5j0ILYYVb8 lD/boDKulBBrN1dEJrhS8oA1N54P8KXfCUBPlQcar1x3sdGmDiQccLBK09W+w5XW YQdIazMxz81IC5O3H92AmpU= Received: (qmail 7128 invoked by alias); 24 Jan 2015 17:13:17 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 7104 invoked by uid 89); 24 Jan 2015 17:13:16 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-1.0 required=5.0 tests=AWL, BAYES_00 autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx01.qsc.de Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Sat, 24 Jan 2015 17:13:08 +0000 Received: from tux.net-b.de (port-92-194-20-233.dynamic.qsc.de [92.194.20.233]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx01.qsc.de (Postfix) with ESMTPSA id B45B23CD50; Sat, 24 Jan 2015 18:13:04 +0100 (CET) Message-ID: <54C3D2A0.5090905@net-b.de> Date: Sat, 24 Jan 2015 18:13:04 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.3.0 MIME-Version: 1.0 To: gcc-patches , gfortran , Alessandro Fanfarillo Subject: [Patch, Fortran] PR64771 - Fix coarray ICE Build and regtested on x86-64-gnu-linux. OK for the trunk and 4.9? (It's a regression.) Tobias 2015-01-24 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. diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index dd3ad2a..5de416b 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1205,8 +1205,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 +1227,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/gfortran.dg/coarray_36.f b/gcc/testsuite/gfortran.dg/coarray_36.f new file mode 100644 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 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