From patchwork Fri Aug 26 15:16:43 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Cesar Philippidis X-Patchwork-Id: 663146 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 3sLPm80P44z9stY for ; Sat, 27 Aug 2016 01:17:11 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=D3eRhAeo; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :subject:to:message-id:date:mime-version:content-type; q=dns; s= default; b=VTPXrOHjMKFCaLXmGACehAEcws8e9mOCdZ+S4A1/2Ut657UNyCyin GmRSJUbZFYLk8ftKjxLxW+0yAQhzgxKG8H8++T3uQqVL4WMmgVO276/4uvTg5OOl 58WT1ZGSjFt2QZkggQFMu/iMH1DE8jQ+6LZc62d060jPebOO0wN0go= 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:from :subject:to:message-id:date:mime-version:content-type; s= default; bh=Msn4BSEs9qDLYzNLCffXgSREp4Q=; b=D3eRhAeoOmFTaZ1jKlYc QlPt6iWlqOWa29KySyQehOl+ClIsMdljllUu4o9Dppx5esG4N1F+kueSC+4ifRoJ MWCNtuNfs9CGGPLdrRQz/IE/A6hOtiA87BAcTfBTGCCYhBL3wfyjRmu8cPkaFpOG binwTwP5tTlXcFp1ROXP2RM= Received: (qmail 55586 invoked by alias); 26 Aug 2016 15:16:56 -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 55567 invoked by uid 89); 26 Aug 2016 15:16:56 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=imposed, Assume, 25, 6, 26, 7 X-Spam-User: qpsmtpd, 2 recipients 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; Fri, 26 Aug 2016 15:16:45 +0000 Received: from svr-orw-fem-03.mgc.mentorg.com ([147.34.97.39]) by relay1.mentorg.com with esmtp id 1bdIs7-0001I6-S4 from Cesar_Philippidis@mentor.com ; Fri, 26 Aug 2016 08:16:43 -0700 Received: from [127.0.0.1] (147.34.91.1) by svr-orw-fem-03.mgc.mentorg.com (147.34.97.39) with Microsoft SMTP Server id 14.3.224.2; Fri, 26 Aug 2016 08:16:43 -0700 From: Cesar Philippidis Subject: [gomp4] check for sufficient parallelism when calling acc routines in fortran To: "gcc-patches@gcc.gnu.org" , Fortran List Message-ID: <9e1f3bc5-2da8-1aae-67b0-bf478a53dd2a@codesourcery.com> Date: Fri, 26 Aug 2016 08:16:43 -0700 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:45.0) Gecko/20100101 Thunderbird/45.2.0 MIME-Version: 1.0 This patch teaches the fortran FE how to verify that there is sufficient parallelism when calling acc routines inside acc loop. E.g. the fortran FE will now error if you call a gang routine from a vector loop, because there's no way for vector partitioned code to spawn new gangs with the OpenACC current execution model. While working on this, I noticed that the fortran FE wasn't permitting named functions inside acc routine directives. E.g. integer :: foo !$acc routine(foo) gang ... = foo () This patch also fixes this issue. But to do that, I had to add a gfc_resolve_oacc_routines pass in order to identify if a variable is a function or variable because that information isn't available during matching. I've applied this patch to gomp-4_0-branch. Cesar 2016-08-26 Cesar Philippidis gcc/fortran/ * gfortran.h (enum oacc_function): Make OACC_FUNCTION_SEQ the last entry the enum. (gfc_oacc_routine_name): Add a loc member. (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-6.f90: Remove errors deferred to the resolving stage. * 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. diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7784e93..192bb1f 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -295,10 +295,10 @@ enum save_state /* Flags to keep track of ACC routine states. */ enum oacc_function { OACC_FUNCTION_NONE = 0, - OACC_FUNCTION_SEQ, OACC_FUNCTION_GANG, OACC_FUNCTION_WORKER, - OACC_FUNCTION_VECTOR + OACC_FUNCTION_VECTOR, + OACC_FUNCTION_SEQ }; /* Strings for all symbol attributes. We use these for dumping the @@ -1631,6 +1631,7 @@ typedef struct gfc_oacc_routine_name struct gfc_symbol *sym; struct gfc_omp_clauses *clauses; struct gfc_oacc_routine_name *next; + locus loc; } gfc_oacc_routine_name; @@ -2994,6 +2995,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 cb8efb8..cea37ea 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -1951,25 +1951,25 @@ 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; if (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 @@ -1981,17 +1981,15 @@ gfc_match_oacc_routine (void) } else { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L", &old_loc); + goto cleanup; } if (gfc_match_char (')') != MATCH_YES) { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" - " ')' after NAME"); - gfc_current_locus = old_loc; - return MATCH_ERROR; + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %L, expecting" + " ')' after NAME", &old_loc); + goto cleanup; } } @@ -2006,7 +2004,8 @@ 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. */ @@ -2018,8 +2017,8 @@ gfc_match_oacc_routine (void) 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 @@ -2038,7 +2037,7 @@ gfc_match_oacc_routine (void) needs_entry = false; if (dims != gfc_oacc_routine_dims (n->clauses)) { - gfc_error ("$!ACC ROUTINE already applied at %C"); + gfc_error ("$!ACC ROUTINE already applied at %L", &old_loc); goto cleanup; } } @@ -2049,6 +2048,7 @@ gfc_match_oacc_routine (void) n->sym = sym; n->clauses = c; n->next = NULL; + n->loc = old_loc; if (gfc_current_ns->oacc_routine_names != NULL) n->next = gfc_current_ns->oacc_routine_names; @@ -2064,7 +2064,7 @@ gfc_match_oacc_routine (void) if (gfc_current_ns->proc_name->attr.oacc_function != OACC_FUNCTION_NONE && !seen_error) { - gfc_error ("!$ACC ROUTINE already applied at %C"); + gfc_error ("!$ACC ROUTINE already applied at %L", &old_loc); goto cleanup; } @@ -4559,6 +4559,7 @@ 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; @@ -5198,6 +5199,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); @@ -5206,6 +5208,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); @@ -5548,3 +5565,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 f5cd588..6b67b65 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -3131,6 +3131,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; } @@ -3474,6 +3479,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; } @@ -15551,6 +15561,7 @@ resolve_codes (gfc_namespace *ns) bitmap_obstack_initialize (&labels_obstack); gfc_resolve_oacc_declare (ns); + gfc_resolve_oacc_routines (ns); gfc_resolve_code (ns->code, ns); bitmap_obstack_release (&labels_obstack); diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 index 10943cf..ee43935 100644 --- a/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 +++ b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 @@ -5,7 +5,6 @@ contains subroutine subr5 (x) implicit none !$acc routine (subr5) - !$acc routine (m1int) ! { dg-error "invalid function name" } integer, intent(inout) :: x if (x < 1) then x = 1 @@ -26,7 +25,6 @@ program main end interface integer, parameter :: n = 10 integer :: a(n), i - !$acc routine (subr1) ! { dg-error "invalid function name" } external :: subr2 !$acc routine (subr2) @@ -56,7 +54,6 @@ subroutine subr1 (x) end subroutine subr1 subroutine subr2 (x) - !$acc routine (subr1) ! { dg-error "invalid function name" } integer, intent(inout) :: x if (x < 1) then x = 1 @@ -86,7 +83,6 @@ subroutine subr4 (x) 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 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 0000000..590e594 --- /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 0000000..d1304c6 --- /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 0000000..94e0464 --- /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