From patchwork Thu Nov 19 16:26:45 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Cesar Philippidis X-Patchwork-Id: 546565 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 AE6CF141490 for ; Fri, 20 Nov 2015 03:27:01 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=GRW7Kdzk; 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=uGfWo+Lp9vmrWiAtGZtwhurCv/amXeekCR0FSp/dusIriAJmjf4Gn GU1z9OSiVvmYbcgC0XJrEhPoe+N7HIiZsC1Fh3lZtydoZqFI6r0yKEeFpAfbcc6q nC16BiDQdAuzPF+MkeG/peFugaoJBTZ2GHmtnzr5tYl9mCVHaZmIrA= 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=QNwD15VvMXdRlzCa1qV/bPNuwQ4=; b=GRW7KdzkCsp/RhmIfZHn EIBp4Qtp1S2W+xBE/VtNDvxfLwJRuHZF0j3iiOU1oXxLUhAi+ExDYCbGfBHC/js7 Yfw21462ZFVaRFqK0nwmyZPvS7pLAOn/62yOYyCimW+0z3bTa1Q0toFpq4WdIS98 4jHRgtQlUXvPqZ1w8VXzqbE= Received: (qmail 108195 invoked by alias); 19 Nov 2015 16:26:53 -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 108178 invoked by uid 89); 19 Nov 2015 16:26:52 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.2 required=5.0 tests=AWL, BAYES_40, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 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; Thu, 19 Nov 2015 16:26:49 +0000 Received: from svr-orw-fem-06.mgc.mentorg.com ([147.34.97.120]) by relay1.mentorg.com with esmtp id 1ZzS2n-0004wM-GU from Cesar_Philippidis@mentor.com ; Thu, 19 Nov 2015 08:26:45 -0800 Received: from [127.0.0.1] (147.34.91.1) by SVR-ORW-FEM-06.mgc.mentorg.com (147.34.97.120) with Microsoft SMTP Server id 14.3.224.2; Thu, 19 Nov 2015 08:26:45 -0800 From: Cesar Philippidis Subject: update acc routines in fortran To: "gcc-patches@gcc.gnu.org" , Fortran List , Jakub Jelinek , Tobias Burnus Message-ID: <564DF845.3030308@codesourcery.com> Date: Thu, 19 Nov 2015 08:26:45 -0800 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:38.0) Gecko/20100101 Thunderbird/38.3.0 MIME-Version: 1.0 This patch extends the existing support for acc routines in fortran. It's a little bit more invasive than what I remembered, but it's still fairly straightforward. Basically, it adds support for the following: - name routines - gang, worker, vector and seq clauses In addition, I've also taught tree-nested to be aware of the aforementioned clauses. Without those tree-nested changes, a lot of the new test cases would fail. If you observe the changelog closely, you'll noticed that I didn't include libgomp.oacc-fortran/routine-[48].f90. The reason is, we don't have support for the bind and nohost clauses on trunk yet. Thomas posted a patch right before stage1 closed. So if that patch gets accepted, I'll create a follow up patch for routines in fortran. This this OK for trunk? Cesar 2015-11-19 Cesar Philippidis gcc/ * tree-nested.c (convert_nonlocal_omp_clauses): Add support for OMP_CLAUSE_{NUM_GANGS,NUM_VECTORS,VECTOR_LENGTH,SEQ}. (convert_local_omp_clauses): Likewise. 2015-11-19 Cesar Philippidis James Norris Nathan Sidwell gcc/fortran/ * f95-lang.c (gfc_attribute_table): Add an "oacc function" attribute. * gfortran.h (symbol_attribute): Add an oacc_function bit-field. (gfc_oacc_routine_name): New struct; (gfc_get_oacc_routine_name): New macro. (gfc_namespace): Add oacc_routine_clauses, oacc_routine_names and oacc_routine fields. (gfc_exec_op): Add EXEC_OACC_ROUTINE. * openmp.c (OACC_ROUTINE_CLAUSES): New mask. (gfc_oacc_routine_dims): New function. (gfc_match_oacc_routine): Add support for named routines and the gang, worker vector and seq clauses. * parse.c (is_oacc): Add EXEC_OACC_ROUTINE. * resolve.c (gfc_resolve_blocks): Likewise. * st.c (gfc_free_statement): Likewise. * trans-decl.c (add_attributes_to_decl): Attach an 'oacc function' attribute and shape geometry for acc routine. 2015-11-19 Cesar Philippidis Nathan Sidwell gcc/testsuite/ * gfortran.dg/goacc/routine-3.f90: New test. * gfortran.dg/goacc/routine-4.f90: New test. * gfortran.dg/goacc/routine-5.f90: New test. * gfortran.dg/goacc/routine-6.f90: New test. 2015-11-19 James Norris Cesar Philippidis libgomp/ * libgomp.oacc-fortran/routine-5.f90: New test. * libgomp.oacc-fortran/routine-7.f90: New test. * libgomp.oacc-fortran/routine-9.f90: New test. diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 605c2ab..8556b70 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -93,6 +93,8 @@ static const struct attribute_spec gfc_attribute_table[] = affects_type_identity } */ { "omp declare target", 0, 0, true, false, false, gfc_handle_omp_declare_target_attribute, false }, + { "oacc function", 0, -1, true, false, false, + gfc_handle_omp_declare_target_attribute, false }, { NULL, 0, 0, false, false, false, NULL, false } }; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index e13b4d4..3dbcd96 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -841,6 +841,9 @@ typedef struct /* Mentioned in OMP DECLARE TARGET. */ unsigned omp_declare_target:1; + /* This is an OpenACC acclerator function at level N - 1 */ + unsigned oacc_function:3; + /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; @@ -1582,6 +1585,16 @@ gfc_dt_list; /* A list of all derived types. */ extern gfc_dt_list *gfc_derived_types; +typedef struct gfc_oacc_routine_name +{ + struct gfc_symbol *sym; + struct gfc_omp_clauses *clauses; + struct gfc_oacc_routine_name *next; +} +gfc_oacc_routine_name; + +#define gfc_get_oacc_routine_name() XCNEW (gfc_oacc_routine_name) + /* A namespace describes the contents of procedure, module, interface block or BLOCK construct. */ /* ??? Anything else use these? */ @@ -1648,6 +1661,12 @@ typedef struct gfc_namespace /* !$ACC DECLARE clauses. */ gfc_omp_clauses *oacc_declare_clauses; + /* !$ACC ROUTINE clauses. */ + gfc_omp_clauses *oacc_routine_clauses; + + /* !$ACC ROUTINE names. */ + gfc_oacc_routine_name *oacc_routine_names; + gfc_charlen *cl_list, *old_cl_list; gfc_dt_list *derived_types; @@ -1693,6 +1712,9 @@ typedef struct gfc_namespace /* Set to 1 for !$OMP DECLARE REDUCTION namespaces. */ unsigned omp_udr_ns:1; + + /* Set to 1 for !$ACC ROUTINE namespaces. */ + unsigned oacc_routine:1; } gfc_namespace; @@ -2320,7 +2342,7 @@ enum gfc_exec_op EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, EXEC_LOCK, EXEC_UNLOCK, - EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, + EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE, EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA, EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE, EXEC_OACC_ENTER_DATA, EXEC_OACC_EXIT_DATA, EXEC_OACC_ATOMIC, diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 4af139a..ffd4b82 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -1189,6 +1189,8 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, uint64_t mask, | OMP_CLAUSE_DELETE) #define OACC_WAIT_CLAUSES \ (OMP_CLAUSE_ASYNC) +#define OACC_ROUTINE_CLAUSES \ + (OMP_CLAUSE_GANG | OMP_CLAUSE_WORKER | OMP_CLAUSE_VECTOR | OMP_CLAUSE_SEQ) match @@ -1422,13 +1424,44 @@ gfc_match_oacc_cache (void) return MATCH_YES; } +/* Determine the loop level for a routine. */ + +static int +gfc_oacc_routine_dims (gfc_omp_clauses *clauses) +{ + int level = -1; + + if (clauses) + { + unsigned mask = 0; + + if (clauses->gang) + level = GOMP_DIM_GANG, mask |= GOMP_DIM_MASK (level); + if (clauses->worker) + level = GOMP_DIM_WORKER, mask |= GOMP_DIM_MASK (level); + if (clauses->vector) + level = GOMP_DIM_VECTOR, mask |= GOMP_DIM_MASK (level); + if (clauses->seq) + level = GOMP_DIM_MAX, mask |= GOMP_DIM_MASK (level); + + if (mask != (mask & -mask)) + gfc_error ("Multiple loop axes specified for routine"); + } + + if (level < 0) + level = GOMP_DIM_MAX; + + return level; +} match gfc_match_oacc_routine (void) { locus old_loc; - gfc_symbol *sym; + gfc_symbol *sym = NULL; match m; + gfc_omp_clauses *c = NULL; + gfc_oacc_routine_name *n = NULL; old_loc = gfc_current_locus; @@ -1443,52 +1476,85 @@ gfc_match_oacc_routine (void) goto cleanup; } - if (m == MATCH_NO - && gfc_current_ns->proc_name - && gfc_match_omp_eos () == MATCH_YES) + if (m == MATCH_YES) { - if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, - gfc_current_ns->proc_name->name, - &old_loc)) - goto cleanup; - return MATCH_YES; - } + char buffer[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree *st; - if (m != MATCH_YES) - return m; + m = gfc_match_name (buffer); + if (m == MATCH_YES) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, buffer); + if (st) + { + sym = st->n.sym; + if (strcmp (sym->name, gfc_current_ns->proc_name->name) == 0) + sym = NULL; + } - /* Scan for a function name. */ - m = gfc_match_symbol (&sym, 0); + if (st == NULL + || (sym + && !sym->attr.external + && !sym->attr.function + && !sym->attr.subroutine)) + { + 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; + } + } + else + { + gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); + gfc_current_locus = old_loc; + return MATCH_ERROR; + } - if (m != MATCH_YES) - { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C"); - gfc_current_locus = old_loc; - return MATCH_ERROR; + 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; + } } - if (!sym->attr.external && !sym->attr.function && !sym->attr.subroutine) - { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, invalid" - " function name %qs", sym->name); - gfc_current_locus = old_loc; - return MATCH_ERROR; - } + if (gfc_match_omp_eos () != MATCH_YES + && (gfc_match_omp_clauses (&c, OACC_ROUTINE_CLAUSES, false, false, true) + != MATCH_YES)) + return MATCH_ERROR; - if (gfc_match_char (')') != MATCH_YES) + if (sym != NULL) { - gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, expecting" - " ')' after NAME"); - gfc_current_locus = old_loc; - return MATCH_ERROR; + n = gfc_get_oacc_routine_name (); + n->sym = sym; + n->clauses = NULL; + n->next = NULL; + if (gfc_current_ns->oacc_routine_names != NULL) + n->next = gfc_current_ns->oacc_routine_names; + + gfc_current_ns->oacc_routine_names = n; } - - if (gfc_match_omp_eos () != MATCH_YES) + else if (gfc_current_ns->proc_name) { - gfc_error ("Unexpected junk after !$ACC ROUTINE at %C"); - goto cleanup; + if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr, + gfc_current_ns->proc_name->name, + &old_loc)) + goto cleanup; + gfc_current_ns->proc_name->attr.oacc_function + = gfc_oacc_routine_dims (c) + 1; } - return MATCH_YES; + + if (n) + n->clauses = c; + else if (gfc_current_ns->oacc_routine) + gfc_current_ns->oacc_routine_clauses = c; + + new_st.op = EXEC_OACC_ROUTINE; + new_st.ext.omp_clauses = c; + return MATCH_YES; cleanup: gfc_current_locus = old_loc; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index bdb5731..bf7dd45 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -5807,6 +5807,7 @@ is_oacc (gfc_state_data *sd) case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: case EXEC_OACC_ATOMIC: + case EXEC_OACC_ROUTINE: return true; default: diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 90bc6d4..e022de5 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -9373,6 +9373,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: case EXEC_OACC_ATOMIC: + case EXEC_OACC_ROUTINE: case EXEC_OMP_ATOMIC: case EXEC_OMP_CRITICAL: case EXEC_OMP_DISTRIBUTE: diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 629b51d..f4d58cb 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -197,6 +197,7 @@ gfc_free_statement (gfc_code *p) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OACC_ROUTINE: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: case EXEC_OMP_DISTRIBUTE: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 7e05e67..3cb279f 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -44,6 +44,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-const.h" /* Only for gfc_trans_code. Shouldn't need to include this. */ #include "trans-stmt.h" +#include "gomp-constants.h" #define MAX_LABEL_VALUE 99999 @@ -1304,6 +1305,20 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list) list = tree_cons (get_identifier ("omp declare target"), NULL_TREE, list); + if (sym_attr.oacc_function) + { + tree dims = NULL_TREE; + int ix; + int level = sym_attr.oacc_function - 1; + + for (ix = GOMP_DIM_MAX; ix--;) + dims = tree_cons (build_int_cst (boolean_type_node, ix >= level), + integer_zero_node, dims); + + list = tree_cons (get_identifier ("oacc function"), + dims, list); + } + return list; } diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-3.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-3.f90 new file mode 100644 index 0000000..ca9b928 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-3.f90 @@ -0,0 +1,13 @@ +PROGRAM nested_gwv +CONTAINS + SUBROUTINE gwv + INTEGER :: i + REAL(KIND=8), ALLOCATABLE :: un(:), ua(:) + + !$acc parallel num_gangs(2) num_workers(4) vector_length(32) + DO jj = 1, 100 + un(i) = ua(i) + END DO + !$acc end parallel + END SUBROUTINE gwv +END PROGRAM nested_gwv diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-4.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-4.f90 new file mode 100644 index 0000000..6714c7b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-4.f90 @@ -0,0 +1,160 @@ +! Test invalid calls to routines. + +module param + integer, parameter :: N = 32 +end module param + +program main + use param + integer :: i + integer :: a(N) + + do i = 1, N + a(i) = i + end do + + ! + ! Seq routine tests. + ! + + !$acc parallel copy (a) + !$acc loop + do i = 1, N + call seq (a) + end do + + !$acc loop gang + do i = 1, N + call seq (a) + end do + + !$acc loop worker + do i = 1, N + call seq (a) + end do + + !$acc loop vector + do i = 1, N + call seq (a) + end do + !$acc end parallel + + ! + ! Gang routines loops. + ! + + !$acc parallel copy (a) + !$acc loop ! { dg-warning "insufficient partitioning" } + do i = 1, N + call gang (a) + end do + + !$acc loop gang ! { dg-message "containing loop" } + do i = 1, N + call gang (a) ! { dg-error "routine call uses same" } + end do + + !$acc loop worker ! { dg-message "containing loop" } + do i = 1, N + call gang (a) ! { dg-error "routine call uses same" } + end do + + !$acc loop vector ! { dg-message "containing loop" } + do i = 1, N + call gang (a) ! { dg-error "routine call uses same" } + end do + !$acc end parallel + + ! + ! Worker routines loops. + ! + + !$acc parallel copy (a) + !$acc loop + do i = 1, N + call worker (a) + end do + + !$acc loop gang + do i = 1, N + call worker (a) + end do + + !$acc loop worker ! { dg-message "containing loop" } + do i = 1, N + call worker (a) ! { dg-error "routine call uses same" } + end do + + !$acc loop vector ! { dg-message "containing loop" } + do i = 1, N + call worker (a) ! { dg-error "routine call uses same" } + end do + !$acc end parallel + + ! + ! Vector routines loops. + ! + + !$acc parallel copy (a) + !$acc loop + do i = 1, N + call vector (a) + end do + + !$acc loop gang + do i = 1, N + call vector (a) + end do + + !$acc loop worker + do i = 1, N + call vector (a) + end do + + !$acc loop vector ! { dg-message "containing loop" } + do i = 1, N + call vector (a) ! { dg-error "routine call uses same" } + end do + !$acc end parallel +contains + + subroutine gang (a) ! { dg-message "declared here" 3 } + !$acc routine gang + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine gang + + subroutine worker (a) ! { dg-message "declared here" 2 } + !$acc routine worker + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine worker + + subroutine vector (a) ! { dg-message "declared here" } + !$acc routine vector + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine vector + + subroutine seq (a) + !$acc routine seq + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine seq +end program main diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-5.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-5.f90 new file mode 100644 index 0000000..68c5149 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-5.f90 @@ -0,0 +1,109 @@ +! Test invalid intra-routine parallellism. + +module param + integer, parameter :: N = 32 +end module param + +subroutine gang (a) + !$acc routine gang + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine gang + +subroutine worker (a) + !$acc routine worker + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine worker + +subroutine vector (a) + !$acc routine vector + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine vector + +subroutine seq (a) + !$acc routine seq + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop ! { dg-warning "insufficient partitioning" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine seq diff --git a/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 new file mode 100644 index 0000000..10951ee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/routine-6.f90 @@ -0,0 +1,89 @@ + +module m + integer m1int +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 + else + x = x * x - 1 + end if + end subroutine subr5 +end module m + +program main + implicit none + interface + function subr6 (x) + !$acc routine (subr6) ! { dg-error "without list is allowed in interface" } + 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) + !$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) + !$acc routine (subr1) ! { dg-error "invalid function name" } + 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/tree-nested.c b/gcc/tree-nested.c index 1f6311c..e321072 100644 --- a/gcc/tree-nested.c +++ b/gcc/tree-nested.c @@ -1106,6 +1106,9 @@ convert_nonlocal_omp_clauses (tree *pclauses, struct walk_stmt_info *wi) case OMP_CLAUSE_NUM_TASKS: case OMP_CLAUSE_HINT: case OMP_CLAUSE__CILK_FOR_COUNT_: + case OMP_CLAUSE_NUM_GANGS: + case OMP_CLAUSE_NUM_WORKERS: + case OMP_CLAUSE_VECTOR_LENGTH: wi->val_only = true; wi->is_lhs = false; convert_nonlocal_reference_op (&OMP_CLAUSE_OPERAND (clause, 0), @@ -1173,6 +1176,10 @@ convert_nonlocal_omp_clauses (tree *pclauses, struct walk_stmt_info *wi) case OMP_CLAUSE_THREADS: case OMP_CLAUSE_SIMD: case OMP_CLAUSE_DEFAULTMAP: + case OMP_CLAUSE_GANG: + case OMP_CLAUSE_WORKER: + case OMP_CLAUSE_VECTOR: + case OMP_CLAUSE_SEQ: break; default: @@ -1758,6 +1765,9 @@ convert_local_omp_clauses (tree *pclauses, struct walk_stmt_info *wi) case OMP_CLAUSE_NUM_TASKS: case OMP_CLAUSE_HINT: case OMP_CLAUSE__CILK_FOR_COUNT_: + case OMP_CLAUSE_NUM_GANGS: + case OMP_CLAUSE_NUM_WORKERS: + case OMP_CLAUSE_VECTOR_LENGTH: wi->val_only = true; wi->is_lhs = false; convert_local_reference_op (&OMP_CLAUSE_OPERAND (clause, 0), &dummy, @@ -1830,6 +1840,10 @@ convert_local_omp_clauses (tree *pclauses, struct walk_stmt_info *wi) case OMP_CLAUSE_THREADS: case OMP_CLAUSE_SIMD: case OMP_CLAUSE_DEFAULTMAP: + case OMP_CLAUSE_GANG: + case OMP_CLAUSE_WORKER: + case OMP_CLAUSE_VECTOR: + case OMP_CLAUSE_SEQ: break; default: diff --git a/libgomp/testsuite/libgomp.oacc-fortran/routine-5.f90 b/libgomp/testsuite/libgomp.oacc-fortran/routine-5.f90 new file mode 100644 index 0000000..956da8e --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/routine-5.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-fno-inline" } + +program main + integer :: n + + n = 5 + + !$acc parallel copy (n) + n = func (n) + !$acc end parallel + + if (n .ne. 6) call abort + +contains + + function func (n) result (rc) + !$acc routine + integer, intent (in) :: n + integer :: rc + + rc = n + rc = rc + 1 + + end function + +end program diff --git a/libgomp/testsuite/libgomp.oacc-fortran/routine-7.f90 b/libgomp/testsuite/libgomp.oacc-fortran/routine-7.f90 new file mode 100644 index 0000000..7fc8169 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/routine-7.f90 @@ -0,0 +1,121 @@ + +! { dg-do run } +! { dg-additional-options "-cpp" } + +#define M 8 +#define N 32 + +program main + integer :: i + integer :: a(N) + integer :: b(M * N) + + do i = 1, N + a(i) = 0 + end do + + !$acc parallel copy (a) + !$acc loop seq + do i = 1, N + call seq (a) + end do + !$acc end parallel + + do i = 1, N + if (a(i) .ne.N) call abort + end do + + !$acc parallel copy (a) + !$acc loop seq + do i = 1, N + call gang (a) + end do + !$acc end parallel + + do i = 1, N + if (a(i) .ne. (N + (N * (-1 * i)))) call abort + end do + + do i = 1, N + b(i) = i + end do + + !$acc parallel copy (b) + !$acc loop + do i = 1, N + call worker (b) + end do + !$acc end parallel + + do i = 1, N + if (b(i) .ne. N + i) call abort + end do + + do i = 1, N + a(i) = i + end do + + !$acc parallel copy (a) + !$acc loop + do i = 1, N + call vector (a) + end do + !$acc end parallel + + do i = 1, N + if (a(i) .ne. 0) call abort + end do + +contains + +subroutine vector (a) + !$acc routine vector + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop vector + do i = 1, N + a(i) = a(i) - a(i) + end do + +end subroutine vector + +subroutine worker (b) + !$acc routine worker + integer, intent (inout) :: b(M*N) + integer :: i, j + + !$acc loop worker + do i = 1, N + !$acc loop vector + do j = 1, M + b(j + ((i - 1) * M)) = b(j + ((i - 1) * M)) + 1 + end do + end do + +end subroutine worker + +subroutine gang (a) + !$acc routine gang + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop gang + do i = 1, N + a(i) = a(i) - i + end do + +end subroutine gang + +subroutine seq (a) + !$acc routine seq + integer, intent (inout) :: a(M) + integer :: i + + do i = 1, N + a(i) = a(i) + 1 + end do + +end subroutine seq + +end program main diff --git a/libgomp/testsuite/libgomp.oacc-fortran/routine-9.f90 b/libgomp/testsuite/libgomp.oacc-fortran/routine-9.f90 new file mode 100644 index 0000000..95d1a13 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/routine-9.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fno-inline" } + +program main + implicit none + integer, parameter :: n = 10 + integer :: a(n), i + integer, external :: fact + !$acc routine (fact) + !$acc parallel + !$acc loop + do i = 1, n + a(i) = fact (i) + end do + !$acc end parallel + do i = 1, n + if (a(i) .ne. fact(i)) call abort + end do +end program main + +recursive function fact (x) result (res) + implicit none + !$acc routine (fact) + integer, intent(in) :: x + integer :: res + if (x < 1) then + res = 1 + else + res = x * fact(x - 1) + end if +end function fact