dump-parse-tree.c (show_omp_namelist): Dump reduction id in each list item.

gcc/fortran/
	* dump-parse-tree.c (show_omp_namelist): Dump reduction
	id in each list item.
	(show_omp_node): Only handle OMP_LIST_REDUCTION, not
	OMP_LIST_REDUCTION_FIRST .. OMP_LIST_REDUCTION_LAST.  Don't
	dump reduction id here.
	* frontend-passes.c (dummy_code_callback): Renamed to...
	(gfc_dummy_code_callback): ... this.  No longer static.
	(optimize_reduction): Use gfc_dummy_code_callback instead of
	dummy_code_callback.
	* gfortran.h (gfc_statement): Add ST_OMP_DECLARE_REDUCTION.
	(symbol_attribute): Add omp_udr_artificial_var bitfield.
	(gfc_omp_reduction_op): New enum.
	(gfc_omp_namelist): Add rop and udr fields.
	(OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
	OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
	OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
	OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST): Removed.
	(OMP_LIST_REDUCTION): New.
	(gfc_omp_udr): New type.
	(gfc_get_omp_udr): Define.
	(gfc_symtree): Add n.omp_udr field.
	(gfc_namespace): Add omp_udr_root field, add omp_udr_ns bitfield.
	(gfc_free_omp_udr, gfc_omp_udr_find, gfc_resolve_omp_udrs,
	gfc_dummy_code_callback): New prototypes.
	* match.h (gfc_match_omp_declare_reduction): New prototype.
	* module.c (MOD_VERSION): Increase to 13.
	(omp_declare_reduction_stmt): New array.
	(mio_omp_udr_expr, write_omp_udr, write_omp_udrs, load_omp_udrs):
	New functions.
	(read_module): Read OpenMP user defined reductions.
	(write_module): Write OpenMP user defined reductions.
	* openmp.c: Include arith.h.
	(gfc_free_omp_udr, gfc_find_omp_udr): New functions.
	(gfc_match_omp_clauses): Handle user defined reductions.
	Store reduction kind into gfc_omp_namelist instead of using
	several OMP_LIST_* entries.
	(match_udr_expr, gfc_omp_udr_predef, gfc_omp_udr_find,
	gfc_match_omp_declare_reduction): New functions.
	(resolve_omp_clauses): Adjust for reduction clauses being only
	in OMP_LIST_REDUCTION list.  Diagnose missing UDRs.
	(struct omp_udr_callback_data): New type.
	(omp_udr_callback, gfc_resolve_omp_udr, gfc_resolve_omp_udrs): New
	functions.
	* parse.c (decode_omp_directive): Handle !$omp declare reduction.
	(case_decl): Add ST_OMP_DECLARE_REDUCTION.
	(gfc_ascii_statement): Print ST_OMP_DECLARE_REDUCTION.
	* resolve.c (resolve_fl_variable): Allow len=: or len=* on
	sym->attr.omp_udr_artificial_var symbols.
	(resolve_types): Call gfc_resolve_omp_udrs.
	* symbol.c (gfc_get_uop): If gfc_current_ns->omp_udr_ns,
	use parent ns instead of gfc_current_ns.
	(gfc_get_sym_tree): Don't insert symbols into
	namespaces with omp_udr_ns set.
	(free_omp_udr_tree): New function.
	(gfc_free_namespace): Call it.
	* trans-openmp.c (struct omp_udr_find_orig_data): New type.
	(omp_udr_find_orig, gfc_trans_omp_udr_expr): New functions.
	(gfc_trans_omp_array_reduction): Renamed to...
	(gfc_trans_omp_array_reduction_or_udr): ... this.  Remove SYM
	argument, instead pass gfc_omp_namelist pointer N.  Handle
	user defined reductions.
	(gfc_trans_omp_reduction_list): Remove REDUCTION_CODE argument.
	Handle user defined reductions and reduction ops in gfc_omp_namelist.
	(gfc_trans_omp_clauses): Adjust for just a single OMP_LIST_REDUCTION
	list.
	(gfc_split_omp_clauses): Likewise.
gcc/testsuite/
	* gfortran.dg/gomp/allocatable_components_1.f90: Adjust for
	reduction clause diagnostic changes.
	* gfortran.dg/gomp/appendix-a/a.31.3.f90: Likewise.
	* gfortran.dg/gomp/reduction1.f90: Likewise.
	* gfortran.dg/gomp/reduction3.f90: Likewise.
	* gfortran.dg/gomp/udr1.f90: New test.
	* gfortran.dg/gomp/udr2.f90: New test.
	* gfortran.dg/gomp/udr3.f90: New test.
	* gfortran.dg/gomp/udr4.f90: New test.
	* gfortran.dg/gomp/udr5.f90: New test.
	* gfortran.dg/gomp/udr6.f90: New test.
	* gfortran.dg/gomp/udr7.f90: New test.
libgomp/
	* testsuite/libgomp.fortran/simd1.f90: New test.
	* testsuite/libgomp.fortran/udr1.f90: New test.
	* testsuite/libgomp.fortran/udr2.f90: New test.
	* testsuite/libgomp.fortran/udr3.f90: New test.
	* testsuite/libgomp.fortran/udr4.f90: New test.
	* testsuite/libgomp.fortran/udr5.f90: New test.
	* testsuite/libgomp.fortran/udr6.f90: New test.
	* testsuite/libgomp.fortran/udr7.f90: New test.
	* testsuite/libgomp.fortran/udr8.f90: New test.
	* testsuite/libgomp.fortran/udr9.f90: New test.
	* testsuite/libgomp.fortran/udr10.f90: New test.
	* testsuite/libgomp.fortran/udr11.f90: New test.

From-SVN: r211303

1 files changed, 295 insertions, 2 deletions

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8b374a2..261c904 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -82,7 +82,7 @@ along with GCC; see the file COPYING3.  If not see
 
 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
    recognized.  */
-#define MOD_VERSION "12"
+#define MOD_VERSION "13"
 
 
 /* Structure that describes a position within a module file.  */
@@ -3896,6 +3896,98 @@ mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
 }
 
 
+static const mstring omp_declare_reduction_stmt[] =
+{
+    minit ("ASSIGN", 0),
+    minit ("CALL", 1),
+    minit (NULL, -1)
+};
+
+
+static void
+mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
+		  gfc_namespace *ns, bool is_initializer)
+{
+  if (iomode == IO_OUTPUT)
+    {
+      if ((*sym1)->module == NULL)
+	{
+	  (*sym1)->module = module_name;
+	  (*sym2)->module = module_name;
+	}
+      mio_symbol_ref (sym1);
+      mio_symbol_ref (sym2);
+      if (ns->code->op == EXEC_ASSIGN)
+	{
+	  mio_name (0, omp_declare_reduction_stmt);
+	  mio_expr (&ns->code->expr1);
+	  mio_expr (&ns->code->expr2);
+	}
+      else
+	{
+	  int flag;
+	  mio_name (1, omp_declare_reduction_stmt);
+	  mio_symtree_ref (&ns->code->symtree);
+	  mio_actual_arglist (&ns->code->ext.actual);
+
+	  flag = ns->code->resolved_isym != NULL;
+	  mio_integer (&flag);
+	  if (flag)
+	    write_atom (ATOM_STRING, ns->code->resolved_isym->name);
+	  else
+	    mio_symbol_ref (&ns->code->resolved_sym);
+	}
+    }
+  else
+    {
+      pointer_info *p1 = mio_symbol_ref (sym1);
+      pointer_info *p2 = mio_symbol_ref (sym2);
+      gfc_symbol *sym;
+      gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
+      gcc_assert (p1->u.rsym.sym == NULL);
+      /* Add hidden symbols to the symtree.  */
+      pointer_info *q = get_integer (p1->u.rsym.ns);
+      q->u.pointer = (void *) ns;
+      sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
+      sym->ts = udr->ts;
+      sym->module = gfc_get_string (p1->u.rsym.module);
+      associate_integer_pointer (p1, sym);
+      sym->attr.omp_udr_artificial_var = 1;
+      gcc_assert (p2->u.rsym.sym == NULL);
+      sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
+      sym->ts = udr->ts;
+      sym->module = gfc_get_string (p2->u.rsym.module);
+      associate_integer_pointer (p2, sym);
+      sym->attr.omp_udr_artificial_var = 1;
+      if (mio_name (0, omp_declare_reduction_stmt) == 0)
+	{
+	  ns->code = gfc_get_code (EXEC_ASSIGN);
+	  mio_expr (&ns->code->expr1);
+	  mio_expr (&ns->code->expr2);
+	}
+      else
+	{
+	  int flag;
+	  ns->code = gfc_get_code (EXEC_CALL);
+	  mio_symtree_ref (&ns->code->symtree);
+	  mio_actual_arglist (&ns->code->ext.actual);
+
+	  mio_integer (&flag);
+	  if (flag)
+	    {
+	      require_atom (ATOM_STRING);
+	      ns->code->resolved_isym = gfc_find_subroutine (atom_string);
+	      free (atom_string);
+	    }
+	  else
+	    mio_symbol_ref (&ns->code->resolved_sym);
+	}
+      ns->code->loc = gfc_current_locus;
+      ns->omp_udr_ns = 1;
+    }
+}
+
+
 /* Unlike most other routines, the address of the symbol node is already
    fixed on input and the name/module has already been filled in.
    If you update the symbol format here, don't forget to update read_module
@@ -4453,6 +4545,119 @@ load_derived_extensions (void)
 }
 
 
+/* This function loads OpenMP user defined reductions.  */
+static void
+load_omp_udrs (void)
+{
+  mio_lparen ();
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      const char *name, *newname;
+      char *altname;
+      gfc_typespec ts;
+      gfc_symtree *st;
+      gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
+
+      mio_lparen ();
+      mio_pool_string (&name);
+      mio_typespec (&ts);
+      if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
+	{
+	  const char *p = name + sizeof ("operator ") - 1;
+	  if (strcmp (p, "+") == 0)
+	    rop = OMP_REDUCTION_PLUS;
+	  else if (strcmp (p, "*") == 0)
+	    rop = OMP_REDUCTION_TIMES;
+	  else if (strcmp (p, "-") == 0)
+	    rop = OMP_REDUCTION_MINUS;
+	  else if (strcmp (p, ".and.") == 0)
+	    rop = OMP_REDUCTION_AND;
+	  else if (strcmp (p, ".or.") == 0)
+	    rop = OMP_REDUCTION_OR;
+	  else if (strcmp (p, ".eqv.") == 0)
+	    rop = OMP_REDUCTION_EQV;
+	  else if (strcmp (p, ".neqv.") == 0)
+	    rop = OMP_REDUCTION_NEQV;
+	}
+      altname = NULL;
+      if (rop == OMP_REDUCTION_USER && name[0] == '.')
+	{
+	  size_t len = strlen (name + 1);
+	  altname = XALLOCAVEC (char, len);
+	  gcc_assert (name[len] == '.');
+	  memcpy (altname, name + 1, len - 1);
+	  altname[len - 1] = '\0';
+	}
+      newname = name;
+      if (rop == OMP_REDUCTION_USER)
+	newname = find_use_name (altname ? altname : name, !!altname);
+      else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
+	newname = NULL;
+      if (newname == NULL)
+	{
+	  skip_list (1);
+	  continue;
+	}
+      if (altname && newname != altname)
+	{
+	  size_t len = strlen (newname);
+	  altname = XALLOCAVEC (char, len + 3);
+	  altname[0] = '.';
+	  memcpy (altname + 1, newname, len);
+	  altname[len + 1] = '.';
+	  altname[len + 2] = '\0';
+	  name = gfc_get_string (altname);
+	}
+      st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
+      gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
+      if (udr)
+	{
+	  require_atom (ATOM_INTEGER);
+	  pointer_info *p = get_integer (atom_int);
+	  if (strcmp (p->u.rsym.module, udr->omp_out->module))
+	    {
+	      gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
+			 "module %s at %L",
+			 p->u.rsym.module, &gfc_current_locus);
+	      gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
+			 "%s at %L",
+			 udr->omp_out->module, &udr->where);
+	    }
+	  skip_list (1);
+	  continue;
+	}
+      udr = gfc_get_omp_udr ();
+      udr->name = name;
+      udr->rop = rop;
+      udr->ts = ts;
+      udr->where = gfc_current_locus;
+      udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
+      udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
+      mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
+			false);
+      if (peek_atom () != ATOM_RPAREN)
+	{
+	  udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
+	  udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
+	  mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
+			    udr->initializer_ns, true);
+	}
+      if (st)
+	{
+	  udr->next = st->n.omp_udr;
+	  st->n.omp_udr = udr;
+	}
+      else
+	{
+	  st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
+	  st->n.omp_udr = udr;
+	}
+      mio_rparen ();
+    }
+  mio_rparen ();
+}
+
+
 /* Recursive function to traverse the pointer_info tree and load a
    needed symbol.  We return nonzero if we load a symbol and stop the
    traversal, because the act of loading can alter the tree.  */
@@ -4640,7 +4845,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
 static void
 read_module (void)
 {
-  module_locus operator_interfaces, user_operators, extensions;
+  module_locus operator_interfaces, user_operators, extensions, omp_udrs;
   const char *p;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   int i;
@@ -4664,6 +4869,10 @@ read_module (void)
   get_module_locus (&extensions);
   skip_list ();
 
+  /* Skip OpenMP UDRs.  */
+  get_module_locus (&omp_udrs);
+  skip_list ();
+
   mio_lparen ();
 
   /* Create the fixup nodes for all the symbols.  */
@@ -4929,6 +5138,10 @@ read_module (void)
   load_commons ();
   load_equiv ();
 
+  /* Load OpenMP user defined reductions.  */
+  set_module_locus (&omp_udrs);
+  load_omp_udrs ();
+
   /* At this point, we read those symbols that are needed but haven't
      been loaded yet.  If one symbol requires another, the other gets
      marked as NEEDED if its previous state was UNUSED.  */
@@ -5307,6 +5520,80 @@ write_symbol0 (gfc_symtree *st)
 }
 
 
+static void
+write_omp_udr (gfc_omp_udr *udr)
+{
+  switch (udr->rop)
+    {
+    case OMP_REDUCTION_USER:
+      /* Non-operators can't be used outside of the module.  */
+      if (udr->name[0] != '.')
+	return;
+      else
+	{
+	  gfc_symtree *st;
+	  size_t len = strlen (udr->name + 1);
+	  char *name = XALLOCAVEC (char, len);
+	  memcpy (name, udr->name, len - 1);
+	  name[len - 1] = '\0';
+	  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+	  /* If corresponding user operator is private, don't write
+	     the UDR.  */
+	  if (st != NULL)
+	    {
+	      gfc_user_op *uop = st->n.uop;
+	      if (!check_access (uop->access, uop->ns->default_access))
+		return;
+	    }
+	}
+      break;
+    case OMP_REDUCTION_PLUS:
+    case OMP_REDUCTION_MINUS:
+    case OMP_REDUCTION_TIMES:
+    case OMP_REDUCTION_AND:
+    case OMP_REDUCTION_OR:
+    case OMP_REDUCTION_EQV:
+    case OMP_REDUCTION_NEQV:
+      /* If corresponding operator is private, don't write the UDR.  */
+      if (!check_access (gfc_current_ns->operator_access[udr->rop],
+			 gfc_current_ns->default_access))
+	return;
+      break;
+    default:
+      break;
+    }
+  if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
+    {
+      /* If derived type is private, don't write the UDR.  */
+      if (!gfc_check_symbol_access (udr->ts.u.derived))
+	return;
+    }
+
+  mio_lparen ();
+  mio_pool_string (&udr->name);
+  mio_typespec (&udr->ts);
+  mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
+  if (udr->initializer_ns)
+    mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
+		      udr->initializer_ns, true);
+  mio_rparen ();
+}
+
+
+static void
+write_omp_udrs (gfc_symtree *st)
+{
+  if (st == NULL)
+    return;
+
+  write_omp_udrs (st->left);
+  gfc_omp_udr *udr;
+  for (udr = st->n.omp_udr; udr; udr = udr->next)
+    write_omp_udr (udr);
+  write_omp_udrs (st->right);
+}
+
+
 /* Type for the temporary tree used when writing secondary symbols.  */
 
 struct sorted_pointer_info
@@ -5555,6 +5842,12 @@ write_module (void)
   write_char ('\n');
   write_char ('\n');
 
+  mio_lparen ();
+  write_omp_udrs (gfc_current_ns->omp_udr_root);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
   /* Write symbol information.  First we traverse all symbols in the
      primary namespace, writing those that need to be written.
      Sometimes writing one symbol will cause another to need to be