OpenMP: Fortran front-end support for dispatch + adjust_args

This patch adds support for the `dispatch` construct and the `adjust_args`
clause to the Fortran front-end.

Handling of `adjust_args` across translation units is missing due to PR115271.

Minor modifications to the C++ FE and the ME are also folded into this patch as
a side effect of the Fortran work.

gcc/c-family/ChangeLog:

	* c-attribs.cc: (c_common_gnu_attributes): Rename "omp declare variant
	variant adjust_args" into "omp declare variant variant args" to also
	accommodate append_args.

gcc/cp/ChangeLog:

	* parser.cc (cp_parser_omp_dispatch): Handle INDIRECT_REF.

gcc/fortran/ChangeLog:

	* dump-parse-tree.cc (show_omp_clauses): Handle novariants and nocontext
	clauses.
	(show_omp_node): Handle EXEC_OMP_DISPATCH.
	(show_code_node): Likewise.
	* frontend-passes.cc (gfc_code_walker): Handle novariants and nocontext.
	* gfortran.h (enum gfc_statement): Add ST_OMP_DISPATCH.
	(symbol_attribute): Add omp_declare_variant_need_device_ptr.
	(gfc_omp_clauses): Add novariants and nocontext.
	(gfc_omp_declare_variant): Add need_device_ptr_arg_list.
	(enum gfc_exec_op): Add EXEC_OMP_DISPATCH.
	* match.h (gfc_match_omp_dispatch): Declare.
	* openmp.cc (gfc_free_omp_clauses): Free novariants and nocontext
	clauses.
	(gfc_free_omp_declare_variant_list): Free need_device_ptr_arg_list
	namelist.
	(enum omp_mask2): Add OMP_CLAUSE_NOVARIANTS and OMP_CLAUSE_NOCONTEXT.
	(gfc_match_omp_clauses): Handle OMP_CLAUSE_NOVARIANTS and
	OMP_CLAUSE_NOCONTEXT.
	(OMP_DISPATCH_CLAUSES): Define.
	(gfc_match_omp_dispatch): New function.
	(gfc_match_omp_declare_variant): Parse adjust_args.
	(resolve_omp_clauses): Handle adjust_args, novariants and nocontext.
	Adjust handling of OMP_LIST_IS_DEVICE_PTR.
	(icode_code_error_callback): Handle EXEC_OMP_DISPATCH.
	(omp_code_to_statement): Likewise.
	(resolve_omp_dispatch): New function.
	(gfc_resolve_omp_directive): Handle EXEC_OMP_DISPATCH.
	* parse.cc (decode_omp_directive): Match dispatch.
	(next_statement): Handle ST_OMP_DISPATCH.
	(gfc_ascii_statement): Likewise.
	(parse_omp_dispatch): New function.
	(parse_executable): Handle ST_OMP_DISPATCH.
	* resolve.cc (gfc_resolve_blocks): Handle EXEC_OMP_DISPATCH.
	* st.cc (gfc_free_statement): Likewise.
	* trans-decl.cc (create_function_arglist): Declare.
	(gfc_get_extern_function_decl): Call it.
	* trans-openmp.cc (gfc_trans_omp_clauses): Handle novariants and
	nocontext.
	(replace_omp_dispatch_call): New function.
	(gfc_trans_omp_dispatch): New function.
	(gfc_trans_omp_directive): Handle EXEC_OMP_DISPATCH.
	(gfc_trans_omp_declare_variant): Handle adjust_args.
	* trans.cc (trans_code): Handle EXEC_OMP_DISPATCH:.

gcc/ChangeLog:

	* gimplify.cc (gimplify_call_expr): Fix handling of need_device_ptr for
	type(c_ptr). Fix handling of nested function calls in a dispatch region.
	(find_ifn_gomp_dispatch): Return the IFN without stripping it.
	(gimplify_omp_dispatch): Keep IFN_GOMP_DISPATCH until
	gimplify_call_expr.

libgomp/ChangeLog:
	* testsuite/libgomp.fortran/declare-variant-2-aux.f90: New test.
	* testsuite/libgomp.fortran/declare-variant-2.f90: New test (xfail).
	* testsuite/libgomp.fortran/dispatch-1.f90: New test.
	* testsuite/libgomp.fortran/dispatch-2.f90: New test.
	* testsuite/libgomp.fortran/dispatch-3.f90: New test.

gcc/testsuite/ChangeLog:

	* g++.dg/gomp/dispatch-3.C: Update scan dumps.
	* gfortran.dg/gomp/declare-variant-2.f90: Update dg-error.
	* gfortran.dg/gomp/adjust-args-1.f90: New test.
	* gfortran.dg/gomp/adjust-args-2.f90: New test.
	* gfortran.dg/gomp/adjust-args-2a.f90: New test.
	* gfortran.dg/gomp/adjust-args-3.f90: New test.
	* gfortran.dg/gomp/adjust-args-4.f90: New test.
	* gfortran.dg/gomp/adjust-args-5.f90: New test.
	* gfortran.dg/gomp/adjust-args-6.f90: New test.
	* gfortran.dg/gomp/adjust-args-7.f90: New test.
	* gfortran.dg/gomp/adjust-args-8.f90: New test.
	* gfortran.dg/gomp/adjust-args-9.f90: New test.
	* gfortran.dg/gomp/dispatch-1.f90: New test.
	* gfortran.dg/gomp/dispatch-2.f90: New test.
	* gfortran.dg/gomp/dispatch-3.f90: New test.
	* gfortran.dg/gomp/dispatch-4.f90: New test.
	* gfortran.dg/gomp/dispatch-5.f90: New test.
	* gfortran.dg/gomp/dispatch-6.f90: New test.
	* gfortran.dg/gomp/dispatch-7.f90: New test.
	* gfortran.dg/gomp/dispatch-8.f90: New test.
	* gfortran.dg/gomp/dispatch-9.f90: New test.
	* gfortran.dg/gomp/dispatch-9a.f90: New test.
	* gfortran.dg/gomp/dispatch-10.f90: New test.

1 files changed, 197 insertions, 0 deletions

diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index b794066..b04adf3 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -4282,6 +4282,36 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
       omp_clauses = gfc_trans_add_clause (c, omp_clauses);
     }
 
+  if (clauses->novariants)
+    {
+      tree novariants_var;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, clauses->novariants);
+      gfc_add_block_to_block (block, &se.pre);
+      novariants_var = gfc_evaluate_now (se.expr, block);
+      gfc_add_block_to_block (block, &se.post);
+
+      c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOVARIANTS);
+      OMP_CLAUSE_NOVARIANTS_EXPR (c) = novariants_var;
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
+  if (clauses->nocontext)
+    {
+      tree nocontext_var;
+
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, clauses->nocontext);
+      gfc_add_block_to_block (block, &se.pre);
+      nocontext_var = gfc_evaluate_now (se.expr, block);
+      gfc_add_block_to_block (block, &se.post);
+
+      c = build_omp_clause (gfc_get_location (&where), OMP_CLAUSE_NOCONTEXT);
+      OMP_CLAUSE_NOCONTEXT_EXPR (c) = nocontext_var;
+      omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+    }
+
   if (clauses->num_threads)
     {
       tree num_threads;
@@ -6409,6 +6439,113 @@ gfc_trans_omp_depobj (gfc_code *code)
   return gfc_finish_block (&block);
 }
 
+/* Callback for walk_tree to find an OMP dispatch call and wrap it into an
+ * IFN_GOMP_DISPATCH.  */
+
+static tree
+replace_omp_dispatch_call (tree *tp, int *, void *decls_p)
+{
+  tree t = *tp;
+  tree decls = (tree) decls_p;
+  tree orig_fn_decl = TREE_PURPOSE (decls);
+  tree dup_fn_decl = TREE_VALUE (decls);
+  if (TREE_CODE (t) == CALL_EXPR)
+    {
+      if (CALL_EXPR_FN (t) == dup_fn_decl)
+	CALL_EXPR_FN (t) = orig_fn_decl;
+      else if (TREE_CODE (CALL_EXPR_FN (t)) == ADDR_EXPR
+	       && TREE_OPERAND (CALL_EXPR_FN (t), 0) == dup_fn_decl)
+	TREE_OPERAND (CALL_EXPR_FN (t), 0) = dup_fn_decl;
+      else
+	return NULL_TREE;
+      *tp = build_call_expr_internal_loc (input_location, IFN_GOMP_DISPATCH,
+					  TREE_TYPE (t), 1, t);
+      return *tp;
+    }
+
+  return NULL_TREE;
+}
+
+static tree
+gfc_trans_omp_dispatch (gfc_code *code)
+{
+  stmtblock_t block;
+  gfc_code *next = code->block->next;
+  // assume ill-formed "function dispatch structured
+  // block" have already been rejected by resolve_omp_dispatch
+  gcc_assert (next->op == EXEC_CALL || next->op == EXEC_ASSIGN);
+
+  // Make duplicate decl for dispatch function call to make it easy to spot
+  // after translation
+  gfc_symbol *orig_fn_sym;
+  gfc_expr *call_expr = next->op == EXEC_CALL ? next->expr1 : next->expr2;
+  if (call_expr != NULL) // function
+    {
+      if (call_expr->value.function.isym != NULL) // dig into convert intrinsics
+	call_expr = call_expr->value.function.actual->expr;
+      gcc_assert (call_expr->expr_type == EXPR_FUNCTION);
+      orig_fn_sym = call_expr->value.function.esym
+		      ? call_expr->value.function.esym
+		      : call_expr->symtree->n.sym;
+    }
+  else // subroutine
+    {
+      orig_fn_sym = next->resolved_sym;
+    }
+  if (!orig_fn_sym->backend_decl)
+    gfc_get_symbol_decl (orig_fn_sym);
+  gfc_symbol dup_fn_sym = *orig_fn_sym;
+  dup_fn_sym.backend_decl = copy_node (orig_fn_sym->backend_decl);
+  if (call_expr != NULL)
+    call_expr->value.function.esym = &dup_fn_sym;
+  else
+    next->resolved_sym = &dup_fn_sym;
+
+  tree body = gfc_trans_code (next);
+
+  // Walk the tree to find the duplicate decl, wrap IFN call and replace
+  // dup decl with original
+  tree fn_decls
+    = build_tree_list (orig_fn_sym->backend_decl, dup_fn_sym.backend_decl);
+  tree dispatch_call
+    = walk_tree (&body, replace_omp_dispatch_call, fn_decls, NULL);
+  gcc_assert (dispatch_call != NULL_TREE);
+
+  gfc_start_block (&block);
+  tree omp_clauses
+    = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, code->loc);
+
+  // Extract depend clauses and create taskwait
+  tree depend_clauses = NULL_TREE;
+  tree *depend_clauses_ptr = &depend_clauses;
+  for (tree c = omp_clauses; c; c = OMP_CLAUSE_CHAIN (c))
+    {
+      if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_DEPEND)
+	{
+	  *depend_clauses_ptr = c;
+	  depend_clauses_ptr = &OMP_CLAUSE_CHAIN (c);
+	}
+    }
+  if (depend_clauses != NULL_TREE)
+    {
+      tree stmt = make_node (OMP_TASK);
+      TREE_TYPE (stmt) = void_node;
+      OMP_TASK_CLAUSES (stmt) = depend_clauses;
+      OMP_TASK_BODY (stmt) = NULL_TREE;
+      SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
+      gfc_add_expr_to_block (&block, stmt);
+    }
+
+  tree stmt = make_node (OMP_DISPATCH);
+  SET_EXPR_LOCATION (stmt, gfc_get_location (&code->loc));
+  TREE_TYPE (stmt) = void_type_node;
+  OMP_DISPATCH_BODY (stmt) = body;
+  OMP_DISPATCH_CLAUSES (stmt) = omp_clauses;
+
+  gfc_add_expr_to_block (&block, stmt);
+  return gfc_finish_block (&block);
+}
+
 static tree
 gfc_trans_omp_error (gfc_code *code)
 {
@@ -8333,6 +8470,8 @@ gfc_trans_omp_directive (gfc_code *code)
     case EXEC_OMP_UNROLL:
       return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
 			       NULL);
+    case EXEC_OMP_DISPATCH:
+      return gfc_trans_omp_dispatch (code);
     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
     case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
     case EXEC_OMP_DISTRIBUTE_SIMD:
@@ -8646,6 +8785,18 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
 		  variant_proc_sym = NULL;
 		}
 	    }
+	  if (odv->adjust_args_list != NULL
+	      && omp_get_context_selector (set_selectors,
+					   OMP_TRAIT_SET_CONSTRUCT,
+					   OMP_TRAIT_CONSTRUCT_DISPATCH)
+		   == NULL_TREE)
+	    {
+	      gfc_error ("an %<adjust_args%> clause can only be specified if "
+			 "the %<dispatch%> selector of the construct "
+			 "selector set appears in the %<match%> clause at %L",
+			 &odv->where);
+	      variant_proc_sym = NULL;
+	    }
 	  if (variant_proc_sym != NULL)
 	    {
 	      gfc_set_sym_referenced (variant_proc_sym);
@@ -8662,6 +8813,52 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
 		  DECL_ATTRIBUTES (base_fn_decl)
 		    = tree_cons (id, build_tree_list (variant, set_selectors),
 				 DECL_ATTRIBUTES (base_fn_decl));
+
+		  // Handle adjust_args
+		  tree need_device_ptr_list = make_node (TREE_LIST);
+		  vec<gfc_symbol *> adjust_args_list = vNULL;
+		  for (gfc_omp_namelist *arg_list = odv->adjust_args_list;
+		       arg_list != NULL; arg_list = arg_list->next)
+		    {
+		      if (!arg_list->sym->attr.dummy)
+			{
+			  gfc_error (
+			    "list item %qs at %L is not a dummy argument",
+			    arg_list->sym->name, &arg_list->where);
+			  continue;
+			}
+		      if (adjust_args_list.contains (arg_list->sym))
+			{
+			  gfc_error ("%qs at %L is specified more than once",
+				     arg_list->sym->name, &arg_list->where);
+			  continue;
+			}
+		      adjust_args_list.safe_push (arg_list->sym);
+		      if (arg_list->u.need_device_ptr)
+			{
+			  int idx;
+			  gfc_formal_arglist *arg;
+			  for (arg = ns->proc_name->formal, idx = 0;
+			       arg != NULL; arg = arg->next, idx++)
+			    if (arg->sym == arg_list->sym)
+			      break;
+			  gcc_assert (arg != NULL);
+			  need_device_ptr_list = chainon (
+			    need_device_ptr_list,
+			    build_tree_list (
+			      NULL_TREE,
+			      build_int_cst (
+				integer_type_node,
+				idx))); // Store 0-based argument index,
+					// as in gimplify_call_expr
+			}
+		    }
+
+		  DECL_ATTRIBUTES (variant) = tree_cons (
+		    get_identifier ("omp declare variant variant args"),
+		    build_tree_list (need_device_ptr_list,
+				     NULL_TREE /*need_device_addr */),
+		    DECL_ATTRIBUTES (variant));
 		}
 	    }
 	}