aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ChangeLog20
-rw-r--r--gcc/fortran/ChangeLog42
-rw-r--r--gcc/fortran/dump-parse-tree.c2
-rw-r--r--gcc/fortran/f95-lang.c7
-rw-r--r--gcc/fortran/gfortran.h12
-rw-r--r--gcc/fortran/match.c8
-rw-r--r--gcc/fortran/module.c41
-rw-r--r--gcc/fortran/openmp.c170
-rw-r--r--gcc/fortran/resolve.c32
-rw-r--r--gcc/fortran/trans-openmp.c183
-rw-r--r--gcc/gimplify.c39
-rw-r--r--gcc/omp-low.c17
-rw-r--r--gcc/testsuite/ChangeLog8
-rw-r--r--gcc/testsuite/gfortran.dg/gomp/udr2.f9010
-rw-r--r--gcc/testsuite/gfortran.dg/gomp/udr4.f9014
-rw-r--r--gcc/testsuite/gfortran.dg/gomp/udr8.f90351
-rw-r--r--gcc/tree-nested.c167
17 files changed, 902 insertions, 221 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog
index 567c09a6..d99680a 100644
--- a/gcc/ChangeLog
+++ b/gcc/ChangeLog
@@ -1,3 +1,23 @@
+2014-06-24 Jakub Jelinek <jakub@redhat.com>
+
+ * gimplify.c (gimplify_scan_omp_clauses) <case OMP_CLAUSE_MAP,
+ OMP_CLAUSE_TO, OMP_CLAUSE_FROM): Make sure OMP_CLAUSE_SIZE is
+ non-NULL.
+ <case OMP_CLAUSE_ALIGNED>: Gimplify OMP_CLAUSE_ALIGNED_ALIGNMENT.
+ (gimplify_adjust_omp_clauses_1): Make sure OMP_CLAUSE_SIZE is
+ non-NULL.
+ (gimplify_adjust_omp_clauses): Likewise.
+ * omp-low.c (lower_rec_simd_input_clauses,
+ lower_rec_input_clauses, expand_omp_simd): Handle non-constant
+ safelen the same as safelen(1).
+ * tree-nested.c (convert_nonlocal_omp_clauses,
+ convert_local_omp_clauses): Handle OMP_CLAUSE_ALIGNED. For
+ OMP_CLAUSE_{MAP,TO,FROM} if not decl use walk_tree.
+ (convert_nonlocal_reference_stmt, convert_local_reference_stmt):
+ Fixup handling of GIMPLE_OMP_TARGET.
+ (convert_tramp_reference_stmt, convert_gimple_call): Handle
+ GIMPLE_OMP_TARGET.
+
2014-06-24 Chung-Lin Tang <cltang@codesourcery.com>
PR tree-optimization/61554
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 05df7c1..57c5f8f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,45 @@
+2014-06-24 Jakub Jelinek <jakub@redhat.com>
+
+ * dump-parse-tree.c (show_omp_namelist): Use n->udr->udr instead
+ of n->udr.
+ * f95-lang.c (gfc_init_builtin_functions): Initialize
+ BUILT_IN_ASSUME_ALIGNED.
+ * gfortran.h (gfc_omp_namelist): Change udr field type to
+ struct gfc_omp_namelist_udr.
+ (gfc_omp_namelist_udr): New type.
+ (gfc_get_omp_namelist_udr): Define.
+ (gfc_resolve_code): New prototype.
+ * match.c (gfc_free_omp_namelist): Free name->udr.
+ * module.c (intrinsics): Add INTRINSIC_USER.
+ (fix_mio_expr): Likewise.
+ (mio_expr): Handle INSTRINSIC_USER and non-resolved EXPR_FUNCTION.
+ * openmp.c (gfc_match_omp_clauses): Adjust initialization of n->udr.
+ (gfc_match_omp_declare_reduction): Treat len=: the same as len=*.
+ Set attr.flavor on omp_{out,in,priv,orig} artificial variables.
+ (struct resolve_omp_udr_callback_data): New type.
+ (resolve_omp_udr_callback, resolve_omp_udr_callback2,
+ resolve_omp_udr_clause): New functions.
+ (resolve_omp_clauses): Adjust for n->udr changes, resolve UDR clauses
+ here.
+ (omp_udr_callback): Don't check for implicitly declared functions
+ here.
+ (gfc_resolve_omp_udr): Don't call gfc_resolve. Don't check for
+ implicitly declared subroutines here.
+ * resolve.c (resolve_function): If value.function.isym is non-NULL,
+ consider it already resolved.
+ (resolve_code): Renamed to ...
+ (gfc_resolve_code): ... this. No longer static.
+ (gfc_resolve_blocks, generate_component_assignments, resolve_codes):
+ Adjust callers.
+ * trans-openmp.c (gfc_omp_privatize_by_reference): Don't privatize
+ by reference type (C_PTR) variables.
+ (gfc_omp_finish_clause): Make sure OMP_CLAUSE_SIZE is non-NULL.
+ (gfc_trans_omp_udr_expr): Remove.
+ (gfc_trans_omp_array_reduction_or_udr): Adjust for n->udr changes.
+ Don't call gfc_trans_omp_udr_expr, even for sym->attr.dimension
+ expand it as assignment or subroutine call. Don't initialize
+ value.function.isym.
+
2014-06-23 Tobias Burnus <burnus@net-b.de>
* trans-decl.c (gfc_trans_deferred_vars): Fix handling of
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index de942f8..19f83a9 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1040,7 +1040,7 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n)
case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
case OMP_REDUCTION_USER:
if (n->udr)
- fprintf (dumpfile, "%s:", n->udr->name);
+ fprintf (dumpfile, "%s:", n->udr->udr->name);
break;
default: break;
}
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index e41f61a..40f7f18 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -1082,6 +1082,13 @@ gfc_init_builtin_functions (void)
BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST);
TREE_THIS_VOLATILE (builtin_decl_explicit (BUILT_IN_TRAP)) = 1;
+ ftype = build_varargs_function_type_list (ptr_type_node, const_ptr_type_node,
+ size_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_assume_aligned", ftype,
+ BUILT_IN_ASSUME_ALIGNED,
+ "__builtin_assume_aligned",
+ ATTR_CONST_NOTHROW_LEAF_LIST);
+
gfc_define_builtin ("__emutls_get_address",
builtin_types[BT_FN_PTR_PTR],
BUILT_IN_EMUTLS_GET_ADDRESS,
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a11ca3d..1c4638f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1111,7 +1111,7 @@ typedef struct gfc_omp_namelist
gfc_omp_depend_op depend_op;
gfc_omp_map_op map_op;
} u;
- struct gfc_omp_udr *udr;
+ struct gfc_omp_namelist_udr *udr;
struct gfc_omp_namelist *next;
}
gfc_omp_namelist;
@@ -1237,6 +1237,15 @@ typedef struct gfc_omp_udr
gfc_omp_udr;
#define gfc_get_omp_udr() XCNEW (gfc_omp_udr)
+typedef struct gfc_omp_namelist_udr
+{
+ struct gfc_omp_udr *udr;
+ struct gfc_code *combiner;
+ struct gfc_code *initializer;
+}
+gfc_omp_namelist_udr;
+#define gfc_get_omp_namelist_udr() XCNEW (gfc_omp_namelist_udr)
+
/* The gfc_st_label structure is a BBT attached to a namespace that
records the usage of statement labels within that space. */
@@ -3011,6 +3020,7 @@ void gfc_free_association_list (gfc_association_list *);
/* resolve.c */
bool gfc_resolve_expr (gfc_expr *);
void gfc_resolve (gfc_namespace *);
+void gfc_resolve_code (gfc_code *, gfc_namespace *);
void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
int gfc_impure_variable (gfc_symbol *);
int gfc_pure (gfc_symbol *);
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 41915b4..b3f47a8 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4577,6 +4577,14 @@ gfc_free_omp_namelist (gfc_omp_namelist *name)
for (; name; name = n)
{
gfc_free_expr (name->expr);
+ if (name->udr)
+ {
+ if (name->udr->combiner)
+ gfc_free_statement (name->udr->combiner);
+ if (name->udr->initializer)
+ gfc_free_statement (name->udr->initializer);
+ free (name->udr);
+ }
n = name->next;
free (name);
}
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index bdd9961..ec67960 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3136,6 +3136,7 @@ static const mstring intrinsics[] =
minit ("LE", INTRINSIC_LE_OS),
minit ("NOT", INTRINSIC_NOT),
minit ("PARENTHESES", INTRINSIC_PARENTHESES),
+ minit ("USER", INTRINSIC_USER),
minit (NULL, -1)
};
@@ -3172,7 +3173,8 @@ fix_mio_expr (gfc_expr *e)
&& !e->symtree->n.sym->attr.dummy)
e->symtree = ns_st;
}
- else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
+ else if (e->expr_type == EXPR_FUNCTION
+ && (e->value.function.name || e->value.function.isym))
{
gfc_symbol *sym;
@@ -3287,6 +3289,32 @@ mio_expr (gfc_expr **ep)
mio_expr (&e->value.op.op2);
break;
+ case INTRINSIC_USER:
+ /* INTRINSIC_USER should not appear in resolved expressions,
+ though for UDRs we need to stream unresolved ones. */
+ if (iomode == IO_OUTPUT)
+ write_atom (ATOM_STRING, e->value.op.uop->name);
+ else
+ {
+ char *name = read_string ();
+ const char *uop_name = find_use_name (name, true);
+ if (uop_name == NULL)
+ {
+ size_t len = strlen (name);
+ char *name2 = XCNEWVEC (char, len + 2);
+ memcpy (name2, name, len);
+ name2[len] = ' ';
+ name2[len + 1] = '\0';
+ free (name);
+ uop_name = name = name2;
+ }
+ e->value.op.uop = gfc_get_uop (uop_name);
+ free (name);
+ }
+ mio_expr (&e->value.op.op1);
+ mio_expr (&e->value.op.op2);
+ break;
+
default:
bad_module ("Bad operator");
}
@@ -3305,6 +3333,8 @@ mio_expr (gfc_expr **ep)
flag = 1;
else if (e->ref)
flag = 2;
+ else if (e->value.function.isym == NULL)
+ flag = 3;
else
flag = 0;
mio_integer (&flag);
@@ -3316,6 +3346,8 @@ mio_expr (gfc_expr **ep)
case 2:
mio_ref_list (&e->ref);
break;
+ case 3:
+ break;
default:
write_atom (ATOM_STRING, e->value.function.isym->name);
}
@@ -3323,7 +3355,10 @@ mio_expr (gfc_expr **ep)
else
{
require_atom (ATOM_STRING);
- e->value.function.name = gfc_get_string (atom_string);
+ if (atom_string[0] == '\0')
+ e->value.function.name = NULL;
+ else
+ e->value.function.name = gfc_get_string (atom_string);
free (atom_string);
mio_integer (&flag);
@@ -3335,6 +3370,8 @@ mio_expr (gfc_expr **ep)
case 2:
mio_ref_list (&e->ref);
break;
+ case 3:
+ break;
default:
require_atom (ATOM_STRING);
e->value.function.isym = gfc_find_function (atom_string);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 266ac3d..68ba70f 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -486,7 +486,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask,
for (n = *head; n; n = n->next)
{
n->u.reduction_op = rop;
- n->udr = udr;
+ if (udr)
+ {
+ n->udr = gfc_get_omp_namelist_udr ();
+ n->udr->udr = udr;
+ }
}
continue;
}
@@ -1182,6 +1186,9 @@ gfc_match_omp_declare_reduction (void)
m = gfc_match_type_spec (&ts);
if (m != MATCH_YES)
return MATCH_ERROR;
+ /* Treat len=: the same as len=*. */
+ if (ts.type == BT_CHARACTER)
+ ts.deferred = false;
tss.safe_push (ts);
while (gfc_match_char (',') == MATCH_YES)
@@ -1219,6 +1226,8 @@ gfc_match_omp_declare_reduction (void)
omp_in->n.sym->ts = tss[i];
omp_out->n.sym->attr.omp_udr_artificial_var = 1;
omp_in->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_out->n.sym->attr.flavor = FL_VARIABLE;
+ omp_in->n.sym->attr.flavor = FL_VARIABLE;
gfc_commit_symbols ();
omp_udr->combiner_ns = combiner_ns;
omp_udr->omp_out = omp_out->n.sym;
@@ -1249,6 +1258,8 @@ gfc_match_omp_declare_reduction (void)
omp_orig->n.sym->ts = tss[i];
omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_priv->n.sym->attr.flavor = FL_VARIABLE;
+ omp_orig->n.sym->attr.flavor = FL_VARIABLE;
gfc_commit_symbols ();
omp_udr->initializer_ns = initializer_ns;
omp_udr->omp_priv = omp_priv->n.sym;
@@ -1900,6 +1911,104 @@ gfc_match_omp_end_single (void)
}
+struct resolve_omp_udr_callback_data
+{
+ gfc_symbol *sym1, *sym2;
+};
+
+
+static int
+resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
+{
+ struct resolve_omp_udr_callback_data *rcd
+ = (struct resolve_omp_udr_callback_data *) data;
+ if ((*e)->expr_type == EXPR_VARIABLE
+ && ((*e)->symtree->n.sym == rcd->sym1
+ || (*e)->symtree->n.sym == rcd->sym2))
+ {
+ gfc_ref *ref = gfc_get_ref ();
+ ref->type = REF_ARRAY;
+ ref->u.ar.where = (*e)->where;
+ ref->u.ar.as = (*e)->symtree->n.sym->as;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.dimen = 0;
+ ref->next = (*e)->ref;
+ (*e)->ref = ref;
+ }
+ return 0;
+}
+
+
+static int
+resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
+{
+ if ((*e)->expr_type == EXPR_FUNCTION
+ && (*e)->value.function.isym == NULL)
+ {
+ gfc_symbol *sym = (*e)->symtree->n.sym;
+ if (!sym->attr.intrinsic
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ gfc_error ("Implicitly declared function %s used in "
+ "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where);
+ }
+ return 0;
+}
+
+
+static gfc_code *
+resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
+ gfc_symbol *sym1, gfc_symbol *sym2)
+{
+ gfc_code *copy;
+ gfc_symbol sym1_copy, sym2_copy;
+
+ if (ns->code->op == EXEC_ASSIGN)
+ {
+ copy = gfc_get_code (EXEC_ASSIGN);
+ copy->expr1 = gfc_copy_expr (ns->code->expr1);
+ copy->expr2 = gfc_copy_expr (ns->code->expr2);
+ }
+ else
+ {
+ copy = gfc_get_code (EXEC_CALL);
+ copy->symtree = ns->code->symtree;
+ copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
+ }
+ copy->loc = ns->code->loc;
+ sym1_copy = *sym1;
+ sym2_copy = *sym2;
+ *sym1 = *n->sym;
+ *sym2 = *n->sym;
+ sym1->name = sym1_copy.name;
+ sym2->name = sym2_copy.name;
+ ns->proc_name = ns->parent->proc_name;
+ if (n->sym->attr.dimension)
+ {
+ struct resolve_omp_udr_callback_data rcd;
+ rcd.sym1 = sym1;
+ rcd.sym2 = sym2;
+ gfc_code_walker (&copy, gfc_dummy_code_callback,
+ resolve_omp_udr_callback, &rcd);
+ }
+ gfc_resolve_code (copy, gfc_current_ns);
+ if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
+ {
+ gfc_symbol *sym = copy->resolved_sym;
+ if (sym
+ && !sym->attr.intrinsic
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ gfc_error ("Implicitly declared subroutine %s used in "
+ "!$OMP DECLARE REDUCTION at %L ", sym->name,
+ &copy->loc);
+ }
+ gfc_code_walker (&copy, gfc_dummy_code_callback,
+ resolve_omp_udr_callback2, NULL);
+ *sym1 = sym1_copy;
+ *sym2 = sym2_copy;
+ return copy;
+}
+
+
/* OpenMP directive resolving routines. */
static void
@@ -2295,9 +2404,15 @@ resolve_omp_clauses (gfc_code *code, locus *where,
const char *udr_name = NULL;
if (n->udr)
{
- udr_name = n->udr->name;
- n->udr = gfc_find_omp_udr (NULL, udr_name,
- &n->sym->ts);
+ udr_name = n->udr->udr->name;
+ n->udr->udr
+ = gfc_find_omp_udr (NULL, udr_name,
+ &n->sym->ts);
+ if (n->udr->udr == NULL)
+ {
+ free (n->udr);
+ n->udr = NULL;
+ }
}
if (n->udr == NULL)
{
@@ -2337,7 +2452,20 @@ resolve_omp_clauses (gfc_code *code, locus *where,
gfc_typename (&n->sym->ts), where);
}
else
- n->u.reduction_op = OMP_REDUCTION_USER;
+ {
+ gfc_omp_udr *udr = n->udr->udr;
+ n->u.reduction_op = OMP_REDUCTION_USER;
+ n->udr->combiner
+ = resolve_omp_udr_clause (n, udr->combiner_ns,
+ udr->omp_out,
+ udr->omp_in);
+ if (udr->initializer_ns)
+ n->udr->initializer
+ = resolve_omp_udr_clause (n,
+ udr->initializer_ns,
+ udr->omp_priv,
+ udr->omp_orig);
+ }
}
break;
case OMP_LIST_LINEAR:
@@ -3317,15 +3445,6 @@ omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
&(*e)->where);
}
}
- else if ((*e)->expr_type == EXPR_FUNCTION
- && (*e)->value.function.isym == NULL)
- {
- gfc_symbol *sym = (*e)->symtree->n.sym;
- if (!sym->attr.intrinsic
- && sym->attr.if_source == IFSRC_UNKNOWN)
- gfc_error ("Implicitly declared function %s used in "
- "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where);
- }
return 0;
}
@@ -3337,9 +3456,6 @@ gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
gfc_actual_arglist *a;
const char *predef_name = NULL;
- gfc_resolve (omp_udr->combiner_ns);
- if (omp_udr->initializer_ns)
- gfc_resolve (omp_udr->initializer_ns);
switch (omp_udr->rop)
{
case OMP_REDUCTION_PLUS:
@@ -3394,16 +3510,6 @@ gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
gfc_error ("Subroutine call with alternate returns in combiner "
"of !$OMP DECLARE REDUCTION at %L",
&omp_udr->combiner_ns->code->loc);
- if (omp_udr->combiner_ns->code->resolved_isym == NULL)
- {
- gfc_symbol *sym = omp_udr->combiner_ns->code->resolved_sym;
- if (sym
- && !sym->attr.intrinsic
- && sym->attr.if_source == IFSRC_UNKNOWN)
- gfc_error ("Implicitly declared subroutine %s used in "
- "!$OMP DECLARE REDUCTION at %L ", sym->name,
- &omp_udr->combiner_ns->code->loc);
- }
}
if (omp_udr->initializer_ns)
{
@@ -3429,16 +3535,6 @@ gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
gfc_error ("One of actual subroutine arguments in INITIALIZER "
"clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
"at %L", &omp_udr->initializer_ns->code->loc);
- if (omp_udr->initializer_ns->code->resolved_isym == NULL)
- {
- gfc_symbol *sym = omp_udr->initializer_ns->code->resolved_sym;
- if (sym
- && !sym->attr.intrinsic
- && sym->attr.if_source == IFSRC_UNKNOWN)
- gfc_error ("Implicitly declared subroutine %s used in "
- "!$OMP DECLARE REDUCTION at %L ", sym->name,
- &omp_udr->initializer_ns->code->loc);
- }
}
}
else if (omp_udr->ts.type == BT_DERIVED
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 64f3489..48b3a40 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -40,7 +40,7 @@ typedef enum seq_type
seq_type;
/* Stack to keep track of the nesting of blocks as we move through the
- code. See resolve_branch() and resolve_code(). */
+ code. See resolve_branch() and gfc_resolve_code(). */
typedef struct code_stack
{
@@ -2887,7 +2887,8 @@ resolve_function (gfc_expr *expr)
/* See if function is already resolved. */
- if (expr->value.function.name != NULL)
+ if (expr->value.function.name != NULL
+ || expr->value.function.isym != NULL)
{
if (expr->ts.type == BT_UNKNOWN)
expr->ts = sym->ts;
@@ -4930,7 +4931,7 @@ resolve_variable (gfc_expr *e)
if (check_assumed_size_reference (sym, e))
return false;
- /* Deal with forward references to entries during resolve_code, to
+ /* Deal with forward references to entries during gfc_resolve_code, to
satisfy, at least partially, 12.5.2.5. */
if (gfc_current_ns->entries
&& current_entry_id == sym->entry_id
@@ -8979,8 +8980,6 @@ resolve_block_construct (gfc_code* code)
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
DO code nodes. */
-static void resolve_code (gfc_code *, gfc_namespace *);
-
void
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
@@ -9072,7 +9071,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
- resolve_code (b->next, ns);
+ gfc_resolve_code (b->next, ns);
}
}
@@ -9520,7 +9519,7 @@ nonscalar_typebound_assign (gfc_symbol *derived, int depth)
The pointer assignments are taken care of by the intrinsic
assignment of the structure itself. This function recursively adds
defined assignments where required. The recursion is accomplished
- by calling resolve_code.
+ by calling gfc_resolve_code.
When the lhs in a defined assignment has intent INOUT, we need a
temporary for the lhs. In pseudo-code:
@@ -9638,9 +9637,9 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
comp1, comp2, (*code)->loc);
/* Convert the assignment if there is a defined assignment for
- this type. Otherwise, using the call from resolve_code,
+ this type. Otherwise, using the call from gfc_resolve_code,
recurse into its components. */
- resolve_code (this_code, ns);
+ gfc_resolve_code (this_code, ns);
if (this_code->op == EXEC_ASSIGN_CALL)
{
@@ -9804,8 +9803,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
-static void
-resolve_code (gfc_code *code, gfc_namespace *ns)
+void
+gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
int forall_save, do_concurrent_save;
@@ -10091,7 +10090,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_DO_WHILE:
if (code->expr1 == NULL)
- gfc_internal_error ("resolve_code(): No expression on DO WHILE");
+ gfc_internal_error ("gfc_resolve_code(): No expression on "
+ "DO WHILE");
if (t
&& (code->expr1->rank != 0
|| code->expr1->ts.type != BT_LOGICAL))
@@ -10233,7 +10233,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
break;
default:
- gfc_internal_error ("resolve_code(): Bad statement code");
+ gfc_internal_error ("gfc_resolve_code(): Bad statement code");
}
}
@@ -14696,7 +14696,7 @@ gfc_resolve_uops (gfc_symtree *symtree)
assign types to all intermediate expressions, make sure that all
assignments are to compatible types and figure out which names
refer to which functions or subroutines. It doesn't check code
- block, which is handled by resolve_code. */
+ block, which is handled by gfc_resolve_code. */
static void
resolve_types (gfc_namespace *ns)
@@ -14785,7 +14785,7 @@ resolve_types (gfc_namespace *ns)
}
-/* Call resolve_code recursively. */
+/* Call gfc_resolve_code recursively. */
static void
resolve_codes (gfc_namespace *ns)
@@ -14811,7 +14811,7 @@ resolve_codes (gfc_namespace *ns)
old_obstack = labels_obstack;
bitmap_obstack_initialize (&labels_obstack);
- resolve_code (ns->code, ns);
+ gfc_resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);
labels_obstack = old_obstack;
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 7667f25..458cfff 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -53,11 +53,13 @@ gfc_omp_privatize_by_reference (const_tree decl)
if (TREE_CODE (type) == POINTER_TYPE)
{
/* Array POINTER/ALLOCATABLE have aggregate types, all user variables
- that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P
- set are supposed to be privatized by reference. */
+ that have POINTER_TYPE type and aren't scalar pointers, scalar
+ allocatables, Cray pointees or C pointers are supposed to be
+ privatized by reference. */
if (GFC_DECL_GET_SCALAR_POINTER (decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
- || GFC_DECL_CRAY_POINTEE (decl))
+ || GFC_DECL_CRAY_POINTEE (decl)
+ || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
return false;
if (!DECL_ARTIFICIAL (decl)
@@ -895,6 +897,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
OMP_CLAUSE_SIZE (c4) = size_int (0);
decl = build_fold_indirect_ref (decl);
OMP_CLAUSE_DECL (c) = decl;
+ OMP_CLAUSE_SIZE (c) = NULL_TREE;
}
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
{
@@ -956,6 +959,10 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
gimplify_and_add (stmt, pre_p);
}
tree last = c;
+ if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c)
+ = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
if (c2)
{
OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last);
@@ -1182,78 +1189,6 @@ omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
return 0;
}
-static tree
-gfc_trans_omp_udr_expr (gfc_omp_namelist *n, bool is_initializer,
- gfc_expr *syme, gfc_expr *outere)
-{
- gfc_se symse, outerse;
- gfc_ss *symss, *outerss;
- gfc_loopinfo loop;
- stmtblock_t block, body;
- tree tem;
- int i;
- gfc_namespace *ns = (is_initializer
- ? n->udr->initializer_ns : n->udr->combiner_ns);
-
- syme = gfc_copy_expr (syme);
- outere = gfc_copy_expr (outere);
- gfc_init_se (&symse, NULL);
- gfc_init_se (&outerse, NULL);
- gfc_start_block (&block);
- gfc_init_loopinfo (&loop);
- symss = gfc_walk_expr (syme);
- outerss = gfc_walk_expr (outere);
- gfc_add_ss_to_loop (&loop, symss);
- gfc_add_ss_to_loop (&loop, outerss);
- gfc_conv_ss_startstride (&loop);
- /* Enable loop reversal. */
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
- loop.reverse[i] = GFC_ENABLE_REVERSE;
- gfc_conv_loop_setup (&loop, &ns->code->loc);
- gfc_copy_loopinfo_to_se (&symse, &loop);
- gfc_copy_loopinfo_to_se (&outerse, &loop);
- symse.ss = symss;
- outerse.ss = outerss;
- gfc_mark_ss_chain_used (symss, 1);
- gfc_mark_ss_chain_used (outerss, 1);
- gfc_start_scalarized_body (&loop, &body);
- gfc_conv_expr (&symse, syme);
- gfc_conv_expr (&outerse, outere);
-
- if (is_initializer)
- {
- n->udr->omp_priv->backend_decl = symse.expr;
- n->udr->omp_orig->backend_decl = outerse.expr;
- }
- else
- {
- n->udr->omp_out->backend_decl = outerse.expr;
- n->udr->omp_in->backend_decl = symse.expr;
- }
-
- if (ns->code->op == EXEC_ASSIGN)
- tem = gfc_trans_assignment (ns->code->expr1, ns->code->expr2,
- false, false);
- else
- tem = gfc_trans_call (ns->code, false, NULL_TREE, NULL_TREE, false);
- gfc_add_expr_to_block (&body, tem);
-
- gcc_assert (symse.ss == gfc_ss_terminator
- && outerse.ss == gfc_ss_terminator);
- /* Generate the copying loops. */
- gfc_trans_scalarizing_loops (&loop, &body);
-
- /* Wrap the whole thing up. */
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
-
- gfc_cleanup_loop (&loop);
- gfc_free_expr (syme);
- gfc_free_expr (outere);
-
- return gfc_finish_block (&block);
-}
-
static void
gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
{
@@ -1268,6 +1203,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
locus old_loc = gfc_current_locus;
const char *iname;
bool t;
+ gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL;
decl = OMP_CLAUSE_DECL (c);
gfc_current_locus = where;
@@ -1292,7 +1228,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
init_val_sym.attr.flavor = FL_VARIABLE;
if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK)
backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym));
- else if (n->udr->initializer_ns)
+ else if (udr->initializer_ns)
backend_decl = NULL;
else
switch (sym->ts.type)
@@ -1334,34 +1270,18 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
gcc_assert (symtree3 == root3);
memset (omp_var_copy, 0, sizeof omp_var_copy);
- if (n->udr)
+ if (udr)
{
- omp_var_copy[0] = *n->udr->omp_out;
- omp_var_copy[1] = *n->udr->omp_in;
- if (sym->attr.dimension)
- {
- n->udr->omp_out->ts = sym->ts;
- n->udr->omp_in->ts = sym->ts;
- }
- else
+ omp_var_copy[0] = *udr->omp_out;
+ omp_var_copy[1] = *udr->omp_in;
+ *udr->omp_out = outer_sym;
+ *udr->omp_in = *sym;
+ if (udr->initializer_ns)
{
- *n->udr->omp_out = outer_sym;
- *n->udr->omp_in = *sym;
- }
- if (n->udr->initializer_ns)
- {
- omp_var_copy[2] = *n->udr->omp_priv;
- omp_var_copy[3] = *n->udr->omp_orig;
- if (sym->attr.dimension)
- {
- n->udr->omp_priv->ts = sym->ts;
- n->udr->omp_orig->ts = sym->ts;
- }
- else
- {
- *n->udr->omp_priv = *sym;
- *n->udr->omp_orig = outer_sym;
- }
+ omp_var_copy[2] = *udr->omp_priv;
+ omp_var_copy[3] = *udr->omp_orig;
+ *udr->omp_priv = *sym;
+ *udr->omp_orig = outer_sym;
}
}
@@ -1394,7 +1314,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
t = gfc_resolve_expr (e2);
gcc_assert (t);
}
- else if (n->udr->initializer_ns == NULL)
+ else if (udr->initializer_ns == NULL)
{
gcc_assert (sym->ts.type == BT_DERIVED);
e2 = gfc_default_initializer (&sym->ts);
@@ -1402,21 +1322,18 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
t = gfc_resolve_expr (e2);
gcc_assert (t);
}
- else if (n->udr->initializer_ns->code->op == EXEC_ASSIGN)
+ else if (n->udr->initializer->op == EXEC_ASSIGN)
{
- if (!sym->attr.dimension)
- {
- e2 = gfc_copy_expr (n->udr->initializer_ns->code->expr2);
- t = gfc_resolve_expr (e2);
- gcc_assert (t);
- }
+ e2 = gfc_copy_expr (n->udr->initializer->expr2);
+ t = gfc_resolve_expr (e2);
+ gcc_assert (t);
}
- if (n->udr && n->udr->initializer_ns)
+ if (udr && udr->initializer_ns)
{
struct omp_udr_find_orig_data cd;
- cd.omp_udr = n->udr;
+ cd.omp_udr = udr;
cd.omp_orig_seen = false;
- gfc_code_walker (&n->udr->initializer_ns->code,
+ gfc_code_walker (&n->udr->initializer,
gfc_dummy_code_callback, omp_udr_find_orig, &cd);
if (cd.omp_orig_seen)
OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1;
@@ -1466,18 +1383,15 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
iname = "ieor";
break;
case ERROR_MARK:
- if (n->udr->combiner_ns->code->op == EXEC_ASSIGN)
+ if (n->udr->combiner->op == EXEC_ASSIGN)
{
- if (!sym->attr.dimension)
- {
- gfc_free_expr (e3);
- e3 = gfc_copy_expr (n->udr->combiner_ns->code->expr1);
- e4 = gfc_copy_expr (n->udr->combiner_ns->code->expr2);
- t = gfc_resolve_expr (e3);
- gcc_assert (t);
- t = gfc_resolve_expr (e4);
- gcc_assert (t);
- }
+ gfc_free_expr (e3);
+ e3 = gfc_copy_expr (n->udr->combiner->expr1);
+ e4 = gfc_copy_expr (n->udr->combiner->expr2);
+ t = gfc_resolve_expr (e3);
+ gcc_assert (t);
+ t = gfc_resolve_expr (e4);
+ gcc_assert (t);
}
break;
default:
@@ -1503,7 +1417,6 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
e4->expr_type = EXPR_FUNCTION;
e4->where = where;
e4->symtree = symtree4;
- e4->value.function.isym = gfc_find_function (iname);
e4->value.function.actual = gfc_get_actual_arglist ();
e4->value.function.actual->expr = e3;
e4->value.function.actual->next = gfc_get_actual_arglist ();
@@ -1522,10 +1435,8 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
pushlevel ();
if (e2)
stmt = gfc_trans_assignment (e1, e2, false, false);
- else if (sym->attr.dimension)
- stmt = gfc_trans_omp_udr_expr (n, true, e1, e3);
else
- stmt = gfc_trans_call (n->udr->initializer_ns->code, false,
+ stmt = gfc_trans_call (n->udr->initializer, false,
NULL_TREE, NULL_TREE, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
@@ -1537,10 +1448,8 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
pushlevel ();
if (e4)
stmt = gfc_trans_assignment (e3, e4, false, true);
- else if (sym->attr.dimension)
- stmt = gfc_trans_omp_udr_expr (n, false, e1, e3);
else
- stmt = gfc_trans_call (n->udr->combiner_ns->code, false,
+ stmt = gfc_trans_call (n->udr->combiner, false,
NULL_TREE, NULL_TREE, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
@@ -1566,14 +1475,14 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
if (outer_sym.as)
gfc_free_array_spec (outer_sym.as);
- if (n->udr)
+ if (udr)
{
- *n->udr->omp_out = omp_var_copy[0];
- *n->udr->omp_in = omp_var_copy[1];
- if (n->udr->initializer_ns)
+ *udr->omp_out = omp_var_copy[0];
+ *udr->omp_in = omp_var_copy[1];
+ if (udr->initializer_ns)
{
- *n->udr->omp_priv = omp_var_copy[2];
- *n->udr->omp_orig = omp_var_copy[3];
+ *udr->omp_priv = omp_var_copy[2];
+ *udr->omp_orig = omp_var_copy[3];
}
}
}
diff --git a/gcc/gimplify.c b/gcc/gimplify.c
index 338c5c0..21ddcf7 100644
--- a/gcc/gimplify.c
+++ b/gcc/gimplify.c
@@ -5993,14 +5993,21 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
goto do_add;
case OMP_CLAUSE_MAP:
- if (OMP_CLAUSE_SIZE (c)
- && gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
- NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
+ decl = OMP_CLAUSE_DECL (c);
+ if (error_operand_p (decl))
+ {
+ remove = true;
+ break;
+ }
+ if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
+ NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
{
remove = true;
break;
}
- decl = OMP_CLAUSE_DECL (c);
if (!DECL_P (decl))
{
if (gimplify_expr (&OMP_CLAUSE_DECL (c), pre_p,
@@ -6038,15 +6045,17 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
case OMP_CLAUSE_TO:
case OMP_CLAUSE_FROM:
- if (OMP_CLAUSE_SIZE (c)
- && gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
- NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
+ decl = OMP_CLAUSE_DECL (c);
+ if (error_operand_p (decl))
{
remove = true;
break;
}
- decl = OMP_CLAUSE_DECL (c);
- if (error_operand_p (decl))
+ if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
+ NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
{
remove = true;
break;
@@ -6221,6 +6230,12 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p,
remove = true;
break;
}
+ if (gimplify_expr (&OMP_CLAUSE_ALIGNED_ALIGNMENT (c), pre_p, NULL,
+ is_gimple_val, fb_rvalue) == GS_ERROR)
+ {
+ remove = true;
+ break;
+ }
if (!is_global_var (decl)
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
omp_add_variable (ctx, decl, GOVD_ALIGNED);
@@ -6350,6 +6365,8 @@ gimplify_adjust_omp_clauses_1 (splay_tree_node n, void *data)
OMP_CLAUSE_CHAIN (nc) = OMP_CLAUSE_CHAIN (clause);
OMP_CLAUSE_CHAIN (clause) = nc;
}
+ else
+ OMP_CLAUSE_SIZE (clause) = DECL_SIZE_UNIT (decl);
}
if (code == OMP_CLAUSE_FIRSTPRIVATE && (flags & GOVD_LASTPRIVATE) != 0)
{
@@ -6518,6 +6535,8 @@ gimplify_adjust_omp_clauses (gimple_seq *pre_p, tree *list_p)
OMP_CLAUSE_CHAIN (c) = nc;
c = nc;
}
+ else if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
break;
case OMP_CLAUSE_TO:
@@ -6542,6 +6561,8 @@ gimplify_adjust_omp_clauses (gimple_seq *pre_p, tree *list_p)
OMP_CLAUSE_SIZE (c), true);
}
}
+ else if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
break;
case OMP_CLAUSE_REDUCTION:
diff --git a/gcc/omp-low.c b/gcc/omp-low.c
index a30ce5a..adbd0eb 100644
--- a/gcc/omp-low.c
+++ b/gcc/omp-low.c
@@ -2996,8 +2996,10 @@ lower_rec_simd_input_clauses (tree new_var, omp_context *ctx, int &max_vf,
{
tree c = find_omp_clause (gimple_omp_for_clauses (ctx->stmt),
OMP_CLAUSE_SAFELEN);
- if (c
- && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c), max_vf) == -1)
+ if (c && TREE_CODE (OMP_CLAUSE_SAFELEN_EXPR (c)) != INTEGER_CST)
+ max_vf = 1;
+ else if (c && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c),
+ max_vf) == -1)
max_vf = tree_to_shwi (OMP_CLAUSE_SAFELEN_EXPR (c));
}
if (max_vf > 1)
@@ -3745,8 +3747,9 @@ lower_rec_input_clauses (tree clauses, gimple_seq *ilist, gimple_seq *dlist,
tree c = find_omp_clause (gimple_omp_for_clauses (ctx->stmt),
OMP_CLAUSE_SAFELEN);
if (c == NULL_TREE
- || compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c),
- max_vf) == 1)
+ || (TREE_CODE (OMP_CLAUSE_SAFELEN_EXPR (c)) == INTEGER_CST
+ && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c),
+ max_vf) == 1))
{
c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_SAFELEN);
OMP_CLAUSE_SAFELEN_EXPR (c) = build_int_cst (integer_type_node,
@@ -6900,8 +6903,10 @@ expand_omp_simd (struct omp_region *region, struct omp_for_data *fd)
else
{
safelen = OMP_CLAUSE_SAFELEN_EXPR (safelen);
- if (!tree_fits_uhwi_p (safelen)
- || tree_to_uhwi (safelen) > INT_MAX)
+ if (TREE_CODE (safelen) != INTEGER_CST)
+ loop->safelen = 0;
+ else if (!tree_fits_uhwi_p (safelen)
+ || tree_to_uhwi (safelen) > INT_MAX)
loop->safelen = INT_MAX;
else
loop->safelen = tree_to_uhwi (safelen);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e797c79..279d4ee 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,11 @@
+2014-06-24 Jakub Jelinek <jakub@redhat.com>
+
+ * gfortran.dg/gomp/udr2.f90 (f7, f9): Add !$omp parallel with
+ reduction clause.
+ * gfortran.dg/gomp/udr4.f90 (f4): Likewise.
+ Remove Label is never defined expected error.
+ * gfortran.dg/gomp/udr8.f90: New test.
+
2014-06-24 Markus Trippelsdorf <markus@trippelsdorf.de>
PR tree-optimization/61554
diff --git a/gcc/testsuite/gfortran.dg/gomp/udr2.f90 b/gcc/testsuite/gfortran.dg/gomp/udr2.f90
index 83fe6bd..7038d18 100644
--- a/gcc/testsuite/gfortran.dg/gomp/udr2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/udr2.f90
@@ -11,6 +11,10 @@ subroutine f7
!$omp declare reduction (bar:real:omp_out = omp_out.or.omp_in) ! { dg-error "Operands of logical operator" }
!$omp declare reduction (baz:real:omp_out = omp_out + omp_in)
!$omp & initializer (a (omp_priv, omp_orig)) ! { dg-error "Unclassifiable OpenMP directive" }
+ real :: r
+ r = 0.0
+!$omp parallel reduction (bar:r)
+!$omp end parallel
end subroutine f7
subroutine f8
interface
@@ -29,9 +33,15 @@ subroutine f9
integer :: x = 0
integer :: y = 0
end type dt
+ integer :: i
!$omp declare reduction (foo:integer:dt (omp_out, omp_in)) ! { dg-error "which is not consistent with the CALL" }
!$omp declare reduction (bar:integer:omp_out = omp_out + omp_in) &
!$omp & initializer (dt (omp_priv, omp_orig)) ! { dg-error "which is not consistent with the CALL" }
+ i = 0
+!$omp parallel reduction (foo : i)
+!$omp end parallel
+!$omp parallel reduction (bar : i)
+!$omp end parallel
end subroutine f9
subroutine f10
integer :: a, b
diff --git a/gcc/testsuite/gfortran.dg/gomp/udr4.f90 b/gcc/testsuite/gfortran.dg/gomp/udr4.f90
index 7e86a75..b48c109 100644
--- a/gcc/testsuite/gfortran.dg/gomp/udr4.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/udr4.f90
@@ -23,6 +23,18 @@ subroutine f4
!$omp & initializer(omp_priv = omp_in (omp_orig)) ! { dg-error "Implicitly declared function omp_in used" }
!$omp declare reduction (id2:real:omp_out=omp_out+omp_in) &
!$omp & initializer(omp_priv = baz (omp_orig)) ! { dg-error "Implicitly declared function baz used" }
+ integer :: i
+ real :: r
+ i = 0
+ r = 0
+!$omp parallel reduction (foo: i, r)
+!$omp end parallel
+!$omp parallel reduction (bar: i, r)
+!$omp end parallel
+!$omp parallel reduction (id1: i, r)
+!$omp end parallel
+!$omp parallel reduction (id2: i, r)
+!$omp end parallel
end subroutine f4
subroutine f5
interface
@@ -37,8 +49,6 @@ subroutine f5
!$omp & initializer (f5a (omp_priv, *20, omp_orig)) ! { dg-error "Subroutine call with alternate returns in INITIALIZER clause" }
10 continue
20 continue
-! { dg-error "Label\[^\n\r]* is never defined" "" { target *-*-* } 0 }
-! { dg-prune-output "<During initialization>" }
end subroutine f5
subroutine f6
integer :: a
diff --git a/gcc/testsuite/gfortran.dg/gomp/udr8.f90 b/gcc/testsuite/gfortran.dg/gomp/udr8.f90
new file mode 100644
index 0000000..e040b3d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/udr8.f90
@@ -0,0 +1,351 @@
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fopenmp" }
+
+module m
+contains
+ function fn1 (x, y)
+ integer, intent(in) :: x, y
+ integer :: fn1
+ fn1 = x + 2 * y
+ end function
+ subroutine sub1 (x, y)
+ integer, intent(in) :: y
+ integer, intent(out) :: x
+ x = y
+ end subroutine
+ function fn2 (x)
+ integer, intent(in) :: x
+ integer :: fn2
+ fn2 = x
+ end function
+ subroutine sub2 (x, y)
+ integer, intent(in) :: y
+ integer, intent(inout) :: x
+ x = x + y
+ end subroutine
+ function fn3 (x, y)
+ integer, intent(in) :: x(:), y(:)
+ integer :: fn3(lbound(x, 1):ubound(x, 1))
+ fn3 = x + 2 * y
+ end function
+ subroutine sub3 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(out) :: x(:)
+ x = y
+ end subroutine
+ function fn4 (x)
+ integer, intent(in) :: x(:)
+ integer :: fn4(lbound(x, 1):ubound(x, 1))
+ fn4 = x
+ end function
+ subroutine sub4 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(inout) :: x(:)
+ x = x + y
+ end subroutine
+ function fn5 (x, y)
+ integer, intent(in) :: x(10), y(10)
+ integer :: fn5(10)
+ fn5 = x + 2 * y
+ end function
+ subroutine sub5 (x, y)
+ integer, intent(in) :: y(10)
+ integer, intent(out) :: x(10)
+ x = y
+ end subroutine
+ function fn6 (x)
+ integer, intent(in) :: x(10)
+ integer :: fn6(10)
+ fn6 = x
+ end function
+ subroutine sub6 (x, y)
+ integer, intent(in) :: y(10)
+ integer, intent(inout) :: x(10)
+ x = x + y
+ end subroutine
+ function fn7 (x, y)
+ integer, allocatable, intent(in) :: x(:), y(:)
+ integer, allocatable :: fn7(:)
+ fn7 = x + 2 * y
+ end function
+ subroutine sub7 (x, y)
+ integer, allocatable, intent(in) :: y(:)
+ integer, allocatable, intent(out) :: x(:)
+ x = y
+ end subroutine
+ function fn8 (x)
+ integer, allocatable, intent(in) :: x(:)
+ integer, allocatable :: fn8(:)
+ fn8 = x
+ end function
+ subroutine sub8 (x, y)
+ integer, allocatable, intent(in) :: y(:)
+ integer, allocatable, intent(inout) :: x(:)
+ x = x + y
+ end subroutine
+end module
+subroutine test1
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test1
+subroutine test2
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) &
+!$omp & initializer (sub1 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn2 (omp_orig))
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test2
+subroutine test3
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test3
+subroutine test4
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) &
+!$omp & initializer (sub1 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn2 (omp_orig))
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test4
+subroutine test5
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) &
+!$omp & initializer (sub3 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn4 (omp_orig))
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test5
+subroutine test6
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test6
+subroutine test7
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) &
+!$omp & initializer (sub3 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn4 (omp_orig))
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test7
+subroutine test8
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test8
+subroutine test9
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) &
+!$omp & initializer (sub5 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn6 (omp_orig))
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test9
+subroutine test10
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test10
+subroutine test11
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) &
+!$omp & initializer (sub5 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn6 (omp_orig))
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test11
+subroutine test12
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test12
+subroutine test13
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" }
+!$omp & fn5 (omp_out, omp_in)) & ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+!$omp initializer (omp_priv = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" }
+!$omp & fn6 (omp_orig)) ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+ integer :: a(9)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test13
+subroutine test14
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test14
+subroutine test15
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test15
+subroutine test16
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) &
+!$omp & initializer (sub7 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn8 (omp_orig))
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test16
+subroutine test17
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test17
diff --git a/gcc/tree-nested.c b/gcc/tree-nested.c
index ea2fb72..5408fba 100644
--- a/gcc/tree-nested.c
+++ b/gcc/tree-nested.c
@@ -1151,8 +1151,29 @@ convert_nonlocal_omp_clauses (tree *pclauses, struct walk_stmt_info *wi)
goto do_decl_clause;
wi->val_only = true;
wi->is_lhs = false;
- convert_nonlocal_reference_op (&OMP_CLAUSE_DECL (clause),
- &dummy, wi);
+ walk_tree (&OMP_CLAUSE_DECL (clause), convert_nonlocal_reference_op,
+ wi, NULL);
+ break;
+
+ case OMP_CLAUSE_ALIGNED:
+ if (OMP_CLAUSE_ALIGNED_ALIGNMENT (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op
+ (&OMP_CLAUSE_ALIGNED_ALIGNMENT (clause), &dummy, wi);
+ }
+ /* Like do_decl_clause, but don't add any suppression. */
+ decl = OMP_CLAUSE_DECL (clause);
+ if (TREE_CODE (decl) == VAR_DECL
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ break;
+ if (decl_function_context (decl) != info->context)
+ {
+ OMP_CLAUSE_DECL (clause) = get_nonlocal_debug_decl (info, decl);
+ if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_PRIVATE)
+ need_chain = true;
+ }
break;
case OMP_CLAUSE_NOWAIT:
@@ -1353,10 +1374,42 @@ convert_nonlocal_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p,
break;
case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ save_suppress = info->suppress_expansion;
+ convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt),
+ wi);
+ info->suppress_expansion = save_suppress;
+ walk_body (convert_nonlocal_reference_stmt,
+ convert_nonlocal_reference_op, info,
+ gimple_omp_body_ptr (stmt));
+ break;
+ }
save_suppress = info->suppress_expansion;
- convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi);
+ if (convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt),
+ wi))
+ {
+ tree c, decl;
+ decl = get_chain_decl (info);
+ c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP);
+ OMP_CLAUSE_DECL (c) = decl;
+ OMP_CLAUSE_MAP_KIND (c) = OMP_CLAUSE_MAP_TO;
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
+ OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt);
+ gimple_omp_target_set_clauses (stmt, c);
+ }
+
+ save_local_var_chain = info->new_local_var_chain;
+ info->new_local_var_chain = NULL;
+
walk_body (convert_nonlocal_reference_stmt, convert_nonlocal_reference_op,
info, gimple_omp_body_ptr (stmt));
+
+ if (info->new_local_var_chain)
+ declare_vars (info->new_local_var_chain,
+ gimple_seq_first_stmt (gimple_omp_body (stmt)),
+ false);
+ info->new_local_var_chain = save_local_var_chain;
info->suppress_expansion = save_suppress;
break;
@@ -1728,10 +1781,35 @@ convert_local_omp_clauses (tree *pclauses, struct walk_stmt_info *wi)
goto do_decl_clause;
wi->val_only = true;
wi->is_lhs = false;
- convert_local_reference_op (&OMP_CLAUSE_DECL (clause),
- &dummy, wi);
+ walk_tree (&OMP_CLAUSE_DECL (clause), convert_local_reference_op,
+ wi, NULL);
break;
+ case OMP_CLAUSE_ALIGNED:
+ if (OMP_CLAUSE_ALIGNED_ALIGNMENT (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_local_reference_op
+ (&OMP_CLAUSE_ALIGNED_ALIGNMENT (clause), &dummy, wi);
+ }
+ /* Like do_decl_clause, but don't add any suppression. */
+ decl = OMP_CLAUSE_DECL (clause);
+ if (TREE_CODE (decl) == VAR_DECL
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ break;
+ if (decl_function_context (decl) == info->context
+ && !use_pointer_in_frame (decl))
+ {
+ tree field = lookup_field_for_decl (info, decl, NO_INSERT);
+ if (field)
+ {
+ OMP_CLAUSE_DECL (clause)
+ = get_local_debug_decl (info, decl, field);
+ need_frame = true;
+ }
+ }
+ break;
case OMP_CLAUSE_NOWAIT:
case OMP_CLAUSE_ORDERED:
@@ -1862,10 +1940,38 @@ convert_local_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p,
break;
case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ save_suppress = info->suppress_expansion;
+ convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi);
+ info->suppress_expansion = save_suppress;
+ walk_body (convert_local_reference_stmt, convert_local_reference_op,
+ info, gimple_omp_body_ptr (stmt));
+ break;
+ }
save_suppress = info->suppress_expansion;
- convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi);
- walk_body (convert_local_reference_stmt, convert_local_reference_op,
- info, gimple_omp_body_ptr (stmt));
+ if (convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi))
+ {
+ tree c;
+ (void) get_frame_type (info);
+ c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP);
+ OMP_CLAUSE_DECL (c) = info->frame_decl;
+ OMP_CLAUSE_MAP_KIND (c) = OMP_CLAUSE_MAP_TOFROM;
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (info->frame_decl);
+ OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt);
+ gimple_omp_target_set_clauses (stmt, c);
+ }
+
+ save_local_var_chain = info->new_local_var_chain;
+ info->new_local_var_chain = NULL;
+
+ walk_body (convert_local_reference_stmt, convert_local_reference_op, info,
+ gimple_omp_body_ptr (stmt));
+
+ if (info->new_local_var_chain)
+ declare_vars (info->new_local_var_chain,
+ gimple_seq_first_stmt (gimple_omp_body (stmt)), false);
+ info->new_local_var_chain = save_local_var_chain;
info->suppress_expansion = save_suppress;
break;
@@ -2166,6 +2272,13 @@ convert_tramp_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p,
break;
}
+ case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ *handled_ops_p = false;
+ return NULL_TREE;
+ }
+ /* FALLTHRU */
case GIMPLE_OMP_PARALLEL:
case GIMPLE_OMP_TASK:
{
@@ -2186,7 +2299,6 @@ convert_tramp_reference_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p,
default:
*handled_ops_p = false;
return NULL_TREE;
- break;
}
*handled_ops_p = true;
@@ -2258,6 +2370,42 @@ convert_gimple_call (gimple_stmt_iterator *gsi, bool *handled_ops_p,
info->static_chain_added |= save_static_chain_added;
break;
+ case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ walk_body (convert_gimple_call, NULL, info, gimple_omp_body_ptr (stmt));
+ break;
+ }
+ save_static_chain_added = info->static_chain_added;
+ info->static_chain_added = 0;
+ walk_body (convert_gimple_call, NULL, info, gimple_omp_body_ptr (stmt));
+ for (i = 0; i < 2; i++)
+ {
+ tree c, decl;
+ if ((info->static_chain_added & (1 << i)) == 0)
+ continue;
+ decl = i ? get_chain_decl (info) : info->frame_decl;
+ /* Don't add CHAIN.* or FRAME.* twice. */
+ for (c = gimple_omp_target_clauses (stmt);
+ c;
+ c = OMP_CLAUSE_CHAIN (c))
+ if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_MAP
+ && OMP_CLAUSE_DECL (c) == decl)
+ break;
+ if (c == NULL)
+ {
+ c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP);
+ OMP_CLAUSE_DECL (c) = decl;
+ OMP_CLAUSE_MAP_KIND (c)
+ = i ? OMP_CLAUSE_MAP_TO : OMP_CLAUSE_MAP_TOFROM;
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
+ OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt);
+ gimple_omp_target_set_clauses (stmt, c);
+ }
+ }
+ info->static_chain_added |= save_static_chain_added;
+ break;
+
case GIMPLE_OMP_FOR:
walk_body (convert_gimple_call, NULL, info,
gimple_omp_for_pre_body_ptr (stmt));
@@ -2265,7 +2413,6 @@ convert_gimple_call (gimple_stmt_iterator *gsi, bool *handled_ops_p,
case GIMPLE_OMP_SECTIONS:
case GIMPLE_OMP_SECTION:
case GIMPLE_OMP_SINGLE:
- case GIMPLE_OMP_TARGET:
case GIMPLE_OMP_TEAMS:
case GIMPLE_OMP_MASTER:
case GIMPLE_OMP_TASKGROUP:
generated by cgit v1.1 at 2025-05-28 17:24:34 +0000