mirror of
https://gcc.gnu.org/git/gcc.git
synced 2024-11-24 03:14:08 +08:00
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:
parent
335123531f
commit
b46ebd6c7b
@ -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
|
||||
|
@ -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
|
||||
|
@ -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;
|
||||
}
|
||||
|
@ -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,
|
||||
|
@ -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 *);
|
||||
|
@ -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);
|
||||
}
|
||||
|
@ -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);
|
||||
|
@ -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 (©, 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
|
||||
@ -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
|
||||
|
@ -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;
|
||||
|
@ -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];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
@ -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:
|
||||
|
@ -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);
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
351
gcc/testsuite/gfortran.dg/gomp/udr8.f90
Normal 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
|
@ -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:
|
||||
|
@ -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
133
libgomp/testsuite/libgomp.fortran/aligned1.f03
Normal 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
96
libgomp/testsuite/libgomp.fortran/nestedfn5.f90
Normal 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
|
@ -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
33
libgomp/testsuite/libgomp.fortran/target8.f90
Normal 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
76
libgomp/testsuite/libgomp.fortran/udr12.f90
Normal 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
106
libgomp/testsuite/libgomp.fortran/udr13.f90
Normal 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
50
libgomp/testsuite/libgomp.fortran/udr14.f90
Normal 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
64
libgomp/testsuite/libgomp.fortran/udr15.f90
Normal 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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user