Fortran OpenMP UDR fixes, nested handling fixes etc.
Jakub Jelinek
jakub@redhat.com
Fri Jun 20 16:50:00 GMT 2014
Hi!
This patch changes Fortran UDR handling based on feedback on omp-lang,
in particular UDRs are no longer resolved on the UDR constructs
(where we know just the type of the artificial omp_{out,in,priv,orig}
variables, but not their rank/shape, whether they are allocatable etc.),
but when the UDRs are used in some reduction clause.
In addition to that the patch has various fixes for contained function
handling (though, one testcase I also wrote, not included in the patch,
raised an omp-lang query, we don't ICE on that testcase, but need to wait
for feedback), adds an aligned clause test and fixes a bug in handling it
(though, right now we don't ignore aligned clauses for middle-end for
Fortran unless it is a c_ptr, to be worked on later (and probably not
backported)) and fixes ICEs with non-constant safelen clause expression.
Bootstrap/regtest pending, does this look ok?
For reference, the pending OpenMP Fortran items I'm aware of are support
for linear clause with array variables, and depending on omp-lang feedback
also at least calls to contained functions from target regions, copyprivate
with array associate-name, pointer vars in reduction clauses etc.
2014-06-20 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.
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.
(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_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.
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.
--- gcc/gimplify.c.jj 2014-06-20 08:02:51.000000000 +0200
+++ gcc/gimplify.c 2014-06-20 15:39:42.251141439 +0200
@@ -5975,14 +5975,21 @@ gimplify_scan_omp_clauses (tree *list_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,
@@ -6020,15 +6027,17 @@ gimplify_scan_omp_clauses (tree *list_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;
@@ -6203,6 +6212,12 @@ gimplify_scan_omp_clauses (tree *list_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);
@@ -6332,6 +6347,8 @@ gimplify_adjust_omp_clauses_1 (splay_tre
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)
{
@@ -6500,6 +6517,8 @@ gimplify_adjust_omp_clauses (gimple_seq
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:
@@ -6524,6 +6543,8 @@ gimplify_adjust_omp_clauses (gimple_seq
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:
--- gcc/omp-low.c.jj 2014-06-18 09:11:57.000000000 +0200
+++ gcc/omp-low.c 2014-06-20 16:07:13.025631830 +0200
@@ -2996,8 +2996,10 @@ lower_rec_simd_input_clauses (tree new_v
{
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, g
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 *regi
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);
--- gcc/tree-nested.c.jj 2014-06-20 08:02:48.635702616 +0200
+++ gcc/tree-nested.c 2014-06-20 15:24:04.524979978 +0200
@@ -1151,8 +1151,29 @@ convert_nonlocal_omp_clauses (tree *pcla
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_
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));
+ 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 *pclause
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_stm
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_stm
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_stm
default:
*handled_ops_p = false;
return NULL_TREE;
- break;
}
*handled_ops_p = true;
@@ -2258,6 +2370,42 @@ convert_gimple_call (gimple_stmt_iterato
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_iterato
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:
--- gcc/fortran/dump-parse-tree.c.jj 2014-06-20 08:02:48.625702667 +0200
+++ gcc/fortran/dump-parse-tree.c 2014-06-20 08:33:05.865329114 +0200
@@ -1040,7 +1040,7 @@ show_omp_namelist (int list_type, gfc_om
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;
}
--- gcc/fortran/f95-lang.c.jj 2014-06-18 09:11:57.000000000 +0200
+++ gcc/fortran/f95-lang.c 2014-06-20 10:41:59.005386153 +0200
@@ -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,
--- gcc/fortran/gfortran.h.jj 2014-06-20 08:02:48.624702673 +0200
+++ gcc/fortran/gfortran.h 2014-06-20 08:33:05.863329309 +0200
@@ -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_asso
/* 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 *);
--- gcc/fortran/match.c.jj 2014-06-20 08:02:48.625702667 +0200
+++ gcc/fortran/match.c 2014-06-20 08:33:05.864329210 +0200
@@ -4577,6 +4577,14 @@ gfc_free_omp_namelist (gfc_omp_namelist
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);
}
--- gcc/fortran/module.c.jj 2014-06-20 08:02:48.627702657 +0200
+++ gcc/fortran/module.c 2014-06-20 08:33:05.867328932 +0200
@@ -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)
};
@@ -3287,6 +3288,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 +3332,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 +3345,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 +3354,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 +3369,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);
--- gcc/fortran/openmp.c.jj 2014-06-20 08:02:48.626702662 +0200
+++ gcc/fortran/openmp.c 2014-06-20 08:33:05.863329309 +0200
@@ -486,7 +486,11 @@ gfc_match_omp_clauses (gfc_omp_clauses *
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, loc
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, loc
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 *wal
&(*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_ud
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_ud
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_ud
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
--- gcc/fortran/resolve.c.jj 2014-06-20 08:02:48.626702662 +0200
+++ gcc/fortran/resolve.c 2014-06-20 08:33:05.869328760 +0200
@@ -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
{
@@ -4930,7 +4930,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 +8979,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 +9070,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
- resolve_code (b->next, ns);
+ gfc_resolve_code (b->next, ns);
}
}
@@ -9520,7 +9518,7 @@ nonscalar_typebound_assign (gfc_symbol *
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 +9636,9 @@ generate_component_assignments (gfc_code
comp1, comp2, (*code)->loc);
/* Convert the assignment if there is a defined assignment for
- this type. Otherwise, using the call from resolve_code,
+ this type. Otherwise, using the call from gfc_resolve_code,
recurse into its components. */
- resolve_code (this_code, ns);
+ gfc_resolve_code (this_code, ns);
if (this_code->op == EXEC_ASSIGN_CALL)
{
@@ -9804,8 +9802,8 @@ generate_component_assignments (gfc_code
/* 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 +10089,8 @@ resolve_code (gfc_code *code, gfc_namesp
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 +10232,7 @@ resolve_code (gfc_code *code, gfc_namesp
break;
default:
- gfc_internal_error ("resolve_code(): Bad statement code");
+ gfc_internal_error ("gfc_resolve_code(): Bad statement code");
}
}
@@ -14696,7 +14695,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 +14784,7 @@ resolve_types (gfc_namespace *ns)
}
-/* Call resolve_code recursively. */
+/* Call gfc_resolve_code recursively. */
static void
resolve_codes (gfc_namespace *ns)
@@ -14811,7 +14810,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;
--- gcc/fortran/trans-openmp.c.jj 2014-06-20 08:02:48.624702673 +0200
+++ gcc/fortran/trans-openmp.c 2014-06-20 15:42:38.504232667 +0200
@@ -53,11 +53,13 @@ gfc_omp_privatize_by_reference (const_tr
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_se
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_se
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 *wa
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 (tr
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 (tr
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 (tr
gcc_assert (symtree3 == root3);
memset (omp_var_copy, 0, sizeof omp_var_copy);
- if (n->udr)
+ if (udr)
{
- omp_var_copy[0] = *n->udr->omp_out;
- omp_var_copy[1] = *n->udr->omp_in;
- if (sym->attr.dimension)
- {
- n->udr->omp_out->ts = sym->ts;
- n->udr->omp_in->ts = sym->ts;
- }
- else
- {
- *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[0] = *udr->omp_out;
+ omp_var_copy[1] = *udr->omp_in;
+ *udr->omp_out = outer_sym;
+ *udr->omp_in = *sym;
+ if (udr->initializer_ns)
+ {
+ 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 (tr
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 (tr
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 (tr
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:
@@ -1522,10 +1436,8 @@ gfc_trans_omp_array_reduction_or_udr (tr
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 +1449,8 @@ gfc_trans_omp_array_reduction_or_udr (tr
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 +1476,14 @@ gfc_trans_omp_array_reduction_or_udr (tr
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];
}
}
}
--- gcc/testsuite/gfortran.dg/gomp/udr2.f90.jj 2014-06-20 08:02:48.402703818 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr2.f90 2014-06-20 08:33:05.870328677 +0200
@@ -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
--- gcc/testsuite/gfortran.dg/gomp/udr4.f90.jj 2014-06-20 08:02:48.417703741 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr4.f90 2014-06-20 08:33:05.870328677 +0200
@@ -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
--- gcc/testsuite/gfortran.dg/gomp/udr8.f90.jj 2014-06-20 08:33:05.870328677 +0200
+++ gcc/testsuite/gfortran.dg/gomp/udr8.f90 2014-06-20 08:33:05.870328677 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/aligned1.f03.jj 2014-06-20 10:49:30.050053878 +0200
+++ libgomp/testsuite/libgomp.fortran/aligned1.f03 2014-06-20 11:18:02.000000000 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/nestedfn5.f90.jj 2014-06-20 16:11:00.501456748 +0200
+++ libgomp/testsuite/libgomp.fortran/nestedfn5.f90 2014-06-20 16:23:54.701467686 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/target7.f90.jj 2014-06-20 08:02:31.116793036 +0200
+++ libgomp/testsuite/libgomp.fortran/target7.f90 2014-06-20 08:33:05.871328598 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/target8.f90.jj 2014-06-20 08:33:05.872328520 +0200
+++ libgomp/testsuite/libgomp.fortran/target8.f90 2014-06-20 08:33:05.872328520 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/udr4.f90.jj 2014-06-20 08:02:31.085793193 +0200
+++ libgomp/testsuite/libgomp.fortran/udr4.f90 2014-06-20 08:33:05.872328520 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/udr6.f90.jj 2014-06-20 08:02:31.099793127 +0200
+++ libgomp/testsuite/libgomp.fortran/udr6.f90 2014-06-20 08:33:05.872328520 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/udr7.f90.jj 2014-06-20 08:02:31.142792901 +0200
+++ libgomp/testsuite/libgomp.fortran/udr7.f90 2014-06-20 08:33:05.871328598 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/udr12.f90.jj 2014-06-20 08:33:05.871328598 +0200
+++ libgomp/testsuite/libgomp.fortran/udr12.f90 2014-06-20 08:33:05.871328598 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/udr13.f90.jj 2014-06-20 08:33:05.871328598 +0200
+++ libgomp/testsuite/libgomp.fortran/udr13.f90 2014-06-20 08:33:05.871328598 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/udr14.f90.jj 2014-06-20 08:33:05.871328598 +0200
+++ libgomp/testsuite/libgomp.fortran/udr14.f90 2014-06-20 08:33:05.871328598 +0200
@@ -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
--- libgomp/testsuite/libgomp.fortran/udr15.f90.jj 2014-06-20 08:33:05.872328520 +0200
+++ libgomp/testsuite/libgomp.fortran/udr15.f90 2014-06-20 08:33:05.872328520 +0200
@@ -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
Jakub
More information about the Fortran
mailing list