Fortran: Add code gen for do,concurrent's LOCAL/LOCAL_INIT [PR101602]

Implement LOCAL and LOCAL_INIT; we locally replace the tree declaration by
a local declaration of the outer variable. The 'local_init' then assigns
the value at the beginning of each loop iteration from the outer
declaration.

Note that the current implementation does not handle LOCAL with types that
have a default initializer and LOCAL/LOCAL_INIT for assumed-shape arrays;
this is diagnosed with a sorry error.

	PR fortran/101602

gcc/fortran/ChangeLog:

	* resolve.cc (resolve_locality_spec): Remove 'sorry, unimplemented'.
	* trans-stmt.cc (struct symbol_and_tree_t): New.
	(gfc_trans_concurrent_locality_spec): New.
	(gfc_trans_forall_1): Call it; update to handle local and local_init.
	* trans-decl.cc (gfc_start_saved_local_decls,
	gfc_stop_saved_local_decls): New; moved code from ...
	(gfc_process_block_locals): ... here. Call it.
	* trans.h (gfc_start_saved_local_decls,
	gfc_stop_saved_local_decls): Declare.

gcc/testsuite/ChangeLog:

	* gfortran.dg/do_concurrent_8_f2023.f90: Update for removed 'sorry,
	unimplemented'.
	* gfortran.dg/do_concurrent_9.f90: Likewise.
	* gfortran.dg/do_concurrent_all_clauses.f90: Likewise.
	* gfortran.dg/do_concurrent_local_init.f90: Likewise.
	* gfortran.dg/do_concurrent_locality_specs.f90: Likewise.
	* gfortran.dg/do_concurrent_11.f90: New test.
	* gfortran.dg/do_concurrent_12.f90: New test.
	* gfortran.dg/do_concurrent_13.f90: New test.
	* gfortran.dg/do_concurrent_14.f90: New test.
	* gfortran.dg/do_concurrent_15.f90: New test.

4 files changed, 167 insertions, 21 deletions

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index cb36589..cdf043b 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8422,13 +8422,6 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
 	  plist = &((*plist)->next);
 	}
     }
-
-  if (code->ext.concur.locality[LOCALITY_LOCAL]
-      || code->ext.concur.locality[LOCALITY_LOCAL_INIT])
-    {
-      gfc_error ("Sorry, LOCAL and LOCAL_INIT are not yet supported for "
-		 "%<do concurrent%> constructs at %L", &code->loc);
-    }
 }
 
 /* Resolve a list of FORALL iterators.  The FORALL index-name is constrained
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 8dd1c93..9087221 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -8361,23 +8361,17 @@ gfc_generate_block_data (gfc_namespace * ns)
   rest_of_decl_compilation (decl, 1, 0);
 }
 
-
-/* Process the local variables of a BLOCK construct.  */
-
 void
-gfc_process_block_locals (gfc_namespace* ns)
+gfc_start_saved_local_decls ()
 {
-  tree decl;
-
+  gcc_checking_assert (current_function_decl != NULL_TREE);
   saved_local_decls = NULL_TREE;
-  has_coarray_vars_or_accessors = caf_accessor_head != NULL;
-
-  generate_local_vars (ns);
-
-  if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
-    generate_coarray_init (ns);
+}
 
-  decl = nreverse (saved_local_decls);
+void
+gfc_stop_saved_local_decls ()
+{
+  tree decl = nreverse (saved_local_decls);
   while (decl)
     {
       tree next;
@@ -8390,5 +8384,20 @@ gfc_process_block_locals (gfc_namespace* ns)
   saved_local_decls = NULL_TREE;
 }
 
+/* Process the local variables of a BLOCK construct.  */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+  gfc_start_saved_local_decls ();
+  has_coarray_vars_or_accessors = caf_accessor_head != NULL;
+
+  generate_local_vars (ns);
+
+  if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
+    generate_coarray_init (ns);
+  gfc_stop_saved_local_decls ();
+}
+
 
 #include "gt-fortran-trans-decl.h"
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f16e1e3..94ecde0 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -19,7 +19,7 @@ You should have received a copy of the GNU General Public License
 along with GCC; see the file COPYING3.  If not see
 <http://www.gnu.org/licenses/>.  */
 
-
+#define INCLUDE_VECTOR
 #include "config.h"
 #include "system.h"
 #include "coretypes.h"
@@ -5093,6 +5093,138 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
     }
 }
 
+/* For saving the outer-variable data when doing
+   LOCAL and LOCAL_INIT substitution.  */
+struct symbol_and_tree_t
+{
+  gfc_symbol *sym;
+  gfc_expr *value;
+  tree decl;
+  symbol_attribute attr;
+};
+
+/* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be
+   called twice, once with after_body=false - and then after the loop
+   body has been processed with after_body=true.
+
+   Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT
+   locality specifiers of 'do concurrent' - and use it in the original
+   gfc_symbol.  The declaration is then reset by after_body=true.
+
+   Variables in LOCAL_INIT are set in every loop iteration.  */
+
+void
+gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body,
+				    std::vector<symbol_and_tree_t> *saved_decls,
+				    gfc_expr_list **locality_list)
+{
+  if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT])
+    return;
+
+  if (after_body)
+    {
+      for (unsigned i = 0; i < saved_decls->size (); i++)
+	{
+	  (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl;
+	  (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr;
+	  (*saved_decls)[i].sym->value = (*saved_decls)[i].value;
+	}
+      return;
+    }
+
+  gfc_expr_list *el;
+  int cnt = 0;
+  for (int i = 0; i <= 1; i++)
+    for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT];
+	 el; el = el->next)
+      {
+	gfc_symbol *outer_sym = el->expr->symtree->n.sym;
+	if (!outer_sym->backend_decl)
+	  outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym);
+	cnt++;
+      }
+  saved_decls->resize (cnt);
+
+  /* The variables have to be created in the scope of the loop body.  */
+  if (!body->has_scope)
+    {
+      gcc_checking_assert (body->head == NULL_TREE);
+      gfc_start_block (body);
+    }
+  gfc_start_saved_local_decls ();
+
+  cnt = 0;
+  static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1);
+  for (int type = LOCALITY_LOCAL;
+       type <= LOCALITY_LOCAL_INIT; type++)
+    for (el = locality_list[type]; el; el = el->next)
+      {
+	gfc_symbol *sym = el->expr->symtree->n.sym;
+	(*saved_decls)[cnt].sym = sym;
+	(*saved_decls)[cnt].attr = sym->attr;
+	(*saved_decls)[cnt].value = sym->value;
+	(*saved_decls)[cnt].decl = sym->backend_decl;
+
+	if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE)
+	  {
+	    gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs "
+		       "is not yet supported",
+		       type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT",
+		       &el->expr->where, sym->name);
+	    continue;
+	  }
+
+	gfc_symbol outer_sym = *sym;
+
+	/* Create the inner local variable.  */
+	sym->backend_decl = NULL;
+	sym->value = NULL;
+	sym->attr.save = SAVE_NONE;
+	sym->attr.value = 0;
+	sym->attr.dummy = 0;
+	sym->attr.optional = 0;
+
+	{
+	  /* Slightly ugly hack for adding the decl via add_decl_as_local. */
+	  gfc_symbol dummy_block_sym;
+	  dummy_block_sym.attr.flavor = FL_LABEL;
+	  gfc_symbol *saved_proc_name = sym->ns->proc_name;
+	  sym->ns->proc_name = &dummy_block_sym;
+
+	  gfc_get_symbol_decl (sym);
+	  DECL_SOURCE_LOCATION (sym->backend_decl)
+	    = gfc_get_location (&el->expr->where);
+
+	  sym->ns->proc_name = saved_proc_name;
+	}
+
+	symbol_attribute attr = gfc_expr_attr (el->expr);
+	if (type == LOCALITY_LOCAL
+	    && !attr.pointer
+	    && sym->ts.type == BT_DERIVED
+	    && gfc_has_default_initializer (sym->ts.u.derived))
+	  /* Cf. PR fortran/  */
+	  gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with"
+		     " default initializer is not yet supported",
+		     &el->expr->where, sym->name);
+	if (type == LOCALITY_LOCAL_INIT)
+	  {
+	    /* LOCAL_INIT:  local_var = outer_var.  */
+	    gfc_symtree st = *el->expr->symtree;
+	    st.n.sym = &outer_sym;
+	    gfc_expr expr = *el->expr;
+	    expr.symtree = &st;
+	    tree t = (attr.pointer
+		      ? gfc_trans_pointer_assignment (el->expr, &expr)
+		      : gfc_trans_assignment (el->expr, &expr, false, false,
+					      false, false));
+	    gfc_add_expr_to_block (body, t);
+	  }
+	cnt++;
+      }
+  gfc_stop_saved_local_decls ();
+}
+
 
 /* FORALL and WHERE statements are really nasty, especially when you nest
    them. All the rhs of a forall assignment must be evaluated before the
@@ -5348,9 +5480,19 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
       gfc_init_block (&body);
       cycle_label = gfc_build_label_decl (NULL_TREE);
       code->cycle_label = cycle_label;
+
+      /* Handle LOCAL and LOCAL_INIT.  */
+      std::vector<symbol_and_tree_t> saved_decls;
+      gfc_trans_concurrent_locality_spec (false, &body, &saved_decls,
+					  code->ext.concur.locality);
+
+      /* Translate the body.  */
       tmp = gfc_trans_code (code->block->next);
       gfc_add_expr_to_block (&body, tmp);
 
+      /* Reset locality variables. */
+      gfc_trans_concurrent_locality_spec (true, &body, &saved_decls,
+					  code->ext.concur.locality);
       if (TREE_USED (cycle_label))
 	{
 	  tmp = build1_v (LABEL_EXPR, cycle_label);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 69c3d90..63a566a 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -804,6 +804,8 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
 						tree rettype, int nargs, ...);
 
 /* Process the local variable decls of a block construct.  */
+void gfc_start_saved_local_decls ();
+void gfc_stop_saved_local_decls ();
 void gfc_process_block_locals (gfc_namespace*);
 
 /* Output initialization/clean-up code that was deferred.  */