OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

gimplify.c (gimplify_scan_omp_clauses) <case OMP_CLAUSE_MAP, [...]): Make sure OMP_CLAUSE_SIZE is non-NULL. 

* 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.
gcc/fortran/
	* 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.
gcc/testsuite/
	* 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.
libgomp/
	* 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.

From-SVN: r211929
This commit is contained in:
Jakub Jelinek 2014-06-24 09:45:22 +02:00 committed by Jakub Jelinek
parent 335123531f
commit b46ebd6c7b
29 changed files with 1513 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/ChangeLog
View File

@ -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

42
gcc/fortran/ChangeLog
View File

@ -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

2
gcc/fortran/dump-parse-tree.c
View File

@ -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;
}

7
gcc/fortran/f95-lang.c
View File

@ -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,

12
gcc/fortran/gfortran.h
View File

@ -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 *);

8
gcc/fortran/match.c
View File

@ -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);
}

41
gcc/fortran/module.c
View File

@ -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);

170
gcc/fortran/openmp.c
View File

@ -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

32
gcc/fortran/resolve.c
View File

@ -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;

183
gcc/fortran/trans-openmp.c
View File

@ -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)
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->ts = sym->ts;
n->udr->omp_in->ts = sym->ts;
}
else
{
*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];
}
}
}

39
gcc/gimplify.c
View File

@ -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:

17
gcc/omp-low.c
View File

@ -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);

8
gcc/testsuite/ChangeLog
View File

@ -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

10
gcc/testsuite/gfortran.dg/gomp/udr2.f90
View File

@ -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

14
gcc/testsuite/gfortran.dg/gomp/udr4.f90
View File

@ -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

351
gcc/testsuite/gfortran.dg/gomp/udr8.f90 Normal file
View File

@ -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

167
gcc/tree-nested.c
View File

@ -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:

19
libgomp/ChangeLog
View File

@ -1,3 +1,22 @@
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.

133
libgomp/testsuite/libgomp.fortran/aligned1.f03 Normal file
View File

@ -0,0 +1,133 @@
! { 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

96
libgomp/testsuite/libgomp.fortran/nestedfn5.f90 Normal file
View File

@ -0,0 +1,96 @@
! { 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

4
libgomp/testsuite/libgomp.fortran/target7.f90
View File

@ -13,6 +13,8 @@
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))
@ -23,6 +25,8 @@
!$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

33
libgomp/testsuite/libgomp.fortran/target8.f90 Normal file
View File

@ -0,0 +1,33 @@
! { 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

76
libgomp/testsuite/libgomp.fortran/udr12.f90 Normal file
View File

@ -0,0 +1,76 @@
! { 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

106
libgomp/testsuite/libgomp.fortran/udr13.f90 Normal file
View File

@ -0,0 +1,106 @@
! { 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

50
libgomp/testsuite/libgomp.fortran/udr14.f90 Normal file
View File

@ -0,0 +1,50 @@
! { 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

64
libgomp/testsuite/libgomp.fortran/udr15.f90 Normal file
View File

@ -0,0 +1,64 @@
! { 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

15
libgomp/testsuite/libgomp.fortran/udr4.f90
View File

@ -1,9 +1,9 @@
! { 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')
@ -11,6 +11,12 @@
!$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)
@ -37,3 +43,8 @@
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

11
libgomp/testsuite/libgomp.fortran/udr6.f90
View File

@ -8,17 +8,18 @@ module m
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

24
libgomp/testsuite/libgomp.fortran/udr7.f90
View File

@ -3,17 +3,17 @@
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
@ -24,25 +24,23 @@ program udr7
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