This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: update acc routines in fortran
- From: Cesar Philippidis <cesar at codesourcery dot com>
- To: Jakub Jelinek <jakub at redhat dot com>
- Cc: "gcc-patches at gcc dot gnu dot org" <gcc-patches at gcc dot gnu dot org>, Fortran List <fortran at gcc dot gnu dot org>, Tobias Burnus <burnus at net-b dot de>
- Date: Tue, 24 Nov 2015 18:43:11 -0800
- Subject: Re: update acc routines in fortran
- Authentication-results: sourceware.org; auth=none
- References: <564DF845 dot 3030308 at codesourcery dot com> <20151120101811 dot GE5675 at tucnak dot redhat dot com>
On 11/20/2015 02:18 AM, Jakub Jelinek wrote:
> On Thu, Nov 19, 2015 at 08:26:45AM -0800, Cesar Philippidis wrote:
>> (gfc_oacc_routine_name): New struct;
>
> Full stop instead of semicolon.
Fixed.
>> 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:
>
> This looks wrong. OMP_CLAUSE_GANG has 2 arguments, OMP_CLAUSE_WORKER and
> OMP_CLAUSE_VECTOR one argument, if you use a non-local decl or local decl
> that is referenced by a nested routine in those operands, it won't be
> handled properly.
Yeah, you're right. This didn't get updated when we added support for
the loop shape arguments. I fixed that in this patch.
>> @@ -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:
>
> Ditto.
>
> Otherwise LGTM.
Are the tree-nested changes ok?
Cesar
2015-11-24 Cesar Philippidis <cesar@codesourcery.com>
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-24 Cesar Philippidis <cesar@codesourcery.com>
James Norris <jnorris@codesourcery.com>
Nathan Sidwell <nathan@codesourcery.com>
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-24 Cesar Philippidis <cesar@codesourcery.com>
Nathan Sidwell <nathan@codesourcery.com>
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.
* gfortran.dg/goacc/subroutines: New test.
2015-11-24 James Norris <jnorris@codesourcery.com>
Cesar Philippidis <cesar@codesourcery.com>
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 5487c93..0628e86 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -848,6 +848,9 @@ typedef struct
unsigned oacc_declare_device_resident:1;
unsigned oacc_declare_link: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;
@@ -1606,6 +1609,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? */
@@ -1672,6 +1685,12 @@ typedef struct gfc_namespace
/* !$ACC DECLARE. */
gfc_oacc_declare *oacc_declare;
+ /* !$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;
@@ -1717,6 +1736,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;
@@ -2344,7 +2366,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 a07cee1..730b7f9 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1318,6 +1318,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
@@ -1619,13 +1621,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;
@@ -1640,52 +1673,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 b280621..b2d15a8 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -5786,6 +5786,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 685e3f5..febf0fa 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 d0a11aa..566150b 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -202,6 +202,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 39ff8e2..331b43d 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/testsuite/gfortran.dg/goacc/subroutines.f90 b/gcc/testsuite/gfortran.dg/goacc/subroutines.f90
new file mode 100644
index 0000000..6cab798
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/subroutines.f90
@@ -0,0 +1,73 @@
+! Exercise how tree-nested.c handles gang, worker vector and seq.
+
+! { dg-do compile }
+
+program main
+ integer, parameter :: N = 100
+ integer :: nonlocal_arg
+ integer :: nonlocal_a(N)
+ integer :: nonlocal_i
+ integer :: nonlocal_j
+
+ nonlocal_a (:) = 5
+ nonlocal_arg = 5
+
+ call local ()
+ call nonlocal ()
+
+contains
+
+ subroutine local ()
+ integer :: local_i
+ integer :: local_arg
+ integer :: local_a(N)
+ integer :: local_j
+
+ local_a (:) = 5
+ local_arg = 5
+
+ !$acc kernels loop gang(num:local_arg) worker(local_arg) vector(local_arg)
+ do local_i = 1, N
+ local_a(local_i) = 100
+ !$acc loop seq
+ do local_j = 1, N
+ enddo
+ enddo
+ !$acc end kernels loop
+
+ !$acc kernels loop gang(static:local_arg) worker(local_arg) &
+ !$acc vector(local_arg)
+ do local_i = 1, N
+ local_a(local_i) = 100
+ !$acc loop seq
+ do local_j = 1, N
+ enddo
+ enddo
+ !$acc end kernels loop
+ end subroutine local
+
+ subroutine nonlocal ()
+ nonlocal_a (:) = 5
+ nonlocal_arg = 5
+
+ !$acc kernels loop gang(num:nonlocal_arg) worker(nonlocal_arg) &
+ !$acc vector(nonlocal_arg)
+ do nonlocal_i = 1, N
+ nonlocal_a(nonlocal_i) = 100
+ !$acc loop seq
+ do nonlocal_j = 1, N
+ enddo
+ enddo
+ !$acc end kernels loop
+
+ !$acc kernels loop gang(static:nonlocal_arg) worker(nonlocal_arg) &
+ !$acc vector(nonlocal_arg)
+ do nonlocal_i = 1, N
+ nonlocal_a(nonlocal_i) = 100
+ !$acc loop seq
+ do nonlocal_j = 1, N
+ enddo
+ enddo
+ !$acc end kernels loop
+ end subroutine nonlocal
+end program main
diff --git a/gcc/tree-nested.c b/gcc/tree-nested.c
index 1f6311c..6ed7d39 100644
--- a/gcc/tree-nested.c
+++ b/gcc/tree-nested.c
@@ -1091,6 +1091,7 @@ convert_nonlocal_omp_clauses (tree *pclauses, struct walk_stmt_info *wi)
case OMP_CLAUSE_SCHEDULE:
if (OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (clause) == NULL)
break;
+
/* FALLTHRU */
case OMP_CLAUSE_FINAL:
case OMP_CLAUSE_IF:
@@ -1106,10 +1107,31 @@ 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_:
- wi->val_only = true;
- wi->is_lhs = false;
- convert_nonlocal_reference_op (&OMP_CLAUSE_OPERAND (clause, 0),
- &dummy, wi);
+ case OMP_CLAUSE_NUM_GANGS:
+ case OMP_CLAUSE_NUM_WORKERS:
+ case OMP_CLAUSE_VECTOR_LENGTH:
+ case OMP_CLAUSE_GANG:
+ case OMP_CLAUSE_WORKER:
+ case OMP_CLAUSE_VECTOR:
+ /* Several OpenACC clauses have optional arguments. Check if they
+ are present. */
+ if (OMP_CLAUSE_OPERAND (clause, 0))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op (&OMP_CLAUSE_OPERAND (clause, 0),
+ &dummy, wi);
+ }
+
+ /* The gang clause accepts two arguments. */
+ if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_GANG
+ && OMP_CLAUSE_GANG_STATIC_EXPR (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op
+ (&OMP_CLAUSE_GANG_STATIC_EXPR (clause), &dummy, wi);
+ }
break;
case OMP_CLAUSE_DIST_SCHEDULE:
@@ -1173,6 +1195,7 @@ 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_SEQ:
break;
default:
@@ -1743,6 +1766,7 @@ convert_local_omp_clauses (tree *pclauses, struct walk_stmt_info *wi)
case OMP_CLAUSE_SCHEDULE:
if (OMP_CLAUSE_SCHEDULE_CHUNK_EXPR (clause) == NULL)
break;
+
/* FALLTHRU */
case OMP_CLAUSE_FINAL:
case OMP_CLAUSE_IF:
@@ -1758,10 +1782,31 @@ 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_:
- wi->val_only = true;
- wi->is_lhs = false;
- convert_local_reference_op (&OMP_CLAUSE_OPERAND (clause, 0), &dummy,
- wi);
+ case OMP_CLAUSE_NUM_GANGS:
+ case OMP_CLAUSE_NUM_WORKERS:
+ case OMP_CLAUSE_VECTOR_LENGTH:
+ case OMP_CLAUSE_GANG:
+ case OMP_CLAUSE_WORKER:
+ case OMP_CLAUSE_VECTOR:
+ /* Several OpenACC clauses have optional arguments. Check if they
+ are present. */
+ if (OMP_CLAUSE_OPERAND (clause, 0))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_local_reference_op (&OMP_CLAUSE_OPERAND (clause, 0),
+ &dummy, wi);
+ }
+
+ /* The gang clause accepts two arguments. */
+ if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_GANG
+ && OMP_CLAUSE_GANG_STATIC_EXPR (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op
+ (&OMP_CLAUSE_GANG_STATIC_EXPR (clause), &dummy, wi);
+ }
break;
case OMP_CLAUSE_DIST_SCHEDULE:
@@ -1830,6 +1875,7 @@ 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_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