diff options
| author | jakub <jakub@138bc75d-0d04-0410-961f-82ee72b054a4> | 2014-06-30 16:35:48 +0000 |
|---|---|---|
| committer | jakub <jakub@138bc75d-0d04-0410-961f-82ee72b054a4> | 2014-06-30 16:35:48 +0000 |
| commit | b0c271ddcb5ea189db63d68b81396d2c0a047e66 (patch) | |
| tree | 328825b232e24f582da7433336448d561f409665 /gcc/fortran/trans-openmp.c | |
| parent | 2cdb1e5149fe2505fec3de3f2570b6984796a2b4 (diff) | |
| download | ppe42-gcc-b0c271ddcb5ea189db63d68b81396d2c0a047e66.tar.gz ppe42-gcc-b0c271ddcb5ea189db63d68b81396d2c0a047e66.zip | |
gcc/
2014-06-30 Jakub Jelinek <jakub@redhat.com>
Backported from mainline
2014-06-25 Jakub Jelinek <jakub@redhat.com>
* langhooks-def.h (LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR): Define.
(LANG_HOOKS_DECLS): Add it.
* gimplify.c (gimplify_omp_for): Make sure OMP_CLAUSE_LINEAR_STEP
has correct type.
* tree.h (OMP_CLAUSE_LINEAR_ARRAY): Define.
* langhooks.h (struct lang_hooks_for_decls): Add
omp_clause_linear_ctor hook.
* omp-low.c (lower_rec_input_clauses): Set max_vf even if
OMP_CLAUSE_LINEAR_ARRAY is set. Don't fold_convert
OMP_CLAUSE_LINEAR_STEP. For OMP_CLAUSE_LINEAR_ARRAY in
combined simd loop use omp_clause_linear_ctor hook.
2014-06-24 Jakub Jelinek <jakub@redhat.com>
* gimplify.c (gimplify_scan_omp_clauses) <case OMP_CLAUSE_MAP,
OMP_CLAUSE_TO, OMP_CLAUSE_FROM): Make sure OMP_CLAUSE_SIZE is
non-NULL.
<case OMP_CLAUSE_ALIGNED>: Gimplify OMP_CLAUSE_ALIGNED_ALIGNMENT.
(gimplify_adjust_omp_clauses_1): Make sure OMP_CLAUSE_SIZE is
non-NULL.
(gimplify_adjust_omp_clauses): Likewise.
* omp-low.c (lower_rec_simd_input_clauses,
lower_rec_input_clauses, expand_omp_simd): Handle non-constant
safelen the same as safelen(1).
* tree-nested.c (convert_nonlocal_omp_clauses,
convert_local_omp_clauses): Handle OMP_CLAUSE_ALIGNED. For
OMP_CLAUSE_{MAP,TO,FROM} if not decl use walk_tree.
(convert_nonlocal_reference_stmt, convert_local_reference_stmt):
Fixup handling of GIMPLE_OMP_TARGET.
(convert_tramp_reference_stmt, convert_gimple_call): Handle
GIMPLE_OMP_TARGET.
2014-06-18 Jakub Jelinek <jakub@redhat.com>
* gimplify.c (omp_notice_variable): If n is non-NULL
and no flags change in ORT_TARGET region, don't jump to
do_outer.
(struct gimplify_adjust_omp_clauses_data): New type.
(gimplify_adjust_omp_clauses_1): Adjust for data being
a struct gimplify_adjust_omp_clauses_data pointer instead
of tree *. Pass pre_p as a new argument to
lang_hooks.decls.omp_finish_clause hook.
(gimplify_adjust_omp_clauses): Add pre_p argument, adjust
splay_tree_foreach to pass both list_p and pre_p.
(gimplify_omp_parallel, gimplify_omp_task, gimplify_omp_for,
gimplify_omp_workshare, gimplify_omp_target_update): Adjust
gimplify_adjust_omp_clauses callers.
* langhooks.c (lhd_omp_finish_clause): New function.
* langhooks-def.h (lhd_omp_finish_clause): New prototype.
(LANG_HOOKS_OMP_FINISH_CLAUSE): Define to lhd_omp_finish_clause.
* langhooks.h (struct lang_hooks_for_decls): Add a new
gimple_seq * argument to omp_finish_clause hook.
* omp-low.c (scan_sharing_clauses): Call scan_omp_op on
non-DECL_P OMP_CLAUSE_DECL if ctx->outer.
(scan_omp_parallel, lower_omp_for): When adding
_LOOPTEMP_ clause var, add it to outer ctx's decl_map
as identity.
* tree-core.h (OMP_CLAUSE_MAP_TO_PSET): New map kind.
* tree-nested.c (convert_nonlocal_omp_clauses,
convert_local_omp_clauses): Handle various OpenMP 4.0 clauses.
* tree-pretty-print.c (dump_omp_clause): Handle
OMP_CLAUSE_MAP_TO_PSET.
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* omp-low.c (lower_rec_input_clauses) <case OMP_CLAUSE_LASTPRIVATE>:
Set lastprivate_firstprivate even if omp_private_outer_ref
langhook returns true.
<case OMP_CLAUSE_REDUCTION>: When calling omp_clause_default_ctor
langhook, call unshare_expr on new_var and call
build_outer_var_ref to get the last argument.
2014-05-11 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/c-family/
2014-06-30 Jakub Jelinek <jakub@redhat.com>
Backported from mainline
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* c-pragma.c (omp_pragmas_simd): Move PRAGMA_OMP_TASK...
(omp_pragmas): ... back here.
gcc/c/
2014-06-30 Jakub Jelinek <jakub@redhat.com>
Backported from mainline
2014-06-25 Jakub Jelinek <jakub@redhat.com>
* c-typeck.c (c_finish_omp_clauses): Make sure
OMP_CLAUSE_LINEAR_STEP has correct type.
gcc/cp/
2014-06-30 Jakub Jelinek <jakub@redhat.com>
Backported from mainline
2014-06-25 Jakub Jelinek <jakub@redhat.com>
* semantics.c (finish_omp_clauses): Make sure
OMP_CLAUSE_LINEAR_STEP has correct type.
2014-06-18 Jakub Jelinek <jakub@redhat.com>
* cp-gimplify.c (cxx_omp_finish_clause): Add a gimple_seq *
argument.
* cp-tree.h (cxx_omp_finish_clause): Adjust prototype.
gcc/fortran/
2014-06-30 Jakub Jelinek <jakub@redhat.com>
* module.c (MOD_VERSION): Revert back to 12.
(MOD_VERSION_OMP4): Define.
(module_omp4): New variable.
(mio_symbol): Call mio_omp_declare_simd only if module_omp4.
(read_module): Load omp udrs only if module_omp4.
(write_module): Write omp udrs only if module_omp4.
(find_omp_declare_simd): New function.
(gfc_dump_module): Compute module_omp4. Use MOD_VERSION_OMP4
if module_omp4.
(gfc_use_module): Handle MOD_VERSION_OMP4, set module_omp4.
Backported from mainline
2014-06-25 Jakub Jelinek <jakub@redhat.com>
* trans.h (gfc_omp_clause_linear_ctor): New prototype.
* trans-openmp.c (gfc_omp_linear_clause_add_loop,
gfc_omp_clause_linear_ctor): New functions.
(gfc_trans_omp_clauses): Make sure OMP_CLAUSE_LINEAR_STEP has
correct type. Set OMP_CLAUSE_LINEAR_ARRAY flag if needed.
* f95-lang.c (LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR): Redefine.
2014-06-24 Jakub Jelinek <jakub@redhat.com>
* dump-parse-tree.c (show_omp_namelist): Use n->udr->udr instead
of n->udr.
* f95-lang.c (gfc_init_builtin_functions): Initialize
BUILT_IN_ASSUME_ALIGNED.
* gfortran.h (gfc_omp_namelist): Change udr field type to
struct gfc_omp_namelist_udr.
(gfc_omp_namelist_udr): New type.
(gfc_get_omp_namelist_udr): Define.
(gfc_resolve_code): New prototype.
* match.c (gfc_free_omp_namelist): Free name->udr.
* module.c (intrinsics): Add INTRINSIC_USER.
(fix_mio_expr): Likewise.
(mio_expr): Handle INSTRINSIC_USER and non-resolved EXPR_FUNCTION.
* openmp.c (gfc_match_omp_clauses): Adjust initialization of n->udr.
(gfc_match_omp_declare_reduction): Treat len=: the same as len=*.
Set attr.flavor on omp_{out,in,priv,orig} artificial variables.
(struct resolve_omp_udr_callback_data): New type.
(resolve_omp_udr_callback, resolve_omp_udr_callback2,
resolve_omp_udr_clause): New functions.
(resolve_omp_clauses): Adjust for n->udr changes, resolve UDR clauses
here.
(omp_udr_callback): Don't check for implicitly declared functions
here.
(gfc_resolve_omp_udr): Don't call gfc_resolve. Don't check for
implicitly declared subroutines here.
* resolve.c (resolve_function): If value.function.isym is non-NULL,
consider it already resolved.
(resolve_code): Renamed to ...
(gfc_resolve_code): ... this. No longer static.
(gfc_resolve_blocks, generate_component_assignments, resolve_codes):
Adjust callers.
* trans-openmp.c (gfc_omp_privatize_by_reference): Don't privatize
by reference type (C_PTR) variables.
(gfc_omp_finish_clause): Make sure OMP_CLAUSE_SIZE is non-NULL.
(gfc_trans_omp_udr_expr): Remove.
(gfc_trans_omp_array_reduction_or_udr): Adjust for n->udr changes.
Don't call gfc_trans_omp_udr_expr, even for sym->attr.dimension
expand it as assignment or subroutine call. Don't initialize
value.function.isym.
2014-06-18 Tobias Burnus <burnus@net-b.de>
* gfortran.texi (OpenMP): Update refs to OpenMP 4.0.
* intrinsic.texi (OpenMP Modules): Ditto.
2014-06-18 Jakub Jelinek <jakub@redhat.com>
* cpp.c (cpp_define_builtins): Change _OPENMP macro to
201307.
* dump-parse-tree.c (show_omp_namelist): Add list_type
argument. Adjust for rop being u.reduction_op now,
handle depend_op or map_op.
(show_omp_node): Adjust callers. Print some new
OpenMP 4.0 clauses, adjust for OMP_LIST_DEPEND_{IN,OUT}
becoming a single OMP_LIST_DEPEND.
* f95-lang.c (gfc_handle_omp_declare_target_attribute): New
function.
(gfc_attribute_table): New variable.
(LANG_HOOKS_OMP_FINISH_CLAUSE, LANG_HOOKS_ATTRIBUTE_TABLE): Redefine.
* frontend-passes.c (gfc_code_walker): Handle new OpenMP target
EXEC_OMP_* codes and new clauses.
* gfortran.h (gfc_statement): Add ST_OMP_TARGET, ST_OMP_END_TARGET,
ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA, ST_OMP_TARGET_UPDATE,
ST_OMP_DECLARE_TARGET, ST_OMP_TEAMS, ST_OMP_END_TEAMS,
ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE, ST_OMP_DISTRIBUTE_SIMD,
ST_OMP_END_DISTRIBUTE_SIMD, ST_OMP_DISTRIBUTE_PARALLEL_DO,
ST_OMP_END_DISTRIBUTE_PARALLEL_DO, ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD, ST_OMP_TARGET_TEAMS,
ST_OMP_END_TARGET_TEAMS, ST_OMP_TEAMS_DISTRIBUTE,
ST_OMP_END_TEAMS_DISTRIBUTE, ST_OMP_TEAMS_DISTRIBUTE_SIMD,
ST_OMP_END_TEAMS_DISTRIBUTE_SIMD, ST_OMP_TARGET_TEAMS_DISTRIBUTE,
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE,
ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD,
ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO,
ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD and
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD.
(symbol_attribute): Add omp_declare_target field.
(gfc_omp_depend_op, gfc_omp_map_op): New enums.
(gfc_omp_namelist): Replace rop field with union
containing reduction_op, depend_op and map_op.
(OMP_LIST_DEPEND_IN, OMP_LIST_DEPEND_OUT): Remove.
(OMP_LIST_DEPEND, OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM): New.
(gfc_omp_clauses): Add num_teams, device, thread_limit,
dist_sched_kind, dist_chunk_size fields.
(gfc_common_head): Add omp_declare_target field.
(gfc_exec_op): Add EXEC_OMP_TARGET, EXEC_OMP_TARGET_DATA,
EXEC_OMP_TEAMS, EXEC_OMP_DISTRIBUTE, EXEC_OMP_DISTRIBUTE_SIMD,
EXEC_OMP_DISTRIBUTE_PARALLEL_DO, EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
EXEC_OMP_TARGET_TEAMS, EXEC_OMP_TEAMS_DISTRIBUTE,
EXEC_OMP_TEAMS_DISTRIBUTE_SIMD, EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD and
EXEC_OMP_TARGET_UPDATE.
(gfc_add_omp_declare_target): New prototype.
* match.h (gfc_match_omp_declare_target, gfc_match_omp_distribute,
gfc_match_omp_distribute_parallel_do,
gfc_match_omp_distribute_parallel_do_simd,
gfc_match_omp_distribute_simd, gfc_match_omp_target,
gfc_match_omp_target_data, gfc_match_omp_target_teams,
gfc_match_omp_target_teams_distribute,
gfc_match_omp_target_teams_distribute_parallel_do,
gfc_match_omp_target_teams_distribute_parallel_do_simd,
gfc_match_omp_target_teams_distribute_simd,
gfc_match_omp_target_update, gfc_match_omp_teams,
gfc_match_omp_teams_distribute,
gfc_match_omp_teams_distribute_parallel_do,
gfc_match_omp_teams_distribute_parallel_do_simd,
gfc_match_omp_teams_distribute_simd): New prototypes.
* module.c (ab_attribute): Add AB_OMP_DECLARE_TARGET.
(attr_bits): Likewise.
(mio_symbol_attribute): Handle omp_declare_target attribute.
(gfc_free_omp_clauses): Free num_teams, device, thread_limit
and dist_chunk_size expressions.
(OMP_CLAUSE_PRIVATE, OMP_CLAUSE_FIRSTPRIVATE, OMP_CLAUSE_LASTPRIVATE,
OMP_CLAUSE_COPYPRIVATE, OMP_CLAUSE_SHARED, OMP_CLAUSE_COPYIN,
OMP_CLAUSE_REDUCTION, OMP_CLAUSE_IF, OMP_CLAUSE_NUM_THREADS,
OMP_CLAUSE_SCHEDULE, OMP_CLAUSE_DEFAULT, OMP_CLAUSE_ORDERED,
OMP_CLAUSE_COLLAPSE, OMP_CLAUSE_UNTIED, OMP_CLAUSE_FINAL,
OMP_CLAUSE_MERGEABLE, 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): Use 1U instead of 1.
(OMP_CLAUSE_DEVICE, OMP_CLAUSE_MAP, OMP_CLAUSE_TO, OMP_CLAUSE_FROM,
OMP_CLAUSE_NUM_TEAMS, OMP_CLAUSE_THREAD_LIMIT,
OMP_CLAUSE_DIST_SCHEDULE): Define.
(gfc_match_omp_clauses): Change mask parameter to unsigned int.
Adjust for rop becoming u.reduction_op. Disallow inbranch with
notinbranch. For depend clause, always create OMP_LIST_DEPEND
and fill in u.depend_op. Handle num_teams, device, map,
to, from, thread_limit and dist_schedule clauses.
(OMP_DECLARE_SIMD_CLAUSES): Or in OMP_CLAUSE_INBRANCH and
OMP_CLAUSE_NOTINBRANCH.
(OMP_TARGET_CLAUSES, OMP_TARGET_DATA_CLAUSES,
OMP_TARGET_UPDATE_CLAUSES, OMP_TEAMS_CLAUSES,
OMP_DISTRIBUTE_CLAUSES): Define.
(match_omp): New function.
(gfc_match_omp_do, gfc_match_omp_do_simd, gfc_match_omp_parallel,
gfc_match_omp_parallel_do, gfc_match_omp_parallel_do_simd,
gfc_match_omp_parallel_sections, gfc_match_omp_parallel_workshare,
gfc_match_omp_sections, gfc_match_omp_simd, gfc_match_omp_single,
gfc_match_omp_task): Rewritten using match_omp.
(gfc_match_omp_threadprivate, gfc_match_omp_declare_reduction):
Diagnose if the directives are followed by unexpected junk.
(gfc_match_omp_distribute, gfc_match_omp_distribute_parallel_do,
gfc_match_omp_distribute_parallel_do_simd,
gfc_match_omp_distrbute_simd, gfc_match_omp_declare_target,
gfc_match_omp_target, gfc_match_omp_target_data,
gfc_match_omp_target_teams, gfc_match_omp_target_teams_distribute,
gfc_match_omp_target_teams_distribute_parallel_do,
gfc_match_omp_target_teams_distribute_parallel_do_simd,
gfc_match_omp_target_teams_distrbute_simd, gfc_match_omp_target_update,
gfc_match_omp_teams, gfc_match_omp_teams_distribute,
gfc_match_omp_teams_distribute_parallel_do,
gfc_match_omp_teams_distribute_parallel_do_simd,
gfc_match_omp_teams_distrbute_simd): New functions.
* openmp.c (resolve_omp_clauses): Adjust for
OMP_LIST_DEPEND_{IN,OUT} being changed to OMP_LIST_DEPEND. Handle
OMP_LIST_MAP, OMP_LIST_FROM, OMP_LIST_TO, num_teams, device,
dist_chunk_size and thread_limit.
(gfc_resolve_omp_parallel_blocks): Only put sharing clauses into
ctx.sharing_clauses. Call gfc_resolve_omp_do_blocks for various
new EXEC_OMP_* codes.
(resolve_omp_do): Handle various new EXEC_OMP_* codes.
(gfc_resolve_omp_directive): Likewise.
(gfc_resolve_omp_declare_simd): Add missing space to diagnostics.
* parse.c (decode_omp_directive): Handle parsing of OpenMP 4.0
offloading related directives.
(case_executable): Add ST_OMP_TARGET_UPDATE.
(case_exec_markers): Add ST_OMP_TARGET*, ST_OMP_TEAMS*,
ST_OMP_DISTRIBUTE*.
(case_decl): Add ST_OMP_DECLARE_TARGET.
(gfc_ascii_statement): Handle new ST_OMP_* codes.
(parse_omp_do): Handle various new ST_OMP_* codes.
(parse_executable): Likewise.
* resolve.c (gfc_resolve_blocks): Handle various new EXEC_OMP_*
codes.
(resolve_code): Likewise.
(resolve_symbol): Change that !$OMP DECLARE TARGET variables
are saved.
* st.c (gfc_free_statement): Handle various new EXEC_OMP_* codes.
* symbol.c (check_conflict): Check omp_declare_target conflicts.
(gfc_add_omp_declare_target): New function.
(gfc_copy_attr): Copy omp_declare_target.
* trans.c (trans_code): Handle various new EXEC_OMP_* codes.
* trans-common.c (build_common_decl): Add "omp declare target"
attribute if needed.
* trans-decl.c (add_attributes_to_decl): Likewise.
* trans.h (gfc_omp_finish_clause): New prototype.
* trans-openmp.c (gfc_omp_finish_clause): New function.
(gfc_trans_omp_reduction_list): Adjust for rop being renamed
to u.reduction_op.
(gfc_trans_omp_clauses): Adjust for OMP_LIST_DEPEND_{IN,OUT}
change to OMP_LIST_DEPEND and fix up depend handling.
Handle OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM, num_teams,
thread_limit, device, dist_chunk_size and dist_sched_kind.
(gfc_trans_omp_do): Handle EXEC_OMP_DISTRIBUTE.
(GFC_OMP_SPLIT_DISTRIBUTE, GFC_OMP_SPLIT_TEAMS,
GFC_OMP_SPLIT_TARGET, GFC_OMP_SPLIT_NUM, GFC_OMP_MASK_DISTRIBUTE,
GFC_OMP_MASK_TEAMS, GFC_OMP_MASK_TARGET, GFC_OMP_MASK_NUM): New.
(gfc_split_omp_clauses): Handle splitting of clauses for new
EXEC_OMP_* codes.
(gfc_trans_omp_do_simd): Add pblock argument, adjust for being
callable for combined constructs.
(gfc_trans_omp_parallel_do, gfc_trans_omp_parallel_do_simd): Likewise.
(gfc_trans_omp_distribute, gfc_trans_omp_teams,
gfc_trans_omp_target, gfc_trans_omp_target_data,
gfc_trans_omp_target_update): New functions.
(gfc_trans_omp_directive): Adjust gfc_trans_omp_* callers, handle
new EXEC_OMP_* codes.
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* f95-lang.c (gfc_init_builtin_functions): Handle -fopenmp-simd
like -fopenmp.
* openmp.c (resolve_omp_clauses): Remove allocatable components
diagnostics. Add associate-name and intent(in) pointer
diagnostics for various clauses, diagnose procedure pointers in
reduction clause.
* parse.c (match_word_omp_simd): New function.
(matchs, matcho): New macros.
(decode_omp_directive): Change match macros to either matchs
or matcho. Handle -fopenmp-simd.
(next_free, next_fixed): Handle -fopenmp-simd like -fopenmp.
* scanner.c (skip_free_comments, skip_fixed_comments, include_line):
Likewise.
* trans-array.c (get_full_array_size): Rename to...
(gfc_full_array_size): ... this. No longer static.
(duplicate_allocatable): Adjust caller. Add NO_MEMCPY argument
and handle it.
(gfc_duplicate_allocatable, gfc_copy_allocatable_data): Adjust
duplicate_allocatable callers.
(gfc_duplicate_allocatable_nocopy): New function.
(structure_alloc_comps): Adjust g*_full_array_size and
duplicate_allocatable caller.
* trans-array.h (gfc_full_array_size,
gfc_duplicate_allocatable_nocopy): New prototypes.
* trans-common.c (create_common): Call gfc_finish_decl_attrs.
* trans-decl.c (gfc_finish_decl_attrs): New function.
(gfc_finish_var_decl, create_function_arglist,
gfc_get_fake_result_decl): Call it.
(gfc_allocate_lang_decl): If DECL_LANG_SPECIFIC is already allocated,
don't allocate it again.
(gfc_get_symbol_decl): Set GFC_DECL_ASSOCIATE_VAR_P on
associate-names.
* trans.h (gfc_finish_decl_attrs): New prototype.
(struct lang_decl): Add scalar_allocatable and scalar_pointer
bitfields.
(GFC_DECL_SCALAR_ALLOCATABLE, GFC_DECL_SCALAR_POINTER,
GFC_DECL_GET_SCALAR_ALLOCATABLE, GFC_DECL_GET_SCALAR_POINTER,
GFC_DECL_ASSOCIATE_VAR_P): Define.
(GFC_POINTER_TYPE_P): Remove.
* trans-openmp.c (gfc_omp_privatize_by_reference): Don't check
GFC_POINTER_TYPE_P, instead test GFC_DECL_GET_SCALAR_ALLOCATABLE,
GFC_DECL_GET_SCALAR_POINTER or GFC_DECL_CRAY_POINTEE on decl.
(gfc_omp_predetermined_sharing): Associate-names are predetermined.
(enum walk_alloc_comps): New.
(gfc_has_alloc_comps, gfc_omp_unshare_expr_r, gfc_omp_unshare_expr,
gfc_walk_alloc_comps): New functions.
(gfc_omp_private_outer_ref): Return true for scalar allocatables or
decls with allocatable components.
(gfc_omp_clause_default_ctor, gfc_omp_clause_copy_ctor,
gfc_omp_clause_assign_op, gfc_omp_clause_dtor): Fix up handling of
allocatables, handle also OMP_CLAUSE_REDUCTION, handle scalar
allocatables and decls with allocatable components.
(gfc_trans_omp_array_reduction_or_udr): Don't handle allocatable
arrays here.
(gfc_trans_omp_reduction_list): Call
gfc_trans_omp_array_reduction_or_udr even for allocatable scalars.
(gfc_trans_omp_do_simd): If -fno-openmp, just expand it as OMP_SIMD.
(gfc_trans_omp_parallel_do_simd): Likewise.
* trans-types.c (gfc_sym_type): Don't set GFC_POINTER_TYPE_P.
(gfc_get_derived_type): Call gfc_finish_decl_attrs.
2014-06-06 Jakub Jelinek <jakub@redhat.com>
* dump-parse-tree.c (show_omp_namelist): Dump reduction
id in each list item.
(show_omp_node): Only handle OMP_LIST_REDUCTION, not
OMP_LIST_REDUCTION_FIRST .. OMP_LIST_REDUCTION_LAST. Don't
dump reduction id here.
* frontend-passes.c (dummy_code_callback): Renamed to...
(gfc_dummy_code_callback): ... this. No longer static.
(optimize_reduction): Use gfc_dummy_code_callback instead of
dummy_code_callback.
* gfortran.h (gfc_statement): Add ST_OMP_DECLARE_REDUCTION.
(symbol_attribute): Add omp_udr_artificial_var bitfield.
(gfc_omp_reduction_op): New enum.
(gfc_omp_namelist): Add rop and udr fields.
(OMP_LIST_PLUS, OMP_LIST_REDUCTION_FIRST, OMP_LIST_MULT,
OMP_LIST_SUB, OMP_LIST_AND, OMP_LIST_OR, OMP_LIST_EQV,
OMP_LIST_NEQV, OMP_LIST_MAX, OMP_LIST_MIN, OMP_LIST_IAND,
OMP_LIST_IOR, OMP_LIST_IEOR, OMP_LIST_REDUCTION_LAST): Removed.
(OMP_LIST_REDUCTION): New.
(gfc_omp_udr): New type.
(gfc_get_omp_udr): Define.
(gfc_symtree): Add n.omp_udr field.
(gfc_namespace): Add omp_udr_root field, add omp_udr_ns bitfield.
(gfc_free_omp_udr, gfc_omp_udr_find, gfc_resolve_omp_udrs,
gfc_dummy_code_callback): New prototypes.
* match.h (gfc_match_omp_declare_reduction): New prototype.
* module.c (MOD_VERSION): Increase to 13.
(omp_declare_reduction_stmt): New array.
(mio_omp_udr_expr, write_omp_udr, write_omp_udrs, load_omp_udrs):
New functions.
(read_module): Read OpenMP user defined reductions.
(write_module): Write OpenMP user defined reductions.
* openmp.c: Include arith.h.
(gfc_free_omp_udr, gfc_find_omp_udr): New functions.
(gfc_match_omp_clauses): Handle user defined reductions.
Store reduction kind into gfc_omp_namelist instead of using
several OMP_LIST_* entries.
(match_udr_expr, gfc_omp_udr_predef, gfc_omp_udr_find,
gfc_match_omp_declare_reduction): New functions.
(resolve_omp_clauses): Adjust for reduction clauses being only
in OMP_LIST_REDUCTION list. Diagnose missing UDRs.
(struct omp_udr_callback_data): New type.
(omp_udr_callback, gfc_resolve_omp_udr, gfc_resolve_omp_udrs): New
functions.
* parse.c (decode_omp_directive): Handle !$omp declare reduction.
(case_decl): Add ST_OMP_DECLARE_REDUCTION.
(gfc_ascii_statement): Print ST_OMP_DECLARE_REDUCTION.
* resolve.c (resolve_fl_variable): Allow len=: or len=* on
sym->attr.omp_udr_artificial_var symbols.
(resolve_types): Call gfc_resolve_omp_udrs.
* symbol.c (gfc_get_uop): If gfc_current_ns->omp_udr_ns,
use parent ns instead of gfc_current_ns.
(gfc_get_sym_tree): Don't insert symbols into
namespaces with omp_udr_ns set.
(free_omp_udr_tree): New function.
(gfc_free_namespace): Call it.
* trans-openmp.c (struct omp_udr_find_orig_data): New type.
(omp_udr_find_orig, gfc_trans_omp_udr_expr): New functions.
(gfc_trans_omp_array_reduction): Renamed to...
(gfc_trans_omp_array_reduction_or_udr): ... this. Remove SYM
argument, instead pass gfc_omp_namelist pointer N. Handle
user defined reductions.
(gfc_trans_omp_reduction_list): Remove REDUCTION_CODE argument.
Handle user defined reductions and reduction ops in gfc_omp_namelist.
(gfc_trans_omp_clauses): Adjust for just a single OMP_LIST_REDUCTION
list.
(gfc_split_omp_clauses): Likewise.
2014-05-12 Tobias Burnus <burnus@net-b.de>
PR fortran/60127
* openmp.c (resolve_omp_do): Reject do concurrent loops.
2014-05-11 Jakub Jelinek <jakub@redhat.com>
* 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/
2014-06-30 Jakub Jelinek <jakub@redhat.com>
Backported from mainline
2014-06-24 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/gomp/udr2.f90 (f7, f9): Add !$omp parallel with
reduction clause.
* gfortran.dg/gomp/udr4.f90 (f4): Likewise.
Remove Label is never defined expected error.
* gfortran.dg/gomp/udr8.f90: New test.
2014-06-18 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/gomp/declare-simd-1.f90: New test.
* gfortran.dg/gomp/depend-1.f90: New test.
* gfortran.dg/gomp/target1.f90: New test.
* gfortran.dg/gomp/target2.f90: New test.
* gfortran.dg/gomp/target3.f90: New test.
* gfortran.dg/gomp/udr4.f90: Adjust expected diagnostics.
* gfortran.dg/openmp-define-3.f90: Expect _OPENMP 201307 instead of
201107.
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* gfortran.dg/gomp/allocatable_components_1.f90: Remove dg-error
directives.
* gfortran.dg/gomp/associate1.f90: New test.
* gfortran.dg/gomp/intentin1.f90: New test.
* gfortran.dg/gomp/openmp-simd-1.f90: New test.
* gfortran.dg/gomp/openmp-simd-2.f90: New test.
* gfortran.dg/gomp/openmp-simd-3.f90: New test.
* gfortran.dg/gomp/proc_ptr_2.f90: New test.
2014-06-09 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/gomp/udr6.f90 (f1, f2, f3): Use complex(kind=8)
instead of complex(kind=16).
2014-06-06 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/gomp/allocatable_components_1.f90: Adjust for
reduction clause diagnostic changes.
* gfortran.dg/gomp/appendix-a/a.31.3.f90: Likewise.
* gfortran.dg/gomp/reduction1.f90: Likewise.
* gfortran.dg/gomp/reduction3.f90: Likewise.
* gfortran.dg/gomp/udr1.f90: New test.
* gfortran.dg/gomp/udr2.f90: New test.
* gfortran.dg/gomp/udr3.f90: New test.
* gfortran.dg/gomp/udr4.f90: New test.
* gfortran.dg/gomp/udr5.f90: New test.
* gfortran.dg/gomp/udr6.f90: New test.
* gfortran.dg/gomp/udr7.f90: New test.
2014-05-12 Tobias Burnus <burnus@net-b.de>
PR fortran/60127
* gfortran.dg/gomp/omp_do_concurrent.f90: New.
2014-05-11 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/gomp/affinity-1.f90: New test.
libgomp/
2014-06-30 Jakub Jelinek <jakub@redhat.com>
Backported from mainline
2014-06-25 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.fortran/simd5.f90: New test.
* testsuite/libgomp.fortran/simd6.f90: New test.
* testsuite/libgomp.fortran/simd7.f90: New test.
2014-06-24 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.fortran/aligned1.f03: New test.
* testsuite/libgomp.fortran/nestedfn5.f90: New test.
* testsuite/libgomp.fortran/target7.f90: Surround loop spawning
tasks with !$omp parallel !$omp single.
* testsuite/libgomp.fortran/target8.f90: New test.
* testsuite/libgomp.fortran/udr4.f90 (foo UDR, bar UDR): Adjust
not to use trim in the combiner, instead call elemental function.
(fn): New elemental function.
* testsuite/libgomp.fortran/udr6.f90 (do_add, dp_add, dp_init):
Make elemental.
* testsuite/libgomp.fortran/udr7.f90 (omp_priv, omp_orig, omp_out,
omp_in): Likewise.
* testsuite/libgomp.fortran/udr12.f90: New test.
* testsuite/libgomp.fortran/udr13.f90: New test.
* testsuite/libgomp.fortran/udr14.f90: New test.
* testsuite/libgomp.fortran/udr15.f90: New test.
2014-06-18 Jakub Jelinek <jakub@redhat.com>
* omp_lib.f90.in (openmp_version): Set to 201307.
* omp_lib.h.in (openmp_version): Likewise.
* testsuite/libgomp.c/target-8.c: New test.
* testsuite/libgomp.fortran/declare-simd-1.f90: Add notinbranch
and inbranch clauses.
* testsuite/libgomp.fortran/depend-3.f90: New test.
* testsuite/libgomp.fortran/openmp_version-1.f: Adjust for new
openmp_version.
* testsuite/libgomp.fortran/openmp_version-2.f90: Likewise.
* testsuite/libgomp.fortran/target1.f90: New test.
* testsuite/libgomp.fortran/target2.f90: New test.
* testsuite/libgomp.fortran/target3.f90: New test.
* testsuite/libgomp.fortran/target4.f90: New test.
* testsuite/libgomp.fortran/target5.f90: New test.
* testsuite/libgomp.fortran/target6.f90: New test.
* testsuite/libgomp.fortran/target7.f90: New test.
2014-06-10 Jakub Jelinek <jakub@redhat.com>
PR fortran/60928
* testsuite/libgomp.fortran/allocatable9.f90: New test.
* testsuite/libgomp.fortran/allocatable10.f90: New test.
* testsuite/libgomp.fortran/allocatable11.f90: New test.
* testsuite/libgomp.fortran/allocatable12.f90: New test.
* testsuite/libgomp.fortran/alloc-comp-1.f90: New test.
* testsuite/libgomp.fortran/alloc-comp-2.f90: New test.
* testsuite/libgomp.fortran/alloc-comp-3.f90: New test.
* testsuite/libgomp.fortran/associate1.f90: New test.
* testsuite/libgomp.fortran/associate2.f90: New test.
* testsuite/libgomp.fortran/procptr1.f90: New test.
2014-06-06 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.fortran/simd1.f90: New test.
* testsuite/libgomp.fortran/udr1.f90: New test.
* testsuite/libgomp.fortran/udr2.f90: New test.
* testsuite/libgomp.fortran/udr3.f90: New test.
* testsuite/libgomp.fortran/udr4.f90: New test.
* testsuite/libgomp.fortran/udr5.f90: New test.
* testsuite/libgomp.fortran/udr6.f90: New test.
* testsuite/libgomp.fortran/udr7.f90: New test.
* testsuite/libgomp.fortran/udr8.f90: New test.
* testsuite/libgomp.fortran/udr9.f90: New test.
* testsuite/libgomp.fortran/udr10.f90: New test.
* testsuite/libgomp.fortran/udr11.f90: New test.
2014-05-27 Uros Bizjak <ubizjak@gmail.com>
* testsuite/libgomp.fortran/declare-simd-1.f90: Require
vect_simd_clones effective target.
* testsuite/libgomp.fortran/declare-simd-2.f90: Ditto.
2014-05-11 Jakub Jelinek <jakub@redhat.com>
* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_9-branch@212157 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran/trans-openmp.c')
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 2696 |
1 files changed, 2395 insertions, 301 deletions
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 41020a836a7..da01a9034cb 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -53,9 +53,13 @@ gfc_omp_privatize_by_reference (const_tree decl) if (TREE_CODE (type) == POINTER_TYPE) { /* Array POINTER/ALLOCATABLE have aggregate types, all user variables - that have POINTER_TYPE type and don't have GFC_POINTER_TYPE_P - set are supposed to be privatized by reference. */ - if (GFC_POINTER_TYPE_P (type)) + that have POINTER_TYPE type and aren't scalar pointers, scalar + allocatables, Cray pointees or C pointers are supposed to be + privatized by reference. */ + if (GFC_DECL_GET_SCALAR_POINTER (decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + || GFC_DECL_CRAY_POINTEE (decl) + || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) return false; if (!DECL_ARTIFICIAL (decl) @@ -77,6 +81,19 @@ gfc_omp_privatize_by_reference (const_tree decl) enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree decl) { + /* Associate names preserve the association established during ASSOCIATE. + As they are implemented either as pointers to the selector or array + descriptor and shouldn't really change in the ASSOCIATE region, + this decl can be either shared or firstprivate. If it is a pointer, + use firstprivate, as it is cheaper that way, otherwise make it shared. */ + if (GFC_DECL_ASSOCIATE_VAR_P (decl)) + { + if (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) + return OMP_CLAUSE_DEFAULT_FIRSTPRIVATE; + else + return OMP_CLAUSE_DEFAULT_SHARED; + } + if (DECL_ARTIFICIAL (decl) && ! GFC_DECL_RESULT (decl) && ! (DECL_LANG_SPECIFIC (decl) @@ -135,6 +152,41 @@ gfc_omp_report_decl (tree decl) return decl; } +/* Return true if TYPE has any allocatable components. */ + +static bool +gfc_has_alloc_comps (tree type, tree decl) +{ + tree field, ftype; + + if (POINTER_TYPE_P (type)) + { + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + type = TREE_TYPE (type); + else if (GFC_DECL_GET_SCALAR_POINTER (decl)) + return false; + } + + while (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) + type = gfc_get_element_type (type); + + if (TREE_CODE (type) != RECORD_TYPE) + return false; + + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + { + ftype = TREE_TYPE (field); + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + return true; + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + return true; + if (gfc_has_alloc_comps (ftype, field)) + return true; + } + return false; +} + /* Return true if DECL in private clause needs OMP_CLAUSE_PRIVATE_OUTER_REF on the private clause. */ bool @@ -146,68 +198,335 @@ gfc_omp_private_outer_ref (tree decl) && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) return true; + if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)) + return true; + + if (gfc_omp_privatize_by_reference (decl)) + type = TREE_TYPE (type); + + if (gfc_has_alloc_comps (type, decl)) + return true; + return false; } +/* Callback for gfc_omp_unshare_expr. */ + +static tree +gfc_omp_unshare_expr_r (tree *tp, int *walk_subtrees, void *) +{ + tree t = *tp; + enum tree_code code = TREE_CODE (t); + + /* Stop at types, decls, constants like copy_tree_r. */ + if (TREE_CODE_CLASS (code) == tcc_type + || TREE_CODE_CLASS (code) == tcc_declaration + || TREE_CODE_CLASS (code) == tcc_constant + || code == BLOCK) + *walk_subtrees = 0; + else if (handled_component_p (t) + || TREE_CODE (t) == MEM_REF) + { + *tp = unshare_expr (t); + *walk_subtrees = 0; + } + + return NULL_TREE; +} + +/* Unshare in expr anything that the FE which normally doesn't + care much about tree sharing (because during gimplification + everything is unshared) could cause problems with tree sharing + at omp-low.c time. */ + +static tree +gfc_omp_unshare_expr (tree expr) +{ + walk_tree (&expr, gfc_omp_unshare_expr_r, NULL, NULL); + return expr; +} + +enum walk_alloc_comps +{ + WALK_ALLOC_COMPS_DTOR, + WALK_ALLOC_COMPS_DEFAULT_CTOR, + WALK_ALLOC_COMPS_COPY_CTOR +}; + +/* Handle allocatable components in OpenMP clauses. */ + +static tree +gfc_walk_alloc_comps (tree decl, tree dest, tree var, + enum walk_alloc_comps kind) +{ + stmtblock_t block, tmpblock; + tree type = TREE_TYPE (decl), then_b, tem, field; + gfc_init_block (&block); + + if (GFC_ARRAY_TYPE_P (type) || GFC_DESCRIPTOR_TYPE_P (type)) + { + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_init_block (&tmpblock); + tem = gfc_full_array_size (&tmpblock, decl, + GFC_TYPE_ARRAY_RANK (type)); + then_b = gfc_finish_block (&tmpblock); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (then_b)); + tem = gfc_omp_unshare_expr (tem); + tem = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tem, + gfc_index_one_node); + } + else + { + if (!TYPE_DOMAIN (type) + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE + || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) + { + tem = fold_build2 (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (type), + TYPE_SIZE_UNIT (TREE_TYPE (type))); + tem = size_binop (MINUS_EXPR, tem, size_one_node); + } + else + tem = array_type_nelts (type); + tem = fold_convert (gfc_array_index_type, tem); + } + + tree nelems = gfc_evaluate_now (tem, &block); + tree index = gfc_create_var (gfc_array_index_type, "S"); + + gfc_init_block (&tmpblock); + tem = gfc_conv_array_data (decl); + tree declvar = build_fold_indirect_ref_loc (input_location, tem); + tree declvref = gfc_build_array_ref (declvar, index, NULL); + tree destvar, destvref = NULL_TREE; + if (dest) + { + tem = gfc_conv_array_data (dest); + destvar = build_fold_indirect_ref_loc (input_location, tem); + destvref = gfc_build_array_ref (destvar, index, NULL); + } + gfc_add_expr_to_block (&tmpblock, + gfc_walk_alloc_comps (declvref, destvref, + var, kind)); + + gfc_loopinfo loop; + gfc_init_loopinfo (&loop); + loop.dimen = 1; + loop.from[0] = gfc_index_zero_node; + loop.loopvar[0] = index; + loop.to[0] = nelems; + gfc_trans_scalarizing_loops (&loop, &tmpblock); + gfc_add_block_to_block (&block, &loop.pre); + return gfc_finish_block (&block); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (var)) + { + decl = build_fold_indirect_ref_loc (input_location, decl); + if (dest) + dest = build_fold_indirect_ref_loc (input_location, dest); + type = TREE_TYPE (decl); + } + + gcc_assert (TREE_CODE (type) == RECORD_TYPE); + for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field)) + { + tree ftype = TREE_TYPE (field); + tree declf, destf = NULL_TREE; + bool has_alloc_comps = gfc_has_alloc_comps (ftype, field); + if ((!GFC_DESCRIPTOR_TYPE_P (ftype) + || GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (field) + && !has_alloc_comps) + continue; + declf = fold_build3_loc (input_location, COMPONENT_REF, ftype, + decl, field, NULL_TREE); + if (dest) + destf = fold_build3_loc (input_location, COMPONENT_REF, ftype, + dest, field, NULL_TREE); + + tem = NULL_TREE; + switch (kind) + { + case WALK_ALLOC_COMPS_DTOR: + break; + case WALK_ALLOC_COMPS_DEFAULT_CTOR: + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + { + gfc_add_modify (&block, unshare_expr (destf), + unshare_expr (declf)); + tem = gfc_duplicate_allocatable_nocopy + (destf, declf, ftype, + GFC_TYPE_ARRAY_RANK (ftype)); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = gfc_duplicate_allocatable_nocopy (destf, declf, ftype, 0); + break; + case WALK_ALLOC_COMPS_COPY_CTOR: + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + tem = gfc_duplicate_allocatable (destf, declf, ftype, + GFC_TYPE_ARRAY_RANK (ftype)); + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = gfc_duplicate_allocatable (destf, declf, ftype, 0); + break; + } + if (tem) + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + if (has_alloc_comps) + { + gfc_init_block (&tmpblock); + gfc_add_expr_to_block (&tmpblock, + gfc_walk_alloc_comps (declf, destf, + field, kind)); + then_b = gfc_finish_block (&tmpblock); + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + tem = gfc_conv_descriptor_data_get (unshare_expr (declf)); + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + tem = unshare_expr (declf); + else + tem = NULL_TREE; + if (tem) + { + tem = fold_convert (pvoid_type_node, tem); + tem = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tem, + null_pointer_node); + then_b = build3_loc (input_location, COND_EXPR, void_type_node, + tem, then_b, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, then_b); + } + if (kind == WALK_ALLOC_COMPS_DTOR) + { + if (GFC_DESCRIPTOR_TYPE_P (ftype) + && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) + { + tem = gfc_trans_dealloc_allocated (unshare_expr (declf), + false, NULL); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + } + else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) + { + tem = gfc_call_free (unshare_expr (declf)); + gfc_add_expr_to_block (&block, gfc_omp_unshare_expr (tem)); + } + } + } + + return gfc_finish_block (&block); +} + /* Return code to initialize DECL with its default constructor, or NULL if there's nothing to do. */ tree gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) { - tree type = TREE_TYPE (decl), rank, size, esize, ptr, cond, then_b, else_b; + tree type = TREE_TYPE (decl), size, ptr, cond, then_b, else_b; stmtblock_t block, cond_block; - if (! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - return NULL; + gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION); - if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION) - return NULL; + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gcc_assert (outer); + gfc_start_block (&block); + tree tem = gfc_walk_alloc_comps (outer, decl, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DEFAULT_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + return NULL_TREE; + } - gcc_assert (outer != NULL); - gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_PRIVATE - || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LASTPRIVATE); + gcc_assert (outer != NULL_TREE); - /* Allocatable arrays in PRIVATE clauses need to be set to + /* Allocatable arrays and scalars in PRIVATE clauses need to be set to "not currently allocated" allocation status if outer array is "not currently allocated", otherwise should be allocated. */ gfc_start_block (&block); gfc_init_block (&cond_block); - gfc_add_modify (&cond_block, decl, outer); - rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (decl, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, gfc_conv_descriptor_lbound_get (decl, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, gfc_conv_descriptor_stride_get (decl, rank)); - esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); - + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_add_modify (&cond_block, decl, outer); + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (decl, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (decl, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (decl, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); ptr = gfc_create_var (pvoid_type_node, NULL); gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); - gfc_conv_descriptor_data_set (&cond_block, decl, ptr); - + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), ptr); + else + gfc_add_modify (&cond_block, unshare_expr (decl), + fold_convert (TREE_TYPE (decl), ptr)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (outer, decl, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DEFAULT_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } then_b = gfc_finish_block (&cond_block); - gfc_init_block (&cond_block); - gfc_conv_descriptor_data_set (&cond_block, decl, null_pointer_node); - else_b = gfc_finish_block (&cond_block); - - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - fold_convert (pvoid_type_node, - gfc_conv_descriptor_data_get (outer)), - null_pointer_node); - gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, - void_type_node, cond, then_b, else_b)); + /* Reduction clause requires allocated ALLOCATABLE. */ + if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_REDUCTION) + { + gfc_init_block (&cond_block); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (decl), + null_pointer_node); + else + gfc_add_modify (&cond_block, unshare_expr (decl), + build_zero_cst (TREE_TYPE (decl))); + else_b = gfc_finish_block (&cond_block); + + tree tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (outer) : outer); + tem = unshare_expr (tem); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, + else_b)); + } + else + gfc_add_expr_to_block (&block, then_b); return gfc_finish_block (&block); } @@ -217,15 +536,29 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) tree gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) { - tree type = TREE_TYPE (dest), ptr, size, esize, rank, call; + tree type = TREE_TYPE (dest), ptr, size, call; tree cond, then_b, else_b; stmtblock_t block, cond_block; - if (! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - return build2_v (MODIFY_EXPR, dest, src); + gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE + || OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); - gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_FIRSTPRIVATE); + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gfc_start_block (&block); + gfc_add_modify (&block, dest, src); + tree tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + else + return build2_v (MODIFY_EXPR, dest, src); + } /* Allocatable arrays in FIRSTPRIVATE clauses need to be allocated and copied from SRC. */ @@ -234,86 +567,389 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) gfc_init_block (&cond_block); gfc_add_modify (&cond_block, dest, src); - rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (dest, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, gfc_conv_descriptor_lbound_get (dest, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, gfc_conv_descriptor_stride_get (dest, rank)); - esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); - + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (dest, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (dest, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); ptr = gfc_create_var (pvoid_type_node, NULL); gfc_allocate_using_malloc (&cond_block, ptr, size, NULL_TREE); - gfc_conv_descriptor_data_set (&cond_block, dest, ptr); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), ptr); + else + gfc_add_modify (&cond_block, unshare_expr (dest), + fold_convert (TREE_TYPE (dest), ptr)); + tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (src) : src; + srcptr = unshare_expr (srcptr); + srcptr = fold_convert (pvoid_type_node, srcptr); call = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), - 3, ptr, - fold_convert (pvoid_type_node, - gfc_conv_descriptor_data_get (src)), - size); + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, + srcptr, size); gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (src, dest, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } then_b = gfc_finish_block (&cond_block); gfc_init_block (&cond_block); - gfc_conv_descriptor_data_set (&cond_block, dest, null_pointer_node); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_conv_descriptor_data_set (&cond_block, unshare_expr (dest), + null_pointer_node); + else + gfc_add_modify (&cond_block, unshare_expr (dest), + build_zero_cst (TREE_TYPE (dest))); else_b = gfc_finish_block (&cond_block); cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - fold_convert (pvoid_type_node, - gfc_conv_descriptor_data_get (src)), - null_pointer_node); - gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, - void_type_node, cond, then_b, else_b)); + unshare_expr (srcptr), null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, then_b, else_b)); return gfc_finish_block (&block); } -/* Similarly, except use an assignment operator instead. */ +/* Similarly, except use an intrinsic or pointer assignment operator + instead. */ tree -gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src) +gfc_omp_clause_assign_op (tree clause, tree dest, tree src) { - tree type = TREE_TYPE (dest), rank, size, esize, call; - stmtblock_t block; + tree type = TREE_TYPE (dest), ptr, size, call, nonalloc; + tree cond, then_b, else_b; + stmtblock_t block, cond_block, cond_block2, inner_block; - if (! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - return build2_v (MODIFY_EXPR, dest, src); + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + gfc_start_block (&block); + /* First dealloc any allocatable components in DEST. */ + tree tem = gfc_walk_alloc_comps (dest, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + gfc_add_expr_to_block (&block, tem); + /* Then copy over toplevel data. */ + gfc_add_modify (&block, dest, src); + /* Finally allocate any allocatable components and copy. */ + tem = gfc_walk_alloc_comps (src, dest, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&block, tem); + return gfc_finish_block (&block); + } + else + return build2_v (MODIFY_EXPR, dest, src); + } - /* Handle copying allocatable arrays. */ gfc_start_block (&block); - rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (dest, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - size, gfc_conv_descriptor_lbound_get (dest, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, gfc_conv_descriptor_stride_get (dest, rank)); - esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + tree tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (dest) : dest); + tem = unshare_expr (tem); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, null_pointer_node); + tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, + then_b, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tem); + } + + gfc_init_block (&cond_block); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (src, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (src, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (src, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + size, esize); + size = unshare_expr (size); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &cond_block); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + + tree destptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (dest) : dest; + destptr = unshare_expr (destptr); + destptr = fold_convert (pvoid_type_node, destptr); + gfc_add_modify (&cond_block, ptr, destptr); + + nonalloc = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + destptr, null_pointer_node); + cond = nonalloc; + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + int i; + for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++) + { + tree rank = gfc_rank_cst[i]; + tree tem = gfc_conv_descriptor_ubound_get (src, rank); + tem = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, tem, + gfc_conv_descriptor_lbound_get (src, rank)); + tem = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, tem, + gfc_conv_descriptor_lbound_get (dest, rank)); + tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, gfc_conv_descriptor_ubound_get (dest, + rank)); + cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + boolean_type_node, cond, tem); + } + } + + gfc_init_block (&cond_block2); + + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_init_block (&inner_block); + gfc_allocate_using_malloc (&inner_block, ptr, size, NULL_TREE); + then_b = gfc_finish_block (&inner_block); + + gfc_init_block (&inner_block); + gfc_add_modify (&inner_block, ptr, + gfc_call_realloc (&inner_block, ptr, size)); + else_b = gfc_finish_block (&inner_block); + + gfc_add_expr_to_block (&cond_block2, + build3_loc (input_location, COND_EXPR, + void_type_node, + unshare_expr (nonalloc), + then_b, else_b)); + gfc_add_modify (&cond_block2, dest, src); + gfc_conv_descriptor_data_set (&cond_block2, unshare_expr (dest), ptr); + } + else + { + gfc_allocate_using_malloc (&cond_block2, ptr, size, NULL_TREE); + gfc_add_modify (&cond_block2, unshare_expr (dest), + fold_convert (type, ptr)); + } + then_b = gfc_finish_block (&cond_block2); + else_b = build_empty_stmt (input_location); + + gfc_add_expr_to_block (&cond_block, + build3_loc (input_location, COND_EXPR, + void_type_node, unshare_expr (cond), + then_b, else_b)); + + tree srcptr = GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (src) : src; + srcptr = unshare_expr (srcptr); + srcptr = fold_convert (pvoid_type_node, srcptr); call = build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MEMCPY), 3, - fold_convert (pvoid_type_node, - gfc_conv_descriptor_data_get (dest)), - fold_convert (pvoid_type_node, - gfc_conv_descriptor_data_get (src)), - size); - gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); + builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr, + srcptr, size); + gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call)); + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + tree tem = gfc_walk_alloc_comps (src, dest, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_COPY_CTOR); + gfc_add_expr_to_block (&cond_block, tem); + } + then_b = gfc_finish_block (&cond_block); + + if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_COPYIN) + { + gfc_init_block (&cond_block); + if (GFC_DESCRIPTOR_TYPE_P (type)) + gfc_add_expr_to_block (&cond_block, + gfc_trans_dealloc_allocated (unshare_expr (dest), + false, NULL)); + else + { + destptr = gfc_evaluate_now (destptr, &cond_block); + gfc_add_expr_to_block (&cond_block, gfc_call_free (destptr)); + gfc_add_modify (&cond_block, unshare_expr (dest), + build_zero_cst (TREE_TYPE (dest))); + } + else_b = gfc_finish_block (&cond_block); + + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + unshare_expr (srcptr), null_pointer_node); + gfc_add_expr_to_block (&block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, + then_b, else_b)); + } + else + gfc_add_expr_to_block (&block, then_b); + + return gfc_finish_block (&block); +} + +static void +gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src, + tree add, tree nelems) +{ + stmtblock_t tmpblock; + tree desta, srca, index = gfc_create_var (gfc_array_index_type, "S"); + nelems = gfc_evaluate_now (nelems, block); + + gfc_init_block (&tmpblock); + if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE) + { + desta = gfc_build_array_ref (dest, index, NULL); + srca = gfc_build_array_ref (src, index, NULL); + } + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (dest))); + tree idx = fold_build2 (MULT_EXPR, sizetype, + fold_convert (sizetype, index), + TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (dest)))); + desta = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (dest), dest, + idx)); + srca = build_fold_indirect_ref (fold_build2 (POINTER_PLUS_EXPR, + TREE_TYPE (src), src, + idx)); + } + gfc_add_modify (&tmpblock, desta, + fold_build2 (PLUS_EXPR, TREE_TYPE (desta), + srca, add)); + + gfc_loopinfo loop; + gfc_init_loopinfo (&loop); + loop.dimen = 1; + loop.from[0] = gfc_index_zero_node; + loop.loopvar[0] = index; + loop.to[0] = nelems; + gfc_trans_scalarizing_loops (&loop, &tmpblock); + gfc_add_block_to_block (block, &loop.pre); +} + +/* Build and return code for a constructor of DEST that initializes + it to SRC plus ADD (ADD is scalar integer). */ + +tree +gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add) +{ + tree type = TREE_TYPE (dest), ptr, size, nelems = NULL_TREE; + stmtblock_t block; + + gcc_assert (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_LINEAR); + gfc_start_block (&block); + add = gfc_evaluate_now (add, &block); + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + gcc_assert (TREE_CODE (type) == ARRAY_TYPE); + if (!TYPE_DOMAIN (type) + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == NULL_TREE + || TYPE_MIN_VALUE (TYPE_DOMAIN (type)) == error_mark_node + || TYPE_MAX_VALUE (TYPE_DOMAIN (type)) == error_mark_node) + { + nelems = fold_build2 (EXACT_DIV_EXPR, sizetype, + TYPE_SIZE_UNIT (type), + TYPE_SIZE_UNIT (TREE_TYPE (type))); + nelems = size_binop (MINUS_EXPR, nelems, size_one_node); + } + else + nelems = array_type_nelts (type); + nelems = fold_convert (gfc_array_index_type, nelems); + + gfc_omp_linear_clause_add_loop (&block, dest, src, add, nelems); + return gfc_finish_block (&block); + } + + /* Allocatable arrays in LINEAR clauses need to be allocated + and copied from SRC. */ + gfc_add_modify (&block, dest, src); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; + size = gfc_conv_descriptor_ubound_get (dest, rank); + size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + size, + gfc_conv_descriptor_lbound_get (dest, rank)); + size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + size, gfc_index_one_node); + if (GFC_TYPE_ARRAY_RANK (type) > 1) + size = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, size, + gfc_conv_descriptor_stride_get (dest, rank)); + tree esize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + nelems = gfc_evaluate_now (unshare_expr (size), &block); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + nelems, unshare_expr (esize)); + size = gfc_evaluate_now (fold_convert (size_type_node, size), + &block); + nelems = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, nelems, + gfc_index_one_node); + } + else + size = fold_convert (size_type_node, TYPE_SIZE_UNIT (TREE_TYPE (type))); + ptr = gfc_create_var (pvoid_type_node, NULL); + gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + gfc_conv_descriptor_data_set (&block, unshare_expr (dest), ptr); + tree etype = gfc_get_element_type (type); + ptr = fold_convert (build_pointer_type (etype), ptr); + tree srcptr = gfc_conv_descriptor_data_get (unshare_expr (src)); + srcptr = fold_convert (build_pointer_type (etype), srcptr); + gfc_omp_linear_clause_add_loop (&block, ptr, srcptr, add, nelems); + } + else + { + gfc_add_modify (&block, unshare_expr (dest), + fold_convert (TREE_TYPE (dest), ptr)); + ptr = fold_convert (TREE_TYPE (dest), ptr); + tree dstm = build_fold_indirect_ref (ptr); + tree srcm = build_fold_indirect_ref (unshare_expr (src)); + gfc_add_modify (&block, dstm, + fold_build2 (PLUS_EXPR, TREE_TYPE (add), srcm, add)); + } return gfc_finish_block (&block); } @@ -321,20 +957,161 @@ gfc_omp_clause_assign_op (tree clause ATTRIBUTE_UNUSED, tree dest, tree src) to be done. */ tree -gfc_omp_clause_dtor (tree clause ATTRIBUTE_UNUSED, tree decl) +gfc_omp_clause_dtor (tree clause, tree decl) { - tree type = TREE_TYPE (decl); + tree type = TREE_TYPE (decl), tem; + + if ((! GFC_DESCRIPTOR_TYPE_P (type) + || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))) + { + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + return gfc_walk_alloc_comps (decl, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR); + return NULL_TREE; + } - if (! GFC_DESCRIPTOR_TYPE_P (type) - || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE) - return NULL; + if (GFC_DESCRIPTOR_TYPE_P (type)) + /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need + to be deallocated if they were allocated. */ + tem = gfc_trans_dealloc_allocated (decl, false, NULL); + else + tem = gfc_call_free (decl); + tem = gfc_omp_unshare_expr (tem); - if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION) - return NULL; + if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause))) + { + stmtblock_t block; + tree then_b; + + gfc_init_block (&block); + gfc_add_expr_to_block (&block, + gfc_walk_alloc_comps (decl, NULL_TREE, + OMP_CLAUSE_DECL (clause), + WALK_ALLOC_COMPS_DTOR)); + gfc_add_expr_to_block (&block, tem); + then_b = gfc_finish_block (&block); + + tem = fold_convert (pvoid_type_node, + GFC_DESCRIPTOR_TYPE_P (type) + ? gfc_conv_descriptor_data_get (decl) : decl); + tem = unshare_expr (tem); + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem, null_pointer_node); + tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, + then_b, build_empty_stmt (input_location)); + } + return tem; +} - /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need - to be deallocated if they were allocated. */ - return gfc_trans_dealloc_allocated (decl, false, NULL); + +void +gfc_omp_finish_clause (tree c, gimple_seq *pre_p) +{ + if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP) + return; + + tree decl = OMP_CLAUSE_DECL (c); + tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + { + if (!gfc_omp_privatize_by_reference (decl) + && !GFC_DECL_GET_SCALAR_POINTER (decl) + && !GFC_DECL_GET_SCALAR_ALLOCATABLE (decl) + && !GFC_DECL_CRAY_POINTEE (decl) + && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + return; + c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (c4) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (c4) = decl; + OMP_CLAUSE_SIZE (c4) = size_int (0); + decl = build_fold_indirect_ref (decl); + OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_SIZE (c) = NULL_TREE; + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + stmtblock_t block; + gfc_start_block (&block); + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + ptr = fold_convert (build_pointer_type (char_type_node), ptr); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c) = ptr; + c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (c2) = OMP_CLAUSE_MAP_TO_PSET; + OMP_CLAUSE_DECL (c2) = decl; + OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type); + c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (c3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_SIZE (c3) = size_int (0); + tree size = create_tmp_var (gfc_array_index_type, NULL); + tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) + { + stmtblock_t cond_block; + tree tem, then_b, else_b, zero, cond; + + gfc_init_block (&cond_block); + tem = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + gfc_add_modify (&cond_block, size, tem); + gfc_add_modify (&cond_block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + then_b = gfc_finish_block (&cond_block); + gfc_init_block (&cond_block); + zero = build_int_cst (gfc_array_index_type, 0); + gfc_add_modify (&cond_block, size, zero); + else_b = gfc_finish_block (&cond_block); + tem = gfc_conv_descriptor_data_get (decl); + tem = fold_convert (pvoid_type_node, tem); + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tem, null_pointer_node); + gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, + void_type_node, cond, + then_b, else_b)); + } + else + { + gfc_add_modify (&block, size, + gfc_full_array_size (&block, decl, + GFC_TYPE_ARRAY_RANK (type))); + gfc_add_modify (&block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + } + OMP_CLAUSE_SIZE (c) = size; + tree stmt = gfc_finish_block (&block); + gimplify_and_add (stmt, pre_p); + } + tree last = c; + if (OMP_CLAUSE_SIZE (c) == NULL_TREE) + OMP_CLAUSE_SIZE (c) + = DECL_P (decl) ? DECL_SIZE_UNIT (decl) + : TYPE_SIZE_UNIT (TREE_TYPE (decl)); + if (c2) + { + OMP_CLAUSE_CHAIN (c2) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c2; + last = c2; + } + if (c3) + { + OMP_CLAUSE_CHAIN (c3) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c3; + last = c3; + } + if (c4) + { + OMP_CLAUSE_CHAIN (c4) = OMP_CLAUSE_CHAIN (last); + OMP_CLAUSE_CHAIN (last) = c4; + last = c4; + } } @@ -427,8 +1204,33 @@ gfc_trans_add_clause (tree node, tree tail) } 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 +1244,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 +1284,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); @@ -498,18 +1302,39 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_namelist *namelist, return list; } +struct omp_udr_find_orig_data +{ + gfc_omp_udr *omp_udr; + bool omp_orig_seen; +}; + +static int +omp_udr_find_orig (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + struct omp_udr_find_orig_data *cd = (struct omp_udr_find_orig_data *) data; + if ((*e)->expr_type == EXPR_VARIABLE + && (*e)->symtree->n.sym == cd->omp_udr->omp_orig) + cd->omp_orig_seen = true; + + return 0; +} + static void -gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) +gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where) { + gfc_symbol *sym = n->sym; gfc_symtree *root1 = NULL, *root2 = NULL, *root3 = NULL, *root4 = NULL; gfc_symtree *symtree1, *symtree2, *symtree3, *symtree4 = NULL; gfc_symbol init_val_sym, outer_sym, intrinsic_sym; + gfc_symbol omp_var_copy[4]; gfc_expr *e1, *e2, *e3, *e4; gfc_ref *ref; tree decl, backend_decl, stmt, type, outer_decl; locus old_loc = gfc_current_locus; const char *iname; bool t; + gfc_omp_udr *udr = n->udr ? n->udr->udr : NULL; decl = OMP_CLAUSE_DECL (c); gfc_current_locus = where; @@ -532,12 +1357,29 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) init_val_sym.attr.referenced = 1; init_val_sym.declared_at = where; init_val_sym.attr.flavor = FL_VARIABLE; - backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); + if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) + backend_decl = omp_reduction_init (c, gfc_sym_type (&init_val_sym)); + else if (udr->initializer_ns) + backend_decl = NULL; + else + switch (sym->ts.type) + { + case BT_LOGICAL: + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + backend_decl = build_zero_cst (gfc_sym_type (&init_val_sym)); + break; + default: + backend_decl = NULL_TREE; + break; + } init_val_sym.backend_decl = backend_decl; /* Create a fake symbol for the outer array reference. */ outer_sym = *sym; - outer_sym.as = gfc_copy_array_spec (sym->as); + if (sym->as) + outer_sym.as = gfc_copy_array_spec (sym->as); outer_sym.attr.dummy = 0; outer_sym.attr.result = 0; outer_sym.attr.flavor = FL_VARIABLE; @@ -558,28 +1400,75 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) symtree3->n.sym = &outer_sym; gcc_assert (symtree3 == root3); + memset (omp_var_copy, 0, sizeof omp_var_copy); + if (udr) + { + omp_var_copy[0] = *udr->omp_out; + omp_var_copy[1] = *udr->omp_in; + *udr->omp_out = outer_sym; + *udr->omp_in = *sym; + if (udr->initializer_ns) + { + omp_var_copy[2] = *udr->omp_priv; + omp_var_copy[3] = *udr->omp_orig; + *udr->omp_priv = *sym; + *udr->omp_orig = outer_sym; + } + } + /* Create expressions. */ e1 = gfc_get_expr (); e1->expr_type = EXPR_VARIABLE; e1->where = where; e1->symtree = symtree1; e1->ts = sym->ts; - e1->ref = ref = gfc_get_ref (); - ref->type = REF_ARRAY; - ref->u.ar.where = where; - ref->u.ar.as = sym->as; - ref->u.ar.type = AR_FULL; - ref->u.ar.dimen = 0; + if (sym->attr.dimension) + { + e1->ref = ref = gfc_get_ref (); + ref->type = REF_ARRAY; + ref->u.ar.where = where; + ref->u.ar.as = sym->as; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = 0; + } t = gfc_resolve_expr (e1); gcc_assert (t); - e2 = gfc_get_expr (); - e2->expr_type = EXPR_VARIABLE; - e2->where = where; - e2->symtree = symtree2; - e2->ts = sym->ts; - t = gfc_resolve_expr (e2); - gcc_assert (t); + e2 = NULL; + if (backend_decl != NULL_TREE) + { + e2 = gfc_get_expr (); + e2->expr_type = EXPR_VARIABLE; + e2->where = where; + e2->symtree = symtree2; + e2->ts = sym->ts; + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + else if (udr->initializer_ns == NULL) + { + gcc_assert (sym->ts.type == BT_DERIVED); + e2 = gfc_default_initializer (&sym->ts); + gcc_assert (e2); + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + else if (n->udr->initializer->op == EXEC_ASSIGN) + { + e2 = gfc_copy_expr (n->udr->initializer->expr2); + t = gfc_resolve_expr (e2); + gcc_assert (t); + } + if (udr && udr->initializer_ns) + { + struct omp_udr_find_orig_data cd; + cd.omp_udr = udr; + cd.omp_orig_seen = false; + gfc_code_walker (&n->udr->initializer, + gfc_dummy_code_callback, omp_udr_find_orig, &cd); + if (cd.omp_orig_seen) + OMP_CLAUSE_REDUCTION_OMP_ORIG_REF (c) = 1; + } e3 = gfc_copy_expr (e1); e3->symtree = symtree3; @@ -587,6 +1476,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gcc_assert (t); iname = NULL; + e4 = NULL; switch (OMP_CLAUSE_REDUCTION_CODE (c)) { case PLUS_EXPR: @@ -623,6 +1513,18 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) case BIT_XOR_EXPR: iname = "ieor"; break; + case ERROR_MARK: + if (n->udr->combiner->op == EXEC_ASSIGN) + { + gfc_free_expr (e3); + e3 = gfc_copy_expr (n->udr->combiner->expr1); + e4 = gfc_copy_expr (n->udr->combiner->expr2); + t = gfc_resolve_expr (e3); + gcc_assert (t); + t = gfc_resolve_expr (e4); + gcc_assert (t); + } + break; default: gcc_unreachable (); } @@ -646,58 +1548,27 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) e4->expr_type = EXPR_FUNCTION; e4->where = where; e4->symtree = symtree4; - e4->value.function.isym = gfc_find_function (iname); e4->value.function.actual = gfc_get_actual_arglist (); e4->value.function.actual->expr = e3; e4->value.function.actual->next = gfc_get_actual_arglist (); e4->value.function.actual->next->expr = e1; } - /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ - e1 = gfc_copy_expr (e1); - e3 = gfc_copy_expr (e3); - t = gfc_resolve_expr (e4); - gcc_assert (t); + if (OMP_CLAUSE_REDUCTION_CODE (c) != ERROR_MARK) + { + /* e1 and e3 have been stored as arguments of e4, avoid sharing. */ + e1 = gfc_copy_expr (e1); + e3 = gfc_copy_expr (e3); + t = gfc_resolve_expr (e4); + gcc_assert (t); + } /* Create the init statement list. */ pushlevel (); - if (GFC_DESCRIPTOR_TYPE_P (type) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) - { - /* If decl is an allocatable array, it needs to be allocated - with the same bounds as the outer var. */ - tree rank, size, esize, ptr; - stmtblock_t block; - - gfc_start_block (&block); - - gfc_add_modify (&block, decl, outer_sym.backend_decl); - rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1]; - size = gfc_conv_descriptor_ubound_get (decl, rank); - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, size, - gfc_conv_descriptor_lbound_get (decl, rank)); - size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, - size, gfc_index_one_node); - if (GFC_TYPE_ARRAY_RANK (type) > 1) - size = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, size, - gfc_conv_descriptor_stride_get (decl, rank)); - esize = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (gfc_get_element_type (type))); - size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - size, esize); - size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); - - ptr = gfc_create_var (pvoid_type_node, NULL); - gfc_allocate_using_malloc (&block, ptr, size, NULL_TREE); - gfc_conv_descriptor_data_set (&block, decl, ptr); - - gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false, - false)); - stmt = gfc_finish_block (&block); - } - else + if (e2) stmt = gfc_trans_assignment (e1, e2, false, false); + else + stmt = gfc_trans_call (n->udr->initializer, false, + NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); else @@ -706,22 +1577,11 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) /* Create the merge statement list. */ pushlevel (); - if (GFC_DESCRIPTOR_TYPE_P (type) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) - { - /* If decl is an allocatable array, it needs to be deallocated - afterwards. */ - stmtblock_t block; - - gfc_start_block (&block); - gfc_add_expr_to_block (&block, gfc_trans_assignment (e3, e4, false, - true)); - gfc_add_expr_to_block (&block, gfc_trans_dealloc_allocated (decl, false, - NULL)); - stmt = gfc_finish_block (&block); - } - else + if (e4) stmt = gfc_trans_assignment (e3, e4, false, true); + else + stmt = gfc_trans_call (n->udr->combiner, false, + NULL_TREE, NULL_TREE, false); if (TREE_CODE (stmt) != BIND_EXPR) stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); else @@ -734,32 +1594,91 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) gfc_current_locus = old_loc; gfc_free_expr (e1); - gfc_free_expr (e2); + if (e2) + gfc_free_expr (e2); gfc_free_expr (e3); - gfc_free_expr (e4); + if (e4) + gfc_free_expr (e4); free (symtree1); free (symtree2); free (symtree3); free (symtree4); - gfc_free_array_spec (outer_sym.as); + if (outer_sym.as) + gfc_free_array_spec (outer_sym.as); + + if (udr) + { + *udr->omp_out = omp_var_copy[0]; + *udr->omp_in = omp_var_copy[1]; + if (udr->initializer_ns) + { + *udr->omp_priv = omp_var_copy[2]; + *udr->omp_orig = omp_var_copy[3]; + } + } } static tree -gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, - enum tree_code reduction_code, locus where) +gfc_trans_omp_reduction_list (gfc_omp_namelist *namelist, tree list, + 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, OMP_CLAUSE_REDUCTION); OMP_CLAUSE_DECL (node) = t; - OMP_CLAUSE_REDUCTION_CODE (node) = reduction_code; - if (namelist->sym->attr.dimension) - gfc_trans_omp_array_reduction (node, namelist->sym, where); + switch (namelist->u.reduction_op) + { + case OMP_REDUCTION_PLUS: + OMP_CLAUSE_REDUCTION_CODE (node) = PLUS_EXPR; + break; + case OMP_REDUCTION_MINUS: + OMP_CLAUSE_REDUCTION_CODE (node) = MINUS_EXPR; + break; + case OMP_REDUCTION_TIMES: + OMP_CLAUSE_REDUCTION_CODE (node) = MULT_EXPR; + break; + case OMP_REDUCTION_AND: + OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ANDIF_EXPR; + break; + case OMP_REDUCTION_OR: + OMP_CLAUSE_REDUCTION_CODE (node) = TRUTH_ORIF_EXPR; + break; + case OMP_REDUCTION_EQV: + OMP_CLAUSE_REDUCTION_CODE (node) = EQ_EXPR; + break; + case OMP_REDUCTION_NEQV: + OMP_CLAUSE_REDUCTION_CODE (node) = NE_EXPR; + break; + case OMP_REDUCTION_MAX: + OMP_CLAUSE_REDUCTION_CODE (node) = MAX_EXPR; + break; + case OMP_REDUCTION_MIN: + OMP_CLAUSE_REDUCTION_CODE (node) = MIN_EXPR; + break; + case OMP_REDUCTION_IAND: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_AND_EXPR; + break; + case OMP_REDUCTION_IOR: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_IOR_EXPR; + break; + case OMP_REDUCTION_IEOR: + OMP_CLAUSE_REDUCTION_CODE (node) = BIT_XOR_EXPR; + break; + case OMP_REDUCTION_USER: + OMP_CLAUSE_REDUCTION_CODE (node) = ERROR_MARK; + break; + default: + gcc_unreachable (); + } + if (namelist->sym->attr.dimension + || namelist->u.reduction_op == OMP_REDUCTION_USER + || namelist->sym->attr.allocatable) + gfc_trans_omp_array_reduction_or_udr (node, namelist, where); list = gfc_trans_add_clause (node, list); } } @@ -768,7 +1687,7 @@ gfc_trans_omp_reduction_list (gfc_namelist *namelist, tree list, 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,62 +1699,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, 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; - if (list >= OMP_LIST_REDUCTION_FIRST - && list <= OMP_LIST_REDUCTION_LAST) - { - enum tree_code reduction_code; - switch (list) - { - case OMP_LIST_PLUS: - reduction_code = PLUS_EXPR; - break; - case OMP_LIST_MULT: - reduction_code = MULT_EXPR; - break; - case OMP_LIST_SUB: - reduction_code = MINUS_EXPR; - break; - case OMP_LIST_AND: - reduction_code = TRUTH_ANDIF_EXPR; - break; - case OMP_LIST_OR: - reduction_code = TRUTH_ORIF_EXPR; - break; - case OMP_LIST_EQV: - reduction_code = EQ_EXPR; - break; - case OMP_LIST_NEQV: - reduction_code = NE_EXPR; - break; - case OMP_LIST_MAX: - reduction_code = MAX_EXPR; - break; - case OMP_LIST_MIN: - reduction_code = MIN_EXPR; - break; - case OMP_LIST_IAND: - reduction_code = BIT_AND_EXPR; - break; - case OMP_LIST_IOR: - reduction_code = BIT_IOR_EXPR; - break; - case OMP_LIST_IEOR: - reduction_code = BIT_XOR_EXPR; - break; - default: - gcc_unreachable (); - } - omp_clauses - = gfc_trans_omp_reduction_list (n, omp_clauses, reduction_code, - where); - continue; - } switch (list) { + case OMP_LIST_REDUCTION: + omp_clauses = gfc_trans_omp_reduction_list (n, omp_clauses, where); + break; case OMP_LIST_PRIVATE: clause_code = OMP_CLAUSE_PRIVATE; goto add_clause; @@ -853,10 +1725,411 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, 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) + = fold_convert (gfc_typenode_for_spec (&n->sym->ts), + last_step); + if (n->sym->attr.dimension || n->sym->attr.allocatable) + OMP_CLAUSE_LINEAR_ARRAY (node) = 1; + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + } + } + } + break; + case OMP_LIST_DEPEND: + 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) + { + tree decl = gfc_get_symbol_decl (n->sym); + if (gfc_omp_privatize_by_reference (decl)) + decl = build_fold_indirect_ref (decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + decl = gfc_conv_descriptor_data_get (decl); + decl = fold_convert (build_pointer_type (char_type_node), + decl); + decl = build_fold_indirect_ref (decl); + } + else if (DECL_P (decl)) + TREE_ADDRESSABLE (decl) = 1; + OMP_CLAUSE_DECL (node) = decl; + } + 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); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + switch (n->u.depend_op) + { + case OMP_DEPEND_IN: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_IN; + break; + case OMP_DEPEND_OUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_OUT; + break; + case OMP_DEPEND_INOUT: + OMP_CLAUSE_DEPEND_KIND (node) = OMP_CLAUSE_DEPEND_INOUT; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } + break; + case OMP_LIST_MAP: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.referenced) + continue; + + tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP); + tree node2 = NULL_TREE; + tree node3 = NULL_TREE; + tree node4 = NULL_TREE; + tree decl = gfc_get_symbol_decl (n->sym); + if (DECL_P (decl)) + TREE_ADDRESSABLE (decl) = 1; + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + { + if (POINTER_TYPE_P (TREE_TYPE (decl))) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node4) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node2) = OMP_CLAUSE_MAP_TO_PSET; + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + OMP_CLAUSE_SIZE (node3) = size_int (0); + if (n->sym->attr.pointer) + { + stmtblock_t cond_block; + tree size + = gfc_create_var (gfc_array_index_type, NULL); + tree tem, then_b, else_b, zero, cond; + + gfc_init_block (&cond_block); + tem + = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + gfc_add_modify (&cond_block, size, tem); + then_b = gfc_finish_block (&cond_block); + gfc_init_block (&cond_block); + zero = build_int_cst (gfc_array_index_type, 0); + gfc_add_modify (&cond_block, size, zero); + else_b = gfc_finish_block (&cond_block); + tem = gfc_conv_descriptor_data_get (decl); + tem = fold_convert (pvoid_type_node, tem); + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, + tem, null_pointer_node); + gfc_add_expr_to_block (block, + build3_loc (input_location, + COND_EXPR, + void_type_node, + cond, then_b, + else_b)); + OMP_CLAUSE_SIZE (node) = size; + } + else + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, decl, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + else + OMP_CLAUSE_DECL (node) = decl; + } + else + { + tree ptr, ptr2; + gfc_init_se (&se, NULL); + if (n->expr->ref->u.ar.type == AR_ELEMENT) + { + gfc_conv_expr_reference (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + ptr = se.expr; + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gfc_add_block_to_block (block, &se.post); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + + if (POINTER_TYPE_P (TREE_TYPE (decl)) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) + { + node4 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node4) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node4) = decl; + OMP_CLAUSE_SIZE (node4) = size_int (0); + decl = build_fold_indirect_ref (decl); + } + ptr = fold_convert (sizetype, ptr); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + ptr2 = gfc_conv_descriptor_data_get (decl); + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node2) = OMP_CLAUSE_MAP_TO_PSET; + OMP_CLAUSE_DECL (node2) = decl; + OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type); + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); + } + else + { + if (TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) + ptr2 = build_fold_addr_expr (decl); + else + { + gcc_assert (POINTER_TYPE_P (TREE_TYPE (decl))); + ptr2 = decl; + } + node3 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + OMP_CLAUSE_MAP_KIND (node3) = OMP_CLAUSE_MAP_POINTER; + OMP_CLAUSE_DECL (node3) = decl; + } + ptr2 = fold_convert (sizetype, ptr2); + OMP_CLAUSE_SIZE (node3) + = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); + } + switch (n->u.map_op) + { + case OMP_MAP_ALLOC: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_ALLOC; + break; + case OMP_MAP_TO: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_TO; + break; + case OMP_MAP_FROM: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_FROM; + break; + case OMP_MAP_TOFROM: + OMP_CLAUSE_MAP_KIND (node) = OMP_CLAUSE_MAP_TOFROM; + break; + default: + gcc_unreachable (); + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + if (node2) + omp_clauses = gfc_trans_add_clause (node2, omp_clauses); + if (node3) + omp_clauses = gfc_trans_add_clause (node3, omp_clauses); + if (node4) + omp_clauses = gfc_trans_add_clause (node4, omp_clauses); + } + break; + case OMP_LIST_TO: + case OMP_LIST_FROM: + for (; n != NULL; n = n->next) + { + if (!n->sym->attr.referenced) + continue; + + tree node = build_omp_clause (input_location, + list == OMP_LIST_TO + ? OMP_CLAUSE_TO : OMP_CLAUSE_FROM); + if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + { + tree decl = gfc_get_symbol_decl (n->sym); + if (gfc_omp_privatize_by_reference (decl)) + decl = build_fold_indirect_ref (decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) + { + tree type = TREE_TYPE (decl); + tree ptr = gfc_conv_descriptor_data_get (decl); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node) = ptr; + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, decl, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + else + OMP_CLAUSE_DECL (node) = decl; + } + 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; + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + gfc_conv_expr_descriptor (&se, n->expr); + ptr = gfc_conv_array_data (se.expr); + tree type = TREE_TYPE (se.expr); + gfc_add_block_to_block (block, &se.pre); + OMP_CLAUSE_SIZE (node) + = gfc_full_array_size (block, se.expr, + GFC_TYPE_ARRAY_RANK (type)); + tree elemsz + = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + elemsz = fold_convert (gfc_array_index_type, elemsz); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, gfc_array_index_type, + OMP_CLAUSE_SIZE (node), elemsz); + } + gfc_add_block_to_block (block, &se.post); + ptr = fold_convert (build_pointer_type (char_type_node), + ptr); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + omp_clauses = gfc_trans_add_clause (node, omp_clauses); + } break; default: break; @@ -1000,7 +2273,146 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (c, omp_clauses); } - return 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); + } + + if (clauses->num_teams) + { + tree num_teams; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->num_teams); + gfc_add_block_to_block (block, &se.pre); + num_teams = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_NUM_TEAMS); + OMP_CLAUSE_NUM_TEAMS_EXPR (c) = num_teams; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->device) + { + tree device; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->device); + gfc_add_block_to_block (block, &se.pre); + device = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_DEVICE); + OMP_CLAUSE_DEVICE_ID (c) = device; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + if (clauses->thread_limit) + { + tree thread_limit; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->thread_limit); + gfc_add_block_to_block (block, &se.pre); + thread_limit = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + + c = build_omp_clause (where.lb->location, OMP_CLAUSE_THREAD_LIMIT); + OMP_CLAUSE_THREAD_LIMIT_EXPR (c) = thread_limit; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + chunk_size = NULL_TREE; + if (clauses->dist_chunk_size) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, clauses->dist_chunk_size); + gfc_add_block_to_block (block, &se.pre); + chunk_size = gfc_evaluate_now (se.expr, block); + gfc_add_block_to_block (block, &se.post); + } + + if (clauses->dist_sched_kind != OMP_SCHED_NONE) + { + c = build_omp_clause (where.lb->location, OMP_CLAUSE_DIST_SCHEDULE); + OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (c) = chunk_size; + omp_clauses = gfc_trans_add_clause (c, omp_clauses); + } + + return nreverse (omp_clauses); } /* Like gfc_trans_code, but force creation of a BIND_EXPR around it. */ @@ -1045,6 +2457,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 +2473,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 +2485,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 +2521,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 +2645,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 +2670,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 +2692,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 +2708,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 +2781,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 +2821,16 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, if (clauses) { - gfc_namelist *n; - for (n = clauses->lists[OMP_LIST_LASTPRIVATE]; n != NULL; - n = n->next) - if (code->ext.iterator->var->symtree->n.sym == n->sym) - break; + gfc_omp_namelist *n = NULL; + if (op != EXEC_OMP_DISTRIBUTE) + 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 +2872,8 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, } 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 +2927,24 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, 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 +2968,14 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, 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 +2995,17 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, } 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 +3047,13 @@ gfc_trans_omp_do (gfc_code *code, stmtblock_t *pblock, } /* End of loop body. */ - stmt = make_node (OMP_FOR); + switch (op) + { + case EXEC_OMP_SIMD: stmt = make_node (OMP_SIMD); break; + case EXEC_OMP_DO: stmt = make_node (OMP_FOR); break; + case EXEC_OMP_DISTRIBUTE: stmt = make_node (OMP_DISTRIBUTE); break; + default: gcc_unreachable (); + } TREE_TYPE (stmt) = void_type_node; OMP_FOR_BODY (stmt) = gfc_finish_block (&body); @@ -1589,41 +3104,352 @@ 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_DISTRIBUTE, + GFC_OMP_SPLIT_TEAMS, + GFC_OMP_SPLIT_TARGET, + 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), + GFC_OMP_MASK_DISTRIBUTE = (1 << GFC_OMP_SPLIT_DISTRIBUTE), + GFC_OMP_MASK_TEAMS = (1 << GFC_OMP_SPLIT_TEAMS), + GFC_OMP_MASK_TARGET = (1 << GFC_OMP_SPLIT_TARGET) +}; + +static void +gfc_split_omp_clauses (gfc_code *code, + gfc_omp_clauses clausesa[GFC_OMP_SPLIT_NUM]) +{ + int mask = 0, innermost = 0; + memset (clausesa, 0, GFC_OMP_SPLIT_NUM * sizeof (gfc_omp_clauses)); + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_PARALLEL + | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_DO: + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_DO_SIMD: + mask = GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_PARALLEL: + innermost = GFC_OMP_SPLIT_PARALLEL; + 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; + case EXEC_OMP_SIMD: + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET: + innermost = GFC_OMP_SPLIT_TARGET; + break; + case EXEC_OMP_TARGET_TEAMS: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS; + innermost = GFC_OMP_SPLIT_TEAMS; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS + | GFC_OMP_MASK_DISTRIBUTE; + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_TARGET | GFC_OMP_MASK_TEAMS + | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TEAMS: + innermost = GFC_OMP_SPLIT_TEAMS; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE; + innermost = GFC_OMP_SPLIT_DISTRIBUTE; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO; + innermost = GFC_OMP_SPLIT_DO; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE + | GFC_OMP_MASK_PARALLEL | GFC_OMP_MASK_DO | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + mask = GFC_OMP_MASK_TEAMS | GFC_OMP_MASK_DISTRIBUTE | GFC_OMP_MASK_SIMD; + innermost = GFC_OMP_SPLIT_SIMD; + break; + default: + gcc_unreachable (); + } + if (mask == 0) + { + clausesa[innermost] = *code->ext.omp_clauses; + return; + } + if (code->ext.omp_clauses != NULL) + { + if (mask & GFC_OMP_MASK_TARGET) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_MAP] + = code->ext.omp_clauses->lists[OMP_LIST_MAP]; + clausesa[GFC_OMP_SPLIT_TARGET].device + = code->ext.omp_clauses->device; + } + if (mask & GFC_OMP_MASK_TEAMS) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_TEAMS].num_teams + = code->ext.omp_clauses->num_teams; + clausesa[GFC_OMP_SPLIT_TEAMS].thread_limit + = code->ext.omp_clauses->thread_limit; + /* Shared and default clauses are allowed on parallel and teams. */ + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_SHARED] + = code->ext.omp_clauses->lists[OMP_LIST_SHARED]; + clausesa[GFC_OMP_SPLIT_TEAMS].default_sharing + = code->ext.omp_clauses->default_sharing; + } + if (mask & GFC_OMP_MASK_DISTRIBUTE) + { + /* First the clauses that are unique to some constructs. */ + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_sched_kind + = code->ext.omp_clauses->dist_sched_kind; + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].dist_chunk_size + = code->ext.omp_clauses->dist_chunk_size; + /* Duplicate collapse. */ + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].collapse + = code->ext.omp_clauses->collapse; + } + 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; + } + 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_TEAMS) + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + else if (mask & GFC_OMP_MASK_DISTRIBUTE) + clausesa[GFC_OMP_SPLIT_DISTRIBUTE].lists[OMP_LIST_FIRSTPRIVATE] + = code->ext.omp_clauses->lists[OMP_LIST_FIRSTPRIVATE]; + 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. */ + if (mask & GFC_OMP_MASK_TEAMS) + clausesa[GFC_OMP_SPLIT_TEAMS].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + if (mask & GFC_OMP_MASK_PARALLEL) + clausesa[GFC_OMP_SPLIT_PARALLEL].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + else if (mask & GFC_OMP_MASK_DO) + clausesa[GFC_OMP_SPLIT_DO].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + if (mask & GFC_OMP_MASK_SIMD) + clausesa[GFC_OMP_SPLIT_SIMD].lists[OMP_LIST_REDUCTION] + = code->ext.omp_clauses->lists[OMP_LIST_REDUCTION]; + /* FIXME: This is currently being discussed. */ + if (mask & GFC_OMP_MASK_PARALLEL) + clausesa[GFC_OMP_SPLIT_PARALLEL].if_expr + = code->ext.omp_clauses->if_expr; + else + clausesa[GFC_OMP_SPLIT_TARGET].if_expr + = code->ext.omp_clauses->if_expr; + } + 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, stmtblock_t *pblock, + 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; + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, body, omp_do_clauses = NULL_TREE; - gfc_start_block (&block); + if (pblock == NULL) + gfc_start_block (&block); + else + gfc_init_block (&block); - memset (&do_clauses, 0, sizeof (do_clauses)); - if (code->ext.omp_clauses != NULL) + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_do_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DO], code->loc); + body = gfc_trans_omp_do (code, EXEC_OMP_SIMD, pblock ? pblock : &block, + &clausesa[GFC_OMP_SPLIT_SIMD], omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (body) != BIND_EXPR) + body = build3_v (BIND_EXPR, NULL, body, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (body) != BIND_EXPR) + body = build3_v (BIND_EXPR, NULL, body, NULL_TREE); + if (gfc_option.gfc_flag_openmp) { - 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); - } - do_clauses.nowait = true; - if (!do_clauses.ordered && do_clauses.sched_kind != OMP_SCHED_STATIC) - pblock = █ + stmt = make_node (OMP_FOR); + TREE_TYPE (stmt) = void_type_node; + OMP_FOR_BODY (stmt) = body; + OMP_FOR_CLAUSES (stmt) = omp_do_clauses; + } else - pushlevel (); - stmt = gfc_trans_omp_do (code, pblock, &do_clauses, omp_clauses); - if (TREE_CODE (stmt) != BIND_EXPR) - stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + stmt = body; + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_parallel_do (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clausesa) +{ + stmtblock_t block, *new_pblock = pblock; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + if (pblock == NULL) + gfc_start_block (&block); else - poplevel (0, 0); + gfc_init_block (&block); + + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + if (pblock == NULL) + { + if (!clausesa[GFC_OMP_SPLIT_DO].ordered + && clausesa[GFC_OMP_SPLIT_DO].sched_kind != OMP_SCHED_STATIC) + new_pblock = █ + else + pushlevel (); + } + stmt = gfc_trans_omp_do (code, EXEC_OMP_DO, new_pblock, + &clausesa[GFC_OMP_SPLIT_DO], omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); stmt = build2_loc (input_location, OMP_PARALLEL, void_type_node, stmt, omp_clauses); OMP_PARALLEL_COMBINED (stmt) = 1; @@ -1632,6 +3458,50 @@ gfc_trans_omp_parallel_do (gfc_code *code) } static tree +gfc_trans_omp_parallel_do_simd (gfc_code *code, stmtblock_t *pblock, + gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + if (pblock == NULL) + gfc_start_block (&block); + else + gfc_init_block (&block); + + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_PARALLEL], + code->loc); + if (pblock == NULL) + pushlevel (); + stmt = gfc_trans_omp_do_simd (code, pblock, clausesa, omp_clauses); + if (pblock == NULL) + { + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + } + else if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); + if (gfc_option.gfc_flag_openmp) + { + 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_sections (gfc_code *code) { stmtblock_t block; @@ -1743,6 +3613,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); @@ -1757,6 +3634,170 @@ gfc_trans_omp_taskyield (void) } static tree +gfc_trans_omp_distribute (gfc_code *code, gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], + code->loc); + switch (code->op) + { + case EXEC_OMP_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE: + /* This is handled in gfc_trans_omp_do. */ + gcc_unreachable (); + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + stmt = gfc_trans_omp_parallel_do (code, &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + stmt = gfc_trans_omp_parallel_do_simd (code, &block, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + case EXEC_OMP_DISTRIBUTE_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + stmt = gfc_trans_omp_do (code, EXEC_OMP_SIMD, &block, + &clausesa[GFC_OMP_SPLIT_SIMD], NULL_TREE); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0)); + else + poplevel (0, 0); + break; + default: + gcc_unreachable (); + } + if (gfc_option.gfc_flag_openmp) + { + tree distribute = make_node (OMP_DISTRIBUTE); + TREE_TYPE (distribute) = void_type_node; + OMP_FOR_BODY (distribute) = stmt; + OMP_FOR_CLAUSES (distribute) = omp_clauses; + stmt = distribute; + } + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_teams (gfc_code *code, gfc_omp_clauses *clausesa) +{ + stmtblock_t block; + gfc_omp_clauses clausesa_buf[GFC_OMP_SPLIT_NUM]; + tree stmt, omp_clauses = NULL_TREE; + + gfc_start_block (&block); + if (clausesa == NULL) + { + clausesa = clausesa_buf; + gfc_split_omp_clauses (code, clausesa); + } + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TEAMS], + code->loc); + switch (code->op) + { + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TEAMS: + stmt = gfc_trans_omp_code (code->block->next, true); + break; + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE: + stmt = gfc_trans_omp_do (code, EXEC_OMP_DISTRIBUTE, NULL, + &clausesa[GFC_OMP_SPLIT_DISTRIBUTE], + NULL); + break; + default: + stmt = gfc_trans_omp_distribute (code, clausesa); + break; + } + stmt = build2_loc (input_location, OMP_TEAMS, void_type_node, stmt, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target (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); + if (gfc_option.gfc_flag_openmp) + omp_clauses + = gfc_trans_omp_clauses (&block, &clausesa[GFC_OMP_SPLIT_TARGET], + code->loc); + if (code->op == EXEC_OMP_TARGET) + stmt = gfc_trans_omp_code (code->block->next, true); + else + stmt = gfc_trans_omp_teams (code, clausesa); + if (TREE_CODE (stmt) != BIND_EXPR) + stmt = build3_v (BIND_EXPR, NULL, stmt, NULL_TREE); + if (gfc_option.gfc_flag_openmp) + stmt = build2_loc (input_location, OMP_TARGET, void_type_node, stmt, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_data (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + stmt = gfc_trans_omp_code (code->block->next, true); + stmt = build2_loc (input_location, OMP_TARGET_DATA, void_type_node, stmt, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree +gfc_trans_omp_target_update (gfc_code *code) +{ + stmtblock_t block; + tree stmt, omp_clauses; + + gfc_start_block (&block); + omp_clauses = gfc_trans_omp_clauses (&block, code->ext.omp_clauses, + code->loc); + stmt = build1_loc (input_location, OMP_TARGET_UPDATE, void_type_node, + omp_clauses); + gfc_add_expr_to_block (&block, stmt); + return gfc_finish_block (&block); +} + +static tree gfc_trans_omp_workshare (gfc_code *code, gfc_omp_clauses *clauses) { tree res, tmp, stmt; @@ -1923,10 +3964,23 @@ 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_DISTRIBUTE: 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_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_DISTRIBUTE_SIMD: + return gfc_trans_omp_distribute (code, NULL); + case EXEC_OMP_DO_SIMD: + return gfc_trans_omp_do_simd (code, NULL, NULL, NULL_TREE); case EXEC_OMP_FLUSH: return gfc_trans_omp_flush (); case EXEC_OMP_MASTER: @@ -1936,7 +3990,9 @@ gfc_trans_omp_directive (gfc_code *code) case EXEC_OMP_PARALLEL: return gfc_trans_omp_parallel (code); case EXEC_OMP_PARALLEL_DO: - return gfc_trans_omp_parallel_do (code); + return gfc_trans_omp_parallel_do (code, NULL, NULL); + case EXEC_OMP_PARALLEL_DO_SIMD: + return gfc_trans_omp_parallel_do_simd (code, NULL, NULL); case EXEC_OMP_PARALLEL_SECTIONS: return gfc_trans_omp_parallel_sections (code); case EXEC_OMP_PARALLEL_WORKSHARE: @@ -1945,15 +4001,53 @@ gfc_trans_omp_directive (gfc_code *code) return gfc_trans_omp_sections (code, code->ext.omp_clauses); case EXEC_OMP_SINGLE: return gfc_trans_omp_single (code, code->ext.omp_clauses); + case EXEC_OMP_TARGET: + case EXEC_OMP_TARGET_TEAMS: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: + return gfc_trans_omp_target (code); + case EXEC_OMP_TARGET_DATA: + return gfc_trans_omp_target_data (code); + case EXEC_OMP_TARGET_UPDATE: + return gfc_trans_omp_target_update (code); 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: return gfc_trans_omp_taskyield (); + case EXEC_OMP_TEAMS: + case EXEC_OMP_TEAMS_DISTRIBUTE: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: + case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: + case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: + return gfc_trans_omp_teams (code, NULL); case EXEC_OMP_WORKSHARE: return gfc_trans_omp_workshare (code, code->ext.omp_clauses); default: 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; + } +} |
