* [PATCH] Fortran OpenMP 4.0 support, part 1
@ 2014-05-07 20:53 Jakub Jelinek
2014-05-09 19:35 ` Tobias Burnus
0 siblings, 1 reply; 5+ messages in thread
From: Jakub Jelinek @ 2014-05-07 20:53 UTC (permalink / raw)
To: gcc-patches, fortran
Hi!
This patch attempts to implement first part of Fortran OpenMP 4.0 support,
in particular:
1) proc_bind clause on !$omp parallel
2) simd support (!$omp {{,parallel }{,do },declare }simd and corresponding clauses)
3) taskgroup
4) depend clause on !$omp task
5) cancellation support (!$omp cancel{,llation point} and corresponding clauses)
Things left out for later, incremental patches (not yet written):
6) user defined reductions
7) Fortran 2003 support (the standard basically says that F2003 is supported
with a list of exceptions that aren't supported yet)
8) device constructs and related clauses
The testsuite coverage could certainly be improved, volunteers for that
and/or bugreports will be certainly appreciated. Don't know how to actually
test aligned clauses, is there any way (except for doing allocations in
C/C++ on the side) to allocate objects on aligned boundaries (aligned
attribute, some way to dynamically allocate aligned storage, ...)?
Bootstrapped/regtested on x86_64-linux and i686-linux. Any comments on
this? If all goes well and say at least 6) and 7) is written in the near
future as well, perhaps after a while on the trunk I'd consider backporting
this to 4.9.1 or 4.9.2, so we have full OpenMP 4.0 support or at least
full OpenMP 4.0 support but Fortran device construct support in a released
compiler earlier than next year.
2014-05-07 Jakub Jelinek <jakub@redhat.com>
* tree.h (OMP_CLAUSE_LINEAR_STMT): Define.
* tree.c (omp_clause_num_ops): Increase OMP_CLAUSE_LINEAR
number of operands to 3.
(walk_tree_1): Walk all operands of OMP_CLAUSE_LINEAR.
* tree-nested.c (convert_nonlocal_omp_clauses,
convert_local_omp_clauses): Handle OMP_CLAUSE_DEPEND.
* gimplify.c (gimplify_scan_omp_clauses): Handle
OMP_CLAUSE_LINEAR_STMT.
* omp-low.c (lower_rec_input_clauses): Fix typo.
(maybe_add_implicit_barrier_cancel, lower_omp_1): Add
cast between Fortran boolean_type_node and C _Bool if
needed.
gcc/fortran/
* gfortran.h (gfc_statement): Add ST_OMP_CANCEL,
ST_OMP_CANCELLATION_POINT, ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP,
ST_OMP_SIMD, ST_OMP_END_SIMD, ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD,
ST_OMP_PARALLEL_DO_SIMD, ST_OMP_END_PARALLEL_DO_SIMD and
ST_OMP_DECLARE_SIMD.
(gfc_omp_namelist): New typedef.
(gfc_get_omp_namelist): Define.
(OMP_LIST_UNIFORM, OMP_LIST_ALIGNED, OMP_LIST_LINEAR,
OMP_LIST_DEPEND_IN, OMP_LIST_DEPEND_OUT): New clause list kinds.
(gfc_omp_proc_bind_kind, gfc_omp_cancel_kind): New enums.
(gfc_omp_clauses): Change type of lists to gfc_omp_namelist *.
Add inbranch, notinbranch, cancel, proc_bind, safelen_expr and
simdlen_expr fields.
(gfc_omp_declare_simd): New typedef.
(gfc_get_omp_declare_simd): Define.
(gfc_namespace): Add omp_declare_simd field.
(gfc_exec_op): Add EXEC_OMP_CANCEL, EXEC_OMP_CANCELLATION_POINT,
EXEC_OMP_TASKGROUP, EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD and
EXEC_OMP_PARALLEL_DO_SIMD.
(gfc_omp_atomic_op): Add GFC_OMP_ATOMIC_MASK, GFC_OMP_ATOMIC_SEQ_CST
and GFC_OMP_ATOMIC_SWAP.
(gfc_code): Change type of omp_namelist field to gfc_omp_namelist *.
(gfc_free_omp_namelist, gfc_free_omp_declare_simd,
gfc_free_omp_declare_simd_list, gfc_resolve_omp_declare_simd): New
prototypes.
* trans-stmt.h (gfc_trans_omp_declare_simd): New prototype.
* symbol.c (gfc_free_namespace): Call gfc_free_omp_declare_simd.
* openmp.c (gfc_free_omp_clauses): Free safelen_expr and
simdlen_expr. Use gfc_free_omp_namelist instead of
gfc_free_namelist.
(gfc_free_omp_declare_simd, gfc_free_omp_declare_simd_list): New
functions.
(gfc_match_omp_variable_list): Add end_colon, headp and
allow_sections arguments. Handle parsing of array sections.
Use *omp_namelist* instead of *namelist* data structure and
functions/macros. Allow termination at : character.
(OMP_CLAUSE_ALIGNED, OMP_CLAUSE_DEPEND, OMP_CLAUSE_INBRANCH,
OMP_CLAUSE_LINEAR, OMP_CLAUSE_NOTINBRANCH, OMP_CLAUSE_PROC_BIND,
OMP_CLAUSE_SAFELEN, OMP_CLAUSE_SIMDLEN, OMP_CLAUSE_UNIFORM): Define.
(gfc_match_omp_clauses): Change first and needs_space variables
into arguments with default values. Parse inbranch, notinbranch,
proc_bind, safelen, simdlen, uniform, linear, aligned and
depend clauses.
(OMP_PARALLEL_CLAUSES): Add OMP_CLAUSE_PROC_BIND.
(OMP_DECLARE_SIMD_CLAUSES, OMP_SIMD_CLAUSES): Define.
(OMP_TASK_CLAUSES): Add OMP_CLAUSE_DEPEND.
(gfc_match_omp_do_simd): New function.
(gfc_match_omp_flush): Use *omp_namelist* instead of *namelist*
data structure and functions/macros.
(gfc_match_omp_simd, gfc_match_omp_declare_simd,
gfc_match_omp_parallel_do_simd): New functions.
(gfc_match_omp_atomic): Handle seq_cst clause. Handle atomic swap.
(gfc_match_omp_taskgroup, gfc_match_omp_cancel_kind,
gfc_match_omp_cancel, gfc_match_omp_cancellation_point): New
functions.
(resolve_omp_clauses): Add where, omp_clauses and ns arguments.
Use *omp_namelist* instead of *namelist* data structure and
functions/macros. Resolve uniform, aligned, linear, depend,
safelen and simdlen clauses.
(resolve_omp_atomic): Adjust for GFC_OMP_ATOMIC_{MASK,SEQ_CST,SWAP}
addition, recognize atomic swap.
(gfc_resolve_omp_parallel_blocks): Use gfc_omp_namelist instead
of gfc_namelist. Handle EXEC_OMP_PARALLEL_DO_SIMD the same as
EXEC_OMP_PARALLEL_DO.
(gfc_resolve_do_iterator): Use *omp_namelist* instead of *namelist*
data structure and functions/macros.
(resolve_omp_do): Likewise. Handle EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD,
EXEC_OMP_PARALLEL_DO_SIMD.
(gfc_resolve_omp_directive): Handle EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD,
EXEC_OMP_PARALLEL_DO_SIMD and EXEC_OMP_CANCEL. Adjust
resolve_omp_clauses caller.
(gfc_resolve_omp_declare_simd): New function.
* parse.c (decode_omp_directive): Parse cancellation point, cancel,
declare simd, end do simd, end simd, end parallel do simd,
end taskgroup, parallel do simd, simd and taskgroup directives.
(case_executable): Add ST_OMP_CANCEL and ST_OMP_CANCELLATION_POINT.
(case_exec_markers): Add ST_OMP_TASKGROUP, case ST_OMP_SIMD,
ST_OMP_DO_SIMD and ST_OMP_PARALLEL_DO_SIMD.
(case_decl): Add ST_OMP_DECLARE_SIMD.
(gfc_ascii_statement): Handle ST_OMP_CANCEL,
ST_OMP_CANCELLATION_POINT, ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP,
ST_OMP_SIMD, ST_OMP_END_SIMD, ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD,
ST_OMP_PARALLEL_DO_SIMD, ST_OMP_END_PARALLEL_DO_SIMD and
ST_OMP_DECLARE_SIMD.
(parse_omp_do): Handle ST_OMP_SIMD, ST_OMP_DO_SIMD and
ST_OMP_PARALLEL_DO_SIMD.
(parse_omp_atomic): Adjust for GFC_OMP_ATOMIC_* additions.
(parse_omp_structured_block): Handle ST_OMP_TASKGROUP and
ST_OMP_PARALLEL_DO_SIMD.
(parse_executable): Handle ST_OMP_SIMD, ST_OMP_DO_SIMD,
ST_OMP_PARALLEL_DO_SIMD and ST_OMP_TASKGROUP.
* trans-decl.c (gfc_get_extern_function_decl,
gfc_create_function_decl): Call gfc_trans_omp_declare_simd if
needed.
* frontend-passes.c (gfc_code_walker): Handle EXEC_OMP_SIMD,
EXEC_OMP_DO_SIMD and EXEC_OMP_PARALLEL_DO_SIMD. Walk
safelen_expr and simdlen_expr. Walk expressions in gfc_omp_namelist
of depend, aligned and linear clauses.
* match.c (match_exit_cycle): Handle EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD
and EXEC_OMP_PARALLEL_DO_SIMD.
(gfc_free_omp_namelist): New function.
* dump-parse-tree.c (show_namelist): Removed.
(show_omp_namelist): New function.
(show_omp_node): Handle OpenMP 4.0 additions.
(show_code_node): Handle EXEC_OMP_CANCEL, EXEC_OMP_CANCELLATION_POINT,
EXEC_OMP_DO_SIMD, EXEC_OMP_PARALLEL_DO_SIMD, EXEC_OMP_SIMD and
EXEC_OMP_TASKGROUP.
* match.h (gfc_match_omp_cancel, gfc_match_omp_cancellation_point,
gfc_match_omp_declare_simd, gfc_match_omp_do_simd,
gfc_match_omp_parallel_do_simd, gfc_match_omp_simd,
gfc_match_omp_taskgroup): New prototypes.
* trans-openmp.c (gfc_trans_omp_variable): Add declare_simd
argument, handle it. Allow current_function_decl to be NULL.
(gfc_trans_omp_variable_list): Add declare_simd argument, pass
it through to gfc_trans_omp_variable and disregard whether
sym is referenced if declare_simd is true. Work on gfc_omp_namelist
instead of gfc_namelist.
(gfc_trans_omp_reduction_list): Work on gfc_omp_namelist instead of
gfc_namelist. Adjust gfc_trans_omp_variable caller.
(gfc_trans_omp_clauses): Add declare_simd argument, pass it through
to gfc_trans_omp_variable{,_list} callers. Work on gfc_omp_namelist
instead of gfc_namelist. Handle inbranch, notinbranch, safelen,
simdlen, depend, uniform, linear, proc_bind and aligned clauses.
Handle cancel kind.
(gfc_trans_omp_atomic): Handle seq_cst clause, handle atomic swap,
adjust for GFC_OMP_ATOMIC_* changes.
(gfc_trans_omp_cancel, gfc_trans_omp_cancellation_point): New
functions.
(gfc_trans_omp_do): Add op argument, handle simd translation into
generic.
(GFC_OMP_SPLIT_SIMD, GFC_OMP_SPLIT_DO, GFC_OMP_SPLIT_PARALLEL,
GFC_OMP_SPLIT_NUM, GFC_OMP_MASK_SIMD, GFC_OMP_MASK_DO,
GFC_OMP_MASK_PARALLEL): New.
(gfc_split_omp_clauses, gfc_trans_omp_do_simd): New functions.
(gfc_trans_omp_parallel_do): Rework to use gfc_split_omp_clauses.
(gfc_trans_omp_parallel_do_simd, gfc_trans_omp_taskgroup): New
functions.
(gfc_trans_omp_directive): Handle EXEC_OMP_CANCEL,
EXEC_OMP_CANCELLATION_POINT, EXEC_OMP_DO_SIMD,
EXEC_OMP_PARALLEL_DO_SIMD, EXEC_OMP_SIMD and EXEC_OMP_TASKGROUP.
Adjust gfc_trans_omp_do caller.
(gfc_trans_omp_declare_simd): New function.
* st.c (gfc_free_statement): Handle EXEC_OMP_CANCEL,
EXEC_OMP_CANCELLATION_POINT, EXEC_OMP_DO_SIMD,
EXEC_OMP_PARALLEL_DO_SIMD, EXEC_OMP_SIMD and EXEC_OMP_TASKGROUP.
For EXEC_OMP_FLUSH call gfc_free_omp_namelist instead of
gfc_free_namelist.
* module.c (omp_declare_simd_clauses): New variable.
(mio_omp_declare_simd): New function.
(mio_symbol): Call it.
* trans.c (trans_code): Handle EXEC_OMP_CANCEL,
EXEC_OMP_CANCELLATION_POINT, EXEC_OMP_DO_SIMD,
EXEC_OMP_PARALLEL_DO_SIMD, EXEC_OMP_SIMD and EXEC_OMP_TASKGROUP.
* resolve.c (gfc_resolve_blocks): Handle EXEC_OMP_DO_SIMD,
EXEC_OMP_PARALLEL_DO_SIMD, EXEC_OMP_SIMD and EXEC_OMP_TASKGROUP.
(resolve_code): Handle EXEC_OMP_CANCEL,
EXEC_OMP_CANCELLATION_POINT, EXEC_OMP_DO_SIMD,
EXEC_OMP_PARALLEL_DO_SIMD, EXEC_OMP_SIMD and EXEC_OMP_TASKGROUP.
(resolve_types): Call gfc_resolve_omp_declare_simd.
gcc/testsuite/
* gfortran.dg/gomp/affinity-1.f90: New test.
libgomp/
* testsuite/libgomp.fortran/cancel-do-1.f90: New test.
* testsuite/libgomp.fortran/cancel-do-2.f90: New test.
* testsuite/libgomp.fortran/cancel-parallel-1.f90: New test.
* testsuite/libgomp.fortran/cancel-parallel-3.f90: New test.
* testsuite/libgomp.fortran/cancel-sections-1.f90: New test.
* testsuite/libgomp.fortran/cancel-taskgroup-2.f90: New test.
* testsuite/libgomp.fortran/declare-simd-1.f90: New test.
* testsuite/libgomp.fortran/declare-simd-2.f90: New test.
* testsuite/libgomp.fortran/declare-simd-3.f90: New test.
* testsuite/libgomp.fortran/depend-1.f90: New test.
* testsuite/libgomp.fortran/depend-2.f90: New test.
* testsuite/libgomp.fortran/omp_atomic5.f90: New test.
* testsuite/libgomp.fortran/simd1.f90: New test.
* testsuite/libgomp.fortran/simd2.f90: New test.
* testsuite/libgomp.fortran/simd3.f90: New test.
* testsuite/libgomp.fortran/simd4.f90: New test.
* testsuite/libgomp.fortran/taskgroup1.f90: New test.
--- gcc/tree.h.jj 2014-05-02 19:39:53.747678193 +0200
+++ gcc/tree.h 2014-05-02 20:13:06.769495349 +0200
@@ -1330,6 +1330,9 @@ extern void protected_set_expr_location
#define OMP_CLAUSE_LINEAR_STEP(NODE) \
OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LINEAR), 1)
+#define OMP_CLAUSE_LINEAR_STMT(NODE) \
+ OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LINEAR), 2)
+
#define OMP_CLAUSE_LINEAR_GIMPLE_SEQ(NODE) \
(OMP_CLAUSE_CHECK (NODE))->omp_clause.gimple_reduction_init
--- gcc/tree.c.jj 2014-05-02 19:39:53.738678240 +0200
+++ gcc/tree.c 2014-05-02 20:13:06.753494712 +0200
@@ -252,7 +252,7 @@ unsigned const char omp_clause_num_ops[]
4, /* OMP_CLAUSE_REDUCTION */
1, /* OMP_CLAUSE_COPYIN */
1, /* OMP_CLAUSE_COPYPRIVATE */
- 2, /* OMP_CLAUSE_LINEAR */
+ 3, /* OMP_CLAUSE_LINEAR */
2, /* OMP_CLAUSE_ALIGNED */
1, /* OMP_CLAUSE_DEPEND */
1, /* OMP_CLAUSE_UNIFORM */
@@ -11067,8 +11067,13 @@ walk_tree_1 (tree *tp, walk_tree_fn func
WALK_SUBTREE_TAIL (OMP_CLAUSE_CHAIN (*tp));
}
- case OMP_CLAUSE_ALIGNED:
case OMP_CLAUSE_LINEAR:
+ WALK_SUBTREE (OMP_CLAUSE_DECL (*tp));
+ WALK_SUBTREE (OMP_CLAUSE_LINEAR_STEP (*tp));
+ WALK_SUBTREE (OMP_CLAUSE_LINEAR_STMT (*tp));
+ WALK_SUBTREE_TAIL (OMP_CLAUSE_CHAIN (*tp));
+
+ case OMP_CLAUSE_ALIGNED:
case OMP_CLAUSE_FROM:
case OMP_CLAUSE_TO:
case OMP_CLAUSE_MAP:
--- gcc/tree-nested.c.jj 2014-04-24 23:16:43.000000000 +0200
+++ gcc/tree-nested.c 2014-05-06 12:52:43.206621003 +0200
@@ -1112,6 +1112,7 @@ convert_nonlocal_omp_clauses (tree *pcla
case OMP_CLAUSE_FINAL:
case OMP_CLAUSE_IF:
case OMP_CLAUSE_NUM_THREADS:
+ case OMP_CLAUSE_DEPEND:
wi->val_only = true;
wi->is_lhs = false;
convert_nonlocal_reference_op (&OMP_CLAUSE_OPERAND (clause, 0),
@@ -1651,6 +1652,7 @@ convert_local_omp_clauses (tree *pclause
case OMP_CLAUSE_FINAL:
case OMP_CLAUSE_IF:
case OMP_CLAUSE_NUM_THREADS:
+ case OMP_CLAUSE_DEPEND:
wi->val_only = true;
wi->is_lhs = false;
convert_local_reference_op (&OMP_CLAUSE_OPERAND (clause, 0), &dummy,
--- gcc/gimplify.c.jj 2014-05-02 19:42:46.630785907 +0200
+++ gcc/gimplify.c 2014-05-02 20:13:06.766495190 +0200
@@ -6069,6 +6069,27 @@ gimplify_scan_omp_clauses (tree *list_p,
gimplify_omp_ctxp = outer_ctx;
}
+ else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
+ && OMP_CLAUSE_LINEAR_STMT (c))
+ {
+ gimplify_omp_ctxp = ctx;
+ push_gimplify_context ();
+ if (TREE_CODE (OMP_CLAUSE_LINEAR_STMT (c)) != BIND_EXPR)
+ {
+ tree bind = build3 (BIND_EXPR, void_type_node, NULL,
+ NULL, NULL);
+ TREE_SIDE_EFFECTS (bind) = 1;
+ BIND_EXPR_BODY (bind) = OMP_CLAUSE_LINEAR_STMT (c);
+ OMP_CLAUSE_LINEAR_STMT (c) = bind;
+ }
+ gimplify_and_add (OMP_CLAUSE_LINEAR_STMT (c),
+ &OMP_CLAUSE_LINEAR_GIMPLE_SEQ (c));
+ pop_gimplify_context
+ (gimple_seq_first_stmt (OMP_CLAUSE_LINEAR_GIMPLE_SEQ (c)));
+ OMP_CLAUSE_LINEAR_STMT (c) = NULL_TREE;
+
+ gimplify_omp_ctxp = outer_ctx;
+ }
if (notice_outer)
goto do_notice;
break;
--- gcc/omp-low.c.jj 2014-05-02 19:42:46.633786172 +0200
+++ gcc/omp-low.c 2014-05-07 18:41:14.591395817 +0200
@@ -3407,8 +3407,8 @@ lower_rec_input_clauses (tree clauses, g
= gimple_build_assign (unshare_expr (lvar), iv);
gsi_insert_before_without_update (&gsi, g,
GSI_SAME_STMT);
- tree stept = POINTER_TYPE_P (TREE_TYPE (x))
- ? sizetype : TREE_TYPE (x);
+ tree stept = POINTER_TYPE_P (TREE_TYPE (iv))
+ ? sizetype : TREE_TYPE (iv);
tree t = fold_convert (stept,
OMP_CLAUSE_LINEAR_STEP (c));
enum tree_code code = PLUS_EXPR;
@@ -8418,10 +8418,14 @@ maybe_add_implicit_barrier_cancel (omp_c
&& gimple_code (ctx->outer->stmt) == GIMPLE_OMP_PARALLEL
&& ctx->outer->cancellable)
{
- tree lhs = create_tmp_var (boolean_type_node, NULL);
+ tree fndecl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
+ tree c_bool_type = TREE_TYPE (TREE_TYPE (fndecl));
+ tree lhs = create_tmp_var (c_bool_type, NULL);
gimple_omp_return_set_lhs (omp_return, lhs);
tree fallthru_label = create_artificial_label (UNKNOWN_LOCATION);
- gimple g = gimple_build_cond (NE_EXPR, lhs, boolean_false_node,
+ gimple g = gimple_build_cond (NE_EXPR, lhs,
+ fold_convert (c_bool_type,
+ boolean_false_node),
ctx->outer->cancel_label, fallthru_label);
gimple_seq_add_stmt (body, g);
gimple_seq_add_stmt (body, gimple_build_label (fallthru_label));
@@ -10127,21 +10131,23 @@ lower_omp_1 (gimple_stmt_iterator *gsi_p
}
break;
}
- tree lhs;
- lhs = create_tmp_var (boolean_type_node, NULL);
if (DECL_FUNCTION_CODE (fndecl) == BUILT_IN_GOMP_BARRIER)
{
fndecl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER_CANCEL);
gimple_call_set_fndecl (stmt, fndecl);
gimple_call_set_fntype (stmt, TREE_TYPE (fndecl));
}
+ tree lhs;
+ lhs = create_tmp_var (TREE_TYPE (TREE_TYPE (fndecl)), NULL);
gimple_call_set_lhs (stmt, lhs);
tree fallthru_label;
fallthru_label = create_artificial_label (UNKNOWN_LOCATION);
gimple g;
g = gimple_build_label (fallthru_label);
gsi_insert_after (gsi_p, g, GSI_SAME_STMT);
- g = gimple_build_cond (NE_EXPR, lhs, boolean_false_node,
+ g = gimple_build_cond (NE_EXPR, lhs,
+ fold_convert (TREE_TYPE (lhs),
+ boolean_false_node),
cctx->cancel_label, fallthru_label);
gsi_insert_after (gsi_p, g, GSI_SAME_STMT);
break;
--- gcc/fortran/gfortran.h.jj 2014-05-02 19:39:53.438679780 +0200
+++ gcc/fortran/gfortran.h 2014-05-06 11:00:09.256740272 +0200
@@ -211,8 +211,12 @@ typedef enum
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
- ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL,
- ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
+ ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_OMP_CANCEL, ST_OMP_CANCELLATION_POINT,
+ ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP, ST_OMP_SIMD, ST_OMP_END_SIMD,
+ ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
+ ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_PROCEDURE, ST_GENERIC,
+ ST_CRITICAL, ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK,
+ ST_UNLOCK, ST_NONE
}
gfc_statement;
@@ -1028,6 +1032,19 @@ gfc_namelist;
#define gfc_get_namelist() XCNEW (gfc_namelist)
+/* For use in OpenMP clauses in case we need extra information
+ (aligned clause alignment, linear clause step, etc. */
+
+typedef struct gfc_omp_namelist
+{
+ struct gfc_symbol *sym;
+ struct gfc_expr *expr;
+ struct gfc_omp_namelist *next;
+}
+gfc_omp_namelist;
+
+#define gfc_get_omp_namelist() XCNEW (gfc_omp_namelist)
+
enum
{
OMP_LIST_PRIVATE,
@@ -1036,6 +1053,11 @@ enum
OMP_LIST_COPYPRIVATE,
OMP_LIST_SHARED,
OMP_LIST_COPYIN,
+ OMP_LIST_UNIFORM,
+ OMP_LIST_ALIGNED,
+ OMP_LIST_LINEAR,
+ OMP_LIST_DEPEND_IN,
+ OMP_LIST_DEPEND_OUT,
OMP_LIST_PLUS,
OMP_LIST_REDUCTION_FIRST = OMP_LIST_PLUS,
OMP_LIST_MULT,
@@ -1075,23 +1097,60 @@ enum gfc_omp_default_sharing
OMP_DEFAULT_FIRSTPRIVATE
};
+enum gfc_omp_proc_bind_kind
+{
+ OMP_PROC_BIND_UNKNOWN,
+ OMP_PROC_BIND_MASTER,
+ OMP_PROC_BIND_SPREAD,
+ OMP_PROC_BIND_CLOSE
+};
+
+enum gfc_omp_cancel_kind
+{
+ OMP_CANCEL_UNKNOWN,
+ OMP_CANCEL_PARALLEL,
+ OMP_CANCEL_SECTIONS,
+ OMP_CANCEL_DO,
+ OMP_CANCEL_TASKGROUP
+};
+
typedef struct gfc_omp_clauses
{
struct gfc_expr *if_expr;
struct gfc_expr *final_expr;
struct gfc_expr *num_threads;
- gfc_namelist *lists[OMP_LIST_NUM];
+ gfc_omp_namelist *lists[OMP_LIST_NUM];
enum gfc_omp_sched_kind sched_kind;
struct gfc_expr *chunk_size;
enum gfc_omp_default_sharing default_sharing;
int collapse;
bool nowait, ordered, untied, mergeable;
+ bool inbranch, notinbranch;
+ enum gfc_omp_cancel_kind cancel;
+ enum gfc_omp_proc_bind_kind proc_bind;
+ struct gfc_expr *safelen_expr;
+ struct gfc_expr *simdlen_expr;
}
gfc_omp_clauses;
#define gfc_get_omp_clauses() XCNEW (gfc_omp_clauses)
+/* Node in the linked list used for storing !$omp declare simd constructs. */
+
+typedef struct gfc_omp_declare_simd
+{
+ struct gfc_omp_declare_simd *next;
+ locus where; /* Where the !$omp declare simd construct occurred. */
+
+ gfc_symbol *proc_name;
+
+ gfc_omp_clauses *clauses;
+}
+gfc_omp_declare_simd;
+#define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd)
+
+
/* The gfc_st_label structure is a BBT attached to a namespace that
records the usage of statement labels within that space. */
@@ -1464,6 +1523,9 @@ typedef struct gfc_namespace
/* A list of USE statements in this namespace. */
gfc_use_list *use_stmts;
+ /* Linked list of !$omp declare simd constructs. */
+ struct gfc_omp_declare_simd *omp_declare_simd;
+
/* Set to 1 if namespace is a BLOCK DATA program unit. */
unsigned is_block_data:1;
@@ -2111,16 +2173,21 @@ typedef enum
EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
EXEC_OMP_END_SINGLE, EXEC_OMP_TASK, EXEC_OMP_TASKWAIT,
- EXEC_OMP_TASKYIELD
+ EXEC_OMP_TASKYIELD, EXEC_OMP_CANCEL, EXEC_OMP_CANCELLATION_POINT,
+ EXEC_OMP_TASKGROUP, EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD,
+ EXEC_OMP_PARALLEL_DO_SIMD
}
gfc_exec_op;
typedef enum
{
- GFC_OMP_ATOMIC_UPDATE,
- GFC_OMP_ATOMIC_READ,
- GFC_OMP_ATOMIC_WRITE,
- GFC_OMP_ATOMIC_CAPTURE
+ GFC_OMP_ATOMIC_UPDATE = 0,
+ GFC_OMP_ATOMIC_READ = 1,
+ GFC_OMP_ATOMIC_WRITE = 2,
+ GFC_OMP_ATOMIC_CAPTURE = 3,
+ GFC_OMP_ATOMIC_MASK = 3,
+ GFC_OMP_ATOMIC_SEQ_CST = 4,
+ GFC_OMP_ATOMIC_SWAP = 8
}
gfc_omp_atomic_op;
@@ -2172,7 +2239,7 @@ typedef struct gfc_code
gfc_entry_list *entry;
gfc_omp_clauses *omp_clauses;
const char *omp_name;
- gfc_namelist *omp_namelist;
+ gfc_omp_namelist *omp_namelist;
bool omp_bool;
gfc_omp_atomic_op omp_atomic;
}
@@ -2728,6 +2795,7 @@ void gfc_free_iterator (gfc_iterator *,
void gfc_free_forall_iterator (gfc_forall_iterator *);
void gfc_free_alloc_list (gfc_alloc *);
void gfc_free_namelist (gfc_namelist *);
+void gfc_free_omp_namelist (gfc_omp_namelist *);
void gfc_free_equiv (gfc_equiv *);
void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *);
void gfc_free_data (gfc_data *);
@@ -2739,10 +2807,13 @@ gfc_expr *gfc_get_parentheses (gfc_expr
/* openmp.c */
struct gfc_omp_saved_state { void *ptrs[2]; int ints[1]; };
void gfc_free_omp_clauses (gfc_omp_clauses *);
+void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
+void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *);
void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_omp_declare_simd (gfc_namespace *);
void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
void gfc_omp_restore_state (struct gfc_omp_saved_state *);
--- gcc/fortran/trans-stmt.h.jj 2014-01-03 11:40:53.000000000 +0100
+++ gcc/fortran/trans-stmt.h 2014-05-05 13:25:53.864971450 +0200
@@ -63,6 +63,7 @@ tree gfc_trans_deallocate_array (tree);
/* trans-openmp.c */
tree gfc_trans_omp_directive (gfc_code *);
+void gfc_trans_omp_declare_simd (gfc_namespace *);
/* trans-io.c */
tree gfc_trans_open (gfc_code *);
--- gcc/fortran/symbol.c.jj 2014-05-02 19:39:53.435679797 +0200
+++ gcc/fortran/symbol.c 2014-05-02 20:13:06.763495078 +0200
@@ -3468,6 +3468,7 @@ gfc_free_namespace (gfc_namespace *ns)
free_tb_tree (ns->tb_sym_root);
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
+ gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
--- gcc/fortran/openmp.c.jj 2014-05-02 19:39:53.484679544 +0200
+++ gcc/fortran/openmp.c 2014-05-07 17:19:02.197914819 +0200
@@ -69,19 +69,47 @@ gfc_free_omp_clauses (gfc_omp_clauses *c
gfc_free_expr (c->final_expr);
gfc_free_expr (c->num_threads);
gfc_free_expr (c->chunk_size);
+ gfc_free_expr (c->safelen_expr);
+ gfc_free_expr (c->simdlen_expr);
for (i = 0; i < OMP_LIST_NUM; i++)
- gfc_free_namelist (c->lists[i]);
+ gfc_free_omp_namelist (c->lists[i]);
free (c);
}
+/* Free an !$omp declare simd construct list. */
+
+void
+gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
+{
+ if (ods)
+ {
+ gfc_free_omp_clauses (ods->clauses);
+ free (ods);
+ }
+}
+
+void
+gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
+{
+ while (list)
+ {
+ gfc_omp_declare_simd *current = list;
+ list = list->next;
+ gfc_free_omp_declare_simd (current);
+ }
+}
+
+
/* Match a variable/common block list and construct a namelist from it. */
static match
-gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
- bool allow_common)
+gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
+ bool allow_common, bool *end_colon = NULL,
+ gfc_omp_namelist ***headp = NULL,
+ bool allow_sections = false)
{
- gfc_namelist *head, *tail, *p;
- locus old_loc;
+ gfc_omp_namelist *head, *tail, *p;
+ locus old_loc, cur_loc;
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *sym;
match m;
@@ -97,12 +125,29 @@ gfc_match_omp_variable_list (const char
for (;;)
{
+ cur_loc = gfc_current_locus;
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
+ gfc_expr *expr;
+ expr = NULL;
+ if (allow_sections && gfc_peek_ascii_char () == '(')
+ {
+ gfc_current_locus = cur_loc;
+ m = gfc_match_variable (&expr, 0);
+ switch (m)
+ {
+ case MATCH_ERROR:
+ goto cleanup;
+ case MATCH_NO:
+ goto syntax;
+ default:
+ break;
+ }
+ }
gfc_set_sym_referenced (sym);
- p = gfc_get_namelist ();
+ p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
@@ -111,6 +156,7 @@ gfc_match_omp_variable_list (const char
tail = tail->next;
}
tail->sym = sym;
+ tail->expr = expr;
goto next_item;
case MATCH_NO:
break;
@@ -136,7 +182,7 @@ gfc_match_omp_variable_list (const char
for (sym = st->n.common->head; sym; sym = sym->common_next)
{
gfc_set_sym_referenced (sym);
- p = gfc_get_namelist ();
+ p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
@@ -148,6 +194,11 @@ gfc_match_omp_variable_list (const char
}
next_item:
+ if (end_colon && gfc_match_char (':') == MATCH_YES)
+ {
+ *end_colon = true;
+ break;
+ }
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
@@ -158,13 +209,15 @@ gfc_match_omp_variable_list (const char
list = &(*list)->next;
*list = head;
+ if (headp)
+ *headp = list;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_namelist (head);
+ gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
@@ -185,16 +238,25 @@ cleanup:
#define OMP_CLAUSE_UNTIED (1 << 13)
#define OMP_CLAUSE_FINAL (1 << 14)
#define OMP_CLAUSE_MERGEABLE (1 << 15)
+#define OMP_CLAUSE_ALIGNED (1 << 16)
+#define OMP_CLAUSE_DEPEND (1 << 17)
+#define OMP_CLAUSE_INBRANCH (1 << 18)
+#define OMP_CLAUSE_LINEAR (1 << 19)
+#define OMP_CLAUSE_NOTINBRANCH (1 << 20)
+#define OMP_CLAUSE_PROC_BIND (1 << 21)
+#define OMP_CLAUSE_SAFELEN (1 << 22)
+#define OMP_CLAUSE_SIMDLEN (1 << 23)
+#define OMP_CLAUSE_UNIFORM (1 << 24)
/* Match OpenMP directive clauses. MASK is a bitmask of
clauses that are allowed for a particular directive. */
static match
-gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
+gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask, bool first = true,
+ bool needs_space = true)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
- bool needs_space = true, first = true;
*cp = NULL;
while (1)
@@ -419,6 +481,115 @@ gfc_match_omp_clauses (gfc_omp_clauses *
continue;
}
}
+ if ((mask & OMP_CLAUSE_INBRANCH) && !c->inbranch
+ && gfc_match ("inbranch") == MATCH_YES)
+ {
+ c->inbranch = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOTINBRANCH) && !c->notinbranch
+ && gfc_match ("notinbranch") == MATCH_YES)
+ {
+ c->notinbranch = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_PROC_BIND)
+ && c->proc_bind == OMP_PROC_BIND_UNKNOWN)
+ {
+ if (gfc_match ("proc_bind ( master )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_MASTER;
+ else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_SPREAD;
+ else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_CLOSE;
+ if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_SAFELEN) && c->safelen_expr == NULL
+ && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_SIMDLEN) && c->simdlen_expr == NULL
+ && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_UNIFORM)
+ && gfc_match_omp_variable_list ("uniform (",
+ &c->lists[OMP_LIST_UNIFORM], false)
+ == MATCH_YES)
+ continue;
+ bool end_colon = false;
+ gfc_omp_namelist **head = NULL;
+ old_loc = gfc_current_locus;
+ if ((mask & OMP_CLAUSE_ALIGNED)
+ && gfc_match_omp_variable_list ("aligned (",
+ &c->lists[OMP_LIST_ALIGNED], false,
+ &end_colon, &head)
+ == MATCH_YES)
+ {
+ gfc_expr *alignment = NULL;
+ gfc_omp_namelist *n;
+
+ if (end_colon
+ && gfc_match (" %e )", &alignment) != MATCH_YES)
+ {
+ gfc_free_omp_namelist (*head);
+ gfc_current_locus = old_loc;
+ *head = NULL;
+ break;
+ }
+ for (n = *head; n; n = n->next)
+ if (n->next && alignment)
+ n->expr = gfc_copy_expr (alignment);
+ else
+ n->expr = alignment;
+ continue;
+ }
+ end_colon = false;
+ head = NULL;
+ old_loc = gfc_current_locus;
+ if ((mask & OMP_CLAUSE_LINEAR)
+ && gfc_match_omp_variable_list ("linear (",
+ &c->lists[OMP_LIST_LINEAR], false,
+ &end_colon, &head)
+ == MATCH_YES)
+ {
+ gfc_expr *step = NULL;
+
+ if (end_colon
+ && gfc_match (" %e )", &step) != MATCH_YES)
+ {
+ gfc_free_omp_namelist (*head);
+ gfc_current_locus = old_loc;
+ *head = NULL;
+ break;
+ }
+ else if (!end_colon)
+ {
+ step = gfc_get_constant_expr (BT_INTEGER,
+ gfc_default_integer_kind,
+ &old_loc);
+ mpz_set_si (step->value.integer, 1);
+ }
+ (*head)->expr = step;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_DEPEND)
+ && gfc_match_omp_variable_list ("depend ( in : ",
+ &c->lists[OMP_LIST_DEPEND_IN], false,
+ NULL, NULL, true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_DEPEND)
+ && gfc_match_omp_variable_list ("depend ( out : ",
+ &c->lists[OMP_LIST_DEPEND_OUT], false,
+ NULL, NULL, true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_DEPEND)
+ && gfc_match_omp_variable_list ("depend ( inout : ",
+ &c->lists[OMP_LIST_DEPEND_OUT], false,
+ NULL, NULL, true)
+ == MATCH_YES)
+ continue;
break;
}
@@ -436,7 +607,10 @@ gfc_match_omp_clauses (gfc_omp_clauses *
#define OMP_PARALLEL_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
- | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
+ | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PROC_BIND)
+#define OMP_DECLARE_SIMD_CLAUSES \
+ (OMP_CLAUSE_SIMDLEN | OMP_CLAUSE_LINEAR | OMP_CLAUSE_UNIFORM \
+ | OMP_CLAUSE_ALIGNED)
#define OMP_DO_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
@@ -444,10 +618,14 @@ gfc_match_omp_clauses (gfc_omp_clauses *
#define OMP_SECTIONS_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
+#define OMP_SIMD_CLAUSES \
+ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
+ | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN | OMP_CLAUSE_LINEAR \
+ | OMP_CLAUSE_ALIGNED)
#define OMP_TASK_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
| OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \
- | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE)
+ | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_DEPEND)
match
gfc_match_omp_parallel (void)
@@ -532,14 +710,28 @@ gfc_match_omp_do (void)
match
+gfc_match_omp_do_simd (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, ((OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~OMP_CLAUSE_ORDERED))
+ != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_DO_SIMD;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
gfc_match_omp_flush (void)
{
- gfc_namelist *list = NULL;
+ gfc_omp_namelist *list = NULL;
gfc_match_omp_variable_list (" (", &list, true);
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
- gfc_free_namelist (list);
+ gfc_free_omp_namelist (list);
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_FLUSH;
@@ -549,6 +741,43 @@ gfc_match_omp_flush (void)
match
+gfc_match_omp_simd (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, OMP_SIMD_CLAUSES) != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_SIMD;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_declare_simd (void)
+{
+ locus where = gfc_current_locus;
+ gfc_symbol *proc_name;
+ gfc_omp_clauses *c;
+ gfc_omp_declare_simd *ods;
+
+ if (gfc_match (" ( %s ) ", &proc_name) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
+ false) != MATCH_YES)
+ return MATCH_ERROR;
+
+ ods = gfc_get_omp_declare_simd ();
+ ods->where = where;
+ ods->proc_name = proc_name;
+ ods->clauses = c;
+ ods->next = gfc_current_ns->omp_declare_simd;
+ gfc_current_ns->omp_declare_simd = ods;
+ return MATCH_YES;
+}
+
+
+match
gfc_match_omp_threadprivate (void)
{
locus old_loc;
@@ -630,6 +859,20 @@ gfc_match_omp_parallel_do (void)
match
+gfc_match_omp_parallel_do_simd (void)
+{
+ gfc_omp_clauses *c;
+ if (gfc_match_omp_clauses (&c, (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
+ | OMP_SIMD_CLAUSES) & ~OMP_CLAUSE_ORDERED)
+ != MATCH_YES)
+ return MATCH_ERROR;
+ new_st.op = EXEC_OMP_PARALLEL_DO_SIMD;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
gfc_match_omp_parallel_sections (void)
{
gfc_omp_clauses *c;
@@ -725,20 +968,44 @@ match
gfc_match_omp_atomic (void)
{
gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
- if (gfc_match ("% update") == MATCH_YES)
- op = GFC_OMP_ATOMIC_UPDATE;
- else if (gfc_match ("% read") == MATCH_YES)
- op = GFC_OMP_ATOMIC_READ;
- else if (gfc_match ("% write") == MATCH_YES)
- op = GFC_OMP_ATOMIC_WRITE;
- else if (gfc_match ("% capture") == MATCH_YES)
- op = GFC_OMP_ATOMIC_CAPTURE;
+ int seq_cst = 0;
+ if (gfc_match ("% seq_cst") == MATCH_YES)
+ seq_cst = 1;
+ locus old_loc = gfc_current_locus;
+ if (seq_cst && gfc_match_char (',') == MATCH_YES)
+ seq_cst = 2;
+ if (seq_cst == 2
+ || gfc_match_space () == MATCH_YES)
+ {
+ gfc_gobble_whitespace ();
+ if (gfc_match ("update") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_UPDATE;
+ else if (gfc_match ("read") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_READ;
+ else if (gfc_match ("write") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_WRITE;
+ else if (gfc_match ("capture") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_CAPTURE;
+ else
+ {
+ if (seq_cst == 2)
+ gfc_current_locus = old_loc;
+ goto finish;
+ }
+ if (!seq_cst
+ && (gfc_match (", seq_cst") == MATCH_YES
+ || gfc_match ("% seq_cst") == MATCH_YES))
+ seq_cst = 1;
+ }
+ finish:
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_ATOMIC;
+ if (seq_cst)
+ op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST);
new_st.ext.omp_atomic = op;
return MATCH_YES;
}
@@ -759,6 +1026,73 @@ gfc_match_omp_barrier (void)
match
+gfc_match_omp_taskgroup (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_TASKGROUP;
+ return MATCH_YES;
+}
+
+
+static enum gfc_omp_cancel_kind
+gfc_match_omp_cancel_kind (void)
+{
+ if (gfc_match_space () != MATCH_YES)
+ return OMP_CANCEL_UNKNOWN;
+ if (gfc_match ("parallel") == MATCH_YES)
+ return OMP_CANCEL_PARALLEL;
+ if (gfc_match ("sections") == MATCH_YES)
+ return OMP_CANCEL_SECTIONS;
+ if (gfc_match ("do") == MATCH_YES)
+ return OMP_CANCEL_DO;
+ if (gfc_match ("taskgroup") == MATCH_YES)
+ return OMP_CANCEL_TASKGROUP;
+ return OMP_CANCEL_UNKNOWN;
+}
+
+
+match
+gfc_match_omp_cancel (void)
+{
+ gfc_omp_clauses *c;
+ enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
+ if (kind == OMP_CANCEL_UNKNOWN)
+ return MATCH_ERROR;
+ if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, false) != MATCH_YES)
+ return MATCH_ERROR;
+ c->cancel = kind;
+ new_st.op = EXEC_OMP_CANCEL;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_cancellation_point (void)
+{
+ gfc_omp_clauses *c;
+ enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
+ if (kind == OMP_CANCEL_UNKNOWN)
+ return MATCH_ERROR;
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
+ "at %C");
+ return MATCH_ERROR;
+ }
+ c = gfc_get_omp_clauses ();
+ c->cancel = kind;
+ new_st.op = EXEC_OMP_CANCELLATION_POINT;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
gfc_match_omp_end_nowait (void)
{
bool nowait = false;
@@ -796,14 +1130,15 @@ gfc_match_omp_end_single (void)
/* OpenMP directive resolving routines. */
static void
-resolve_omp_clauses (gfc_code *code)
+resolve_omp_clauses (gfc_code *code, locus *where,
+ gfc_omp_clauses *omp_clauses, gfc_namespace *ns)
{
- gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
- gfc_namelist *n;
+ gfc_omp_namelist *n;
int list;
static const char *clause_names[]
= { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
- "COPYIN", "REDUCTION" };
+ "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "DEPEND",
+ "REDUCTION" };
if (omp_clauses == NULL)
return;
@@ -847,8 +1182,15 @@ resolve_omp_clauses (gfc_code *code)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
n->sym->mark = 0;
- if (n->sym->attr.flavor == FL_VARIABLE || n->sym->attr.proc_pointer)
- continue;
+ if (n->sym->attr.flavor == FL_VARIABLE
+ || n->sym->attr.proc_pointer
+ || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
+ {
+ if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
+ gfc_error ("Variable '%s' is not a dummy argument at %L",
+ n->sym->name, where);
+ continue;
+ }
if (n->sym->attr.flavor == FL_PROCEDURE
&& n->sym->result == n->sym
&& n->sym->attr.function)
@@ -878,16 +1220,20 @@ resolve_omp_clauses (gfc_code *code)
}
}
gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
- &code->loc);
+ where);
}
for (list = 0; list < OMP_LIST_NUM; list++)
- if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
+ if (list != OMP_LIST_FIRSTPRIVATE
+ && list != OMP_LIST_LASTPRIVATE
+ && list != OMP_LIST_ALIGNED
+ && list != OMP_LIST_DEPEND_IN
+ && list != OMP_LIST_DEPEND_OUT)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
else
n->sym->mark = 1;
}
@@ -898,7 +1244,7 @@ resolve_omp_clauses (gfc_code *code)
if (n->sym->mark)
{
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
n->sym->mark = 0;
}
@@ -906,7 +1252,7 @@ resolve_omp_clauses (gfc_code *code)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
else
n->sym->mark = 1;
}
@@ -917,10 +1263,23 @@ resolve_omp_clauses (gfc_code *code)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
else
n->sym->mark = 1;
}
+
+ for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ n->sym->mark = 0;
+
+ for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol '%s' present on multiple clauses at %L",
+ n->sym->name, where);
+ else
+ n->sym->mark = 1;
+ }
+
for (list = 0; list < OMP_LIST_NUM; list++)
if ((n = omp_clauses->lists[list]) != NULL)
{
@@ -940,10 +1299,10 @@ resolve_omp_clauses (gfc_code *code)
{
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
- " at %L", n->sym->name, &code->loc);
+ " at %L", n->sym->name, where);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
- n->sym->name, &code->loc);
+ n->sym->name, where);
}
break;
case OMP_LIST_COPYPRIVATE:
@@ -951,10 +1310,10 @@ resolve_omp_clauses (gfc_code *code)
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
- "at %L", n->sym->name, &code->loc);
+ "at %L", n->sym->name, where);
if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
- n->sym->name, &code->loc);
+ n->sym->name, where);
}
break;
case OMP_LIST_SHARED:
@@ -962,49 +1321,128 @@ resolve_omp_clauses (gfc_code *code)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
- "%L", n->sym->name, &code->loc);
+ "%L", n->sym->name, where);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
+ }
+ break;
+ case OMP_LIST_ALIGNED:
+ for (; n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.pointer
+ && !n->sym->attr.allocatable
+ && !n->sym->attr.cray_pointer
+ && (n->sym->ts.type != BT_DERIVED
+ || (n->sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_C_BINDING)
+ || (n->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR)))
+ gfc_error ("'%s' in ALIGNED clause must be POINTER, "
+ "ALLOCATABLE, Cray pointer or C_PTR at %L",
+ n->sym->name, where);
+ else if (n->expr)
+ {
+ gfc_expr *expr = n->expr;
+ int alignment = 0;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER
+ || expr->rank != 0
+ || gfc_extract_int (expr, &alignment)
+ || alignment <= 0)
+ gfc_error ("'%s' in ALIGNED clause at %L requires a scalar "
+ "positive constant integer alignment "
+ "expression", n->sym->name, where);
+ }
}
break;
+ case OMP_LIST_DEPEND_IN:
+ case OMP_LIST_DEPEND_OUT:
+ for (; n != NULL; n = n->next)
+ if (n->expr)
+ {
+ if (!gfc_resolve_expr (n->expr)
+ || n->expr->expr_type != EXPR_VARIABLE
+ || n->expr->ref == NULL
+ || n->expr->ref->next
+ || n->expr->ref->type != REF_ARRAY)
+ gfc_error ("'%s' in DEPEND clause at %L is not a proper "
+ "array section", n->sym->name, where);
+ else if (n->expr->ref->u.ar.codimen)
+ gfc_error ("Coarrays not supported in DEPEND clause at %L",
+ where);
+ else
+ {
+ int i;
+ gfc_array_ref *ar = &n->expr->ref->u.ar;
+ for (i = 0; i < ar->dimen; i++)
+ if (ar->stride[i])
+ {
+ gfc_error ("Stride should not be specified for "
+ "array section in DEPEND clause at %L",
+ where);
+ break;
+ }
+ else if (ar->dimen_type[i] != DIMEN_ELEMENT
+ && ar->dimen_type[i] != DIMEN_RANGE)
+ {
+ gfc_error ("'%s' in DEPEND clause at %L is not a "
+ "proper array section",
+ n->sym->name, where);
+ break;
+ }
+ else if (ar->start[i]
+ && ar->start[i]->expr_type == EXPR_CONSTANT
+ && ar->end[i]
+ && ar->end[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ar->start[i]->value.integer,
+ ar->end[i]->value.integer) > 0)
+ {
+ gfc_error ("'%s' in DEPEND clause at %L is a zero "
+ "size array section", n->sym->name,
+ where);
+ break;
+ }
+ }
+ }
+ break;
default:
for (; n != NULL; n = n->next)
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
if (list != OMP_LIST_PRIVATE)
{
if (n->sym->attr.pointer
&& list >= OMP_LIST_REDUCTION_FIRST
&& list <= OMP_LIST_REDUCTION_LAST)
gfc_error ("POINTER object '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
/* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)
&& n->sym->ts.type == BT_DERIVED
&& n->sym->ts.u.derived->attr.alloc_comp)
gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
- name, n->sym->name, &code->loc);
+ name, n->sym->name, where);
if (n->sym->attr.cray_pointer
&& list >= OMP_LIST_REDUCTION_FIRST
&& list <= OMP_LIST_REDUCTION_LAST)
gfc_error ("Cray pointer '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
if (n->sym->attr.in_namelist
&& (list < OMP_LIST_REDUCTION_FIRST
|| list > OMP_LIST_REDUCTION_LAST))
gfc_error ("Variable '%s' in %s clause is used in "
"NAMELIST statement at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
switch (list)
{
case OMP_LIST_PLUS:
@@ -1014,7 +1452,7 @@ resolve_omp_clauses (gfc_code *code)
gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
list == OMP_LIST_PLUS ? '+'
: list == OMP_LIST_MULT ? '*' : '-',
- n->sym->name, &code->loc,
+ n->sym->name, where,
gfc_typename (&n->sym->ts));
break;
case OMP_LIST_AND:
@@ -1027,7 +1465,7 @@ resolve_omp_clauses (gfc_code *code)
list == OMP_LIST_AND ? ".AND."
: list == OMP_LIST_OR ? ".OR."
: list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
- n->sym->name, &code->loc);
+ n->sym->name, where);
break;
case OMP_LIST_MAX:
case OMP_LIST_MIN:
@@ -1036,7 +1474,7 @@ resolve_omp_clauses (gfc_code *code)
gfc_error ("%s REDUCTION variable '%s' must be "
"INTEGER or REAL at %L",
list == OMP_LIST_MAX ? "MAX" : "MIN",
- n->sym->name, &code->loc);
+ n->sym->name, where);
break;
case OMP_LIST_IAND:
case OMP_LIST_IOR:
@@ -1046,12 +1484,34 @@ resolve_omp_clauses (gfc_code *code)
"at %L",
list == OMP_LIST_IAND ? "IAND"
: list == OMP_LIST_MULT ? "IOR" : "IEOR",
- n->sym->name, &code->loc);
+ n->sym->name, where);
+ break;
+ case OMP_LIST_LINEAR:
+ if (n->sym->ts.type != BT_INTEGER)
+ gfc_error ("LINEAR variable '%s' must be INTEGER "
+ "at %L", n->sym->name, where);
+ else if (!code && !n->sym->attr.value)
+ gfc_error ("LINEAR dummy argument '%s' must have VALUE "
+ "attribute at %L", n->sym->name, where);
+ else if (n->expr)
+ {
+ gfc_expr *expr = n->expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER
+ || expr->rank != 0)
+ gfc_error ("'%s' in LINEAR clause at %L requires "
+ "a scalar integer linear-step expression",
+ n->sym->name, where);
+ else if (!code && expr->expr_type != EXPR_CONSTANT)
+ gfc_error ("'%s' in LINEAR clause at %L requires "
+ "a constant integer linear-step expression",
+ n->sym->name, where);
+ }
break;
/* Workaround for PR middle-end/26316, nothing really needs
to be done here for OMP_LIST_PRIVATE. */
case OMP_LIST_PRIVATE:
- gcc_assert (code->op != EXEC_NOP);
+ gcc_assert (code && code->op != EXEC_NOP);
default:
break;
}
@@ -1059,6 +1519,22 @@ resolve_omp_clauses (gfc_code *code)
break;
}
}
+ if (omp_clauses->safelen_expr)
+ {
+ gfc_expr *expr = omp_clauses->safelen_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("SAFELEN clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->simdlen_expr)
+ {
+ gfc_expr *expr = omp_clauses->simdlen_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("SIMDLEN clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
+ }
}
@@ -1142,12 +1618,13 @@ resolve_omp_atomic (gfc_code *code)
gfc_code *atomic_code = code;
gfc_symbol *var;
gfc_expr *expr2, *expr2_tmp;
+ gfc_omp_atomic_op aop
+ = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
- gcc_assert ((atomic_code->ext.omp_atomic != GFC_OMP_ATOMIC_CAPTURE
- && code->next == NULL)
- || (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE
+ gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) && code->next == NULL)
+ || ((aop == GFC_OMP_ATOMIC_CAPTURE)
&& code->next != NULL
&& code->next->op == EXEC_ASSIGN
&& code->next->next == NULL));
@@ -1169,14 +1646,13 @@ resolve_omp_atomic (gfc_code *code)
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
{
- if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_READ
- || atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+ if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
expr2 = is_conversion (code->expr2, true);
if (expr2 == NULL)
expr2 = code->expr2;
}
- switch (atomic_code->ext.omp_atomic)
+ switch (aop)
{
case GFC_OMP_ATOMIC_READ:
if (expr2->expr_type != EXPR_VARIABLE
@@ -1249,7 +1725,21 @@ resolve_omp_atomic (gfc_code *code)
break;
}
- if (expr2->expr_type == EXPR_OP)
+ if (var->attr.allocatable)
+ {
+ gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
+ &code->loc);
+ return;
+ }
+
+ if (aop == GFC_OMP_ATOMIC_CAPTURE
+ && code->next == NULL
+ && code->expr2->rank == 0
+ && !expr_references_sym (code->expr2, var, NULL))
+ atomic_code->ext.omp_atomic
+ = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
+ | GFC_OMP_ATOMIC_SWAP);
+ else if (expr2->expr_type == EXPR_OP)
{
gfc_expr *v = NULL, *e, *c;
gfc_intrinsic_op op = expr2->value.op.op;
@@ -1420,11 +1910,18 @@ resolve_omp_atomic (gfc_code *code)
&& arg->expr->symtree->n.sym == var)
var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL))
- gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
- "reference '%s' at %L", var->name, &arg->expr->where);
+ {
+ gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
+ "not reference '%s' at %L",
+ var->name, &arg->expr->where);
+ return;
+ }
if (arg->expr->rank != 0)
- gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
- "at %L", &arg->expr->where);
+ {
+ gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
+ "at %L", &arg->expr->where);
+ return;
+ }
}
if (var_arg == NULL)
@@ -1447,10 +1944,10 @@ resolve_omp_atomic (gfc_code *code)
}
}
else
- gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
- "on right hand side at %L", &expr2->where);
+ gfc_error ("!$OMP ATOMIC assignment must have an operator or "
+ "intrinsic on right hand side at %L", &expr2->where);
- if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE && code->next)
+ if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
{
code = code->next;
if (code->expr1->expr_type != EXPR_VARIABLE
@@ -1542,7 +2039,7 @@ gfc_resolve_omp_parallel_blocks (gfc_cod
{
struct omp_context ctx;
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
- gfc_namelist *n;
+ gfc_omp_namelist *n;
int list;
ctx.code = code;
@@ -1555,7 +2052,8 @@ gfc_resolve_omp_parallel_blocks (gfc_cod
for (n = omp_clauses->lists[list]; n; n = n->next)
pointer_set_insert (ctx.sharing_clauses, n->sym);
- if (code->op == EXEC_OMP_PARALLEL_DO)
+ if (code->op == EXEC_OMP_PARALLEL_DO
+ || code->op == EXEC_OMP_PARALLEL_DO_SIMD)
gfc_resolve_omp_do_blocks (code, ns);
else
gfc_resolve_blocks (code->block, ns);
@@ -1624,9 +2122,9 @@ gfc_resolve_do_iterator (gfc_code *code,
if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
{
gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
- gfc_namelist *p;
+ gfc_omp_namelist *p;
- p = gfc_get_namelist ();
+ p = gfc_get_omp_namelist ();
p->sym = sym;
p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
omp_clauses->lists[OMP_LIST_PRIVATE] = p;
@@ -1639,11 +2137,25 @@ resolve_omp_do (gfc_code *code)
{
gfc_code *do_code, *c;
int list, i, collapse;
- gfc_namelist *n;
+ gfc_omp_namelist *n;
gfc_symbol *dovar;
+ const char *name;
+ bool is_simd = false;
+
+ switch (code->op)
+ {
+ case EXEC_OMP_DO: name = "!$OMP DO"; break;
+ case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
+ case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ name = "!$OMP PARALLEL DO SIMD";
+ is_simd = true; break;
+ case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
+ default: gcc_unreachable ();
+ }
if (code->ext.omp_clauses)
- resolve_omp_clauses (code);
+ resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
do_code = code->block->next;
collapse = code->ext.omp_clauses->collapse;
@@ -1653,27 +2165,40 @@ resolve_omp_do (gfc_code *code)
{
if (do_code->op == EXEC_DO_WHILE)
{
- gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
- "at %L", &do_code->loc);
+ gfc_error ("%s cannot be a DO WHILE or DO without loop control "
+ "at %L", name, &do_code->loc);
break;
}
gcc_assert (do_code->op == EXEC_DO);
if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
- gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
- &do_code->loc);
+ gfc_error ("%s iteration variable must be of type integer at %L",
+ name, &do_code->loc);
dovar = do_code->ext.iterator->var->symtree->n.sym;
if (dovar->attr.threadprivate)
- gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
- "at %L", &do_code->loc);
+ gfc_error ("%s iteration variable must not be THREADPRIVATE "
+ "at %L", name, &do_code->loc);
if (code->ext.omp_clauses)
for (list = 0; list < OMP_LIST_NUM; list++)
- if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
+ if (!is_simd
+ ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
+ : code->ext.omp_clauses->collapse > 1
+ ? (list != OMP_LIST_LASTPRIVATE)
+ : (list != OMP_LIST_LINEAR))
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
if (dovar == n->sym)
{
- gfc_error ("!$OMP DO iteration variable present on clause "
- "other than PRIVATE or LASTPRIVATE at %L",
- &do_code->loc);
+ if (!is_simd)
+ gfc_error ("%s iteration variable present on clause "
+ "other than PRIVATE or LASTPRIVATE at %L",
+ name, &do_code->loc);
+ else if (code->ext.omp_clauses->collapse > 1)
+ gfc_error ("%s iteration variable present on clause "
+ "other than LASTPRIVATE at %L",
+ name, &do_code->loc);
+ else
+ gfc_error ("%s iteration variable present on clause "
+ "other than LINEAR at %L",
+ name, &do_code->loc);
break;
}
if (i > 1)
@@ -1689,8 +2214,8 @@ resolve_omp_do (gfc_code *code)
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
{
- gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
- &do_code->loc);
+ gfc_error ("%s collapsed loops don't form rectangular "
+ "iteration space at %L", name, &do_code->loc);
break;
}
if (j < i)
@@ -1703,8 +2228,8 @@ resolve_omp_do (gfc_code *code)
for (c = do_code->next; c; c = c->next)
if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
{
- gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
- &c->loc);
+ gfc_error ("collapsed %s loops not perfectly nested at %L",
+ name, &c->loc);
break;
}
if (c)
@@ -1712,16 +2237,16 @@ resolve_omp_do (gfc_code *code)
do_code = do_code->block;
if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
{
- gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
- &code->loc);
+ gfc_error ("not enough DO loops for collapsed %s at %L",
+ name, &code->loc);
break;
}
do_code = do_code->next;
if (do_code == NULL
|| (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
{
- gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
- &code->loc);
+ gfc_error ("not enough DO loops for collapsed %s at %L",
+ name, &code->loc);
break;
}
}
@@ -1740,18 +2265,22 @@ gfc_resolve_omp_directive (gfc_code *cod
switch (code->op)
{
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_SIMD:
resolve_omp_do (code);
break;
- case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_CANCEL:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
+ case EXEC_OMP_WORKSHARE:
if (code->ext.omp_clauses)
- resolve_omp_clauses (code);
+ resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
break;
case EXEC_OMP_ATOMIC:
resolve_omp_atomic (code);
@@ -1760,3 +2289,20 @@ gfc_resolve_omp_directive (gfc_code *cod
break;
}
}
+
+/* Resolve !$omp declare simd constructs in NS. */
+
+void
+gfc_resolve_omp_declare_simd (gfc_namespace *ns)
+{
+ gfc_omp_declare_simd *ods;
+
+ for (ods = ns->omp_declare_simd; ods; ods = ods->next)
+ {
+ if (ods->proc_name != ns->proc_name)
+ gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure"
+ "'%s' at %L", ns->proc_name->name, &ods->where);
+ if (ods->clauses)
+ resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
+ }
+}
--- gcc/fortran/parse.c.jj 2014-05-02 19:39:53.458679678 +0200
+++ gcc/fortran/parse.c 2014-05-02 20:13:06.764495109 +0200
@@ -569,17 +569,27 @@ decode_omp_directive (void)
match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
break;
case 'c':
+ match ("cancellation% point", gfc_match_omp_cancellation_point,
+ ST_OMP_CANCELLATION_POINT);
+ match ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
break;
case 'd':
+ match ("declare simd", gfc_match_omp_declare_simd,
+ ST_OMP_DECLARE_SIMD);
+ match ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
match ("do", gfc_match_omp_do, ST_OMP_DO);
break;
case 'e':
match ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+ match ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+ match ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+ match ("end parallel do simd", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_DO_SIMD);
match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
match ("end parallel sections", gfc_match_omp_eos,
ST_OMP_END_PARALLEL_SECTIONS);
@@ -588,6 +598,7 @@ decode_omp_directive (void)
match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+ match ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
match ("end workshare", gfc_match_omp_end_nowait,
ST_OMP_END_WORKSHARE);
@@ -602,6 +613,8 @@ decode_omp_directive (void)
match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
break;
case 'p':
+ match ("parallel do simd", gfc_match_omp_parallel_do_simd,
+ ST_OMP_PARALLEL_DO_SIMD);
match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
match ("parallel sections", gfc_match_omp_parallel_sections,
ST_OMP_PARALLEL_SECTIONS);
@@ -612,12 +625,14 @@ decode_omp_directive (void)
case 's':
match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+ match ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
break;
case 't':
- match ("task", gfc_match_omp_task, ST_OMP_TASK);
+ match ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
match ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
+ match ("task", gfc_match_omp_task, ST_OMP_TASK);
match ("threadprivate", gfc_match_omp_threadprivate,
ST_OMP_THREADPRIVATE);
break;
@@ -1013,6 +1028,7 @@ next_statement (void)
case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
+ case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
case ST_ERROR_STOP: case ST_SYNC_ALL: case ST_SYNC_IMAGES: \
case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
@@ -1026,14 +1042,15 @@ next_statement (void)
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
- case ST_OMP_TASK: case ST_CRITICAL
+ case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
+ case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_CRITICAL
/* Declaration statements */
#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
- case ST_PROCEDURE
+ case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
@@ -1524,12 +1541,24 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_BARRIER:
p = "!$OMP BARRIER";
break;
+ case ST_OMP_CANCEL:
+ p = "!$OMP CANCEL";
+ break;
+ case ST_OMP_CANCELLATION_POINT:
+ p = "!$OMP CANCELLATION POINT";
+ break;
case ST_OMP_CRITICAL:
p = "!$OMP CRITICAL";
break;
+ case ST_OMP_DECLARE_SIMD:
+ p = "!$OMP DECLARE SIMD";
+ break;
case ST_OMP_DO:
p = "!$OMP DO";
break;
+ case ST_OMP_DO_SIMD:
+ p = "!$OMP DO SIMD";
+ break;
case ST_OMP_END_ATOMIC:
p = "!$OMP END ATOMIC";
break;
@@ -1539,6 +1568,12 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_END_DO:
p = "!$OMP END DO";
break;
+ case ST_OMP_END_DO_SIMD:
+ p = "!$OMP END DO SIMD";
+ break;
+ case ST_OMP_END_SIMD:
+ p = "!$OMP END SIMD";
+ break;
case ST_OMP_END_MASTER:
p = "!$OMP END MASTER";
break;
@@ -1551,6 +1586,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_END_PARALLEL_DO:
p = "!$OMP END PARALLEL DO";
break;
+ case ST_OMP_END_PARALLEL_DO_SIMD:
+ p = "!$OMP END PARALLEL DO SIMD";
+ break;
case ST_OMP_END_PARALLEL_SECTIONS:
p = "!$OMP END PARALLEL SECTIONS";
break;
@@ -1566,6 +1604,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_END_TASK:
p = "!$OMP END TASK";
break;
+ case ST_OMP_END_TASKGROUP:
+ p = "!$OMP END TASKGROUP";
+ break;
case ST_OMP_END_WORKSHARE:
p = "!$OMP END WORKSHARE";
break;
@@ -1584,6 +1625,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_PARALLEL_DO:
p = "!$OMP PARALLEL DO";
break;
+ case ST_OMP_PARALLEL_DO_SIMD:
+ p = "!$OMP PARALLEL DO SIMD";
+ break;
case ST_OMP_PARALLEL_SECTIONS:
p = "!$OMP PARALLEL SECTIONS";
break;
@@ -1596,12 +1640,18 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_SECTION:
p = "!$OMP SECTION";
break;
+ case ST_OMP_SIMD:
+ p = "!$OMP SIMD";
+ break;
case ST_OMP_SINGLE:
p = "!$OMP SINGLE";
break;
case ST_OMP_TASK:
p = "!$OMP TASK";
break;
+ case ST_OMP_TASKGROUP:
+ p = "!$OMP TASKGROUP";
+ break;
case ST_OMP_TASKWAIT:
p = "!$OMP TASKWAIT";
break;
@@ -3578,7 +3628,19 @@ parse_omp_do (gfc_statement omp_st)
pop_state ();
st = next_statement ();
- if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
+ gfc_statement omp_end_st = ST_OMP_END_DO;
+ switch (omp_st)
+ {
+ case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
+ case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
+ case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
+ case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
+ case ST_OMP_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
+ break;
+ default: gcc_unreachable ();
+ }
+ if (st == omp_end_st)
{
if (new_st.op == EXEC_OMP_END_NOWAIT)
cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
@@ -3610,7 +3672,8 @@ parse_omp_atomic (void)
np = new_level (cp);
np->op = cp->op;
np->block = NULL;
- count = 1 + (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE);
+ count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_CAPTURE);
while (count)
{
@@ -3636,7 +3699,8 @@ parse_omp_atomic (void)
gfc_warning_check ();
st = next_statement ();
}
- else if (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE)
+ else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_CAPTURE)
gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
return st;
}
@@ -3685,6 +3749,9 @@ parse_omp_structured_block (gfc_statemen
case ST_OMP_TASK:
omp_end_st = ST_OMP_END_TASK;
break;
+ case ST_OMP_TASKGROUP:
+ omp_end_st = ST_OMP_END_TASKGROUP;
+ break;
case ST_OMP_WORKSHARE:
omp_end_st = ST_OMP_END_WORKSHARE;
break;
@@ -3744,6 +3811,7 @@ parse_omp_structured_block (gfc_statemen
break;
case ST_OMP_PARALLEL_DO:
+ case ST_OMP_PARALLEL_DO_SIMD:
st = parse_omp_do (st);
continue;
@@ -3917,6 +3985,7 @@ parse_executable (gfc_statement st)
case ST_OMP_MASTER:
case ST_OMP_SINGLE:
case ST_OMP_TASK:
+ case ST_OMP_TASKGROUP:
parse_omp_structured_block (st, false);
break;
@@ -3926,7 +3995,10 @@ parse_executable (gfc_statement st)
break;
case ST_OMP_DO:
+ case ST_OMP_DO_SIMD:
case ST_OMP_PARALLEL_DO:
+ case ST_OMP_PARALLEL_DO_SIMD:
+ case ST_OMP_SIMD:
st = parse_omp_do (st);
if (st == ST_IMPLIED_ENDDO)
return st;
--- gcc/fortran/trans-decl.c.jj 2014-05-02 15:39:50.000000000 +0200
+++ gcc/fortran/trans-decl.c 2014-05-07 16:45:34.640266398 +0200
@@ -1847,6 +1847,11 @@ module_sym:
if (DECL_CONTEXT (fndecl) == NULL_TREE)
pushdecl_top_level (fndecl);
+ if (sym->formal_ns
+ && sym->formal_ns->proc_name == sym
+ && sym->formal_ns->omp_declare_simd)
+ gfc_trans_omp_declare_simd (sym->formal_ns);
+
return fndecl;
}
@@ -2552,6 +2557,9 @@ gfc_create_function_decl (gfc_namespace
/* Now create the read argument list. */
create_function_arglist (ns->proc_name);
+
+ if (ns->omp_declare_simd)
+ gfc_trans_omp_declare_simd (ns);
}
/* Return the decl used to hold the function return value. If
--- gcc/fortran/frontend-passes.c.jj 2014-05-02 19:39:53.436679791 +0200
+++ gcc/fortran/frontend-passes.c 2014-05-06 14:32:13.551038446 +0200
@@ -2112,6 +2112,7 @@ gfc_code_walker (gfc_code **c, walk_code
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
in_omp_workshare = false;
@@ -2128,9 +2129,11 @@ gfc_code_walker (gfc_code **c, walk_code
/* Fall through */
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_END_SINGLE:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_TASK:
/* Come to this label only from the
@@ -2144,7 +2147,24 @@ gfc_code_walker (gfc_code **c, walk_code
WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
+ WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
}
+ {
+ gfc_omp_namelist *n;
+ for (n = co->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
+ n; n = n->next)
+ WALK_SUBEXPR (n->expr);
+ for (n = co->ext.omp_clauses->lists[OMP_LIST_LINEAR];
+ n; n = n->next)
+ WALK_SUBEXPR (n->expr);
+ for (n = co->ext.omp_clauses->lists[OMP_LIST_DEPEND_IN];
+ n; n = n->next)
+ WALK_SUBEXPR (n->expr);
+ for (n = co->ext.omp_clauses->lists[OMP_LIST_DEPEND_OUT];
+ n; n = n->next)
+ WALK_SUBEXPR (n->expr);
+ }
break;
default:
break;
--- gcc/fortran/match.c.jj 2014-05-02 19:39:53.447679734 +0200
+++ gcc/fortran/match.c 2014-05-02 20:13:06.762495048 +0200
@@ -2595,7 +2595,10 @@ match_exit_cycle (gfc_statement st, gfc_
&& o != NULL
&& o->state == COMP_OMP_STRUCTURED_BLOCK
&& (o->head->op == EXEC_OMP_DO
- || o->head->op == EXEC_OMP_PARALLEL_DO))
+ || o->head->op == EXEC_OMP_PARALLEL_DO
+ || o->head->op == EXEC_OMP_SIMD
+ || o->head->op == EXEC_OMP_DO_SIMD
+ || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
{
int collapse = 1;
gcc_assert (o->head->next != NULL
@@ -4561,6 +4564,22 @@ gfc_free_namelist (gfc_namelist *name)
n = name->next;
free (name);
}
+}
+
+
+/* Free an OpenMP namelist structure. */
+
+void
+gfc_free_omp_namelist (gfc_omp_namelist *name)
+{
+ gfc_omp_namelist *n;
+
+ for (; name; name = n)
+ {
+ gfc_free_expr (name->expr);
+ n = name->next;
+ free (name);
+ }
}
--- gcc/fortran/dump-parse-tree.c.jj 2014-05-02 19:39:53.464679647 +0200
+++ gcc/fortran/dump-parse-tree.c 2014-05-06 14:34:09.206444728 +0200
@@ -1016,11 +1016,19 @@ show_code (int level, gfc_code *c)
}
static void
-show_namelist (gfc_namelist *n)
+show_omp_namelist (gfc_omp_namelist *n)
{
- for (; n->next; n = n->next)
- fprintf (dumpfile, "%s,", n->sym->name);
- fprintf (dumpfile, "%s", n->sym->name);
+ for (; n; n = n->next)
+ {
+ fprintf (dumpfile, "%s", n->sym->name);
+ if (n->expr)
+ {
+ fputc (':', dumpfile);
+ show_expr (n->expr);
+ }
+ if (n->next)
+ fputc (',', dumpfile);
+ }
}
/* Show a single OpenMP directive node and everything underneath it
@@ -1036,18 +1044,24 @@ show_omp_node (int level, gfc_code *c)
{
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
+ case EXEC_OMP_CANCEL: name = "CANCEL"; break;
+ case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
case EXEC_OMP_FLUSH: name = "FLUSH"; break;
case EXEC_OMP_DO: name = "DO"; break;
+ case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
case EXEC_OMP_MASTER: name = "MASTER"; break;
case EXEC_OMP_ORDERED: name = "ORDERED"; break;
case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
+ case EXEC_OMP_SIMD: name = "SIMD"; break;
case EXEC_OMP_SINGLE: name = "SINGLE"; break;
case EXEC_OMP_TASK: name = "TASK"; break;
+ case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
@@ -1057,11 +1071,16 @@ show_omp_node (int level, gfc_code *c)
fprintf (dumpfile, "!$OMP %s", name);
switch (c->op)
{
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
@@ -1076,7 +1095,7 @@ show_omp_node (int level, gfc_code *c)
if (c->ext.omp_namelist)
{
fputs (" (", dumpfile);
- show_namelist (c->ext.omp_namelist);
+ show_omp_namelist (c->ext.omp_namelist);
fputc (')', dumpfile);
}
return;
@@ -1091,6 +1110,23 @@ show_omp_node (int level, gfc_code *c)
{
int list_type;
+ switch (omp_clauses->cancel)
+ {
+ case OMP_CANCEL_UNKNOWN:
+ break;
+ case OMP_CANCEL_PARALLEL:
+ fputs (" PARALLEL", dumpfile);
+ break;
+ case OMP_CANCEL_SECTIONS:
+ fputs (" SECTIONS", dumpfile);
+ break;
+ case OMP_CANCEL_DO:
+ fputs (" DO", dumpfile);
+ break;
+ case OMP_CANCEL_TASKGROUP:
+ fputs (" TASKGROUP", dumpfile);
+ break;
+ }
if (omp_clauses->if_expr)
{
fputs (" IF(", dumpfile);
@@ -1156,7 +1192,7 @@ show_omp_node (int level, gfc_code *c)
if (omp_clauses->lists[list_type] != NULL
&& list_type != OMP_LIST_COPYPRIVATE)
{
- const char *type;
+ const char *type = NULL;
if (list_type >= OMP_LIST_REDUCTION_FIRST)
{
switch (list_type)
@@ -1187,14 +1223,53 @@ show_omp_node (int level, gfc_code *c)
case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
case OMP_LIST_SHARED: type = "SHARED"; break;
case OMP_LIST_COPYIN: type = "COPYIN"; break;
+ case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
+ case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
+ case OMP_LIST_LINEAR: type = "LINEAR"; break;
+ case OMP_LIST_DEPEND_IN:
+ fprintf (dumpfile, " DEPEND(IN:");
+ break;
+ case OMP_LIST_DEPEND_OUT:
+ fprintf (dumpfile, " DEPEND(OUT:");
+ break;
default:
gcc_unreachable ();
}
- fprintf (dumpfile, " %s(", type);
+ if (type)
+ fprintf (dumpfile, " %s(", type);
}
- show_namelist (omp_clauses->lists[list_type]);
+ show_omp_namelist (omp_clauses->lists[list_type]);
fputc (')', dumpfile);
}
+ if (omp_clauses->safelen_expr)
+ {
+ fputs (" SAFELEN(", dumpfile);
+ show_expr (omp_clauses->safelen_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->simdlen_expr)
+ {
+ fputs (" SIMDLEN(", dumpfile);
+ show_expr (omp_clauses->simdlen_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->inbranch)
+ fputs (" INBRANCH", dumpfile);
+ if (omp_clauses->notinbranch)
+ fputs (" NOTINBRANCH", dumpfile);
+ if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
+ {
+ const char *type;
+ switch (omp_clauses->proc_bind)
+ {
+ case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
+ case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
+ case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
+ default:
+ gcc_unreachable ();
+ }
+ fprintf (dumpfile, " PROC_BIND(%s)", type);
+ }
}
fputc ('\n', dumpfile);
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
@@ -1214,6 +1289,7 @@ show_omp_node (int level, gfc_code *c)
show_code (level + 1, c->block->next);
if (c->op == EXEC_OMP_ATOMIC)
return;
+ fputc ('\n', dumpfile);
code_indent (level, 0);
fprintf (dumpfile, "!$OMP END %s", name);
if (omp_clauses != NULL)
@@ -1221,7 +1297,7 @@ show_omp_node (int level, gfc_code *c)
if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
{
fputs (" COPYPRIVATE(", dumpfile);
- show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
+ show_omp_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
fputc (')', dumpfile);
}
else if (omp_clauses->nowait)
@@ -2195,19 +2271,25 @@ show_code_node (int level, gfc_code *c)
break;
case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
--- gcc/fortran/match.h.jj 2014-05-02 19:39:53.458679678 +0200
+++ gcc/fortran/match.h 2014-05-02 20:13:06.758494912 +0200
@@ -126,18 +126,25 @@ gfc_common_head *gfc_get_common (const c
match gfc_match_omp_eos (void);
match gfc_match_omp_atomic (void);
match gfc_match_omp_barrier (void);
+match gfc_match_omp_cancel (void);
+match gfc_match_omp_cancellation_point (void);
match gfc_match_omp_critical (void);
+match gfc_match_omp_declare_simd (void);
match gfc_match_omp_do (void);
+match gfc_match_omp_do_simd (void);
match gfc_match_omp_flush (void);
match gfc_match_omp_master (void);
match gfc_match_omp_ordered (void);
match gfc_match_omp_parallel (void);
match gfc_match_omp_parallel_do (void);
+match gfc_match_omp_parallel_do_simd (void);
match gfc_match_omp_parallel_sections (void);
match gfc_match_omp_parallel_workshare (void);
match gfc_match_omp_sections (void);
+match gfc_match_omp_simd (void);
match gfc_match_omp_single (void);
match gfc_match_omp_task (void);
+match gfc_match_omp_taskgroup (void);
match gfc_match_omp_taskwait (void);
match gfc_match_omp_taskyield (void);
match gfc_match_omp_threadprivate (void);
--- gcc/fortran/trans-openmp.c.jj 2014-05-02 19:39:53.437679786 +0200
+++ gcc/fortran/trans-openmp.c 2014-05-07 18:47:45.640388084 +0200
@@ -427,8 +427,33 @@ gfc_trans_add_clause (tree node, tree ta
}
static tree
-gfc_trans_omp_variable (gfc_symbol *sym)
+gfc_trans_omp_variable (gfc_symbol *sym, bool declare_simd)
{
+ if (declare_simd)
+ {
+ int cnt = 0;
+ gfc_symbol *proc_sym;
+ gfc_formal_arglist *f;
+
+ gcc_assert (sym->attr.dummy);
+ proc_sym = sym->ns->proc_name;
+ if (proc_sym->attr.entry_master)
+ ++cnt;
+ if (gfc_return_by_reference (proc_sym))
+ {
+ ++cnt;
+ if (proc_sym->ts.type == BT_CHARACTER)
+ ++cnt;
+ }
+ for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
+ if (f->sym == sym)
+ break;
+ else if (f->sym)
+ ++cnt;
+ gcc_assert (f);
+ return build_int_cst (integer_type_node, cnt);
+ }
+
tree t = gfc_get_symbol_decl (sym);
tree parent_decl;
int parent_flag;
@@ -442,7 +467,8 @@ gfc_trans_omp_variable (gfc_symbol *sym)
entry_master = sym->attr.result
&& sym->ns->proc_name->attr.entry_master
&& !gfc_return_by_reference (sym->ns->proc_name);
- parent_decl = DECL_CONTEXT (current_function_decl);
+ parent_decl = current_function_decl
+ ? DECL_CONTEXT (current_function_decl) : NULL_TREE;
if ((t == parent_decl && return_value)
|| (sym->ns && sym->ns->proc_name
@@ -481,13 +507,14 @@ gfc_trans_omp_variable (gfc_symbol *sym)
}
static tree
-gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist,
- tree list)
+gfc_trans_omp_variable_list (enum omp_clause_code code,
+ gfc_omp_namelist *namelist, tree list,
+ bool declare_simd)
{
for (; namelist != NULL; namelist = namelist->next)
- if (namelist->sym->attr.referenced)
+ if (namelist->sym->attr.referenced || declare_simd)
{
- tree t = gfc_trans_omp_variable (namelist->sym);
+ tree t = gfc_trans_omp_variable (namelist->sym, declare_simd);
if (t != error_mark_node)
{
tree node = build_omp_clause (input_location, code);
@@ -745,13 +772,13 @@ gfc_trans_omp_array_reduction (tree c, g
}
static tree
-gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list,
+gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list,
enum tree_code reduction_code, locus where)
{
for (; namelist != NULL; namelist = namelist->next)
if (namelist->sym->attr.referenced)
{
- tree t = gfc_trans_omp_variable (namelist->sym);
+ tree t = gfc_trans_omp_variable (namelist->sym, false);
if (t != error_mark_node)
{
tree node = build_omp_clause (where.lb->location,
@@ -768,7 +795,7 @@ gfc_trans_omp_reduction_list (gfc_nameli
static tree
gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
- locus where)
+ locus where, bool declare_simd = false)
{
tree omp_clauses = NULL_TREE, chunk_size, c;
int list;
@@ -780,7 +807,7 @@ gfc_trans_omp_clauses (stmtblock_t *bloc
for (list = 0; list < OMP_LIST_NUM; list++)
{
- gfc_namelist *n = clauses->lists[list];
+ gfc_omp_namelist *n = clauses->lists[list];
if (n == NULL)
continue;
@@ -853,10 +880,125 @@ gfc_trans_omp_clauses (stmtblock_t *bloc
goto add_clause;
case OMP_LIST_COPYPRIVATE:
clause_code = OMP_CLAUSE_COPYPRIVATE;
+ goto add_clause;
+ case OMP_LIST_UNIFORM:
+ clause_code = OMP_CLAUSE_UNIFORM;
/* FALLTHROUGH */
add_clause:
omp_clauses
- = gfc_trans_omp_variable_list (clause_code, n, omp_clauses);
+ = gfc_trans_omp_variable_list (clause_code, n, omp_clauses,
+ declare_simd);
+ break;
+ case OMP_LIST_ALIGNED:
+ for (; n != NULL; n = n->next)
+ if (n->sym->attr.referenced || declare_simd)
+ {
+ tree t = gfc_trans_omp_variable (n->sym, declare_simd);
+ if (t != error_mark_node)
+ {
+ tree node = build_omp_clause (input_location,
+ OMP_CLAUSE_ALIGNED);
+ OMP_CLAUSE_DECL (node) = t;
+ if (n->expr)
+ {
+ tree alignment_var;
+
+ if (block == NULL)
+ alignment_var = gfc_conv_constant_to_tree (n->expr);
+ else
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, n->expr);
+ gfc_add_block_to_block (block, &se.pre);
+ alignment_var = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+ }
+ OMP_CLAUSE_ALIGNED_ALIGNMENT (node) = alignment_var;
+ }
+ omp_clauses = gfc_trans_add_clause (node, omp_clauses);
+ }
+ }
+ break;
+ case OMP_LIST_LINEAR:
+ {
+ gfc_expr *last_step_expr = NULL;
+ tree last_step = NULL_TREE;
+
+ for (; n != NULL; n = n->next)
+ {
+ if (n->expr)
+ {
+ last_step_expr = n->expr;
+ last_step = NULL_TREE;
+ }
+ if (n->sym->attr.referenced || declare_simd)
+ {
+ tree t = gfc_trans_omp_variable (n->sym, declare_simd);
+ if (t != error_mark_node)
+ {
+ tree node = build_omp_clause (input_location,
+ OMP_CLAUSE_LINEAR);
+ OMP_CLAUSE_DECL (node) = t;
+ if (last_step_expr && last_step == NULL_TREE)
+ {
+ if (block == NULL)
+ last_step
+ = gfc_conv_constant_to_tree (last_step_expr);
+ else
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, last_step_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ last_step = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+ }
+ }
+ OMP_CLAUSE_LINEAR_STEP (node) = last_step;
+ omp_clauses = gfc_trans_add_clause (node, omp_clauses);
+ }
+ }
+ }
+ }
+ break;
+ case OMP_LIST_DEPEND_IN:
+ case OMP_LIST_DEPEND_OUT:
+ for (; n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.referenced)
+ continue;
+
+ tree node = build_omp_clause (input_location, OMP_CLAUSE_DEPEND);
+ if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
+ {
+ OMP_CLAUSE_DECL (node) = gfc_get_symbol_decl (n->sym);
+ if (DECL_P (OMP_CLAUSE_DECL (node)))
+ TREE_ADDRESSABLE (OMP_CLAUSE_DECL (node)) = 1;
+ }
+ else
+ {
+ tree ptr;
+ gfc_init_se (&se, NULL);
+ if (n->expr->ref->u.ar.type == AR_ELEMENT)
+ {
+ gfc_conv_expr_reference (&se, n->expr);
+ ptr = se.expr;
+ }
+ else
+ {
+ gfc_conv_expr_descriptor (&se, n->expr);
+ ptr = gfc_conv_array_data (se.expr);
+ }
+ gfc_add_block_to_block (block, &se.pre);
+ gfc_add_block_to_block (block, &se.post);
+ OMP_CLAUSE_DECL (node)
+ = fold_build1_loc (input_location, INDIRECT_REF,
+ TREE_TYPE (TREE_TYPE (ptr)), ptr);
+ }
+ OMP_CLAUSE_DEPEND_KIND (node)
+ = ((list == OMP_LIST_DEPEND_IN)
+ ? OMP_CLAUSE_DEPEND_IN : OMP_CLAUSE_DEPEND_OUT);
+ omp_clauses = gfc_trans_add_clause (node, omp_clauses);
+ }
break;
default:
break;
@@ -1000,6 +1142,83 @@ gfc_trans_omp_clauses (stmtblock_t *bloc
omp_clauses = gfc_trans_add_clause (c, omp_clauses);
}
+ if (clauses->inbranch)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_INBRANCH);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->notinbranch)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_NOTINBRANCH);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ switch (clauses->cancel)
+ {
+ case OMP_CANCEL_UNKNOWN:
+ break;
+ case OMP_CANCEL_PARALLEL:
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_PARALLEL);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ break;
+ case OMP_CANCEL_SECTIONS:
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_SECTIONS);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ break;
+ case OMP_CANCEL_DO:
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_FOR);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ break;
+ case OMP_CANCEL_TASKGROUP:
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_TASKGROUP);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ break;
+ }
+
+ if (clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_PROC_BIND);
+ switch (clauses->proc_bind)
+ {
+ case OMP_PROC_BIND_MASTER:
+ OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_MASTER;
+ break;
+ case OMP_PROC_BIND_SPREAD:
+ OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_SPREAD;
+ break;
+ case OMP_PROC_BIND_CLOSE:
+ OMP_CLAUSE_PROC_BIND_KIND (c) = OMP_CLAUSE_PROC_BIND_CLOSE;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->safelen_expr)
+ {
+ tree safelen_var;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, clauses->safelen_expr);
+ gfc_add_block_to_block (block, &se.pre);
+ safelen_var = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_SAFELEN);
+ OMP_CLAUSE_SAFELEN_EXPR (c) = safelen_var;
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
+ if (clauses->simdlen_expr)
+ {
+ c = build_omp_clause (where.lb->location, OMP_CLAUSE_SIMDLEN);
+ OMP_CLAUSE_SIMDLEN_EXPR (c)
+ = gfc_conv_constant_to_tree (clauses->simdlen_expr);
+ omp_clauses = gfc_trans_add_clause (c, omp_clauses);
+ }
+
return omp_clauses;
}
@@ -1045,6 +1264,7 @@ gfc_trans_omp_atomic (gfc_code *code)
enum tree_code op = ERROR_MARK;
enum tree_code aop = OMP_ATOMIC;
bool var_on_left = false;
+ bool seq_cst = (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SEQ_CST) != 0;
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
@@ -1060,7 +1280,7 @@ gfc_trans_omp_atomic (gfc_code *code)
&& expr2->value.function.isym->id == GFC_ISYM_CONVERSION)
expr2 = expr2->value.function.actual->expr;
- switch (atomic_code->ext.omp_atomic)
+ switch (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
{
case GFC_OMP_ATOMIC_READ:
gfc_conv_expr (&vse, code->expr1);
@@ -1072,6 +1292,7 @@ gfc_trans_omp_atomic (gfc_code *code)
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
x = build1 (OMP_ATOMIC_READ, type, lhsaddr);
+ OMP_ATOMIC_SEQ_CST (x) = seq_cst;
x = convert (TREE_TYPE (vse.expr), x);
gfc_add_modify (&block, vse.expr, x);
@@ -1107,7 +1328,9 @@ gfc_trans_omp_atomic (gfc_code *code)
type = TREE_TYPE (lse.expr);
lhsaddr = gfc_build_addr_expr (NULL, lse.expr);
- if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+ if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_WRITE)
+ || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
{
gfc_conv_expr (&rse, expr2);
gfc_add_block_to_block (&block, &rse.pre);
@@ -1229,7 +1452,9 @@ gfc_trans_omp_atomic (gfc_code *code)
lhsaddr = save_expr (lhsaddr);
rhs = gfc_evaluate_now (rse.expr, &block);
- if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+ if (((atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_WRITE)
+ || (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_SWAP))
x = rhs;
else
{
@@ -1252,6 +1477,7 @@ gfc_trans_omp_atomic (gfc_code *code)
if (aop == OMP_ATOMIC)
{
x = build2_v (OMP_ATOMIC, lhsaddr, convert (type, x));
+ OMP_ATOMIC_SEQ_CST (x) = seq_cst;
gfc_add_expr_to_block (&block, x);
}
else
@@ -1273,6 +1499,7 @@ gfc_trans_omp_atomic (gfc_code *code)
gfc_add_block_to_block (&block, &lse.pre);
}
x = build2 (aop, type, lhsaddr, convert (type, x));
+ OMP_ATOMIC_SEQ_CST (x) = seq_cst;
x = convert (TREE_TYPE (vse.expr), x);
gfc_add_modify (&block, vse.expr, x);
}
@@ -1288,6 +1515,63 @@ gfc_trans_omp_barrier (void)
}
static tree
+gfc_trans_omp_cancel (gfc_code *code)
+{
+ int mask = 0;
+ tree ifc = boolean_true_node;
+ stmtblock_t block;
+ switch (code->ext.omp_clauses->cancel)
+ {
+ case OMP_CANCEL_PARALLEL: mask = 1; break;
+ case OMP_CANCEL_DO: mask = 2; break;
+ case OMP_CANCEL_SECTIONS: mask = 4; break;
+ case OMP_CANCEL_TASKGROUP: mask = 8; break;
+ default: gcc_unreachable ();
+ }
+ gfc_start_block (&block);
+ if (code->ext.omp_clauses->if_expr)
+ {
+ gfc_se se;
+ tree if_var;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, code->ext.omp_clauses->if_expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ if_var = gfc_evaluate_now (se.expr, &block);
+ gfc_add_block_to_block (&block, &se.post);
+ tree type = TREE_TYPE (if_var);
+ ifc = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, if_var,
+ build_zero_cst (type));
+ }
+ tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
+ tree c_bool_type = TREE_TYPE (TREE_TYPE (decl));
+ ifc = fold_convert (c_bool_type, ifc);
+ gfc_add_expr_to_block (&block,
+ build_call_expr_loc (input_location, decl, 2,
+ build_int_cst (integer_type_node,
+ mask), ifc));
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_cancellation_point (gfc_code *code)
+{
+ int mask = 0;
+ switch (code->ext.omp_clauses->cancel)
+ {
+ case OMP_CANCEL_PARALLEL: mask = 1; break;
+ case OMP_CANCEL_DO: mask = 2; break;
+ case OMP_CANCEL_SECTIONS: mask = 4; break;
+ case OMP_CANCEL_TASKGROUP: mask = 8; break;
+ default: gcc_unreachable ();
+ }
+ tree decl = builtin_decl_explicit (BUILT_IN_GOMP_CANCELLATION_POINT);
+ return build_call_expr_loc (input_location, decl, 1,
+ build_int_cst (integer_type_node, mask));
+}
+
+static tree
gfc_trans_omp_critical (gfc_code *code)
{
tree name = NULL_TREE, stmt;
@@ -1304,7 +1588,7 @@ typedef struct dovar_init_d {
static tree
-gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock,
+gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock,
gfc_omp_clauses *do_clauses, tree par_clauses)
{
gfc_se se;
@@ -1344,14 +1628,15 @@ gfc_trans_omp_do (gfc_code *code, stmtbl
if (clauses)
{
- gfc_namelist *n;
- for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL;
- n = n->next)
+ gfc_omp_namelist *n;
+ for (n = clauses->lists[(op == EXEC_OMP_SIMD && collapse == 1)
+ ? OMP_LIST_LINEAR : OMP_LIST_LASTPRIVATE];
+ n != NULL; n = n->next)
if (code->ext.iterator->var->symtree->n.sym == n->sym)
break;
if (n != NULL)
dovar_found = 1;
- else if (n == NULL)
+ else if (n == NULL && op != EXEC_OMP_SIMD)
for (n = clauses->lists[OMP_LIST_PRIVATE]; n != NULL; n = n->next)
if (code->ext.iterator->var->symtree->n.sym == n->sym)
break;
@@ -1393,7 +1678,8 @@ gfc_trans_omp_do (gfc_code *code, stmtbl
}
else
dovar_decl
- = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym);
+ = gfc_trans_omp_variable (code->ext.iterator->var->symtree->n.sym,
+ false);
/* Loop body. */
if (simple)
@@ -1447,11 +1733,24 @@ gfc_trans_omp_do (gfc_code *code, stmtbl
if (!dovar_found)
{
- tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
+ if (op == EXEC_OMP_SIMD)
+ {
+ if (collapse == 1)
+ {
+ tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
+ OMP_CLAUSE_LINEAR_STEP (tmp) = step;
+ }
+ else
+ tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
+ if (!simple)
+ dovar_found = 2;
+ }
+ else
+ tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
OMP_CLAUSE_DECL (tmp) = dovar_decl;
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
}
- else if (dovar_found == 2)
+ if (dovar_found == 2)
{
tree c = NULL;
@@ -1475,8 +1774,14 @@ gfc_trans_omp_do (gfc_code *code, stmtbl
OMP_CLAUSE_LASTPRIVATE_STMT (c) = tmp;
break;
}
+ else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
+ && OMP_CLAUSE_DECL (c) == dovar_decl)
+ {
+ OMP_CLAUSE_LINEAR_STMT (c) = tmp;
+ break;
+ }
}
- if (c == NULL && par_clauses != NULL)
+ if (c == NULL && op == EXEC_OMP_DO && par_clauses != NULL)
{
for (c = par_clauses; c ; c = OMP_CLAUSE_CHAIN (c))
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LASTPRIVATE
@@ -1496,7 +1801,17 @@ gfc_trans_omp_do (gfc_code *code, stmtbl
}
if (!simple)
{
- tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
+ if (op != EXEC_OMP_SIMD)
+ tmp = build_omp_clause (input_location, OMP_CLAUSE_PRIVATE);
+ else if (collapse == 1)
+ {
+ tmp = build_omp_clause (input_location, OMP_CLAUSE_LINEAR);
+ OMP_CLAUSE_LINEAR_STEP (tmp) = step;
+ OMP_CLAUSE_LINEAR_NO_COPYIN (tmp) = 1;
+ OMP_CLAUSE_LINEAR_NO_COPYOUT (tmp) = 1;
+ }
+ else
+ tmp = build_omp_clause (input_location, OMP_CLAUSE_LASTPRIVATE);
OMP_CLAUSE_DECL (tmp) = count;
omp_clauses = gfc_trans_add_clause (tmp, omp_clauses);
}
@@ -1538,7 +1853,7 @@ gfc_trans_omp_do (gfc_code *code, stmtbl
}
/* End of loop body. */
- stmt = make_node (OMP_FOR);
+ stmt = make_node (op == EXEC_OMP_SIMD ? OMP_SIMD : OMP_FOR);
TREE_TYPE (stmt) = void_type_node;
OMP_FOR_BODY (stmt) = gfc_finish_block (&body);
@@ -1589,37 +1904,219 @@ gfc_trans_omp_parallel (gfc_code *code)
return gfc_finish_block (&block);
}
+enum
+{
+ GFC_OMP_SPLIT_SIMD,
+ GFC_OMP_SPLIT_DO,
+ GFC_OMP_SPLIT_PARALLEL,
+ GFC_OMP_SPLIT_NUM
+};
+
+enum
+{
+ GFC_OMP_MASK_SIMD = (1 << GFC_OMP_SPLIT_SIMD),
+ GFC_OMP_MASK_DO = (1 << GFC_OMP_SPLIT_DO),
+ GFC_OMP_MASK_PARALLEL = (1 << GFC_OMP_SPLIT_PARALLEL)
+};
+
+static void
+gfc_split_omp_clauses (gfc_code *code,
+ gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM])
+{
+ int mask = 0, innermost = 0, i;
+ memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses));
+ switch (code->op)
+ {
+ case EXEC_OMP_DO_SIMD:
+ mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
+ innermost = GFC_OMP_SPLIT_SIMD;
+ break;
+ case EXEC_OMP_PARALLEL_DO:
+ mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO;
+ innermost = GFC_OMP_SPLIT_DO;
+ break;
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ mask = GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD;
+ innermost = GFC_OMP_SPLIT_SIMD;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ if (code->ext.omp_clauses != NULL)
+ {
+ if (mask & GFC_OMP_MASK_PARALLEL)
+ {
+ /* First the clauses that are unique to some constructs. */
+ clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_COPYIN]
+ = code->ext.omp_clauses->lists[OMP_LIST_COPYIN];
+ clausesa[GFC_OMP_SPLIT_PARALLEL].num_threads
+ = code->ext.omp_clauses->num_threads;
+ clausesa[GFC_OMP_SPLIT_PARALLEL].proc_bind
+ = code->ext.omp_clauses->proc_bind;
+ /* Shared and default clauses are allowed on parallel and teams. */
+ clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_SHARED]
+ = code->ext.omp_clauses->lists[OMP_LIST_SHARED];
+ clausesa[GFC_OMP_SPLIT_PARALLEL].default_sharing
+ = code->ext.omp_clauses->default_sharing;
+ /* FIXME: This is currently being discussed. */
+ clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr
+ = code->ext.omp_clauses->if_expr;
+ }
+ if (mask & GFC_OMP_MASK_DO)
+ {
+ /* First the clauses that are unique to some constructs. */
+ clausesa[GFC_OMP_SPLIT_DO].ordered
+ = code->ext.omp_clauses->ordered;
+ clausesa[GFC_OMP_SPLIT_DO].sched_kind
+ = code->ext.omp_clauses->sched_kind;
+ clausesa[GFC_OMP_SPLIT_DO].chunk_size
+ = code->ext.omp_clauses->chunk_size;
+ clausesa[GFC_OMP_SPLIT_DO].nowait
+ = code->ext.omp_clauses->nowait;
+ /* Duplicate collapse. */
+ clausesa[GFC_OMP_SPLIT_DO].collapse
+ = code->ext.omp_clauses->collapse;
+ }
+ if (mask & GFC_OMP_MASK_SIMD)
+ {
+ clausesa[GFC_OMP_SPLIT_SIMD].safelen_expr
+ = code->ext.omp_clauses->safelen_expr;
+ clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LINEAR]
+ = code->ext.omp_clauses->lists[OMP_LIST_LINEAR];
+ clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_ALIGNED]
+ = code->ext.omp_clauses->lists[OMP_LIST_ALIGNED];
+ /* Duplicate collapse. */
+ clausesa[GFC_OMP_SPLIT_SIMD].collapse
+ = code->ext.omp_clauses->collapse;
+ }
+ /* Private clause is supported on all constructs but target,
+ it is enough to put it on the innermost one. For
+ !$ omp do put it on parallel though,
+ as that's what we did for OpenMP 3.1. */
+ clausesa[innermost == GFC_OMP_SPLIT_DO
+ ? (int) GFC_OMP_SPLIT_PARALLEL
+ : innermost].lists[OMP_LIST_PRIVATE]
+ = code->ext.omp_clauses->lists[OMP_LIST_PRIVATE];
+ /* Firstprivate clause is supported on all constructs but
+ target and simd. Put it on the outermost of those and
+ duplicate on parallel. */
+ if (mask & GFC_OMP_MASK_PARALLEL)
+ clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_FIRSTPRIVATE]
+ = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
+ else if (mask & GFC_OMP_MASK_DO)
+ clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_FIRSTPRIVATE]
+ = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE];
+ /* Lastprivate is allowed on do and simd. In
+ parallel do{, simd} we actually want to put it on
+ parallel rather than do. */
+ if (mask & GFC_OMP_MASK_PARALLEL)
+ clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_LASTPRIVATE]
+ = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
+ else if (mask & GFC_OMP_MASK_DO)
+ clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_LASTPRIVATE]
+ = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
+ if (mask & GFC_OMP_MASK_SIMD)
+ clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_LASTPRIVATE]
+ = code->ext.omp_clauses->lists[OMP_LIST_LASTPRIVATE];
+ /* Reduction is allowed on simd, do, parallel and teams.
+ Duplicate it on all of them, but omit on do if
+ parallel is present. */
+ for (i = OMP_LIST_REDUCTION_FIRST; i <= OMP_LIST_REDUCTION_LAST; i++)
+ {
+ if (mask & GFC_OMP_MASK_PARALLEL)
+ clausesa[GFC_OMP_SPLIT_PARALLEL].lists[i]
+ = code->ext.omp_clauses->lists[i];
+ else if (mask & GFC_OMP_MASK_DO)
+ clausesa[GFC_OMP_SPLIT_DO].lists[i]
+ = code->ext.omp_clauses->lists[i];
+ if (mask & GFC_OMP_MASK_SIMD)
+ clausesa[GFC_OMP_SPLIT_SIMD].lists[i]
+ = code->ext.omp_clauses->lists[i];
+ }
+ }
+ if ((mask & (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
+ == (GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO))
+ clausesa[GFC_OMP_SPLIT_DO].nowait = true;
+}
+
static tree
-gfc_trans_omp_parallel_do (gfc_code *code)
+gfc_trans_omp_do_simd (gfc_code *code, gfc_omp_clauses *clausesa,
+ tree omp_clauses)
{
stmtblock_t block, *pblock = NULL;
- gfc_omp_clauses parallel_clauses, do_clauses;
- tree stmt, omp_clauses = NULL_TREE;
+ gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM];
+ tree stmt, body, omp_do_clauses = NULL_TREE;
gfc_start_block (&block);
- memset (&do_clauses, 0, sizeof (do_clauses));
- if (code->ext.omp_clauses != NULL)
+ if (clausesa == NULL)
{
- memcpy (¶llel_clauses, code->ext.omp_clauses,
- sizeof (parallel_clauses));
- do_clauses.sched_kind = parallel_clauses.sched_kind;
- do_clauses.chunk_size = parallel_clauses.chunk_size;
- do_clauses.ordered = parallel_clauses.ordered;
- do_clauses.collapse = parallel_clauses.collapse;
- parallel_clauses.sched_kind = OMP_SCHED_NONE;
- parallel_clauses.chunk_size = NULL;
- parallel_clauses.ordered = false;
- parallel_clauses.collapse = 0;
- omp_clauses = gfc_trans_omp_clauses (&block, ¶llel_clauses,
- code->loc);
+ clausesa = clausesa_buf;
+ gfc_split_omp_clauses (code, clausesa);
}
- do_clauses.nowait = true;
- if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC)
+ omp_do_clauses
+ = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc);
+ pblock = █
+ body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock,
+ &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses);
+ if (TREE_CODE (body) != BIND_EXPR)
+ body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0));
+ else
+ poplevel (0, 0);
+ stmt = make_node (OMP_FOR);
+ TREE_TYPE (stmt) = void_type_node;
+ OMP_FOR_BODY (stmt) = body;
+ OMP_FOR_CLAUSES (stmt) = omp_do_clauses;
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_do (gfc_code *code)
+{
+ stmtblock_t block, *pblock = NULL;
+ gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
+ tree stmt, omp_clauses = NULL_TREE;
+
+ gfc_start_block (&block);
+
+ gfc_split_omp_clauses (code, clausesa);
+ omp_clauses
+ = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
+ code->loc);
+ if (!clausesa[GFC_OMP_SPLIT_DO].ordered
+ && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC)
pblock = █
else
pushlevel ();
- stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses);
+ stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, pblock,
+ &clausesa[GFC_OMP_SPLIT_DO], omp_clauses);
+ if (TREE_CODE (stmt) != BIND_EXPR)
+ stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
+ else
+ poplevel (0, 0);
+ stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt,
+ omp_clauses);
+ OMP_PARALLEL_COMBINED (stmt) = 1;
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
+}
+
+static tree
+gfc_trans_omp_parallel_do_simd (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM];
+ tree stmt, omp_clauses = NULL_TREE;
+
+ gfc_start_block (&block);
+
+ gfc_split_omp_clauses (code, clausesa);
+ omp_clauses
+ = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL],
+ code->loc);
+ pushlevel ();
+ stmt = gfc_trans_omp_do_simd (code, clausesa, omp_clauses);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0));
else
@@ -1743,6 +2240,13 @@ gfc_trans_omp_task (gfc_code *code)
}
static tree
+gfc_trans_omp_taskgroup (gfc_code *code)
+{
+ tree stmt = gfc_trans_code (code->block->next);
+ return build1_loc (input_location, OMP_TASKGROUP, void_type_node, stmt);
+}
+
+static tree
gfc_trans_omp_taskwait (void)
{
tree decl = builtin_decl_explicit (BUILT_IN_GOMP_TASKWAIT);
@@ -1923,10 +2427,18 @@ gfc_trans_omp_directive (gfc_code *code)
return gfc_trans_omp_atomic (code);
case EXEC_OMP_BARRIER:
return gfc_trans_omp_barrier ();
+ case EXEC_OMP_CANCEL:
+ return gfc_trans_omp_cancel (code);
+ case EXEC_OMP_CANCELLATION_POINT:
+ return gfc_trans_omp_cancellation_point (code);
case EXEC_OMP_CRITICAL:
return gfc_trans_omp_critical (code);
case EXEC_OMP_DO:
- return gfc_trans_omp_do (code, NULL, code->ext.omp_clauses, NULL);
+ case EXEC_OMP_SIMD:
+ return gfc_trans_omp_do (code, code->op, NULL, code->ext.omp_clauses,
+ NULL);
+ case EXEC_OMP_DO_SIMD:
+ return gfc_trans_omp_do_simd (code, NULL, NULL_TREE);
case EXEC_OMP_FLUSH:
return gfc_trans_omp_flush ();
case EXEC_OMP_MASTER:
@@ -1937,6 +2449,8 @@ gfc_trans_omp_directive (gfc_code *code)
return gfc_trans_omp_parallel (code);
case EXEC_OMP_PARALLEL_DO:
return gfc_trans_omp_parallel_do (code);
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ return gfc_trans_omp_parallel_do_simd (code);
case EXEC_OMP_PARALLEL_SECTIONS:
return gfc_trans_omp_parallel_sections (code);
case EXEC_OMP_PARALLEL_WORKSHARE:
@@ -1947,6 +2461,8 @@ gfc_trans_omp_directive (gfc_code *code)
return gfc_trans_omp_single (code, code->ext.omp_clauses);
case EXEC_OMP_TASK:
return gfc_trans_omp_task (code);
+ case EXEC_OMP_TASKGROUP:
+ return gfc_trans_omp_taskgroup (code);
case EXEC_OMP_TASKWAIT:
return gfc_trans_omp_taskwait ();
case EXEC_OMP_TASKYIELD:
@@ -1957,3 +2473,22 @@ gfc_trans_omp_directive (gfc_code *code)
gcc_unreachable ();
}
}
+
+void
+gfc_trans_omp_declare_simd (gfc_namespace *ns)
+{
+ if (ns->entries)
+ return;
+
+ gfc_omp_declare_simd *ods;
+ for (ods = ns->omp_declare_simd; ods; ods = ods->next)
+ {
+ tree c = gfc_trans_omp_clauses (NULL, ods->clauses, ods->where, true);
+ tree fndecl = ns->proc_name->backend_decl;
+ if (c != NULL_TREE)
+ c = tree_cons (NULL_TREE, c, NULL_TREE);
+ c = build_tree_list (get_identifier ("omp declare simd"), c);
+ TREE_CHAIN (c) = DECL_ATTRIBUTES (fndecl);
+ DECL_ATTRIBUTES (fndecl) = c;
+ }
+}
--- gcc/fortran/st.c.jj 2014-05-02 19:39:53.464679647 +0200
+++ gcc/fortran/st.c 2014-05-02 20:13:06.758494912 +0200
@@ -185,12 +185,17 @@ gfc_free_statement (gfc_code *p)
gfc_free_forall_iterator (p->ext.forall_iterator);
break;
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_END_SINGLE:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
case EXEC_OMP_WORKSHARE:
@@ -203,7 +208,7 @@ gfc_free_statement (gfc_code *p)
break;
case EXEC_OMP_FLUSH:
- gfc_free_namelist (p->ext.omp_namelist);
+ gfc_free_omp_namelist (p->ext.omp_namelist);
break;
case EXEC_OMP_ATOMIC:
@@ -211,6 +216,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_END_NOWAIT:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
break;
--- gcc/fortran/module.c.jj 2014-01-26 21:16:51.000000000 +0100
+++ gcc/fortran/module.c 2014-05-07 17:09:22.602917360 +0200
@@ -3790,6 +3790,111 @@ mio_full_f2k_derived (gfc_symbol *sym)
mio_rparen ();
}
+static const mstring omp_declare_simd_clauses[] =
+{
+ minit ("INBRANCH", 0),
+ minit ("NOTINBRANCH", 1),
+ minit ("SIMDLEN", 2),
+ minit ("UNIFORM", 3),
+ minit ("LINEAR", 4),
+ minit ("ALIGNED", 5),
+ minit (NULL, -1)
+};
+
+/* Handle !$omp declare simd. */
+
+static void
+mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
+{
+ if (iomode == IO_OUTPUT)
+ {
+ if (*odsp == NULL)
+ return;
+ }
+ else if (peek_atom () != ATOM_LPAREN)
+ return;
+
+ gfc_omp_declare_simd *ods = *odsp;
+
+ mio_lparen ();
+ if (iomode == IO_OUTPUT)
+ {
+ write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
+ if (ods->clauses)
+ {
+ gfc_omp_namelist *n;
+
+ if (ods->clauses->inbranch)
+ mio_name (0, omp_declare_simd_clauses);
+ if (ods->clauses->notinbranch)
+ mio_name (1, omp_declare_simd_clauses);
+ if (ods->clauses->simdlen_expr)
+ {
+ mio_name (2, omp_declare_simd_clauses);
+ mio_expr (&ods->clauses->simdlen_expr);
+ }
+ for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
+ {
+ mio_name (3, omp_declare_simd_clauses);
+ mio_symbol_ref (&n->sym);
+ }
+ for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
+ {
+ mio_name (4, omp_declare_simd_clauses);
+ mio_symbol_ref (&n->sym);
+ mio_expr (&n->expr);
+ }
+ for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ {
+ mio_name (5, omp_declare_simd_clauses);
+ mio_symbol_ref (&n->sym);
+ mio_expr (&n->expr);
+ }
+ }
+ }
+ else
+ {
+ gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
+
+ require_atom (ATOM_NAME);
+ *odsp = ods = gfc_get_omp_declare_simd ();
+ ods->where = gfc_current_locus;
+ ods->proc_name = ns->proc_name;
+ if (peek_atom () == ATOM_NAME)
+ {
+ ods->clauses = gfc_get_omp_clauses ();
+ ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
+ ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
+ ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
+ }
+ while (peek_atom () == ATOM_NAME)
+ {
+ gfc_omp_namelist *n;
+ int t = mio_name (0, omp_declare_simd_clauses);
+
+ switch (t)
+ {
+ case 0: ods->clauses->inbranch = true; break;
+ case 1: ods->clauses->notinbranch = true; break;
+ case 2: mio_expr (&ods->clauses->simdlen_expr); break;
+ case 3:
+ case 4:
+ case 5:
+ *ptrs[t - 3] = n = gfc_get_omp_namelist ();
+ ptrs[t - 3] = &n->next;
+ mio_symbol_ref (&n->sym);
+ if (t != 3)
+ mio_expr (&n->expr);
+ break;
+ }
+ }
+ }
+
+ mio_omp_declare_simd (ns, &ods->next);
+
+ mio_rparen ();
+}
+
/* Unlike most other routines, the address of the symbol node is already
fixed on input and the name/module has already been filled in.
@@ -3864,6 +3969,11 @@ mio_symbol (gfc_symbol *sym)
if (sym->attr.flavor == FL_DERIVED)
mio_integer (&(sym->hash_value));
+ if (sym->formal_ns
+ && sym->formal_ns->proc_name == sym
+ && sym->formal_ns->entries == NULL)
+ mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
+
mio_rparen ();
}
--- gcc/fortran/trans.c.jj 2014-05-02 19:39:53.477679580 +0200
+++ gcc/fortran/trans.c 2014-05-02 20:13:06.760494982 +0200
@@ -1848,18 +1848,24 @@ trans_code (gfc_code * code, tree cond)
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_FLUSH:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
--- gcc/fortran/resolve.c.jj 2014-05-02 19:39:53.437679786 +0200
+++ gcc/fortran/resolve.c 2014-05-02 20:13:06.757494875 +0200
@@ -8982,15 +8982,19 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
@@ -9735,6 +9739,7 @@ resolve_code (gfc_code *code, gfc_namesp
break;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
@@ -9742,6 +9747,8 @@ resolve_code (gfc_code *code, gfc_namesp
gfc_resolve_omp_parallel_blocks (code, ns);
break;
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_SIMD:
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_SELECT_TYPE:
@@ -10056,13 +10063,18 @@ resolve_code (gfc_code *code, gfc_namesp
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
@@ -10071,6 +10083,7 @@ resolve_code (gfc_code *code, gfc_namesp
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_TASK:
@@ -14609,6 +14622,8 @@ resolve_types (gfc_namespace *ns)
gfc_resolve_uops (ns->uop_root);
+ gfc_resolve_omp_declare_simd (ns);
+
gfc_current_ns = old_ns;
}
--- gcc/testsuite/gfortran.dg/gomp/affinity-1.f90.jj 2014-05-02 20:13:06.769495349 +0200
+++ gcc/testsuite/gfortran.dg/gomp/affinity-1.f90 2014-05-02 20:13:06.769495349 +0200
@@ -0,0 +1,19 @@
+ integer :: i, j
+ integer, dimension (10, 10) :: a
+!$omp parallel do default(none)proc_bind(master)shared(a)
+ do i = 1, 10
+ j = 4
+ do j = 1, 10
+ a(i, j) = i + j
+ end do
+ j = 8
+ end do
+!$omp end parallel do
+!$omp parallel proc_bind (close)
+!$omp parallel default(none) proc_bind (spread) firstprivate(a) private (i)
+ do i = 1, 10
+ a(i, i) = i
+ enddo
+!$omp end parallel
+!$omp endparallel
+end
--- libgomp/testsuite/libgomp.fortran/cancel-do-1.f90.jj 2014-05-02 20:13:06.770495397 +0200
+++ libgomp/testsuite/libgomp.fortran/cancel-do-1.f90 2014-05-02 20:13:06.770495397 +0200
@@ -0,0 +1,14 @@
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: i
+
+ !$omp parallel num_threads(32)
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do
+ if (omp_get_cancellation ()) call abort
+ enddo
+ !$omp endparallel
+end
--- libgomp/testsuite/libgomp.fortran/cancel-do-2.f90.jj 2014-05-02 20:13:06.771495441 +0200
+++ libgomp/testsuite/libgomp.fortran/cancel-do-2.f90 2014-05-02 20:13:06.771495441 +0200
@@ -0,0 +1,90 @@
+! { dg-do run }
+! { dg-options "-fno-inline -fno-ipa-sra -fno-ipa-cp -fno-ipa-cp-clone" }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: i
+ logical :: x(5)
+
+ x(:) = .false.
+ x(1) = .true.
+ x(3) = .true.
+ if (omp_get_cancellation ()) call foo (x)
+contains
+ subroutine foo (x)
+ use omp_lib
+ logical :: x(5)
+ integer :: v, w, i
+
+ v = 0
+ w = 0
+ !$omp parallel num_threads (32) shared (v, w)
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(1))
+ call abort
+ end do
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(2))
+ !$omp atomic
+ v = v + 1
+ !$omp endatomic
+ enddo
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(3))
+ !$omp atomic
+ w = w + 8
+ !$omp end atomic
+ end do
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(4))
+ !$omp atomic
+ v = v + 2
+ !$omp end atomic
+ end do
+ !$omp end do
+ !$omp end parallel
+ if (v.ne.3000.or.w.ne.0) call abort
+ !$omp parallel num_threads (32) shared (v, w)
+ ! None of these cancel directives should actually cancel anything,
+ ! but the compiler shouldn't know that and thus should use cancellable
+ ! barriers at the end of all the workshares.
+ !$omp cancel parallel if (omp_get_thread_num ().eq.1.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(1))
+ call abort
+ end do
+ !$omp cancel parallel if (omp_get_thread_num ().eq.2.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(2))
+ !$omp atomic
+ v = v + 1
+ !$omp endatomic
+ enddo
+ !$omp cancel parallel if (omp_get_thread_num ().eq.3.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(3))
+ !$omp atomic
+ w = w + 8
+ !$omp end atomic
+ end do
+ !$omp cancel parallel if (omp_get_thread_num ().eq.4.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(4))
+ !$omp atomic
+ v = v + 2
+ !$omp end atomic
+ end do
+ !$omp end do
+ !$omp cancel parallel if (omp_get_thread_num ().eq.5.and.x(5))
+ !$omp end parallel
+ if (v.ne.6000.or.w.ne.0) call abort
+ end subroutine
+end
--- libgomp/testsuite/libgomp.fortran/cancel-parallel-1.f90.jj 2014-05-02 20:13:06.771495441 +0200
+++ libgomp/testsuite/libgomp.fortran/cancel-parallel-1.f90 2014-05-02 20:13:06.771495441 +0200
@@ -0,0 +1,10 @@
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+
+ !$omp parallel num_threads(32)
+ !$omp cancel parallel
+ if (omp_get_cancellation ()) call abort
+ !$omp end parallel
+end
--- libgomp/testsuite/libgomp.fortran/cancel-parallel-3.f90.jj 2014-05-02 20:13:06.771495441 +0200
+++ libgomp/testsuite/libgomp.fortran/cancel-parallel-3.f90 2014-05-02 20:13:06.771495441 +0200
@@ -0,0 +1,38 @@
+! { dg-do run }
+! { dg-options "-fno-inline -fno-ipa-sra -fno-ipa-cp -fno-ipa-cp-clone" }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: x, i, j
+ common /x/ x
+
+ call omp_set_dynamic (.false.)
+ call omp_set_schedule (omp_sched_static, 1)
+ !$omp parallel num_threads(16) private (i, j)
+ call do_some_work
+ !$omp barrier
+ if (omp_get_thread_num ().eq.1) then
+ call sleep (2)
+ !$omp cancellation point parallel
+ end if
+ do j = 3, 16
+ !$omp do schedule(runtime)
+ do i = 0, j - 1
+ call do_some_work
+ end do
+ !$omp enddo nowait
+ end do
+ if (omp_get_thread_num ().eq.0) then
+ call sleep (1)
+ !$omp cancel parallel
+ end if
+ !$omp end parallel
+contains
+ subroutine do_some_work
+ integer :: x
+ common /x/ x
+ !$omp atomic
+ x = x + 1
+ !$omp end atomic
+ endsubroutine do_some_work
+end
--- libgomp/testsuite/libgomp.fortran/cancel-sections-1.f90.jj 2014-05-02 20:13:06.771495441 +0200
+++ libgomp/testsuite/libgomp.fortran/cancel-sections-1.f90 2014-05-02 20:13:06.771495441 +0200
@@ -0,0 +1,23 @@
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+
+ if (omp_get_cancellation ()) then
+ !$omp parallel num_threads(32)
+ !$omp sections
+ !$omp cancel sections
+ call abort
+ !$omp section
+ !$omp cancel sections
+ call abort
+ !$omp section
+ !$omp cancel sections
+ call abort
+ !$omp section
+ !$omp cancel sections
+ call abort
+ !$omp end sections
+ !$omp end parallel
+ end if
+end
--- libgomp/testsuite/libgomp.fortran/cancel-taskgroup-2.f90.jj 2014-05-02 20:13:06.772495482 +0200
+++ libgomp/testsuite/libgomp.fortran/cancel-taskgroup-2.f90 2014-05-02 20:13:06.772495482 +0200
@@ -0,0 +1,28 @@
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: i
+
+ !$omp parallel
+ !$omp taskgroup
+ !$omp task
+ !$omp cancel taskgroup
+ call abort
+ !$omp endtask
+ !$omp endtaskgroup
+ !$omp endparallel
+ !$omp parallel private (i)
+ !$omp barrier
+ !$omp single
+ !$omp taskgroup
+ do i = 0, 49
+ !$omp task
+ !$omp cancellation point taskgroup
+ !$omp cancel taskgroup if (i.gt.5)
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ !$omp endsingle
+ !$omp end parallel
+end
--- libgomp/testsuite/libgomp.fortran/declare-simd-1.f90.jj 2014-05-06 10:22:57.291349705 +0200
+++ libgomp/testsuite/libgomp.fortran/declare-simd-1.f90 2014-05-06 13:24:41.204683418 +0200
@@ -0,0 +1,92 @@
+! { dg-options "-fno-inline" }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+module declare_simd_1_mod
+ contains
+ real function foo (a, b, c)
+ !$omp declare simd (foo) simdlen (4) uniform (a) linear (b : 5)
+ double precision, value :: a
+ real, value :: c
+ !$omp declare simd (foo)
+ integer, value :: b
+ foo = a + b * c
+ end function foo
+end module declare_simd_1_mod
+ use declare_simd_1_mod
+ interface
+ function bar (a, b, c)
+ !$omp declare simd (bar)
+ integer, value :: b
+ real, value :: c
+ real :: bar
+ !$omp declare simd (bar) simdlen (4) linear (b : 2)
+ double precision, value :: a
+ end function bar
+ end interface
+ integer :: i
+ double precision :: a(128)
+ real :: b(128), d(128)
+ data d /171., 414., 745., 1164., 1671., 2266., 2949., 3720., 4579., &
+ & 5526., 6561., 7684., 8895., 10194., 11581., 13056., 14619., &
+ & 16270., 18009., 19836., 21751., 23754., 25845., 28024., &
+ & 30291., 32646., 35089., 37620., 40239., 42946., 45741., &
+ & 48624., 51595., 54654., 57801., 61036., 64359., 67770., &
+ & 71269., 74856., 78531., 82294., 86145., 90084., 94111., &
+ & 98226., 102429., 106720., 111099., 115566., 120121., 124764., &
+ & 129495., 134314., 139221., 144216., 149299., 154470., 159729., &
+ & 165076., 170511., 176034., 181645., 187344., 193131., 199006., &
+ & 204969., 211020., 217159., 223386., 229701., 236104., 242595., &
+ & 249174., 255841., 262596., 269439., 276370., 283389., 290496., &
+ & 297691., 304974., 312345., 319804., 327351., 334986., 342709., &
+ & 350520., 358419., 366406., 374481., 382644., 390895., 399234., &
+ & 407661., 416176., 424779., 433470., 442249., 451116., 460071., &
+ & 469114., 478245., 487464., 496771., 506166., 515649., 525220., &
+ & 534879., 544626., 554461., 564384., 574395., 584494., 594681., &
+ & 604956., 615319., 625770., 636309., 646936., 657651., 668454., &
+ & 679345., 690324., 701391., 712546., 723789., 735120./
+ !$omp simd
+ do i = 1, 128
+ a(i) = 7.0 * i + 16.0
+ b(i) = 5.0 * i + 12.0
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = foo (a(i), 3, b(i))
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = bar (a(i), 2 * i, b(i))
+ end do
+ if (any (b.ne.d)) call abort
+ !$omp simd
+ do i = 1, 128
+ b(i) = i * 2.0
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = baz (7.0_8, 2, b(i))
+ end do
+ do i = 1, 128
+ if (b(i).ne.(7.0 + 4.0 * i)) call abort
+ end do
+contains
+ function baz (x, y, z)
+ !$omp declare simd (baz) simdlen (8) uniform (x, y)
+ !$omp declare simd (baz)
+ integer, value :: y
+ real, value :: z
+ real :: baz
+ double precision, value :: x
+ baz = x + y * z
+ end function baz
+end
+function bar (a, b, c)
+ integer, value :: b
+ real, value :: c
+ real :: bar
+ double precision, value :: a
+ !$omp declare simd (bar)
+ !$omp declare simd (bar) simdlen (4) linear (b : 2)
+ bar = a + b * c
+end function bar
--- libgomp/testsuite/libgomp.fortran/declare-simd-2.f90.jj 2014-05-07 18:38:29.685242078 +0200
+++ libgomp/testsuite/libgomp.fortran/declare-simd-2.f90 2014-05-07 18:38:57.864097872 +0200
@@ -0,0 +1,25 @@
+! { dg-do run }
+! { dg-options "-fno-inline" }
+ ! { dg-additional-sources declare-simd-3.f90 }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+module declare_simd_2_mod
+ contains
+ real function foo (a, b, c)
+ !$omp declare simd (foo) simdlen (4) uniform (a) linear (b : 5)
+ double precision, value :: a
+ real, value :: c
+ !$omp declare simd (foo)
+ integer, value :: b
+ foo = a + b * c
+ end function foo
+end module declare_simd_2_mod
+
+ interface
+ subroutine bar ()
+ end subroutine bar
+ end interface
+
+ call bar ()
+end
--- libgomp/testsuite/libgomp.fortran/declare-simd-3.f90.jj 2014-05-07 18:39:13.174019061 +0200
+++ libgomp/testsuite/libgomp.fortran/declare-simd-3.f90 2014-05-07 18:39:35.667903682 +0200
@@ -0,0 +1,22 @@
+! Don't compile this anywhere, it is just auxiliary
+! file compiled together with declare-simd-2.f90
+! to verify inter-CU module handling of omp declare simd.
+! { dg-do compile { target { lp64 && { ! lp64 } } } }
+
+subroutine bar
+ use declare_simd_2_mod
+ real :: b(128)
+ integer :: i
+
+ !$omp simd
+ do i = 1, 128
+ b(i) = i * 2.0
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = foo (7.0_8, 5 * i, b(i))
+ end do
+ do i = 1, 128
+ if (b(i).ne.(7.0 + 10.0 * i * i)) call abort
+ end do
+end subroutine bar
--- libgomp/testsuite/libgomp.fortran/depend-1.f90.jj 2014-05-06 13:04:11.322051289 +0200
+++ libgomp/testsuite/libgomp.fortran/depend-1.f90 2014-05-06 13:04:03.000000000 +0200
@@ -0,0 +1,203 @@
+! { dg-do run }
+
+ call dep ()
+ call dep2 ()
+ call dep3 ()
+ call firstpriv ()
+ call antidep ()
+ call antidep2 ()
+ call antidep3 ()
+ call outdep ()
+ call concurrent ()
+ call concurrent2 ()
+ call concurrent3 ()
+contains
+ subroutine dep
+ integer :: x
+ x = 1
+ !$omp parallel
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine dep
+
+ subroutine dep2
+ integer :: x
+ !$omp parallel
+ !$omp single private (x)
+ x = 1
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp taskwait
+ !$omp end single
+ !$omp end parallel
+ end subroutine dep2
+
+ subroutine dep3
+ integer :: x
+ !$omp parallel private (x)
+ x = 1
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp endtask
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp endtask
+ !$omp endsingle
+ !$omp endparallel
+ end subroutine dep3
+
+ subroutine firstpriv
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 1
+ !$omp task depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine firstpriv
+
+ subroutine antidep
+ integer :: x
+ x = 1
+ !$omp parallel
+ !$omp single
+ !$omp task shared(x) depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine antidep
+
+ subroutine antidep2
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 1
+ !$omp taskgroup
+ !$omp task shared(x) depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp end taskgroup
+ !$omp end single
+ !$omp end parallel
+ end subroutine antidep2
+
+ subroutine antidep3
+ integer :: x
+ !$omp parallel
+ x = 1
+ !$omp single
+ !$omp task shared(x) depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine antidep3
+
+ subroutine outdep
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 0
+ !$omp task shared(x) depend(out: x)
+ x = 1
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp taskwait
+ if (x.ne.2) call abort
+ !$omp end single
+ !$omp end parallel
+ end subroutine outdep
+
+ subroutine concurrent
+ integer :: x
+ x = 1
+ !$omp parallel
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine concurrent
+
+ subroutine concurrent2
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 1
+ !$omp task shared (x) depend(out: x)
+ x = 2;
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp taskwait
+ !$omp end single
+ !$omp end parallel
+ end subroutine concurrent2
+
+ subroutine concurrent3
+ integer :: x
+ !$omp parallel private (x)
+ x = 1
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine concurrent3
+end
--- libgomp/testsuite/libgomp.fortran/depend-2.f90.jj 2014-05-06 18:23:01.455263329 +0200
+++ libgomp/testsuite/libgomp.fortran/depend-2.f90 2014-05-06 18:22:53.000000000 +0200
@@ -0,0 +1,34 @@
+! { dg-do run }
+
+ integer :: x(3:6, 7:12), y
+ y = 1
+ !$omp parallel shared (x, y)
+ !$omp single
+ !$omp taskgroup
+ !$omp task depend(in: x(:, :))
+ if (y.ne.1) call abort
+ !$omp end task
+ !$omp task depend(out: x(:, :))
+ y = 2
+ !$omp end task
+ !$omp end taskgroup
+ !$omp taskgroup
+ !$omp task depend(in: x(4, 7))
+ if (y.ne.2) call abort
+ !$omp end task
+ !$omp task depend(out: x(4:4, 7:7))
+ y = 3
+ !$omp end task
+ !$omp end taskgroup
+ !$omp taskgroup
+ !$omp task depend(in: x(4:, 8:))
+ if (y.ne.3) call abort
+ !$omp end task
+ !$omp task depend(out: x(4:6, 8:12))
+ y = 4
+ !$omp end task
+ !$omp end taskgroup
+ !$omp end single
+ !$omp end parallel
+ if (y.ne.4) call abort
+end
--- libgomp/testsuite/libgomp.fortran/omp_atomic5.f90.jj 2014-05-02 20:13:06.769495349 +0200
+++ libgomp/testsuite/libgomp.fortran/omp_atomic5.f90 2014-05-02 20:13:06.769495349 +0200
@@ -0,0 +1,59 @@
+! { dg-do run }
+ integer (kind = 4) :: a, a2
+ integer (kind = 2) :: b, b2
+ real :: c
+ double precision :: d, d2, c2
+ integer, dimension (10) :: e
+ e(:) = 5
+ e(7) = 9
+!$omp atomic write seq_cst
+ a = 1
+!$omp atomic seq_cst, write
+ b = 2
+!$omp atomic write, seq_cst
+ c = 3
+!$omp atomic seq_cst write
+ d = 4
+!$omp atomic capture seq_cst
+ a2 = a
+ a = a + 4
+!$omp end atomic
+!$omp atomic capture, seq_cst
+ b = b - 18
+ b2 = b
+!$omp end atomic
+!$omp atomic seq_cst, capture
+ c2 = c
+ c = 2.0 * c
+!$omp end atomic
+!$omp atomic seq_cst capture
+ d = d / 2.0
+ d2 = d
+!$omp end atomic
+ if (a2 .ne. 1 .or. b2 .ne. -16 .or. c2 .ne. 3 .or. d2 .ne. 2) call abort
+!$omp atomic read seq_cst
+ a2 = a
+!$omp atomic seq_cst, read
+ c2 = c
+ if (a2 .ne. 5 .or. b2 .ne. -16 .or. c2 .ne. 6 .or. d2 .ne. 2) call abort
+ a2 = 10
+ if (a2 .ne. 10) call abort
+!$omp atomic capture
+ a2 = a
+ a = e(1) + e(6) + e(7) * 2
+!$omp endatomic
+ if (a2 .ne. 5) call abort
+!$omp atomic read
+ a2 = a
+!$omp end atomic
+ if (a2 .ne. 28) call abort
+!$omp atomic capture seq_cst
+ b2 = b
+ b = e(1) + e(7) + e(5) * 2
+!$omp end atomic
+ if (b2 .ne. -16) call abort
+!$omp atomic seq_cst, read
+ b2 = b
+!$omp end atomic
+ if (b2 .ne. 24) call abort
+end
--- libgomp/testsuite/libgomp.fortran/simd1.f90.jj 2014-05-02 20:13:06.770495397 +0200
+++ libgomp/testsuite/libgomp.fortran/simd1.f90 2014-05-06 09:40:07.956626047 +0200
@@ -0,0 +1,23 @@
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: i, j, k, l, r, a(30)
+ integer, target :: q(30)
+ integer, pointer :: p(:)
+ a(:) = 1
+ q(:) = 1
+ p => q
+ r = 0
+ j = 10
+ k = 20
+ !$omp simd safelen (8) reduction(+:r) linear(j, k : 2) &
+ !$omp& private (l) aligned(p : 4)
+ do i = 1, 30
+ l = j + k + a(i) + p(i)
+ r = r + l
+ j = j + 2
+ k = k + 2
+ end do
+ if (r.ne.2700.or.j.ne.70.or.k.ne.80) call abort
+end
--- libgomp/testsuite/libgomp.fortran/simd2.f90.jj 2014-05-02 20:13:06.770495397 +0200
+++ libgomp/testsuite/libgomp.fortran/simd2.f90 2014-05-06 09:40:20.853564599 +0200
@@ -0,0 +1,101 @@
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: a(1024), b(1024), k, m, i, s, t
+ k = 4
+ m = 2
+ t = 1
+ do i = 1, 1024
+ a(i) = i - 513
+ b(i) = modulo (i - 52, 39)
+ if (i.lt.52.and.b(i).ne.0) b(i) = b(i) - 39
+ end do
+ s = foo (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = bar (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = baz (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+contains
+ function foo (p)
+ integer :: p(1024), u, v, i, s, foo
+ s = 0
+ !$omp simd linear(k : m + 1) reduction(+: s) lastprivate(u, v)
+ do i = 1, 1024
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end simd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ foo = s
+ end function foo
+ function bar (p)
+ integer :: p(1024), u, v, i, s, bar
+ s = 0
+ !$omp simd linear(k : m + 1) reduction(+: s) lastprivate(u, v)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end simd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ bar = s
+ end function bar
+ function baz (p)
+ integer :: p(1024), u, v, i, s, baz
+ s = 0
+ !$omp simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & linear(i : t)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ baz = s
+ end function baz
+end
--- libgomp/testsuite/libgomp.fortran/simd3.f90.jj 2014-05-02 20:13:06.771495441 +0200
+++ libgomp/testsuite/libgomp.fortran/simd3.f90 2014-05-06 13:24:41.204683418 +0200
@@ -0,0 +1,109 @@
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: a(1024), b(1024), k, m, i, s, t
+ k = 4
+ m = 2
+ t = 1
+ do i = 1, 1024
+ a(i) = i - 513
+ b(i) = modulo (i - 52, 39)
+ if (i.lt.52.and.b(i).ne.0) b(i) = b(i) - 39
+ end do
+ s = foo (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = bar (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = baz (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+contains
+ function foo (p)
+ integer :: p(1024), u, v, i, s, foo
+ s = 0
+ !$omp parallel
+ !$omp do simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & schedule (static, 32)
+ do i = 1, 1024
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end do simd
+ !$omp end parallel
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ foo = s
+ end function foo
+ function bar (p)
+ integer :: p(1024), u, v, i, s, bar
+ s = 0
+ !$omp parallel
+ !$omp do simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & schedule (dynamic, 32)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end do simd
+ !$omp endparallel
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ bar = s
+ end function bar
+ function baz (p)
+ integer :: p(1024), u, v, i, s, baz
+ s = 0
+ !$omp parallel
+ !$omp do simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & linear(i : t) schedule (static, 8)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end parallel
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ baz = s
+ end function baz
+end
--- libgomp/testsuite/libgomp.fortran/simd4.f90.jj 2014-05-02 20:13:06.770495397 +0200
+++ libgomp/testsuite/libgomp.fortran/simd4.f90 2014-05-06 13:24:41.205683413 +0200
@@ -0,0 +1,103 @@
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: a(1024), b(1024), k, m, i, s, t
+ k = 4
+ m = 2
+ t = 1
+ do i = 1, 1024
+ a(i) = i - 513
+ b(i) = modulo (i - 52, 39)
+ if (i.lt.52.and.b(i).ne.0) b(i) = b(i) - 39
+ end do
+ s = foo (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = bar (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = baz (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+contains
+ function foo (p)
+ integer :: p(1024), u, v, i, s, foo
+ s = 0
+ !$omp parallel do simd linear(k : m + 1) reduction(+: s) &
+ !$omp & lastprivate(u, v) schedule (static, 32)
+ do i = 1, 1024
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end parallel do simd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ foo = s
+ end function foo
+ function bar (p)
+ integer :: p(1024), u, v, i, s, bar
+ s = 0
+ !$omp parallel do simd linear(k : m + 1) reduction(+: s) &
+ !$omp & lastprivate(u, v) schedule (dynamic, 32)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp endparalleldosimd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ bar = s
+ end function bar
+ function baz (p)
+ integer :: p(1024), u, v, i, s, baz
+ s = 0
+ !$omp parallel do simd linear(k : m + 1) reduction(+: s) &
+ !$omp & lastprivate(u, v) linear(i : t) schedule (static, 8)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ baz = s
+ end function baz
+end
--- libgomp/testsuite/libgomp.fortran/taskgroup1.f90.jj 2014-05-02 20:13:06.770495397 +0200
+++ libgomp/testsuite/libgomp.fortran/taskgroup1.f90 2014-05-06 13:24:41.205683413 +0200
@@ -0,0 +1,80 @@
+ integer :: v(16), i
+ do i = 1, 16
+ v(i) = i
+ end do
+
+ !$omp parallel num_threads (4)
+ !$omp single
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp task
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ do i = 1, 16
+ if (v(i).ne.(i + 1)) call abort
+ end do
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp task
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp endtask
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp endtask
+ !$omp taskwait
+ !$omp endtask
+ end do
+ !$omp endtaskgroup
+ do i = 1, 16
+ if (v(i).ne.(i + 2)) call abort
+ end do
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp task
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ end do
+ !$omp taskwait
+ do i = 1, 16, 2
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ do i = 1, 16, 2
+ if (v(i).ne.(i + 3)) call abort
+ if (v(i + 1).ne.(i + 5)) call abort
+ end do
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp taskgroup
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ !$omp end taskgroup
+ if (v(i).ne.(i + 4).or.v(i + 1).ne.(i + 6)) call abort
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ do i = 1, 16
+ if (v(i).ne.(i + 5)) call abort
+ end do
+ !$omp end single
+ !$omp end parallel
+end
Jakub
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Fortran OpenMP 4.0 support, part 1
2014-05-07 20:53 [PATCH] Fortran OpenMP 4.0 support, part 1 Jakub Jelinek
@ 2014-05-09 19:35 ` Tobias Burnus
2014-05-09 20:23 ` Jakub Jelinek
0 siblings, 1 reply; 5+ messages in thread
From: Tobias Burnus @ 2014-05-09 19:35 UTC (permalink / raw)
To: Jakub Jelinek, gcc-patches, fortran
Hi!
Jakub Jelinek wrote:
> This patch attempts to implement first part of Fortran OpenMP 4.0 support,
> The testsuite coverage could certainly be improved, volunteers for that
> and/or bugreports will be certainly appreciated. Don't know how to actually
> test aligned clauses, is there any way (except for doing allocations in
> C/C++ on the side) to allocate objects on aligned boundaries (aligned
> attribute, some way to dynamically allocate aligned storage, ...)?
Fortran - as also C and C++ - does not provide much support for aligned
memory. [Well, C++ has now alignas and align(ment_)of.] But contrary to
C/C++, using library functions for dynamic allocation is more difficult
and gfortran doesn't support GCC's align attribute for non-heap
allocation. I only know of one commercial compiler, which has alignment
directives (for static and dynamically allocated memory). I also was
considering adding support for it - but I haven't found the time to do
so, yet.
Thus, you can either do the allocation in C/C++, call the C function
directly (but requires a manually written interface), or manually align
the memory - e.g. by checking the address and adding an offset.
Actually, the latter might be the simplest: Allocate - statically or
dynamically - the memory somewhere - and calculate the offset. For instance:
use iso_c_binding
implicit none
integer :: array(1024), y ! Or dynamically allocated
integer(c_ptrdiff_t) :: offset, byte_size
integer, parameter :: ALIGNVALUE = 128
offset = ALIGNVALUE - mod (loc (array), ALIGNVALUE)
if (offset == ALIGNVALUE) &
offset = 0
offset = offset/c_sizeof(y)
call some_subroutine(array(1+offset:))
contains
subroutine some_subroutine(x)
integer :: x(:)
if (mod (loc(x), ALIGNVALUE) /= 0) &
call abort()
end subroutine some_subroutine
end
(Side remark: The code uses "loc()" which is a vendor extension; C_LOC()
can also be used, but that requires the target or pointer attribute.)
> Bootstrapped/regtested on x86_64-linux and i686-linux. Any comments on
> this?
Looks good to me - not that I checked every line. One small nit below.
> +/* For use in OpenMP clauses in case we need extra information
> + (aligned clause alignment, linear clause step, etc. */
The ")" is missing in the comment.
* * *
BTW: I think it would be nice to have a better error message for the
following:
! ---------------------------------------
integer :: a(10) = [1,2,3,4,5,6,7,8,9,0]
integer :: i
!$omp simd safelen(i) linear(a:2) safelen(i)
do i = 1, 5
end do
end
! ---------------------------------------
It currently fails with:
Error: Unclassifiable OpenMP directive at (1)
but the only problem is that there are two "safelen".
With C, one gets a better message:
foo.c:6:25: error: too many 'safelen' clauses
Question is the following valid or not?
void test() {
int a[10];
int i;
#pragma omp simd linear(a:2) safelen(i)
for (i = 1; i < 5; i++)
;
}
It is rejected with:
foo.c:5:24: error: linear clause applied to non-integral non-pointer
variable with type 'int[10]'
Tobias
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Fortran OpenMP 4.0 support, part 1
2014-05-09 19:35 ` Tobias Burnus
@ 2014-05-09 20:23 ` Jakub Jelinek
2014-05-10 6:16 ` Tobias Burnus
0 siblings, 1 reply; 5+ messages in thread
From: Jakub Jelinek @ 2014-05-09 20:23 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, fortran
On Fri, May 09, 2014 at 09:35:03PM +0200, Tobias Burnus wrote:
> >This patch attempts to implement first part of Fortran OpenMP 4.0 support,
> >The testsuite coverage could certainly be improved, volunteers for that
> >and/or bugreports will be certainly appreciated. Don't know how to actually
> >test aligned clauses, is there any way (except for doing allocations in
> >C/C++ on the side) to allocate objects on aligned boundaries (aligned
> >attribute, some way to dynamically allocate aligned storage, ...)?
>
> Fortran - as also C and C++ - does not provide much support for
> aligned memory. [Well, C++ has now alignas and align(ment_)of.] But
> contrary to C/C++, using library functions for dynamic allocation is
> more difficult and gfortran doesn't support GCC's align attribute
> for non-heap allocation. I only know of one commercial compiler,
> which has alignment directives (for static and dynamically allocated
> memory). I also was considering adding support for it - but I
> haven't found the time to do so, yet.
Yeah, but besides alignas/_Alignas in C/C++ one has also posix_memalign etc.
The OpenMP standard allows for aligned clause:
C_PTR or Cray pointer, or var with POINTER or ALLOCATABLE attribute.
so best would be to actually test all of those, but supposedly one can't
really test it e.g. with ALLOCATABLE attribute, unless say the test is
restricted to x86_64-linux or similar platform where we know glibc malloc
allocates 16 byte aligned chunks at least and we rely on libgfortran to use
glibc malloc.
> >Bootstrapped/regtested on x86_64-linux and i686-linux. Any comments on
> >this?
>
> Looks good to me - not that I checked every line. One small nit below.
>
>
> > +/* For use in OpenMP clauses in case we need extra information
> >+ (aligned clause alignment, linear clause step, etc. */
>
> The ")" is missing in the comment.
Thanks, will fix.
> BTW: I think it would be nice to have a better error message for the
> following:
>
> ! ---------------------------------------
> integer :: a(10) = [1,2,3,4,5,6,7,8,9,0]
> integer :: i
>
> !$omp simd safelen(i) linear(a:2) safelen(i)
> do i = 1, 5
> end do
> end
> ! ---------------------------------------
>
> It currently fails with:
> Error: Unclassifiable OpenMP directive at (1)
> but the only problem is that there are two "safelen".
Yeah, the diagnostics could be improved, but this is a general issue of the
whole OpenMP parsing, not specific to SIMD or OpenMP 4.0.
Didn't have time for that yet and it wasn't too high priority so far.
> With C, one gets a better message:
> foo.c:6:25: error: too many 'safelen' clauses
>
>
> Question is the following valid or not?
>
> void test() {
> int a[10];
> int i;
> #pragma omp simd linear(a:2) safelen(i)
> for (i = 1; i < 5; i++)
> ;
> }
>
> It is rejected with:
> foo.c:5:24: error: linear clause applied to non-integral non-pointer
> variable with type 'int[10]'
I believe it is invalid. a has array type, not pointer type, and
array really can't be linear, as its address is constant, for linear
you need to have something that is incremented by 2 every iteration...
Jakub
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Fortran OpenMP 4.0 support, part 1
2014-05-09 20:23 ` Jakub Jelinek
@ 2014-05-10 6:16 ` Tobias Burnus
2014-05-10 8:32 ` Tobias Burnus
0 siblings, 1 reply; 5+ messages in thread
From: Tobias Burnus @ 2014-05-10 6:16 UTC (permalink / raw)
To: Jakub Jelinek; +Cc: gcc-patches, fortran
Jakub Jelinek wrpte:
> On Fri, May 09, 2014 at 09:35:03PM +0200, Tobias Burnus wrote:
>> Fortran - as also C and C++ - does not provide much support for
>> aligned memory. [Well, C++ has now alignas and align(ment_)of.] But
>> contrary to C/C++, using library functions for dynamic allocation is
>> more difficult and gfortran doesn't support GCC's align attribute for
>> non-heap allocation. I only know of one commercial compiler, which
>> has alignment directives (for static and dynamically allocated
>> memory). I also was considering adding support for it - but I haven't
>> found the time to do so, yet.
> Yeah, but besides alignas/_Alignas in C/C++ one has also posix_memalign etc.
That's what I meant with calling library functions. But posix_memalign
is restricted to POSIX systems while _mm_malloc only works on i*86 and
x86_64 systems.
> The OpenMP standard allows for aligned clause:
> C_PTR or Cray pointer, or var with POINTER or ALLOCATABLE attribute.
> so best would be to actually test all of those, but supposedly one can't
> really test it e.g. with ALLOCATABLE attribute, unless say the test is
> restricted to x86_64-linux or similar platform where we know glibc malloc
> allocates 16 byte aligned chunks at least and we rely on libgfortran to use
> glibc malloc.
Well, as written before, you could use the manual alignment as I
suggested before. My code assumes that malloc returns memory which is
aligned to sizeof(data type); I think one can assume that this is
aligned to at least 4-byte or sizeof(void*).
I think that should be sufficient; if not, one can also first align the
memory down to byte level and then associate it with a pointer variable.
That should work with all sizeof(data type).
Below, you have a small program which gives you access to C_PTR, Cray
pointer and POINTER; combining ALLOCATABLE with aligned memory is more
difficult. BTW: gfortran doesn't call libgfortran for allocating the
memory but uses BUILTIN_MALLOC directy (since GCC 4.2?).
Tobias
program align_test
use iso_c_binding
implicit none
real, target :: x, array1(1024)
real, allocatable, target :: array2(:)
real, pointer :: ptr(:)
integer(c_ptrdiff_t) :: offset1
integer(c_ptrdiff_t) :: offset2
integer, parameter :: ALIGNVALUE = 128
offset1 = ALIGNVALUE - mod (loc (array1), ALIGNVALUE)
if (offset1 == ALIGNVALUE) &
offset1 = 0
offset1 = offset1/c_sizeof(x)
allocate (array2(-5:1024))
offset2 = ALIGNVALUE - mod (loc (array2), ALIGNVALUE)
if (offset2 == ALIGNVALUE) &
offset2 = 0
offset2 = offset2/c_sizeof(x)
! Use a lower bound which is not "1"
! For some reasons, the following does not align the memory!
!ptr(-5:) => array2(lbound(array2,dim=1)+offset2 :)
ptr => array2(lbound(array2,dim=1)+offset2 :)
call some_subroutine(array1(lbound(array1,dim=1)+offset1 : ), ptr)
contains
subroutine some_subroutine(a, b)
real, pointer, intent(in) :: a(:), b(:)
type(c_ptr) :: c
! Use an explicit size for the Cray pointer; can also be '*' instead
real :: arr(1024-ALIGNVALUE)
pointer (pt, arr)
if (mod (loc(a), ALIGNVALUE) /= 0) &
call abort()
if (mod (loc(b), ALIGNVALUE) /= 0) &
call abort()
c = c_loc(a)
pt = loc(b)
! ...
end subroutine some_subroutine
end program align_test
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [PATCH] Fortran OpenMP 4.0 support, part 1
2014-05-10 6:16 ` Tobias Burnus
@ 2014-05-10 8:32 ` Tobias Burnus
0 siblings, 0 replies; 5+ messages in thread
From: Tobias Burnus @ 2014-05-10 8:32 UTC (permalink / raw)
To: Jakub Jelinek; +Cc: gcc-patches, fortran
Tobias Burnus wrote:
> ! Use a lower bound which is not "1"
> ! For some reasons, the following does not align the memory!
> !ptr(-5:) => array2(lbound(array2,dim=1)+offset2 :)
The reason is that it wrongly pointer-assigns the whole array, ignoring
the specified offset. (It works with an explicit size array - such as
"array" in the example.)
That's now tracked as PR61138.
Tobias
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2014-05-10 8:32 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2014-05-07 20:53 [PATCH] Fortran OpenMP 4.0 support, part 1 Jakub Jelinek
2014-05-09 19:35 ` Tobias Burnus
2014-05-09 20:23 ` Jakub Jelinek
2014-05-10 6:16 ` Tobias Burnus
2014-05-10 8:32 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).