Re: [WIP] [PR fortran/72741] Rework Fortran OpenACC routine clause handling

[Cesar Philippidis <cesar@codesourcery.com>]

[-- Attachment #1: Type: text/plain, Size: 2868 bytes --]

On 08/11/2016 09:26 AM, Thomas Schwinge wrote:

> As Cesar asked for it, there is now a Git branch
> tschwinge/omp/pr72741-wip containing these changes (plus some other
> pending changes that I didn't single out at this time), at
> <https://gcc.gnu.org/git/?p=gcc.git;a=shortlog;h=refs/heads/tschwinge/omp/pr72741-wip>.
> (I expect it does, but I didn't verify that this actually builds; I have
> further changes on top of that.)  Cesar, please tell me if you'd like me
> to push this to GitHub, in case you want to use their review/commentary
> functions, or the like.

No, that git repository is fine.

> On Thu, 11 Aug 2016 17:40:26 +0200, Jakub Jelinek <jakub@redhat.com> wrote:
>> On Thu, Aug 11, 2016 at 05:18:43PM +0200, Thomas Schwinge wrote:
>>> --- gcc/fortran/gfortran.h
>>> +++ gcc/fortran/gfortran.h
> 
>>>  /* Symbol attribute structure.  */
>>> -typedef struct
>>> +typedef struct symbol_attribute
>>>  {
> 
>> While symbol_attribute is already bloated, I don't like bloating it this
>> much further.  Do you really need it for all symbols, or just all subroutines?
> 
> Certainly not for all symbole; just for what is valid to be used with the
> OpenACC routine directive, which per OpenACC 2.0a, 2.13.1 Routine
> Directive is:
> 
>     In Fortran the syntax of the routine directive is:
>         !$acc routine clause-list
>         !$acc routine( name ) clause-list
>     In Fortran, the routine directive without a name may appear within the specification part of a subroutine or function definition, or within an interface body for a subroutine or function in an interface block, and applies to the containing subroutine or function. The routine directive with a name may appear in the specification part of a subroutine, function or module, and applies to the named subroutine or function.
> 
> (Pasting that in full just in case that contains some additional Fortran
> lingo, meaning more than "subroutines".)

I'm avoided that problem in this patch. For the moment, I'm ignoring the
device_type problem and handling all of the matching errors in
gfc_match_oacc_routine. You're patch was handling those errors in
add_attributes_to_decls, which I think is too late.

device_type will require extra handling down the road. But instead of
introducing new attributes, we can just use the existing
gfc_oacc_routine_name struct to capture and chain all of the clauses for
all of the different device_types. Then we can teach
add_attributes_to_decls to call gfc_oacc_routine_dims to generate the
appropriate OACC_FUNCTION attribute for a given set of device_type clauses.

Note that besides for checking for multiple acc routine directives, this
patch also handles the case where the optional name argument in 'acc
routine (NAME)' is the name of the current procedure. This was a TODO
item in gomp4.

Thomas, does this patch ok to you for gomp4?

Cesar

[-- Attachment #2: pr72741-gomp4.diff --]
[-- Type: text/x-patch, Size: 13085 bytes --]

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.


diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 80f46c0..cb8efb8 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -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 ();
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 5271268..785212f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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);
     }
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741-2.f b/gcc/testsuite/gfortran.dg/goacc/pr72741-2.f
new file mode 100644
index 0000000..5865144
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-2.f
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
index 4bff3e3..d84cdf9 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-1.f
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
index fed8e76..e5e3794 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741-intrinsic-2.f
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/goacc/pr72741.f90 b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
index cf89727..3fbd94f 100644
--- a/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
+++ b/gcc/testsuite/gfortran.dg/goacc/pr72741.f90
@@ -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