+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
+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
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;
}
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,
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;
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. */
/* 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 *);
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);
}
minit ("LE", INTRINSIC_LE_OS),
minit ("NOT", INTRINSIC_NOT),
minit ("PARENTHESES", INTRINSIC_PARENTHESES),
+ minit ("USER", INTRINSIC_USER),
minit (NULL, -1)
};
&& !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;
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");
}
flag = 1;
else if (e->ref)
flag = 2;
+ else if (e->value.function.isym == NULL)
+ flag = 3;
else
flag = 0;
mio_integer (&flag);
case 2:
mio_ref_list (&e->ref);
break;
+ case 3:
+ break;
default:
write_atom (ATOM_STRING, e->value.function.isym->name);
}
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);
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);
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;
}
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)
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;
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;
}
+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 (©, 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,
+ ©->loc);
+ }
+ gfc_code_walker (©, gfc_dummy_code_callback,
+ resolve_omp_udr_callback2, NULL);
+ *sym1 = sym1_copy;
+ *sym2 = sym2_copy;
+ return copy;
+}
+
+
/* OpenMP directive resolving routines. */
static void
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)
{
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:
&(*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;
}
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:
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)
{
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
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
{
/* 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;
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
/* 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)
{
gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
- resolve_code (b->next, ns);
+ gfc_resolve_code (b->next, ns);
}
}
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:
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)
{
/* 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;
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))
break;
default:
- gfc_internal_error ("resolve_code(): Bad statement code");
+ gfc_internal_error ("gfc_resolve_code(): Bad statement code");
}
}
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)
}
-/* Call resolve_code recursively. */
+/* Call gfc_resolve_code recursively. */
static void
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;
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)
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)))
{
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);
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)
{
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;
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)
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;
}
}
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);
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;
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:
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 ();
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));
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));
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];
}
}
}
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,
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;
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);
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)
{
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:
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:
{
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)
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,
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);
+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
!$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
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
!$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
!$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
--- /dev/null
+! { 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
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:
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;
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:
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;
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:
{
default:
*handled_ops_p = false;
return NULL_TREE;
- break;
}
*handled_ops_p = true;
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));
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:
+2014-06-24 Jakub Jelinek <jakub@redhat.com>
+
+ * testsuite/libgomp.fortran/aligned1.f03: New test.
+ * testsuite/libgomp.fortran/nestedfn5.f90: New test.
+ * testsuite/libgomp.fortran/target7.f90: Surround loop spawning
+ tasks with !$omp parallel !$omp single.
+ * testsuite/libgomp.fortran/target8.f90: New test.
+ * testsuite/libgomp.fortran/udr4.f90 (foo UDR, bar UDR): Adjust
+ not to use trim in the combiner, instead call elemental function.
+ (fn): New elemental function.
+ * testsuite/libgomp.fortran/udr6.f90 (do_add, dp_add, dp_init):
+ Make elemental.
+ * testsuite/libgomp.fortran/udr7.f90 (omp_priv, omp_orig, omp_out,
+ omp_in): Likewise.
+ * testsuite/libgomp.fortran/udr12.f90: New test.
+ * testsuite/libgomp.fortran/udr13.f90: New test.
+ * testsuite/libgomp.fortran/udr14.f90: New test.
+ * testsuite/libgomp.fortran/udr15.f90: New test.
+
2014-06-18 Jakub Jelinek <jakub@redhat.com>
* omp_lib.f90.in (openmp_version): Set to 201307.
--- /dev/null
+! { dg-do run }
+! { dg-options "-fopenmp -fcray-pointer" }
+
+ use iso_c_binding, only : c_ptr, c_ptrdiff_t, c_loc
+ interface
+ subroutine foo (x, y, z, w)
+ use iso_c_binding, only : c_ptr
+ real, pointer :: x(:), y(:), w(:)
+ type(c_ptr) :: z
+ end subroutine
+ subroutine bar (x, y, z, w)
+ use iso_c_binding, only : c_ptr
+ real, pointer :: x(:), y(:), w(:)
+ type(c_ptr) :: z
+ end subroutine
+ subroutine baz (x, c)
+ real, pointer :: x(:)
+ real, allocatable :: c(:)
+ end subroutine
+ end interface
+ type dt
+ real, allocatable :: a(:)
+ end type
+ type (dt) :: b(64)
+ real, target :: a(4096+63)
+ real, pointer :: p(:), q(:), r(:), s(:)
+ real, allocatable :: c(:)
+ integer(c_ptrdiff_t) :: o
+ integer :: i
+ o = 64 - mod (loc (a), 64)
+ if (o == 64) o = 0
+ o = o / sizeof(0.0)
+ p => a(o + 1:o + 1024)
+ q => a(o + 1025:o + 2048)
+ r => a(o + 2049:o + 3072)
+ s => a(o + 3073:o + 4096)
+ do i = 1, 1024
+ p(i) = i
+ q(i) = i
+ r(i) = i
+ s(i) = i
+ end do
+ call foo (p, q, c_loc (r(1)), s)
+ do i = 1, 1024
+ if (p(i) /= i * i + 3 * i + 2) call abort
+ p(i) = i
+ end do
+ call bar (p, q, c_loc (r(1)), s)
+ do i = 1, 1024
+ if (p(i) /= i * i + 3 * i + 2) call abort
+ end do
+ ! Attempt to create 64-byte aligned allocatable
+ do i = 1, 64
+ allocate (c(1023 + i))
+ if (iand (loc (c(1)), 63) == 0) exit
+ deallocate (c)
+ allocate (b(i)%a(1023 + i))
+ allocate (c(1023 + i))
+ if (iand (loc (c(1)), 63) == 0) exit
+ deallocate (c)
+ end do
+ if (allocated (c)) then
+ do i = 1, 1024
+ c(i) = 2 * i
+ end do
+ call baz (p, c)
+ do i = 1, 1024
+ if (p(i) /= i * i + 5 * i + 2) call abort
+ end do
+ end if
+end
+subroutine foo (x, y, z, w)
+ use iso_c_binding, only : c_ptr, c_f_pointer
+ real, pointer :: x(:), y(:), w(:), p(:)
+ type(c_ptr) :: z
+ integer :: i
+ real :: pt(1024)
+ pointer (ip, pt)
+ ip = loc (w)
+!$omp simd aligned (x, y : 64)
+ do i = 1, 1024
+ x(i) = x(i) * y(i) + 2.0
+ end do
+!$omp simd aligned (x, z : 64) private (p)
+ do i = 1, 1024
+ call c_f_pointer (z, p, shape=[1024])
+ x(i) = x(i) + p(i)
+ end do
+!$omp simd aligned (x, ip : 64)
+ do i = 1, 1024
+ x(i) = x(i) + 2 * pt(i)
+ end do
+!$omp end simd
+end subroutine
+subroutine bar (x, y, z, w)
+ use iso_c_binding, only : c_ptr, c_f_pointer
+ real, pointer :: x(:), y(:), w(:), a(:), b(:)
+ type(c_ptr) :: z, c
+ integer :: i
+ real :: pt(1024)
+ pointer (ip, pt)
+ ip = loc (w)
+ a => x
+ b => y
+ c = z
+!$omp simd aligned (a, b : 64)
+ do i = 1, 1024
+ a(i) = a(i) * b(i) + 2.0
+ end do
+!$omp simd aligned (a, c : 64)
+ do i = 1, 1024
+ block
+ real, pointer :: p(:)
+ call c_f_pointer (c, p, shape=[1024])
+ a(i) = a(i) + p(i)
+ end block
+ end do
+!$omp simd aligned (a, ip : 64)
+ do i = 1, 1024
+ a(i) = a(i) + 2 * pt(i)
+ end do
+!$omp end simd
+end subroutine
+subroutine baz (x, c)
+ real, pointer :: x(:)
+ real, allocatable :: c(:)
+ integer :: i
+!$omp simd aligned (x, c : 64)
+ do i = 1, 1024
+ x(i) = x(i) + c(i)
+ end do
+!$omp end simd
+end subroutine baz
--- /dev/null
+! { dg-do run }
+
+ interface
+ subroutine bar (q)
+ integer :: q(19:)
+ end subroutine
+ end interface
+ integer :: q(7:15)
+ q(:) = 5
+ call bar (q)
+end
+subroutine bar (q)
+ use iso_c_binding, only: c_ptr, c_loc, c_int
+ integer :: a, b, c, d(2:3,4:5), q(19:), h, k, m, n, o, p
+ integer(c_int), target :: e(64)
+ type (c_ptr) :: f, g(64)
+ logical :: l
+ a = 1
+ b = 2
+ c = 3
+ d = 4
+ l = .false.
+ f = c_loc (e)
+ call foo
+contains
+ subroutine foo
+ use iso_c_binding, only: c_sizeof
+!$omp simd linear(a:2) linear(b:1)
+ do a = 1, 20, 2
+ b = b + 1
+ end do
+!$omp end simd
+ if (a /= 21 .or. b /= 12) call abort
+!$omp simd aligned(f : c_sizeof (e(1)))
+ do b = 1, 64
+ g(b) = f
+ end do
+!$omp end simd
+!$omp parallel
+!$omp single
+!$omp taskgroup
+!$omp task depend(out : a, d(2:2,4:5))
+ a = a + 1
+ d(2:2,4:5) = d(2:2,4:5) + 1
+!$omp end task
+!$omp task depend(in : a, d(2:2,4:5))
+ if (a /= 22) call abort
+ if (any (d(2:2,4:5) /= 5)) call abort
+!$omp end task
+!$omp end taskgroup
+!$omp end single
+!$omp end parallel
+ b = 10
+!$omp target data map (tofrom: a, d(2:3,4:4), q) map (from: l)
+!$omp target map (tofrom: b, d(2:3,4:4))
+ l = .false.
+ if (a /= 22 .or. any (q /= 5)) l = .true.
+ if (lbound (q, 1) /= 19 .or. ubound (q, 1) /= 27) l = .true.
+ if (d(2,4) /= 5 .or. d(3,4) /= 4) l = .true.
+ l = l .or. (b /= 10)
+ a = 6
+ b = 11
+ q = 8
+ d(2:3,4:4) = 9
+!$omp end target
+!$omp target update from (a, q, d(2:3,4:4), l)
+ if (a /= 6 .or. l .or. b /= 11 .or. any (q /= 8)) call abort
+ if (any (d(2:3,4:4) /= 9) .or. d(2,5) /= 5 .or. d(3,5) /= 4) call abort
+ a = 12
+ b = 13
+ q = 14
+ d = 15
+!$omp target update to (a, q, d(2:3,4:4))
+!$omp target map (tofrom: b, d(2:3,4:4))
+ if (a /= 12 .or. b /= 13 .or. any (q /= 14)) l = .true.
+ l = l .or. any (d(2:3,4:4) /= 15)
+!$omp end target
+ a = 0
+ b = 1
+ c = 100
+ h = 8
+ m = 0
+ n = 64
+ o = 16
+ if (l) call abort
+!$omp target teams distribute parallel do simd if (.not.l) device(a) &
+!$omp & num_teams(b) dist_schedule(static, c) num_threads (h) &
+!$omp & reduction (+: m) safelen (n) schedule(static, o)
+ do p = 1, 64
+ m = m + 1
+ end do
+!$omp end target teams distribute parallel do simd
+ if (m /= 64) call abort
+!$omp end target data
+ end subroutine foo
+end subroutine bar
do i = 1, n
a(i) = i
end do
+ !$omp parallel
+ !$omp single
do i = 1, n, c
!$omp task shared(a)
!$omp target map(a(i:i+c-1))
!$omp end target
!$omp end task
end do
+ !$omp end single
+ !$omp end parallel
do i = 1, n
if (a(i) /= i + 1) call abort
end do
--- /dev/null
+! { dg-do run }
+
+ integer, parameter :: n = 1000
+ integer, parameter :: c = 100
+ integer :: i, j
+ real :: a(n)
+ do i = 1, n
+ a(i) = i
+ end do
+ !$omp parallel
+ !$omp single
+ do i = 1, n, c
+ !$omp task shared(a)
+ !$omp target map(a(i:i+c-1))
+ !$omp parallel do
+ do j = i, i + c - 1
+ a(j) = foo (a(j))
+ end do
+ !$omp end target
+ !$omp end task
+ end do
+ !$omp end single
+ !$omp end parallel
+ do i = 1, n
+ if (a(i) /= i + 1) call abort
+ end do
+contains
+ real function foo (x)
+ !$omp declare target
+ real, intent(in) :: x
+ foo = x + 1
+ end function foo
+end
--- /dev/null
+! { dg-do run }
+
+ interface
+ elemental subroutine sub1 (x, y)
+ integer, intent(in) :: y
+ integer, intent(out) :: x
+ end subroutine
+ elemental function fn2 (x)
+ integer, intent(in) :: x
+ integer :: fn2
+ end function
+ end interface
+!$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))
+ interface
+ elemental function fn1 (x, y)
+ integer, intent(in) :: x, y
+ integer :: fn1
+ end function
+ elemental subroutine sub2 (x, y)
+ integer, intent(in) :: y
+ integer, intent(inout) :: x
+ end subroutine
+ end interface
+ integer :: a(10), b, r
+ a(:) = 0
+ b = 0
+ r = 0
+!$omp parallel reduction (foo : a, b) reduction (+: r)
+ a = a + 2
+ b = b + 3
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 2 * r) .or. b /= 3 * r) call abort
+ a(:) = 0
+ b = 0
+ r = 0
+!$omp parallel reduction (bar : a, b) reduction (+: r)
+ a = a + 2
+ b = b + 3
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 4 * r) .or. b /= 6 * r) call abort
+ a(:) = 0
+ b = 0
+ r = 0
+!$omp parallel reduction (baz : a, b) reduction (+: r)
+ a = a + 2
+ b = b + 3
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 2 * r) .or. b /= 3 * r) call abort
+end
+elemental function fn1 (x, y)
+ integer, intent(in) :: x, y
+ integer :: fn1
+ fn1 = x + 2 * y
+end function
+elemental subroutine sub1 (x, y)
+ integer, intent(in) :: y
+ integer, intent(out) :: x
+ x = 0
+end subroutine
+elemental function fn2 (x)
+ integer, intent(in) :: x
+ integer :: fn2
+ fn2 = x
+end function
+elemental subroutine sub2 (x, y)
+ integer, intent(inout) :: x
+ integer, intent(in) :: y
+ x = x + y
+end subroutine
--- /dev/null
+! { dg-do run }
+
+ interface
+ subroutine sub1 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(out) :: x(:)
+ end subroutine
+ function fn2 (x, m1, m2, n1, n2)
+ integer, intent(in) :: x(:,:), m1, m2, n1, n2
+ integer :: fn2(m1:m2,n1:n2)
+ end function
+ subroutine sub3 (x, y)
+ integer, allocatable, intent(in) :: y(:,:)
+ integer, allocatable, intent(inout) :: x(:,:)
+ end subroutine
+ end interface
+!$omp declare reduction (foo : integer : sub3 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn3 (omp_orig))
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in, &
+!$omp & lbound (omp_out, 1), ubound (omp_out, 1))) &
+!$omp & initializer (sub1 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn2 (omp_orig, lbound (omp_priv, 1), &
+!$omp ubound (omp_priv, 1), lbound (omp_priv, 2), ubound (omp_priv, 2)))
+ interface
+ function fn1 (x, y, m1, m2)
+ integer, intent(in) :: x(:), y(:), m1, m2
+ integer :: fn1(m1:m2)
+ end function
+ subroutine sub2 (x, y)
+ integer, intent(in) :: y(:,:)
+ integer, intent(inout) :: x(:,:)
+ end subroutine
+ function fn3 (x)
+ integer, allocatable, intent(in) :: x(:,:)
+ integer, allocatable :: fn3(:,:)
+ end function
+ end interface
+ integer :: a(10), b(3:5,7:9), r
+ integer, allocatable :: c(:,:)
+ a(:) = 0
+ r = 0
+!$omp parallel reduction (bar : a) reduction (+: r)
+ if (lbound (a, 1) /= 1 .or. ubound (a, 1) /= 10) call abort
+ a = a + 2
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 4 * r) ) call abort
+ b(:,:) = 0
+ allocate (c (4:6,8:10))
+ c(:,:) = 0
+ r = 0
+!$omp parallel reduction (baz : b, c) reduction (+: r)
+ if (lbound (b, 1) /= 3 .or. ubound (b, 1) /= 5) call abort
+ if (lbound (b, 2) /= 7 .or. ubound (b, 2) /= 9) call abort
+ if (.not. allocated (c)) call abort
+ if (lbound (c, 1) /= 4 .or. ubound (c, 1) /= 6) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 10) call abort
+ b = b + 3
+ c = c + 4
+ r = r + 1
+!$omp end parallel
+ if (any (b /= 3 * r) .or. any (c /= 4 * r)) call abort
+ deallocate (c)
+ allocate (c (0:1,7:11))
+ c(:,:) = 0
+ r = 0
+!$omp parallel reduction (foo : c) reduction (+: r)
+ if (.not. allocated (c)) call abort
+ if (lbound (c, 1) /= 0 .or. ubound (c, 1) /= 1) call abort
+ if (lbound (c, 2) /= 7 .or. ubound (c, 2) /= 11) call abort
+ c = c + 5
+ r = r + 1
+!$omp end parallel
+ if (any (c /= 10 * r)) call abort
+end
+function fn1 (x, y, m1, m2)
+ integer, intent(in) :: x(:), y(:), m1, m2
+ integer :: fn1(m1:m2)
+ fn1 = x + 2 * y
+end function
+subroutine sub1 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(out) :: x(:)
+ x = 0
+end subroutine
+function fn2 (x, m1, m2, n1, n2)
+ integer, intent(in) :: x(:,:), m1, m2, n1, n2
+ integer :: fn2(m1:m2,n1:n2)
+ fn2 = x
+end function
+subroutine sub2 (x, y)
+ integer, intent(inout) :: x(:,:)
+ integer, intent(in) :: y(:,:)
+ x = x + y
+end subroutine
+function fn3 (x)
+ integer, allocatable, intent(in) :: x(:,:)
+ integer, allocatable :: fn3(:,:)
+ fn3 = x
+end function
+subroutine sub3 (x, y)
+ integer, allocatable, intent(inout) :: x(:,:)
+ integer, allocatable, intent(in) :: y(:,:)
+ x = x + 2 * y
+end subroutine
--- /dev/null
+! { dg-do run }
+
+ type dt
+ integer :: g
+ integer, allocatable :: h(:)
+ end type
+!$omp declare reduction (baz : dt : bar (omp_out, omp_in)) &
+!$omp & initializer (foo (omp_priv, omp_orig))
+ integer :: r
+ type (dt), allocatable :: a(:)
+ allocate (a(7:8))
+ a(:)%g = 0
+ a(7)%h = (/ 0, 0, 0 /)
+ r = 0
+!$omp parallel reduction(+:r) reduction (baz:a)
+ if (.not.allocated (a)) call abort
+ if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort
+ if (.not.allocated (a(7)%h)) call abort
+ if (allocated (a(8)%h)) call abort
+ if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort
+ a(:)%g = a(:)%g + 2
+ a(7)%h = a(7)%h + 3
+ r = r + 1
+!$omp end parallel
+ if (.not.allocated (a)) call abort
+ if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort
+ if (.not.allocated (a(7)%h)) call abort
+ if (allocated (a(8)%h)) call abort
+ if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort
+ if (any (a(:)%g /= 2 * r) .or. any (a(7)%h(:) /= 3 * r)) call abort
+contains
+ subroutine foo (x, y)
+ type (dt), allocatable :: x(:), y(:)
+ if (allocated (x) .neqv. allocated (y)) call abort
+ if (lbound (x, 1) /= lbound (y, 1)) call abort
+ if (ubound (x, 1) /= ubound (y, 1)) call abort
+ if (allocated (x(7)%h) .neqv. allocated (y(7)%h)) call abort
+ if (allocated (x(8)%h) .neqv. allocated (y(8)%h)) call abort
+ if (lbound (x(7)%h, 1) /= lbound (y(7)%h, 1)) call abort
+ if (ubound (x(7)%h, 1) /= ubound (y(7)%h, 1)) call abort
+ x(7)%g = 0
+ x(7)%h = 0
+ x(8)%g = 0
+ end subroutine
+ subroutine bar (x, y)
+ type (dt), allocatable :: x(:), y(:)
+ x(:)%g = x(:)%g + y(:)%g
+ x(7)%h(:) = x(7)%h(:) + y(7)%h(:)
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+
+module udr15m1
+ integer, parameter :: a = 6
+ integer :: b
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+!$omp declare reduction (.add. : integer : &
+!$omp & omp_out = omp_out .add. f3 (omp_in, -4)) &
+!$omp & initializer (s1 (omp_priv, omp_orig))
+ interface operator (.add.)
+ module procedure f1
+ end interface
+contains
+ integer function f1 (x, y)
+ integer, intent (in) :: x, y
+ f1 = x + y
+ end function f1
+ integer function f3 (x, y)
+ integer, intent (in) :: x, y
+ f3 = iand (x, y)
+ end function f3
+ subroutine s1 (x, y)
+ integer, intent (in) :: y
+ integer, intent (out) :: x
+ x = 3
+ end subroutine s1
+end module udr15m1
+module udr15m2
+ use udr15m1, f4 => f1, f5 => f3, s2 => s1, operator (.addtwo.) => operator (.add.)
+ type dt
+ integer :: x
+ end type
+!$omp declare reduction (+ : dt : omp_out = f6 (omp_out + omp_in)) &
+!$omp & initializer (s3 (omp_priv))
+ interface operator (+)
+ module procedure f2
+ end interface
+contains
+ type(dt) function f2 (x, y)
+ type(dt), intent (in) :: x, y
+ f2%x = x%x + y%x
+ end function f2
+ type(dt) function f6 (x)
+ type(dt), intent (in) :: x
+ f6%x = x%x
+ end function f6
+ subroutine s3 (x)
+ type(dt), intent (out) :: x
+ x = dt(0)
+ end subroutine
+end module udr15m2
+ use udr15m2, operator (.addthree.) => operator (.addtwo.), &
+ f7 => f4, f8 => f6, s4 => s3
+ integer :: i, j
+ type(dt) :: d
+ j = 3
+ d%x = 0
+!$omp parallel do reduction (.addthree.: j) reduction (+ : d)
+ do i = 1, 100
+ j = j.addthree.iand (i, -4)
+ d = d + dt(i)
+ end do
+ if (d%x /= 5050 .or. j /= 4903) call abort
+end
! { dg-do run }
!$omp declare reduction (foo : character(kind=1, len=*) &
-!$omp & : omp_out = trim(omp_out) // omp_in) initializer (omp_priv = '')
+!$omp & : omp_out = fn (omp_out, omp_in)) initializer (omp_priv = '')
!$omp declare reduction (bar : character(kind=1, len=:) &
-!$omp & : omp_out = trim(omp_in) // omp_out) initializer (omp_priv = '')
+!$omp & : omp_out = fn (omp_in, omp_out)) initializer (omp_priv = '')
!$omp declare reduction (baz : character(kind=1, len=1) &
!$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) &
!$omp & - ichar ('0'))) initializer (omp_priv = '0')
!$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) &
!$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + &
!$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00')
+ interface
+ elemental function fn (x, y)
+ character (len=64), intent (in) :: x, y
+ character (len=64) :: fn
+ end function
+ end interface
character(kind=1, len=64) :: c(-3:-2,1:1,7:8), d(2:3,-7:-5)
character(kind = 1, len=1) :: e(2:4)
character(kind = 1, len=1+1) :: f(8:10,9:10)
if (any (f(:,:)(1:1).ne.char (ichar ('0') + 32))) call abort
if (any (f(:,:)(2:2).ne.char (ichar ('0') + 64))) call abort
end
+elemental function fn (x, y)
+ character (len=64), intent (in) :: x, y
+ character (len=64) :: fn
+ fn = trim(x) // y
+end function
real :: r = 0.0
end type
contains
- function do_add(x, y)
+ elemental function do_add(x, y)
type (dt), intent (in) :: x, y
type (dt) :: do_add
do_add%r = x%r + y%r
end function
- subroutine dp_add(x, y)
- double precision :: x, y
+ elemental subroutine dp_add(x, y)
+ double precision, intent (inout) :: x
+ double precision, intent (in) :: y
x = x + y
end subroutine
- subroutine dp_init(x)
- double precision :: x
+ elemental subroutine dp_init(x)
+ double precision, intent (out) :: x
x = 0.0
end subroutine
end module
program udr7
implicit none
interface
- subroutine omp_priv (x, y, z)
+ elemental subroutine omp_priv (x, y, z)
real, intent (in) :: x
real, intent (inout) :: y
- real, intent (in) :: z(:)
+ real, intent (in) :: z
end subroutine omp_priv
- real function omp_orig (x)
+ elemental real function omp_orig (x)
real, intent (in) :: x
end function omp_orig
end interface
!$omp declare reduction (omp_priv : real : &
-!$omp & omp_priv (omp_orig (omp_in), omp_out, (/ 1.0, 2.0, 3.0 /))) &
+!$omp & omp_priv (omp_orig (omp_in), omp_out, 1.0)) &
!$omp & initializer (omp_out (omp_priv, omp_in (omp_orig)))
real :: x (2:4, 1:1, -2:0)
integer :: i
end do
if (any (x /= 2080.0)) call abort
contains
- subroutine omp_out (x, y)
+ elemental subroutine omp_out (x, y)
real, intent (out) :: x
real, intent (in) :: y
- if (y /= 4.0) call abort
- x = 0.0
+ x = y - 4.0
end subroutine omp_out
- real function omp_in (x)
+ elemental real function omp_in (x)
real, intent (in) :: x
omp_in = x + 4.0
end function omp_in
end program udr7
-subroutine omp_priv (x, y, z)
+elemental subroutine omp_priv (x, y, z)
real, intent (in) :: x
real, intent (inout) :: y
- real, intent (in) :: z(:)
- if (any (z .ne. (/ 1.0, 2.0, 3.0 /))) call abort
- y = y + (x - 4.0)
+ real, intent (in) :: z
+ y = y + (x - 4.0) + (z - 1.0)
end subroutine omp_priv
-real function omp_orig (x)
+elemental real function omp_orig (x)
real, intent (in) :: x
omp_orig = x + 4.0
end function omp_orig
projects / platform / upstream / linaro-gcc.git / commitdiff