2016-08-15 Cesar Philippidis <cesar@codesourcery.com>
gcc/fortran/
* openmp.c (gfc_match_oacc_routine): Error on repeated ACC ROUTINE
directives. Consider the optional NAME argument being the current
procedure name.
* trans-decl.c (add_attributes_to_decl): Use build_oacc_routine_dims
to construct the oacc_function attribute arguments.
gcc/testsuite/
* gfortran.dg/goacc/pr72741-2.f: New test.
* gfortran.dg/goacc/pr72741-intrinsic-1.f: Add test coverage.
* gfortran.dg/goacc/pr72741-intrinsic-2.f: Likewise.
* gfortran.dg/goacc/pr72741.f90: Likewise.
@@ -1877,8 +1877,9 @@ gfc_match_oacc_cache (void)
return MATCH_YES;
}
-/* Determine the loop level for a routine. Returns OACC_FUNCTION_NONE if
- any error is detected. */
+/* Determine the loop level for a routine. Returns OACC_FUNCTION_NONE
+ if any error is detected. Note that this function needs to be
+ called repeatedly for each DEVICE_TYPE. */
static oacc_function
gfc_oacc_routine_dims (gfc_omp_clauses *clauses)
@@ -1925,6 +1926,7 @@ gfc_match_oacc_routine (void)
gfc_omp_clauses *c = NULL;
gfc_oacc_routine_name *n = NULL;
oacc_function dims = OACC_FUNCTION_NONE;
+ bool seen_error = false;
old_loc = gfc_current_locus;
@@ -1969,6 +1971,13 @@ gfc_match_oacc_routine (void)
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
+
+ /* Set sym to NULL if it matches the current procedure's
+ name. This will simplify the check for duplicate ACC
+ ROUTINE attributes. */
+ if (gfc_current_ns->proc_name
+ && !strcmp (buffer, gfc_current_ns->proc_name->name))
+ sym = NULL;
}
else
{
@@ -1993,19 +2002,24 @@ gfc_match_oacc_routine (void)
!= MATCH_YES))
return MATCH_ERROR;
+ /* Scan for invalid routine geometry. */
dims = gfc_oacc_routine_dims (c);
if (dims == OACC_FUNCTION_NONE)
{
gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %C");
- goto cleanup;
+
+ /* Don't abort early, because it's important to let the user
+ know of any potential duplicate routine directives. */
+ seen_error = true;
}
if (isym != NULL)
{
if (c && (c->gang || c->worker || c->vector))
{
- gfc_error ("Intrinsic function specified in !$ACC ROUTINE ( NAME )"
- " at %C, with incompatible GANG, WORKER, or VECTOR clause");
+ gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) "
+ "at %C, with incompatible clauses specifying the level "
+ "of parallelism");
goto cleanup;
}
/* The intrinsic symbol has been marked with a SEQ, or with no clause at
@@ -2013,24 +2027,59 @@ gfc_match_oacc_routine (void)
}
else if (sym != NULL)
{
- 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;
+ bool needs_entry = true;
+
+ /* Scan for any repeated routine directives on 'sym' and report
+ an error if necessary. TODO: Extend this function to scan
+ for compatible DEVICE_TYPE dims. */
+ for (n = gfc_current_ns->oacc_routine_names; n; n = n->next)
+ if (n->sym == sym)
+ {
+ needs_entry = false;
+ if (dims != gfc_oacc_routine_dims (n->clauses))
+ {
+ gfc_error ("$!ACC ROUTINE already applied at %C");
+ goto cleanup;
+ }
+ }
+
+ if (needs_entry)
+ {
+ n = gfc_get_oacc_routine_name ();
+ n->sym = sym;
+ n->clauses = c;
+ 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 (seen_error)
+ goto cleanup;
}
else if (gfc_current_ns->proc_name)
{
+ if (gfc_current_ns->proc_name->attr.oacc_function != OACC_FUNCTION_NONE
+ && !seen_error)
+ {
+ gfc_error ("!$ACC ROUTINE already applied 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 = 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;
+
+ if (seen_error)
+ goto cleanup;
}
else
gcc_unreachable ();
@@ -45,6 +45,7 @@ along with GCC; see the file COPYING3. If not see
/* Only for gfc_trans_code. Shouldn't need to include this. */
#include "trans-stmt.h"
#include "gomp-constants.h"
+#include "omp-low.h"
#define MAX_LABEL_VALUE 99999
@@ -1329,29 +1330,27 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
if (sym_attr.oacc_function != OACC_FUNCTION_NONE)
{
- tree dims = NULL_TREE;
- int ix;
- int level = GOMP_DIM_MAX;
-
+ omp_clause_code code = OMP_CLAUSE_ERROR;
+ tree clause, dims;
+
switch (sym_attr.oacc_function)
{
case OACC_FUNCTION_GANG:
- level = GOMP_DIM_GANG;
+ code = OMP_CLAUSE_GANG;
break;
case OACC_FUNCTION_WORKER:
- level = GOMP_DIM_WORKER;
+ code = OMP_CLAUSE_WORKER;
break;
case OACC_FUNCTION_VECTOR:
- level = GOMP_DIM_VECTOR;
+ code = OMP_CLAUSE_VECTOR;
break;
case OACC_FUNCTION_SEQ:
- default:;
+ default:
+ code = OMP_CLAUSE_SEQ;
}
- for (ix = GOMP_DIM_MAX; ix--;)
- dims = tree_cons (build_int_cst (boolean_type_node, ix >= level),
- integer_zero_node, dims);
-
+ clause = build_omp_clause (UNKNOWN_LOCATION, code);
+ dims = build_oacc_routine_dims (clause);
list = tree_cons (get_identifier ("oacc function"),
dims, list);
}
new file mode 100644
@@ -0,0 +1,39 @@
+ SUBROUTINE v_1
+!$ACC ROUTINE
+!$ACC ROUTINE ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE GANG ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE SEQ ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE WORKER ! { dg-error "ACC ROUTINE already applied" }
+ END SUBROUTINE v_1
+
+ SUBROUTINE sub_1
+ IMPLICIT NONE
+ EXTERNAL :: g_1
+!$ACC ROUTINE (g_1) GANG
+!$ACC ROUTINE (g_1) VECTOR ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (g_1) SEQ ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (g_1) ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (g_1) ! { dg-error "ACC ROUTINE already applied" }
+
+ CALL v_1
+ CALL g_1
+ CALL ABORT
+ END SUBROUTINE sub_1
+
+ MODULE m_w_1
+ IMPLICIT NONE
+ EXTERNAL :: w_1
+!$ACC ROUTINE (w_1) WORKER
+!$ACC ROUTINE (w_1) ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (w_1) SEQ ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (w_1) ! { dg-error "ACC ROUTINE already applied" }
+!$ACC ROUTINE (w_1) VECTOR ! { dg-error "ACC ROUTINE already applied" }
+
+ CONTAINS
+ SUBROUTINE sub_2
+ CALL v_1
+ CALL w_1
+ CALL ABORT
+ END SUBROUTINE sub_2
+ END MODULE m_w_1
@@ -1,17 +1,13 @@
-! Check for valid clauses with intrinsic function specified in !$ACC ROUTINE ( NAME ).
-
SUBROUTINE sub_1
IMPLICIT NONE
-!$ACC ROUTINE (ABORT)
-!$ACC ROUTINE (ABORT) SEQ
+!$ACC ROUTINE (ABORT) SEQ VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
CALL ABORT
END SUBROUTINE sub_1
MODULE m_w_1
IMPLICIT NONE
-!$ACC ROUTINE (ABORT) SEQ
-!$ACC ROUTINE (ABORT)
+!$ACC ROUTINE (ABORT) VECTOR GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
CONTAINS
SUBROUTINE sub_2
@@ -2,18 +2,18 @@
SUBROUTINE sub_1
IMPLICIT NONE
-!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
+!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
CALL ABORT
END SUBROUTINE sub_1
MODULE m_w_1
IMPLICIT NONE
-!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
-!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic function specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible GANG, WORKER, or VECTOR clause" }
+!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
+!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), with incompatible clauses specifying the level of parallelism" }
CONTAINS
SUBROUTINE sub_2
@@ -1,12 +1,24 @@
SUBROUTINE v_1
!$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes" }
+ !$ACC ROUTINE VECTOR ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes" }
END SUBROUTINE v_1
+SUBROUTINE v_2
+ !$ACC ROUTINE(v_2) VECTOR WORKER ! { dg-error "Multiple loop axes" }
+ !$ACC ROUTINE(v_2) VECTOR ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE(v_2) ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE(v_2) GANG VECTOR ! { dg-error "Multiple loop axes" }
+END SUBROUTINE v_2
+
SUBROUTINE sub_1
IMPLICIT NONE
EXTERNAL :: g_1
!$ACC ROUTINE (g_1) GANG WORKER ! { dg-error "Multiple loop axes" }
- !$ACC ROUTINE (ABORT) SEQ VECTOR ! { dg-error "Multiple loop axes" }
+ !$ACC ROUTINE (g_1) GANG ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE (g_1) ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE (g_1) VECTOR GANG ! { dg-error "Multiple loop axes" }
CALL v_1
CALL g_1
@@ -17,7 +29,9 @@ MODULE m_w_1
IMPLICIT NONE
EXTERNAL :: w_1
!$ACC ROUTINE (w_1) WORKER SEQ ! { dg-error "Multiple loop axes" }
- !$ACC ROUTINE (ABORT) VECTOR GANG ! { dg-error "Multiple loop axes" }
+ !$ACC ROUTINE (w_1) WORKER ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE (w_1) ! { dg-error "ACC ROUTINE already applied" }
+ !$ACC ROUTINE (w_1) VECTOR WORKER ! { dg-error "Multiple loop axes" }
CONTAINS
SUBROUTINE sub_2