[PR fortran/72741] Check clauses with intrinsic function specified in !$ACC ROUTINE ( NAME )
2018-XX-YY Cesar Philippidis <cesar@codesourcery.com>
gcc/fortran/
* openmp.c (gfc_match_oacc_routine): Check clauses of intrinsic
functions.
gcc/testsuite/
* gfortran.dg/goacc/fixed-1.f: Update test.
* gfortran.dg/goacc/pr72741-2.f: New test.
* gfortran.dg/goacc/pr72741-intrinsic-1.f: New test.
* gfortran.dg/goacc/pr72741-intrinsic-2.f: New test.
* gfortran.dg/goacc/pr72741.f90: Update test.
libgomp/
* testsuite/libgomp.oacc-fortran/abort-1.f90: Update test.
* testsuite/libgomp.oacc-fortran/acc_on_device-1-2.f: Update test.
(cherry picked from gomp-4_0-branch r239422)
(cherry picked from gomp-4_0-branch r239515, and r247954)
---
gcc/fortran/openmp.c | 41 +++++++++++++++----
gcc/testsuite/gfortran.dg/goacc/fixed-1.f | 2 +
gcc/testsuite/gfortran.dg/goacc/pr72741-2.f | 39 ++++++++++++++++++
.../gfortran.dg/goacc/pr72741-intrinsic-1.f | 16 ++++++++
.../gfortran.dg/goacc/pr72741-intrinsic-2.f | 22 ++++++++++
gcc/testsuite/gfortran.dg/goacc/pr72741.f90 | 20 +++++++--
.../libgomp.oacc-fortran/abort-1.f90 | 1 +
.../libgomp.oacc-fortran/acc_on_device-1-2.f | 1 +
8 files changed, 130 insertions(+), 12 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/goacc/pr72741-2.f
create mode 100644 gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
create mode 100644 gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
@@ -2288,8 +2288,9 @@ match
gfc_match_oacc_routine (void)
{
locus old_loc;
- gfc_symbol *sym = NULL;
match m;
+ gfc_intrinsic_sym *isym = NULL;
+ gfc_symbol *sym = NULL;
gfc_omp_clauses *c = NULL;
gfc_oacc_routine_name *n = NULL;
oacc_function dims;
@@ -2311,12 +2312,14 @@ gfc_match_oacc_routine (void)
if (m == MATCH_YES)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symtree *st;
+ gfc_symtree *st = NULL;
m = gfc_match_name (buffer);
if (m == MATCH_YES)
{
- st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+ if ((isym = gfc_find_function (buffer)) == NULL
+ && (isym = gfc_find_subroutine (buffer)) == NULL)
+ st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
if (st)
{
sym = st->n.sym;
@@ -2325,7 +2328,7 @@ gfc_match_oacc_routine (void)
sym = NULL;
}
- if (st == NULL
+ if ((isym == NULL && st == NULL)
|| (sym
&& !sym->attr.external
&& !sym->attr.function
@@ -2337,6 +2340,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
{
@@ -2357,15 +2367,30 @@ 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 for routine %C");
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
+ gfc_error ("Multiple loop axes specified in !$ACC ROUTINE at %C");
+
+ /* Don't abort early, because it's important to let the user
+ know of any potential duplicate routine directives. */
+ seen_error = true;
}
- if (sym != NULL)
+ if (isym != NULL)
+ {
+ if (c && (c->gang || c->worker || c->vector))
+ {
+ gfc_error ("Intrinsic symbol specified in !$ACC ROUTINE ( NAME ) "
+ "at %C, with incompatible clauses specifying the level "
+ "of parallelism");
+ goto cleanup;
+ }
+ /* The intrinsic symbol has been marked with a SEQ, or with no clause at
+ all, which is OK. */
+ }
+ else if (sym != NULL)
{
bool needs_entry = true;
@@ -1,3 +1,5 @@
+!$ACC ROUTINE(ABORT) SEQ
+
INTEGER :: ARGC
ARGC = COMMAND_ARGUMENT_COUNT ()
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
new file mode 100644
@@ -0,0 +1,16 @@
+ SUBROUTINE sub_1
+ IMPLICIT NONE
+!$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) 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
+ CALL ABORT
+ END SUBROUTINE sub_2
+ END MODULE m_w_1
new file mode 100644
@@ -0,0 +1,22 @@
+! Check for invalid clauses with intrinsic function specified in !$ACC ROUTINE ( NAME ).
+
+ SUBROUTINE sub_1
+ IMPLICIT NONE
+!$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 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
+ CALL ABORT
+ END SUBROUTINE sub_2
+ END MODULE m_w_1
@@ -1,13 +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" "" { xfail *-*-* } }
-! { dg-bogus "invalid function name abort" "" { xfail *-*-* } .-1 }
+ !$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
@@ -18,8 +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" "" { xfail *-*-* } }
-! { dg-bogus "invalid function name abort" "" { xfail *-*-* } .-1 }
+ !$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
@@ -3,6 +3,7 @@
program main
implicit none
+ !$acc routine(abort) seq
print *, "CheCKpOInT"
!$acc parallel
@@ -6,6 +6,7 @@
USE OPENACC
IMPLICIT NONE
+!$ACC ROUTINE(ABORT) SEQ
!Host.
--
2.17.1