From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 28792 invoked by alias); 2 Oct 2018 15:06:27 -0000 Mailing-List: contact fortran-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Subscribe: List-Post: List-Help: , Sender: fortran-owner@gcc.gnu.org Received: (qmail 28768 invoked by uid 89); 2 Oct 2018 15:06:27 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-25.5 required=5.0 tests=AWL,BAYES_00,GIT_PATCH_0,GIT_PATCH_1,GIT_PATCH_2,GIT_PATCH_3,RCVD_IN_DNSWL_NONE,SPF_PASS autolearn=ham version=3.3.2 spammy= X-HELO: relay1.mentorg.com Received: from relay1.mentorg.com (HELO relay1.mentorg.com) (192.94.38.131) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 02 Oct 2018 15:06:22 +0000 Received: from svr-orw-mbx-04.mgc.mentorg.com ([147.34.90.204]) by relay1.mentorg.com with esmtps (TLSv1.2:ECDHE-RSA-AES256-SHA384:256) id 1g7MFg-00062h-Rr from Cesar_Philippidis@mentor.com ; Tue, 02 Oct 2018 08:06:20 -0700 Received: from [127.0.0.1] (147.34.91.1) by SVR-ORW-MBX-04.mgc.mentorg.com (147.34.90.204) with Microsoft SMTP Server (TLS) id 15.0.1320.4; Tue, 2 Oct 2018 08:06:18 -0700 From: Cesar Philippidis Subject: [patch,openacc] Check for sufficient parallelism when calling acc routines in Fortran To: Fortran List , "gcc-patches@gcc.gnu.org" , "Schwinge, Thomas" Message-ID: <70aa6842-6ccb-5c2b-b664-95d1c9abb1cb@codesourcery.com> Date: Tue, 02 Oct 2018 15:06:00 -0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.9.1 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------D7CE3B25BD8D0595DB876407" X-IsSubscribed: yes X-SW-Source: 2018-10/txt/msg00006.txt.bz2 --------------D7CE3B25BD8D0595DB876407 Content-Type: text/plain; charset="utf-8" Content-Transfer-Encoding: 7bit Content-length: 517 This patch updates the Fortran FE OpenACC routine parser to enforce the new OpenACC 2.5 routine directive semantics. In addition to emitting a warning when the user doesn't specify a gang, worker or vector clause, it also clarifies some error messages and introduces a new error when the user tries to use an acc routine with insufficient parallelism, e.g., calling a gang routine from a vector loop. Is this patch OK for trunk? I bootstrapped and regtested it for x86_64 Linux with nvptx offloading. Thanks, Cesar --------------D7CE3B25BD8D0595DB876407 Content-Type: text/x-patch; name="0007-Check-for-sufficient-parallelism-when-calling-acc-ro.patch" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename*0="0007-Check-for-sufficient-parallelism-when-calling-acc-ro.pa"; filename*1="tch" Content-length: 27143 [OpenACC] Check for sufficient parallelism when calling acc routines in fortran 2018-XX-YY Cesar Philippidis gcc/fortran/ * gfortran.h (gfc_resolve_oacc_routine_call): Declare. (gfc_resolve_oacc_routines): Declare. * openmp.c (gfc_match_oacc_routine): Make error reporting more precise. Defer rejection of non-function and subroutine symbols until gfc_resolve_oacc_routines. (struct fortran_omp_context): Add a dims member. (gfc_resolve_oacc_blocks): Update ctx->dims. (gfc_resolve_oacc_routine_call): New function. (gfc_resolve_oacc_routines): New function. * resolve.c (resolve_function): Call gfc_resolve_oacc_routine_call. (resolve_call): Likewise. (resolve_codes): Call gfc_resolve_oacc_routines. gcc/testsuite/ * gfortran.dg/goacc/routine-10.f90: New test. * gfortran.dg/goacc/routine-9.f90: New test. * gfortran.dg/goacc/routine-nested-parallelism.f: New test. * gfortran.dg/goacc/routine-nested-parallelism.f90: New test. (cherry picked from gomp-4_0-branch r239784) (cherry picked from gomp-4_0-branch r247353) --- gcc/fortran/gfortran.h | 2 + gcc/fortran/openmp.c | 108 +++++- gcc/fortran/resolve.c | 11 + .../gfortran.dg/goacc/routine-10.f90 | 6 + gcc/testsuite/gfortran.dg/goacc/routine-9.f90 | 96 +++++ .../goacc/routine-nested-parallelism.f | 340 ++++++++++++++++++ .../goacc/routine-nested-parallelism.f90 | 340 ++++++++++++++++++ 7 files changed, 887 insertions(+), 16 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-10.f90 create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-9.f90 create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f create mode 100644 gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 781dc2a7d17..87f98bbd110 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3166,6 +3166,8 @@ void gfc_resolve_oacc_directive (gfc_code *, gfc_namespace *); void gfc_resolve_oacc_declare (gfc_namespace *); void gfc_resolve_oacc_parallel_loop_blocks (gfc_code *, gfc_namespace *); void gfc_resolve_oacc_blocks (gfc_code *, gfc_namespace *); +void gfc_resolve_oacc_routine_call (gfc_symbol *, locus *); +void gfc_resolve_oacc_routines (gfc_namespace *); /* expr.c */ void gfc_free_actual_arglist (gfc_actual_arglist *); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 58cbe0ae90c..5850538c1f0 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -2319,7 +2319,13 @@ gfc_match_oacc_routine (void) { if ((isym = gfc_find_function (buffer)) == NULL && (isym = gfc_find_subroutine (buffer)) == NULL) - st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); + { + st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); + if (st == NULL && gfc_current_ns->proc_name->attr.contained + && gfc_current_ns->parent) + st = gfc_find_symtree (gfc_current_ns->parent->sym_root, + buffer); + } if (st) { sym = st->n.sym; @@ -2327,18 +2333,12 @@ gfc_match_oacc_routine (void) && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) sym = NULL; } - - if ((isym == NULL && st == NULL) - || (sym - && !sym->attr.external - && !sym->attr.function - && !sym->attr.subroutine)) + else if (isym == NULL) { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, " - "invalid function name %s", - (sym) ? sym->name : buffer); - gfc_current_locus = old_loc; - return MATCH_ERROR; + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, " + "invalid function name %qs", &old_loc, buffer);\ + goto cleanup; + } /* Set sym to NULL if it matches the current procedure's @@ -2371,20 +2371,27 @@ gfc_match_oacc_routine (void) dims = gfc_oacc_routine_dims (c); if (dims == OACC_FUNCTION_NONE) { - gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %C"); + gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %L", + &old_loc); /* Don't abort early, because it's important to let the user know of any potential duplicate routine directives. */ seen_error = true; } + else if (dims == OACC_FUNCTION_AUTO) + { + gfc_warning (0, "Expected one of %, %, % or " + "% clauses in !$ACC ROUTINE at %L", &old_loc); + dims = OACC_FUNCTION_SEQ; + } if (isym != NULL) { if (c && (c->gang || c->worker || c->vector)) { gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) " - "at %C, with incompatible clauses specifying the level " - "of parallelism"); + "at %L, with incompatible clauses specifying the level " + "of parallelism", &old_loc); goto cleanup; } /* The intrinsic symbol has been marked with a SEQ, or with no clause at @@ -2429,7 +2436,8 @@ gfc_match_oacc_routine (void) &old_loc)) goto cleanup; - gfc_current_ns->proc_name->attr.oacc_function = dims; + gfc_current_ns->proc_name->attr.oacc_function + = seen_error ? OACC_FUNCTION_SEQ : dims; gfc_current_ns->proc_name->attr.oacc_function_nohost = c ? c->nohost : false; @@ -5359,6 +5367,7 @@ static struct fortran_omp_context hash_set *private_iterators; struct fortran_omp_context *previous; bool is_openmp; + oacc_function dims; } *omp_current_ctx; static gfc_code *omp_current_do_code; static int omp_current_do_collapse; @@ -6036,6 +6045,7 @@ void gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) { fortran_omp_context ctx; + oacc_function dims = OACC_FUNCTION_NONE; resolve_oacc_loop_blocks (code); @@ -6044,6 +6054,21 @@ gfc_resolve_oacc_blocks (gfc_code *code, gfc_namespace *ns) ctx.private_iterators = new hash_set; ctx.previous = omp_current_ctx; ctx.is_openmp = false; + + if (code->ext.omp_clauses->gang) + dims = OACC_FUNCTION_GANG; + if (code->ext.omp_clauses->worker) + dims = OACC_FUNCTION_WORKER; + if (code->ext.omp_clauses->vector) + dims = OACC_FUNCTION_VECTOR; + if (code->ext.omp_clauses->seq) + dims = OACC_FUNCTION_SEQ; + + if (dims == OACC_FUNCTION_NONE && ctx.previous != NULL + && !ctx.previous->is_openmp) + dims = ctx.previous->dims; + + ctx.dims = dims; omp_current_ctx = &ctx; gfc_resolve_blocks (code->block, ns); @@ -6401,3 +6426,54 @@ gfc_resolve_omp_udrs (gfc_symtree *st) for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next) gfc_resolve_omp_udr (omp_udr); } + +/* Ensure that any calls to OpenACC routines respects the current + level of parallelism of the innermost loop. */ + +void +gfc_resolve_oacc_routine_call (gfc_symbol *sym, locus *loc) +{ + gfc_oacc_routine_name *n = NULL; + oacc_function loop_dims = OACC_FUNCTION_NONE; + oacc_function routine_dims; + + if (!omp_current_ctx) + return; + + loop_dims = omp_current_ctx->dims; + + if (omp_current_ctx->is_openmp || loop_dims == OACC_FUNCTION_NONE) + return; + + for (n = gfc_current_ns->oacc_routine_names; n; n = n->next) + if (n->sym == sym) + break; + + if (n == NULL) + return; + + routine_dims = gfc_oacc_routine_dims (n->clauses); + + if (routine_dims == OACC_FUNCTION_SEQ) + return; + if (routine_dims <= loop_dims) + gfc_error ("Insufficient !$ACC LOOP parallelism available to call " + "%qs at %L", sym->name, loc); +} + +void +gfc_resolve_oacc_routines (gfc_namespace *ns) +{ + gfc_oacc_routine_name *routines = NULL; + + for (routines = ns->oacc_routine_names; routines; routines = routines->next) + { + gfc_symbol *sym = routines->sym; + + if (!sym->attr.external + && !sym->attr.function + && !sym->attr.subroutine) + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, " + "invalid function name %qs", &routines->loc, sym->name); + } +} diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a2beb7fc90a..a6d0450014a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3337,6 +3337,11 @@ resolve_function (gfc_expr *expr) /* typebound procedure: Assume the worst. */ gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + /* Calls to OpenACC routines have imposed restrictions on gang, + worker and vector parallelism. */ + if (sym) + gfc_resolve_oacc_routine_call (sym, &expr->where); + return t; } @@ -3680,6 +3685,11 @@ resolve_call (gfc_code *c) /* Typebound procedure: Assume the worst. */ gfc_current_ns->proc_name->attr.array_outer_dependency = 1; + /* Calls to OpenACC routines have imposed restrictions on gang, + worker and vector parallelism. */ + if (csym) + gfc_resolve_oacc_routine_call (csym, &c->loc); + return t; } @@ -16645,6 +16655,7 @@ resolve_codes (gfc_namespace *ns) bitmap_obstack_initialize (&labels_obstack); gfc_resolve_oacc_declare (ns); + gfc_resolve_oacc_routines (ns); gfc_resolve_omp_local_vars (ns); gfc_resolve_code (ns->code, ns); diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-10.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-10.f90 new file mode 100644 index 00000000000..20b2d77b59b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-10.f90 @@ -0,0 +1,6 @@ +! Ensure that GFortran doesn't ICE with incomplete function +! definitions. + +integer function f1 ! { dg-error "Expected formal argument list in function definition" } + !$acc routine ! { dg-error "Unclassifiable OpenACC directive" } +end function f1 ! { dg-error "Expecting END PROGRAM statement" } diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-9.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-9.f90 new file mode 100644 index 00000000000..590e5946d2f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-9.f90 @@ -0,0 +1,96 @@ +! Check for late resolver errors caused by invalid ACC ROUTINE +! directives. + +module m + integer m1int +contains + subroutine subr5 (x) + implicit none + integer extfunc + !$acc routine (subr5) + !$acc routine (extfunc) + !$acc routine (m1int) ! { dg-error "invalid function name" } + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + extfunc(2) + end if + end subroutine subr5 +end module m + +program main + implicit none + interface + function subr6 (x) + integer, intent (in) :: x + integer :: subr6 + end function subr6 + end interface + integer, parameter :: n = 10 + integer :: a(n), i + !$acc routine (subr1) ! { dg-error "invalid function name" } + external :: subr2 + !$acc routine (subr2) + + external :: R1, R2 + !$acc routine (R1) + !$acc routine (R2) + + !$acc parallel + !$acc loop + do i = 1, n + call subr1 (i) + call subr2 (i) + end do + !$acc end parallel +end program main + +subroutine subr1 (x) + !$acc routine + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr1 + +subroutine subr2 (x) + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr2 + +subroutine subr3 (x) + !$acc routine (subr3) + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + call subr4 (x) + end if +end subroutine subr3 + +subroutine subr4 (x) + !$acc routine (subr4) + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr4 + +subroutine subr10 (x) + !$acc routine (subr10) device ! { dg-error "Unclassifiable OpenACC directive" } + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr10 diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f new file mode 100644 index 00000000000..d1304c66c22 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f @@ -0,0 +1,340 @@ +! Validate calls to ACC ROUTINES. Ensure that the loop containing the +! call has sufficient parallelism to for the routine. + + subroutine sub + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + external gangr, workerr, vectorr, seqr +!$acc routine (gangr) gang +!$acc routine (workerr) worker +!$acc routine (vectorr) vector +!$acc routine (seqr) seq + +! +! Test subroutine calls inside nested loops. +! + +!$acc parallel loop + do i = 1, n + !$acc loop + do j = 1, n + call workerr (a, n) + end do + end do +!$acc end parallel loop + +!$acc parallel loop + do i = 1, n +!$acc loop gang + do j = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + end do +!$acc end parallel loop + +! +! Test calls to seq routines +! + +!$acc parallel loop + do i = 1, n + call seqr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + call seqr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + call seqr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + call seqr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + call seqr (a, n) + end do +!$acc end parallel loop + +! +! Test calls to gang routines +! + +!$acc parallel loop + do i = 1, n + call gangr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to worker routines +! + +!$acc parallel loop + do i = 1, n + call workerr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + call workerr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to vector routines +! + +!$acc parallel loop + do i = 1, n + call vectorr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + call vectorr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + call vectorr (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + end subroutine sub + + subroutine func + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + integer gangf, workerf, vectorf, seqf +!$acc routine (gangf) gang +!$acc routine (workerf) worker +!$acc routine (vectorf) vector +!$acc routine (seqf) seq + +! +! Test subroutine calls inside nested loops. +! + +!$acc parallel loop + do i = 1, n +!$acc loop + do j = 1, n + a(1) = workerf (a, n) + end do + end do +!$acc end parallel loop + +!$acc parallel loop + do i = 1, n +!$acc loop gang + do j = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + end do +!$acc end parallel loop + +! +! Test calls to seq routines +! + +!$acc parallel loop + do i = 1, n + a(1) = seqf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + a(1) = seqf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + a(1) = seqf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + a(1) = seqf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + a(1) = seqf (a, n) + end do +!$acc end parallel loop + +! +! Test calls to gang routines +! + +!$acc parallel loop + do i = 1, n + a(1) = gangf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to worker routines +! + +!$acc parallel loop + do i = 1, n + a(1) = workerf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + a(1) = workerf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to vector routines +! + +!$acc parallel loop + do i = 1, n + a(1) = vectorf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop gang + do i = 1, n + a(1) = vectorf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop worker + do i = 1, n + a(1) = vectorf (a, n) + end do +!$acc end parallel loop + +!$acc parallel loop vector + do i = 1, n + a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq + do i = 1, n + a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do +!$acc end parallel loop + end subroutine func diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90 new file mode 100644 index 00000000000..94e0464592a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-nested-parallelism.f90 @@ -0,0 +1,340 @@ +! Validate calls to ACC ROUTINES. Ensure that the loop containing the +! call has sufficient parallelism to for the routine. + +subroutine sub + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + external gangr, workerr, vectorr, seqr + !$acc routine (gangr) gang + !$acc routine (workerr) worker + !$acc routine (vectorr) vector + !$acc routine (seqr) seq + + ! + ! Test subroutine calls inside nested loops. + ! + + !$acc parallel loop + do i = 1, n + !$acc loop + do j = 1, n + call workerr (a, n) + end do + end do + !$acc end parallel loop + + !$acc parallel loop + do i = 1, n + !$acc loop gang + do j = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + end do + !$acc end parallel loop + + ! + ! Test calls to seq routines + ! + + !$acc parallel loop + do i = 1, n + call seqr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + call seqr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + call seqr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + call seqr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + call seqr (a, n) + end do + !$acc end parallel loop + + ! + ! Test calls to gang routines + ! + + !$acc parallel loop + do i = 1, n + call gangr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + call gangr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + ! + ! Test calls to worker routines + ! + + !$acc parallel loop + do i = 1, n + call workerr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + call workerr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + call workerr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + ! + ! Test calls to vector routines + ! + + !$acc parallel loop + do i = 1, n + call vectorr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + call vectorr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + call vectorr (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + call vectorr (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop +end subroutine sub + +subroutine func + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + integer gangf, workerf, vectorf, seqf + !$acc routine (gangf) gang + !$acc routine (workerf) worker + !$acc routine (vectorf) vector + !$acc routine (seqf) seq + + ! + ! Test subroutine calls inside nested loops. + ! + + !$acc parallel loop + do i = 1, n + !$acc loop + do j = 1, n + a(1) = workerf (a, n) + end do + end do + !$acc end parallel loop + + !$acc parallel loop + do i = 1, n + !$acc loop gang + do j = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + end do + !$acc end parallel loop + + ! + ! Test calls to seq routines + ! + + !$acc parallel loop + do i = 1, n + a(1) = seqf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + a(1) = seqf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + a(1) = seqf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + a(1) = seqf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + a(1) = seqf (a, n) + end do + !$acc end parallel loop + + ! + ! Test calls to gang routines + ! + + !$acc parallel loop + do i = 1, n + a(1) = gangf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + a(1) = gangf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + ! + ! Test calls to worker routines + ! + + !$acc parallel loop + do i = 1, n + a(1) = workerf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + a(1) = workerf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + a(1) = workerf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + ! + ! Test calls to vector routines + ! + + !$acc parallel loop + do i = 1, n + a(1) = vectorf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, n + a(1) = vectorf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, n + a(1) = vectorf (a, n) + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, n + a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, n + a(1) = vectorf (a, n) ! { dg-error "Insufficient ..ACC LOOP parallelism" } + end do + !$acc end parallel loop +end subroutine func -- 2.17.1 --------------D7CE3B25BD8D0595DB876407--