Re: [Patch] Fortran: Add OpenMP's assume(s) directives

[Jakub Jelinek <jakub@redhat.com>]

On Sun, Oct 02, 2022 at 07:47:18PM +0200, Tobias Burnus wrote:
> gcc/ChangeLog:
> 
> 	* doc/invoke.texi (-fopenmp-simd): Document that also 'assume'
> 	is enabled.
> 
> libgomp/ChangeLog:
> 
> 	* libgomp.texi (OpenMP 5.1 Impl. Status): Mark 'assume' as 'Y'.
> 
> gcc/fortran/ChangeLog:
> 
> 	* dump-parse-tree.cc (show_omp_assumes): New.
> 	(show_omp_clauses, show_namespace): Call it.
> 	(show_omp_node, show_code_node): Handle OpenMP ASSUME.
> 	* gfortran.h (enum gfc_statement): Add ST_OMP_ASSUME,
> 	ST_OMP_END_ASSUME and ST_OMP_ASSUMES.
> 	(gfc_exec_op): Add EXEC_OMP_ASSUME.
> 	(gfc_omp_assumptions): New struct.
> 	(gfc_get_omp_assumptions): New XCNEW #define.
> 	(gfc_omp_clauses, gfc_namespace): Add assume member.
> 	(gfc_resolve_omp_assumptions): New prototype.
> 	* match.h (gfc_match_omp_assume, gfc_match_omp_assumes): New.
> 	* openmp.cc (omp_code_to_statement): Declare.
> 	(gfc_free_omp_clauses): Free assume member and its struct data.
> 	(enum omp_mask2): Add OMP_CLAUSE_ASSUMPTIONS.
> 	(gfc_omp_absent_contains_clause): New.
> 	(gfc_match_omp_clauses): Call it; optionally use passed
> 	omp_clauses argument.
> 	(gfc_match_omp_assume, gfc_match_omp_assumes): New.
> 	(gfc_resolve_omp_assumptions): New.
> 	(resolve_omp_clauses): Call it.
> 	(gfc_resolve_omp_directive, omp_code_to_statement): Handle
> 	EXEC_OMP_ASSUME.
> 	* parse.cc (decode_omp_directive): Parse OpenMP ASSUME(S).
> 	(next_statement, parse_executable, parse_omp_structured_block):
> 	Handle ST_OMP_ASSUME.
> 	(case_omp_decl): Add ST_OMP_ASSUMES.
> 	(gfc_ascii_statement): Handle Assumes, optional return
> 	string without '!$OMP '/'!$ACC ' prefix.
> 	(is_omp_declarative_stmt, is_omp_informational_stmt): New.
> 	* parse.h (gfc_ascii_statement): Add optional bool arg to prototype.
> 	(is_omp_declarative_stmt, is_omp_informational_stmt): New prototype.
> 	* resolve.cc (gfc_resolve_blocks, gfc_resolve_code): Add
> 	EXEC_OMP_ASSUME.
> 	(gfc_resolve): Resolve ASSUMES directive.
> 	* symbol.cc (gfc_free_namespace): Free omp_assumes member.
> 	* st.cc (gfc_free_statement): Handle EXEC_OMP_ASSUME.
> 	* trans-openmp.cc (gfc_trans_omp_directive): Likewise.
> 	* trans.cc (trans_code): Likewise.
> 
> gcc/testsuite/ChangeLog:
> 
> 	* gfortran.dg/gomp/assume-1.f90: New test.
> 	* gfortran.dg/gomp/assume-2.f90: New test.
> 	* gfortran.dg/gomp/assumes-1.f90: New test.
> 	* gfortran.dg/gomp/assumes-2.f90: New test.

> --- a/gcc/doc/invoke.texi
> +++ b/gcc/doc/invoke.texi
> @@ -2749,9 +2749,9 @@ have support for @option{-pthread}. @option{-fopenmp} implies
>  @opindex fopenmp-simd
>  @cindex OpenMP SIMD
>  @cindex SIMD
> -Enable handling of OpenMP's SIMD directives with @code{#pragma omp}
> -in C/C++ and @code{!$omp} in Fortran. Other OpenMP directives
> -are ignored.
> +Enable handling of OpenMP's SIMD directives and OPENMP's @code{assume} directive

s/OPENMP/OpenMP/

We actually handle more directives, @code{declare reduction},
@code{ordered}, @code{scan}, @code{loop} and combined/composite directives
with @code{simd} as constituent.

> +with @code{#pragma omp} in C/C++ and @code{!$omp} in Fortran.  Other OpenMP
> +directives are ignored.

And now in C++ we handle also the attribute syntax (guess we should update
the text for that here as well as in -fopenmp entry).
> @@ -3531,6 +3565,14 @@ show_namespace (gfc_namespace *ns)
>  	}
>      }
>  
> +  if (ns->omp_assumes)
> +    {
> +      show_indent ();
> +      fprintf (dumpfile, "!$OMP ASSUMES");
> +      show_omp_assumes (ns->omp_assumes);
> +    }
> +
> +

Just one empty line?

>    fputc ('\n', dumpfile);
>    show_indent ();
>    fputs ("code:", dumpfile);
> diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
> index 4babd77924b..29a443dcd44 100644
> --- a/gcc/fortran/gfortran.h
> +++ b/gcc/fortran/gfortran.h
> @@ -316,7 +316,7 @@ enum gfc_statement
>    ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD, ST_OMP_MASKED_TASKLOOP,
>    ST_OMP_END_MASKED_TASKLOOP, ST_OMP_MASKED_TASKLOOP_SIMD,
>    ST_OMP_END_MASKED_TASKLOOP_SIMD, ST_OMP_SCOPE, ST_OMP_END_SCOPE,
> -  ST_OMP_ERROR, ST_NONE
> +  ST_OMP_ERROR, ST_OMP_ASSUME, ST_OMP_END_ASSUME, ST_OMP_ASSUMES, ST_NONE
>  };
>  
>  /* Types of interfaces that we can have.  Assignment interfaces are
> @@ -1506,6 +1506,19 @@ enum gfc_omp_bind_type
>    OMP_BIND_THREAD
>  };
>  
> +typedef struct gfc_omp_assumptions
> +{
> +  int n_absent, n_contains;
> +  enum gfc_statement *absent, *contains;
> +  gfc_expr_list *holds;
> +  locus where;
> +  bool no_openmp:1, no_openmp_routines:1, no_parallelism:1;
> +}
> +gfc_omp_assumptions;
> +
> +#define gfc_get_omp_assumptions() XCNEW (gfc_omp_assumptions)
> +
> +
>  typedef struct gfc_omp_clauses
>  {
>    gfc_omp_namelist *lists[OMP_LIST_NUM];
> @@ -1529,6 +1542,7 @@ typedef struct gfc_omp_clauses
>    struct gfc_expr *if_exprs[OMP_IF_LAST];
>    struct gfc_expr *dist_chunk_size;
>    struct gfc_expr *message;
> +  struct gfc_omp_assumptions *assume;
>    const char *critical_name;
>    enum gfc_omp_default_sharing default_sharing;
>    enum gfc_omp_atomic_op atomic_op;
> @@ -2145,6 +2159,9 @@ typedef struct gfc_namespace
>    /* Linked list of !$omp declare variant constructs.  */
>    struct gfc_omp_declare_variant *omp_declare_variant;
>  
> +  /* OpenMP assumptions.  */
> +  struct gfc_omp_assumptions *omp_assumes;
> +
>    /* A hash set for the gfc expressions that have already
>       been finalized in this namespace.  */
>  
> @@ -2913,7 +2930,7 @@ enum gfc_exec_op
>    EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO,
>    EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE,
>    EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
> -  EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
> +  EXEC_OMP_ASSUME, EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
>    EXEC_OMP_END_SINGLE, EXEC_OMP_TASK, EXEC_OMP_TASKWAIT,
>    EXEC_OMP_TASKYIELD, EXEC_OMP_CANCEL, EXEC_OMP_CANCELLATION_POINT,
>    EXEC_OMP_TASKGROUP, EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD,
> @@ -3576,6 +3593,7 @@ void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
>  void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
>  void gfc_free_omp_udr (gfc_omp_udr *);
>  gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
> +void gfc_resolve_omp_assumptions (gfc_omp_assumptions *, const char *, locus *);
>  void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
>  void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *, bool);
>  void gfc_resolve_omp_local_vars (gfc_namespace *);
> diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
> index 1f53e0cb67d..2a805815d9c 100644
> --- a/gcc/fortran/match.h
> +++ b/gcc/fortran/match.h
> @@ -149,6 +149,8 @@ match gfc_match_oacc_routine (void);
>  
>  /* OpenMP directive matchers.  */
>  match gfc_match_omp_eos_error (void);
> +match gfc_match_omp_assume (void);
> +match gfc_match_omp_assumes (void);
>  match gfc_match_omp_atomic (void);
>  match gfc_match_omp_barrier (void);
>  match gfc_match_omp_cancel (void);
> diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
> index ce719bd5d92..df1f046170d 100644
> --- a/gcc/fortran/openmp.cc
> +++ b/gcc/fortran/openmp.cc
> @@ -30,6 +30,9 @@ along with GCC; see the file COPYING3.  If not see
>  #include "gomp-constants.h"
>  #include "target-memory.h"  /* For gfc_encode_character.  */
>  
> +
> +static gfc_statement omp_code_to_statement (gfc_code *);
> +
>  /* Match an end of OpenMP directive.  End of OpenMP directive is optional
>     whitespace, followed by '\n' or comment '!'.  */
>  
> @@ -111,6 +114,13 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
>    gfc_free_expr_list (c->wait_list);
>    gfc_free_expr_list (c->tile_list);
>    free (CONST_CAST (char *, c->critical_name));
> +  if (c->assume)
> +    {
> +      free (c->assume->absent);
> +      free (c->assume->contains);
> +      gfc_free_expr_list (c->assume->holds);
> +      free (c->assume);
> +    }
>    free (c);
>  }
>  
> @@ -992,6 +1002,7 @@ enum omp_mask2
>    OMP_CLAUSE_HAS_DEVICE_ADDR,  /* OpenMP 5.1  */
>    OMP_CLAUSE_ENTER, /* OpenMP 5.2 */
>    OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */
> +  OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */
>    /* This must come last.  */
>    OMP_MASK2_LAST
>  };
> @@ -1407,6 +1418,167 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
>    return MATCH_YES;
>  }
>  
> +static match
> +gfc_omp_absent_contains_clause (gfc_omp_assumptions **assume, bool is_absent)
> +{
> +  if (*assume == NULL)
> +    *assume = gfc_get_omp_assumptions ();
> +  do
> +    {
> +      gfc_statement st = ST_NONE;
> +      gfc_gobble_whitespace ();
> +      locus old_loc = gfc_current_locus;
> +      switch (gfc_peek_ascii_char ())
> +	{
> +	case 'a':
> +	  if (gfc_match ("assumes") == MATCH_YES)
> +	    st = ST_OMP_ASSUMES;
> +	  else if (gfc_match ("assume") == MATCH_YES)
> +	    st = ST_OMP_ASSUME;
> +	  else if (gfc_match ("atomic") == MATCH_YES)
> +	    st = ST_OMP_ATOMIC;

Wouldn't this be better table driven (like c_omp_directives
in c-family, though guess for Fortran you can just use spaces
in the name, don't need 3 strings for the separate tokens)?
Because I think absent/contains isn't the only spot where
you need directive names, metadirective is another.

> +      if (is_omp_declarative_stmt (st) || is_omp_informational_stmt (st))
> +	{
> +	  gfc_error ("Invalid %qs directive at %L in %s clause: declarative, "
> +		     "informational and meta directives not permitted",
> +		     gfc_ascii_statement (st, true), &old_loc,
> +		     is_absent ? "ABSENT" : "CONTAINS");

Do you think we should do the same for C/C++?
Right now it doesn't differentiate between invalid directive names and
names of declarative, informational or meta directives.

> +	  return MATCH_ERROR;
> +	}
> +      if (is_absent)
> +	{
> +	  (*assume)->n_absent++;
> +	  (*assume)->absent
> +	    = (gfc_statement *) xrealloc ((*assume)->absent,
> +					  sizeof (gfc_statement)
> +					  * (*assume)->n_absent);

XRESIZEVEC?
But also, resizing each time a single entry is added to the list isn't
good for compile time, would be nice to grow the allocation size in
powers of 2 or so.

> +	  (*assume)->absent[(*assume)->n_absent - 1] = st;
> +	}
> +      else
> +	{
> +	  (*assume)->n_contains++;
> +	  (*assume)->contains
> +	    = (gfc_statement *) xrealloc ((*assume)->contains,
> +					  sizeof (gfc_statement)
> +					  * (*assume)->n_contains);

Likewise.
> +	  (*assume)->contains[(*assume)->n_contains - 1] = st;
> +	}
> +      gfc_gobble_whitespace ();
> +      if (gfc_match(",") == MATCH_YES)
> +	continue;
> +      if (gfc_match(")") == MATCH_YES)
> +	break;
> +      gfc_error ("Expected %<,%> or %<)%> at %C");
> +      return MATCH_ERROR;
> +    }
> +  while (true);
> +
> +  return MATCH_YES;
> +}
>  
>  /* Match with duplicate check. Matches 'name'. If expr != NULL, it
>     then matches '(expr)', otherwise, if open_parens is true,
> @@ -1472,10 +1644,10 @@ static match
>  gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
>  		       bool first = true, bool needs_space = true,
>  		       bool openacc = false, bool context_selector = false,
> -		       bool openmp_target = false)
> +		       bool openmp_target = false, bool alloc_cp = true)
>  {
>    bool error = false;
> -  gfc_omp_clauses *c = gfc_get_omp_clauses ();
> +  gfc_omp_clauses *c;
>    locus old_loc;
>    /* Determine whether we're dealing with an OpenACC directive that permits
>       derived type member accesses.  This in particular disallows
> @@ -1487,7 +1659,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
>  			    || (mask & OMP_CLAUSE_HOST_SELF)));
>  
>    gcc_checking_assert (OMP_MASK1_LAST <= 64 && OMP_MASK2_LAST <= 64);
> -  *cp = NULL;
> +  if (alloc_cp)
> +    {
> +      c = gfc_get_omp_clauses ();
> +      *cp = NULL;
> +    }
> +  else
> +    c = *cp;
>    while (1)
>      {
>        match m = MATCH_NO;
> @@ -1511,6 +1689,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
>  	case 'a':
>  	  end_colon = false;
>  	  head = NULL;
> +	  if ((mask & OMP_CLAUSE_ASSUMPTIONS)
> +	      && gfc_match ("absent ( ") == MATCH_YES)
> +	    {
> +	      if (gfc_omp_absent_contains_clause (&c->assume, true)
> +		  != MATCH_YES)
> +		goto error;
> +	      continue;
> +	    }
>  	  if ((mask & OMP_CLAUSE_ALIGNED)
>  	      && gfc_match_omp_variable_list ("aligned (",
>  					      &c->lists[OMP_LIST_ALIGNED],
> @@ -1743,6 +1929,14 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
>  	      needs_space = true;
>  	      continue;
>  	    }
> +	  if ((mask & OMP_CLAUSE_ASSUMPTIONS)
> +	      && gfc_match ("contains ( ") == MATCH_YES)
> +	    {
> +	      if (gfc_omp_absent_contains_clause (&c->assume, false)
> +		  != MATCH_YES)
> +		goto error;
> +	      continue;
> +	    }
>  	  if ((mask & OMP_CLAUSE_COPY)
>  	      && gfc_match ("copy ( ") == MATCH_YES
>  	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
> @@ -2277,6 +2471,20 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
>  		goto error;
>  	      continue;
>  	    }
> +	  if ((mask & OMP_CLAUSE_ASSUMPTIONS)
> +	      && gfc_match ("holds ( ") == MATCH_YES)
> +	    {
> +	      gfc_expr *e;
> +	      if (gfc_match ("%e )", &e) != MATCH_YES)
> +		goto error;
> +	      if (c->assume == NULL)
> +		c->assume = gfc_get_omp_assumptions ();
> +	      gfc_expr_list *el = XCNEW (gfc_expr_list);
> +	      el->expr = e;
> +	      el->next = c->assume->holds;
> +	      c->assume->holds = el;
> +	      continue;
> +	    }
>  	  if ((mask & OMP_CLAUSE_HOST_SELF)
>  	      && gfc_match ("host ( ") == MATCH_YES
>  	      && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP],
> @@ -2664,6 +2872,41 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
>  					   OMP_MAP_IF_PRESENT, true,
>  					   allow_derived))
>  	    continue;
> +	  if ((mask & OMP_CLAUSE_ASSUMPTIONS)
> +	      && (m = gfc_match_dupl_check (!c->assume
> +					    || !c->assume->no_openmp_routines,
> +					    "no_openmp_routines")) == MATCH_YES)
> +	    {
> +	      if (m == MATCH_ERROR)
> +		goto error;
> +	      if (c->assume == NULL)
> +		c->assume = gfc_get_omp_assumptions ();
> +	      c->assume->no_openmp_routines = needs_space = true;
> +	      continue;
> +	    }
> +	  if ((mask & OMP_CLAUSE_ASSUMPTIONS)
> +	      && (m = gfc_match_dupl_check (!c->assume || !c->assume->no_openmp,
> +					    "no_openmp")) == MATCH_YES)
> +	    {
> +	      if (m == MATCH_ERROR)
> +		goto error;
> +	      if (c->assume == NULL)
> +		c->assume = gfc_get_omp_assumptions ();
> +	      c->assume->no_openmp = needs_space = true;
> +	      continue;
> +	    }
> +	  if ((mask & OMP_CLAUSE_ASSUMPTIONS)
> +	      && (m = gfc_match_dupl_check (!c->assume
> +					    || !c->assume->no_parallelism,
> +					    "no_parallelism")) == MATCH_YES)
> +	    {
> +	      if (m == MATCH_ERROR)
> +		goto error;
> +	      if (c->assume == NULL)
> +		c->assume = gfc_get_omp_assumptions ();
> +	      c->assume->no_parallelism = needs_space = true;
> +	      continue;
> +	    }
>  	  if ((mask & OMP_CLAUSE_NOGROUP)
>  	      && (m = gfc_match_dupl_check (!c->nogroup, "nogroup"))
>  		 != MATCH_NO)
> @@ -3941,6 +4184,42 @@ match_omp (gfc_exec_op op, const omp_mask mask)
>  }
>  
>  
> +match
> +gfc_match_omp_assume (void)
> +{
> +  return match_omp (EXEC_OMP_ASSUME, omp_mask (OMP_CLAUSE_ASSUMPTIONS));
> +}
> +
> +
> +match
> +gfc_match_omp_assumes (void)
> +{
> +  locus loc = gfc_current_locus;
> +  gfc_omp_clauses *c = gfc_get_omp_clauses ();
> +  c->assume = gfc_current_ns->omp_assumes;
> +  if (!gfc_current_ns->proc_name
> +      || (gfc_current_ns->proc_name->attr.flavor != FL_MODULE
> +	  && !gfc_current_ns->proc_name->attr.subroutine
> +	  && !gfc_current_ns->proc_name->attr.function))
> +    {
> +      gfc_error ("!OMP ASSUMES at %C must be in the specification part of a "
> +		 "subprogram or module");
> +      return MATCH_ERROR;
> +    }
> +  if (gfc_match_omp_clauses (&c, omp_mask (OMP_CLAUSE_ASSUMPTIONS), true, true,
> +			     false, false, false, false) != MATCH_YES)
> +    {
> +      gfc_current_ns->omp_assumes = NULL;
> +      return MATCH_ERROR;
> +    }

I don't understand the point of preallocation of gfc_omp_clauses here,
can't it be allocated inside of gfc_match_omp_clauses like everywhere else?
Because otherwise it e.g. leaks if the first error is reported.

> +  c->assume->where = loc;
> +  gfc_current_ns->omp_assumes = c->assume;
> +  c->assume = NULL;
> +  gfc_free_omp_clauses (c);
> +  return MATCH_YES;
> +}
> +
> +
>  match
>  gfc_match_omp_critical (void)
>  {
> @@ -6505,6 +6784,42 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
>    return copy;
>  }
>  
> +
> +/* Resolve ASSUME's and ASSUMES' assumption clauses.  */
> +
> +void
> +gfc_resolve_omp_assumptions (gfc_omp_assumptions *assume, const char *directive,
> +			     locus *loc)
> +{
> +  for (gfc_expr_list *el = assume->holds; el; el = el->next)
> +    if (!gfc_resolve_expr (el->expr) || el->expr->ts.type != BT_LOGICAL)
> +	gfc_error ("HOLDS expression at %L must be a logical expression",
> +		   &el->expr->where);
> +  for (int i = 0; i < assume->n_absent; i++)
> +    {
> +      for (int j = i + 1; j < assume->n_absent; j++)
> +	if (assume->absent[i] == assume->absent[j])
> +	  gfc_error ("%qs directive mentioned multiple times in %s clause in %s"
> +		     " directive at %L",
> +		     gfc_ascii_statement (assume->absent[i], true),
> +		     "ABSENT", directive, loc);
> +      for (int j = 0; j < assume->n_contains; j++)
> +	if (assume->absent[i] == assume->contains[j])
> +	  gfc_error ("%qs directive mentioned both times in ABSENT and CONTAINS"
> +		     " clauses in %s directive at %L",
> +		     gfc_ascii_statement (assume->absent[i], true),
> +		     directive, loc);
> +    }
> +  for (int i = 0; i < assume->n_contains; i++)
> +    for (int j = i + 1; j < assume->n_contains; j++)
> +      if (assume->contains[i] == assume->contains[j])
> +	gfc_error ("%qs directive mentioned multiple times in %s clause in %s "
> +		   "directive at %L",
> +		   gfc_ascii_statement (assume->contains[i], true),
> +		   "CONTAINS", directive, loc);

This is O(n^2)?  Can't you use a bitmap or hash map instead?

Otherwise LGTM.

	Jakub