+2014-06-29 Richard Biener <rguenther@suse.de>
+
+ * gennews: Use gcc-3.0/index.html.
+
2014-04-22 Release Manager
* GCC 4.9.0 released.
gcc-3.3/index.html gcc-3.3/changes.html
gcc-3.2/index.html gcc-3.2/changes.html
gcc-3.1/index.html gcc-3.1/changes.html
- gcc-3.0/gcc-3.0.html gcc-3.0/features.html gcc-3.0/caveats.html
+ gcc-3.0/index.html gcc-3.0/features.html gcc-3.0/caveats.html
gcc-2.95/index.html gcc-2.95/features.html gcc-2.95/caveats.html
egcs-1.1/index.html egcs-1.1/features.html egcs-1.1/caveats.html
egcs-1.0/index.html egcs-1.0/features.html egcs-1.0/caveats.html"
+2014-07-09 Alan Lawrence <alan.lawrence@arm.com>
+
+ Backport r211369 from trunk.
+ 2014-06-09 Alan Lawrence <alan.lawrence@arm.com>
+
+ PR target/61062
+ * config/arm/arm_neon.h (vtrn_s8, vtrn_s16, vtrn_u8, vtrn_u16, vtrn_p8,
+ vtrn_p16, vtrn_s32, vtrn_f32, vtrn_u32, vtrnq_s8, vtrnq_s16, vtrnq_s32,
+ vtrnq_f32, vtrnq_u8, vtrnq_u16, vtrnq_u32, vtrnq_p8, vtrnq_p16, vzip_s8,
+ vzip_s16, vzip_u8, vzip_u16, vzip_p8, vzip_p16, vzip_s32, vzip_f32,
+ vzip_u32, vzipq_s8, vzipq_s16, vzipq_s32, vzipq_f32, vzipq_u8,
+ vzipq_u16, vzipq_u32, vzipq_p8, vzipq_p16, vuzp_s8, vuzp_s16, vuzp_s32,
+ vuzp_f32, vuzp_u8, vuzp_u16, vuzp_u32, vuzp_p8, vuzp_p16, vuzpq_s8,
+ vuzpq_s16, vuzpq_s32, vuzpq_f32, vuzpq_u8, vuzpq_u16, vuzpq_u32,
+ vuzpq_p8, vuzpq_p16): Correct mask for bigendian.
+
+
+2014-07-09 Alan Lawrence <alan.lawrence@arm.com>
+
+ Backport r210219 from trunk.
+ 2014-05-08 Ramana Radhakrishnan <ramana.radhakrishnan@arm.com>
+
+ * config/arm/arm_neon.h: Update comment.
+ * config/arm/neon-docgen.ml: Delete.
+ * config/arm/neon-gen.ml: Delete.
+ * doc/arm-neon-intrinsics.texi: Update comment.
+
+2014-07-09 Zhenqiang Chen <zhenqiang.chen@linaro.org>
+
+ Backport r211775 from trunk.
+ 2014-06-18 Terry Guo <terry.guo@arm.com>
+
+ PR target/61544
+ * config/arm/arm.c (thumb1_reorg): Move to next basic block if we
+ reach the head.
+
+2014-07-08 Jakub Jelinek <jakub@redhat.com>
+
+ PR rtl-optimization/61673
+ * combine.c (simplify_comparison): Test just mode's sign bit
+ in tmode rather than the sign bit and any bits above it.
+
+2014-07-08 James Greenhalgh <james.greenhalgh@arm.com>
+
+ Backport r212298 from trunk.
+ 2014-07-04 James Greenhalgh <james.greenhalgh@arm.com>
+
+ * config/aarch64/aarch64-simd.md (move_lo_quad_internal_<mode>): New.
+ (move_lo_quad_internal_be_<mode>): Likewise.
+ (move_lo_quad_<mode>): Convert to define_expand.
+ (aarch64_simd_move_hi_quad_<mode>): Gate on BYTES_BIG_ENDIAN.
+ (aarch64_simd_move_hi_quad_be_<mode>): New.
+ (move_hi_quad_<mode>): Use appropriate insn for BYTES_BIG_ENDIAN.
+ (aarch64_combinez<mode>): Gate on BYTES_BIG_ENDIAN.
+ (aarch64_combinez_be<mode>): New.
+ (aarch64_combine<mode>): Convert to define_expand.
+ (aarch64_combine_internal<mode>): New.
+ (aarch64_simd_combine<mode>): Remove bogus RTL description.
+
+2014-07-08 Richard Biener <rguenther@suse.de>
+
+ PR tree-optimization/61680
+ * tree-vect-data-refs.c (vect_analyze_data_ref_dependence):
+ Handle properly all read-write dependences with group accesses.
+
+ PR tree-optimization/61681
+ * tree-ssa-structalias.c (find_what_var_points_to): Expand
+ NONLOCAL inside ESCAPED.
+
+2014-07-08 Alan Lawrence <alan.lawrence@arm.com>
+
+ Backport r211502 from mainline.
+ 2014-06-10 Alan Lawrence <alan.lawrence@arm.com>
+
+ PR target/59843
+ * config/aarch64/aarch64-modes.def: Add V1DFmode.
+ * config/aarch64/aarch64.c (aarch64_vector_mode_supported_p):
+ Support V1DFmode.
+
+2014-07-08 Jakub Jelinek <jakub@redhat.com>
+
+ PR tree-optimization/61725
+ * tree-vrp.c (extract_range_basic): Don't assume vr0 is unsigned
+ range, use range_includes_zerop_p instead of integer_zerop on
+ vr0->min, only use log2 of max if min is not negative.
+
+2014-07-06 Gerald Pfeifer <gerald@pfeifer.com>
+
+ * doc/install.texi (Specific, aarch64*-*-*): Fix markup. Reword a bit.
+
+2014-07-04 Jakub Jelinek <jakub@redhat.com>
+
+ PR middle-end/61654
+ * cgraphunit.c (expand_thunk): Call free_dominance_info.
+
+ PR tree-optimization/61684
+ * tree-ssa-ifcombine.c (recognize_single_bit_test): Make sure
+ rhs1 of conversion is a SSA_NAME before using SSA_NAME_DEF_STMT on it.
+
+2014-06-30 Jakub Jelinek <jakub@redhat.com>
+
+ Backported from mainline
+ 2014-06-27 Jakub Jelinek <jakub@redhat.com>
+
+ PR tree-optimization/57233
+ PR tree-optimization/61299
+ * tree-vect-generic.c (get_compute_type, count_type_subparts): New
+ functions.
+ (expand_vector_operations_1): Use them. If {L,R}ROTATE_EXPR
+ would be lowered to scalar shifts, check if corresponding
+ shifts and vector BIT_IOR_EXPR are supported and don't lower
+ or lower just to narrower vector type in that case.
+ * expmed.c (expand_shift_1): Fix up handling of vector
+ shifts and rotates.
+
+ 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.
+
+2014-06-30 Jason Merrill <jason@redhat.com>
+
+ PR c++/51253
+ PR c++/61382
+ * gimplify.c (gimplify_arg): Non-static.
+ * gimplify.h: Declare it.
+
+2014-06-30 Marcus Shawcroft <marcus.shawcroft@arm.com>
+
+ Backport from Mainline
+ 2014-06-30 Marcus Shawcroft <marcus.shawcroft@arm.com>
+
+ PR target/61633
+ * config/aarch64/aarch64.md (*aarch64_ashr_sisd_or_int_<mode>3):
+ Add alternative; make early clobber. Adjust both split patterns
+ to use operand 0 as the working register.
+
+2014-06-30 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
+
+ * config/aarch64/iterators.md (VCOND): Handle SI and HI modes.
+ Update comments.
+ (VCONQ): Make comment more helpful.
+ (VCON): Delete.
+ * config/aarch64/aarch64-simd.md
+ (aarch64_sqdmulh_lane<mode>):
+ Use VCOND for operands 2. Update lane checking and flipping logic.
+ (aarch64_sqrdmulh_lane<mode>): Likewise.
+ (aarch64_sq<r>dmulh_lane<mode>_internal): Likewise.
+ (aarch64_sqdmull2<mode>): Remove VCON, use VQ_HSI mode iterator.
+ (aarch64_sqdml<SBINQOPS:as>l_lane<mode>_internal, VD_HSI): Change mode
+ attribute of operand 3 to VCOND.
+ (aarch64_sqdml<SBINQOPS:as>l_lane<mode>_internal, SD_HSI): Likewise.
+ (aarch64_sqdml<SBINQOPS:as>l2_lane<mode>_internal): Likewise.
+ (aarch64_sqdmull_lane<mode>_internal, VD_HSI): Likewise.
+ (aarch64_sqdmull_lane<mode>_internal, SD_HSI): Likewise.
+ (aarch64_sqdmull2_lane<mode>_internal): Likewise.
+ (aarch64_sqdml<SBINQOPS:as>l_laneq<mode>_internal, VD_HSI: New
+ define_insn.
+ (aarch64_sqdml<SBINQOPS:as>l_laneq<mode>_internal, SD_HSI): Likewise.
+ (aarch64_sqdml<SBINQOPS:as>l2_laneq<mode>_internal): Likewise.
+ (aarch64_sqdmull_laneq<mode>_internal, VD_HSI): Likewise.
+ (aarch64_sqdmull_laneq<mode>_internal, SD_HSI): Likewise.
+ (aarch64_sqdmull2_laneq<mode>_internal): Likewise.
+ (aarch64_sqdmlal_lane<mode>): Change mode attribute of penultimate
+ operand to VCOND. Update lane flipping and bounds checking logic.
+ (aarch64_sqdmlal2_lane<mode>): Likewise.
+ (aarch64_sqdmlsl_lane<mode>): Likewise.
+ (aarch64_sqdmull_lane<mode>): Likewise.
+ (aarch64_sqdmull2_lane<mode>): Likewise.
+ (aarch64_sqdmlal_laneq<mode>):
+ Replace VCON usage with VCONQ.
+ Emit aarch64_sqdmlal_laneq<mode>_internal insn.
+ (aarch64_sqdmlal2_laneq<mode>): Emit
+ aarch64_sqdmlal2_laneq<mode>_internal insn.
+ Replace VCON with VCONQ.
+ (aarch64_sqdmlsl2_lane<mode>): Replace VCON with VCONQ.
+ (aarch64_sqdmlsl2_laneq<mode>): Likewise.
+ (aarch64_sqdmull_laneq<mode>): Emit
+ aarch64_sqdmull_laneq<mode>_internal insn.
+ Replace VCON with VCONQ.
+ (aarch64_sqdmull2_laneq<mode>): Emit
+ aarch64_sqdmull2_laneq<mode>_internal insn.
+ (aarch64_sqdmlsl_laneq<mode>): Replace VCON usage with VCONQ.
+ * config/aarch64/arm_neon.h (vqdmlal_high_lane_s16): Change type
+ of 3rd argument to int16x4_t.
+ (vqdmlalh_lane_s16): Likewise.
+ (vqdmlslh_lane_s16): Likewise.
+ (vqdmull_high_lane_s16): Likewise.
+ (vqdmullh_lane_s16): Change type of 2nd argument to int16x4_t.
+ (vqdmlal_lane_s16): Don't create temporary int16x8_t value.
+ (vqdmlsl_lane_s16): Likewise.
+ (vqdmull_lane_s16): Don't create temporary int16x8_t value.
+ (vqdmlal_high_lane_s32): Change type 3rd argument to int32x2_t.
+ (vqdmlals_lane_s32): Likewise.
+ (vqdmlsls_lane_s32): Likewise.
+ (vqdmull_high_lane_s32): Change type 2nd argument to int32x2_t.
+ (vqdmulls_lane_s32): Likewise.
+ (vqdmlal_lane_s32): Don't create temporary int32x4_t value.
+ (vqdmlsl_lane_s32): Likewise.
+ (vqdmull_lane_s32): Don't create temporary int32x4_t value.
+ (vqdmulhh_lane_s16): Change type of second argument to int16x4_t.
+ (vqrdmulhh_lane_s16): Likewise.
+ (vqdmlsl_high_lane_s16): Likewise.
+ (vqdmulhs_lane_s32): Change type of second argument to int32x2_t.
+ (vqdmlsl_high_lane_s32): Likewise.
+ (vqrdmulhs_lane_s32): Likewise.
+
+2014-06-30 Thomas Preud'homme <thomas.preudhomme@arm.com>
+
+ Backport from Mainline
+ 2014-06-20 Jakub Jelinek <jakub@redhat.com>
+ 2014-06-11 Thomas Preud'homme <thomas.preudhomme@arm.com>
+
+ PR tree-optimization/61306
+ * tree-ssa-math-opts.c (struct symbolic_number): Store type of
+ expression instead of its size.
+ (do_shift_rotate): Adapt to change in struct symbolic_number. Return
+ false to prevent optimization when the result is unpredictable due to
+ arithmetic right shift of signed type with highest byte is set.
+ (verify_symbolic_number_p): Adapt to change in struct symbolic_number.
+ (find_bswap_1): Likewise. Return NULL to prevent optimization when the
+ result is unpredictable due to sign extension.
+ (find_bswap): Adapt to change in struct symbolic_number.
+
+2014-06-27 Martin Jambor <mjambor@suse.cz>
+
+ PR ipa/61160
+ * cgraphclones.c (duplicate_thunk_for_node): Removed parameter
+ args_to_skip, use those from node instead. Copy args_to_skip and
+ combined_args_to_skip from node to the new thunk.
+ (redirect_edge_duplicating_thunks): Removed parameter args_to_skip.
+ (cgraph_create_virtual_clone): Moved computation of
+ combined_args_to_skip...
+ (cgraph_clone_node): ...here, simplify it to bitmap_ior..
+
+2014-06-27 Uros Bizjak <ubizjak@gmail.com>
+
+ Backport from mainline
+ 2014-06-26 Uros Bizjak <ubizjak@gmail.com>
+
+ PR target/61586
+ * config/alpha/alpha.c (alpha_handle_trap_shadows): Handle BARRIER RTX.
+
+2014-06-26 Bill Schmidt <wschmidt@linux.vnet.ibm.com>
+
+ PR target/61542
+ * config/rs6000/vsx.md (vsx_extract_v4sf): Fix bug with element
+ extraction other than index 3.
+
+2014-06-26 Marc Glisse <marc.glisse@inria.fr>
+
+ PR target/61503
+ * config/i386/i386.md (x86_64_shrd, x86_shrd,
+ ix86_rotr<dwi>3_doubleword): Replace ashiftrt with lshiftrt.
+
+2014-06-26 Martin Jambor <mjambor@suse.cz>
+
+ Backport from mainline
+ * ipa-prop.c (ipa_impossible_devirt_target): No longer static,
+ renamed to ipa_impossible_devirt_target. Fix typo.
+ * ipa-prop.h (ipa_impossible_devirt_target): Declare.
+ * ipa-cp.c (ipa_get_indirect_edge_target_1): Use
+ ipa_impossible_devirt_target.
+
2014-06-24 Jakub Jelinek <jakub@redhat.com>
PR target/61570
2014-06-12 Jeff Law <law@redhat.com>
- PR tree-optimization/61009
+ PR tree-optimization/61009
* tree-ssa-threadedge.c (thread_through_normal_block): Correct return
value when we stop processing a block due to problematic PHIs.
+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.
+
2014-06-12 Jakub Jelinek <jakub@redhat.com>
PR middle-end/61486
{ "section", PRAGMA_OMP_SECTION },
{ "sections", PRAGMA_OMP_SECTIONS },
{ "single", PRAGMA_OMP_SINGLE },
+ { "task", PRAGMA_OMP_TASK },
{ "taskgroup", PRAGMA_OMP_TASKGROUP },
{ "taskwait", PRAGMA_OMP_TASKWAIT },
{ "taskyield", PRAGMA_OMP_TASKYIELD },
{ "parallel", PRAGMA_OMP_PARALLEL },
{ "simd", PRAGMA_OMP_SIMD },
{ "target", PRAGMA_OMP_TARGET },
- { "task", PRAGMA_OMP_TASK },
{ "teams", PRAGMA_OMP_TEAMS },
};
+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.
+
+2014-06-30 Sebastian Huber <sebastian.huber@embedded-brains.de>
+
+ * c-parser.c (c_parser_declaration_or_fndef): Discard all type
+ qualifiers in __auto_type for atomic types.
+ (c_parser_typeof_specifier): Discard all type qualifiers in
+ __typeof__ for atomic types.
+
+2014-06-30 Igor Zamyatin <igor.zamyatin@intel.com>
+
+ PR middle-end/57541
+ * c-array-notation.c (fix_builtin_array_notation_fn):
+ Check for 0 arguments in builtin call. Check that bultin argument is
+ correct.
+ * c-parser.c (c_parser_array_notation): Check for incorrect initial
+ index.
+
2014-06-24 Jakub Jelinek <jakub@redhat.com>
* c-parser.c (c_parser_omp_for_loop): For
if (an_type == BUILT_IN_NONE)
return NULL_TREE;
+ /* Builtin call should contain at least one argument. */
+ if (call_expr_nargs (an_builtin_fn) == 0)
+ {
+ error_at (EXPR_LOCATION (an_builtin_fn), "Invalid builtin arguments");
+ return error_mark_node;
+ }
+
if (an_type == BUILT_IN_CILKPLUS_SEC_REDUCE
|| an_type == BUILT_IN_CILKPLUS_SEC_REDUCE_MUTATING)
{
return error_mark_node;
if (rank == 0)
- return an_builtin_fn;
+ {
+ error_at (location, "Invalid builtin arguments");
+ return error_mark_node;
+ }
else if (rank > 1
&& (an_type == BUILT_IN_CILKPLUS_SEC_REDUCE_MAX_IND
|| an_type == BUILT_IN_CILKPLUS_SEC_REDUCE_MIN_IND))
" initializer");
init = convert_lvalue_to_rvalue (init_loc, init, true, true);
tree init_type = TREE_TYPE (init.value);
- /* As with typeof, remove _Atomic and const
- qualifiers from atomic types. */
+ /* As with typeof, remove all qualifiers from atomic types. */
if (init_type != error_mark_node && TYPE_ATOMIC (init_type))
init_type
- = c_build_qualified_type (init_type,
- (TYPE_QUALS (init_type)
- & ~(TYPE_QUAL_ATOMIC
- | TYPE_QUAL_CONST)));
+ = c_build_qualified_type (init_type, TYPE_UNQUALIFIED);
bool vm_type = variably_modified_type_p (init_type,
NULL_TREE);
if (vm_type)
if (was_vm)
ret.expr = c_fully_fold (expr.value, false, &ret.expr_const_operands);
pop_maybe_used (was_vm);
- /* For use in macros such as those in <stdatomic.h>, remove
- _Atomic and const qualifiers from atomic types. (Possibly
- all qualifiers should be removed; const can be an issue for
- more macros using typeof than just the <stdatomic.h>
- ones.) */
+ /* For use in macros such as those in <stdatomic.h>, remove all
+ qualifiers from atomic types. (const can be an issue for more macros
+ using typeof than just the <stdatomic.h> ones.) */
if (ret.spec != error_mark_node && TYPE_ATOMIC (ret.spec))
- ret.spec = c_build_qualified_type (ret.spec,
- (TYPE_QUALS (ret.spec)
- & ~(TYPE_QUAL_ATOMIC
- | TYPE_QUAL_CONST)));
+ ret.spec = c_build_qualified_type (ret.spec, TYPE_UNQUALIFIED);
}
c_parser_skip_until_found (parser, CPP_CLOSE_PAREN, "expected %<)%>");
return ret;
tree value_tree = NULL_TREE, type = NULL_TREE, array_type = NULL_TREE;
tree array_type_domain = NULL_TREE;
- if (array_value == error_mark_node)
+ if (array_value == error_mark_node || initial_index == error_mark_node)
{
/* No need to continue. If either of these 2 were true, then an error
must be emitted already. Thus, no need to emit them twice. */
s = size_one_node;
OMP_CLAUSE_LINEAR_STEP (c) = s;
}
+ else
+ OMP_CLAUSE_LINEAR_STEP (c)
+ = fold_convert (TREE_TYPE (t), OMP_CLAUSE_LINEAR_STEP (c));
goto check_dup_generic;
check_dup_generic:
thunk is this_adjusting but we are removing this parameter. */
static cgraph_node *
-duplicate_thunk_for_node (cgraph_node *thunk, cgraph_node *node,
- bitmap args_to_skip)
+duplicate_thunk_for_node (cgraph_node *thunk, cgraph_node *node)
{
cgraph_node *new_thunk, *thunk_of;
thunk_of = cgraph_function_or_thunk_node (thunk->callees->callee);
if (thunk_of->thunk.thunk_p)
- node = duplicate_thunk_for_node (thunk_of, node, args_to_skip);
+ node = duplicate_thunk_for_node (thunk_of, node);
struct cgraph_edge *cs;
for (cs = node->callers; cs; cs = cs->next_caller)
return cs->caller;
tree new_decl;
- if (!args_to_skip)
+ if (!node->clone.args_to_skip)
new_decl = copy_node (thunk->decl);
else
{
/* We do not need to duplicate this_adjusting thunks if we have removed
this. */
if (thunk->thunk.this_adjusting
- && bitmap_bit_p (args_to_skip, 0))
+ && bitmap_bit_p (node->clone.args_to_skip, 0))
return node;
- new_decl = build_function_decl_skip_args (thunk->decl, args_to_skip,
+ new_decl = build_function_decl_skip_args (thunk->decl,
+ node->clone.args_to_skip,
false);
}
gcc_checking_assert (!DECL_STRUCT_FUNCTION (new_decl));
new_thunk->thunk = thunk->thunk;
new_thunk->unique_name = in_lto_p;
new_thunk->former_clone_of = thunk->decl;
+ new_thunk->clone.args_to_skip = node->clone.args_to_skip;
+ new_thunk->clone.combined_args_to_skip = node->clone.combined_args_to_skip;
struct cgraph_edge *e = cgraph_create_edge (new_thunk, node, NULL, 0,
CGRAPH_FREQ_BASE);
chain. */
void
-redirect_edge_duplicating_thunks (struct cgraph_edge *e, struct cgraph_node *n,
- bitmap args_to_skip)
+redirect_edge_duplicating_thunks (struct cgraph_edge *e, struct cgraph_node *n)
{
cgraph_node *orig_to = cgraph_function_or_thunk_node (e->callee);
if (orig_to->thunk.thunk_p)
- n = duplicate_thunk_for_node (orig_to, n, args_to_skip);
+ n = duplicate_thunk_for_node (orig_to, n);
cgraph_redirect_edge_callee (e, n);
}
new_node->rtl = n->rtl;
new_node->count = count;
new_node->frequency = n->frequency;
- new_node->clone = n->clone;
- new_node->clone.tree_map = NULL;
new_node->tp_first_run = n->tp_first_run;
+
+ new_node->clone.tree_map = NULL;
+ new_node->clone.args_to_skip = args_to_skip;
+ if (!args_to_skip)
+ new_node->clone.combined_args_to_skip = n->clone.combined_args_to_skip;
+ else if (n->clone.combined_args_to_skip)
+ {
+ new_node->clone.combined_args_to_skip = BITMAP_GGC_ALLOC ();
+ bitmap_ior (new_node->clone.combined_args_to_skip,
+ n->clone.combined_args_to_skip, args_to_skip);
+ }
+ else
+ new_node->clone.combined_args_to_skip = args_to_skip;
+
if (n->count)
{
if (new_node->count > n->count)
if (!e->callee
|| DECL_BUILT_IN_CLASS (e->callee->decl) != BUILT_IN_NORMAL
|| DECL_FUNCTION_CODE (e->callee->decl) != BUILT_IN_UNREACHABLE)
- redirect_edge_duplicating_thunks (e, new_node, args_to_skip);
+ redirect_edge_duplicating_thunks (e, new_node);
}
-
for (e = n->callees;e; e=e->next_callee)
cgraph_clone_edge (e, new_node, e->call_stmt, e->lto_stmt_uid,
count_scale, freq, update_original);
DECL_SECTION_NAME (new_node->decl) = NULL;
set_new_clone_decl_and_node_flags (new_node);
new_node->clone.tree_map = tree_map;
- new_node->clone.args_to_skip = args_to_skip;
/* Clones of global symbols or symbols with unique names are unique. */
if ((TREE_PUBLIC (old_decl)
FOR_EACH_VEC_SAFE_ELT (tree_map, i, map)
ipa_maybe_record_reference (new_node, map->new_tree,
IPA_REF_ADDR, NULL);
- if (!args_to_skip)
- new_node->clone.combined_args_to_skip = old_node->clone.combined_args_to_skip;
- else if (old_node->clone.combined_args_to_skip)
- {
- int newi = 0, oldi = 0;
- tree arg;
- bitmap new_args_to_skip = BITMAP_GGC_ALLOC ();
- struct cgraph_node *orig_node;
- for (orig_node = old_node; orig_node->clone_of; orig_node = orig_node->clone_of)
- ;
- for (arg = DECL_ARGUMENTS (orig_node->decl);
- arg; arg = DECL_CHAIN (arg), oldi++)
- {
- if (bitmap_bit_p (old_node->clone.combined_args_to_skip, oldi))
- {
- bitmap_set_bit (new_args_to_skip, oldi);
- continue;
- }
- if (bitmap_bit_p (args_to_skip, newi))
- bitmap_set_bit (new_args_to_skip, oldi);
- newi++;
- }
- new_node->clone.combined_args_to_skip = new_args_to_skip;
- }
- else
- new_node->clone.combined_args_to_skip = args_to_skip;
cgraph_call_node_duplication_hooks (old_node, new_node);
#ifdef ENABLE_CHECKING
verify_flow_info ();
#endif
+ free_dominance_info (CDI_DOMINATORS);
/* Since we want to emit the thunk, we explicitly mark its name as
referenced. */
= (unsigned HOST_WIDE_INT) 1 << (GET_MODE_BITSIZE (mode) - 1);
op0 = simplify_gen_binary (AND, tmode,
gen_lowpart (tmode, op0),
- gen_int_mode (sign, mode));
+ gen_int_mode (sign, tmode));
code = (code == LT) ? NE : EQ;
break;
}
VECTOR_MODES (INT, 16); /* V16QI V8HI V4SI V2DI. */
VECTOR_MODES (FLOAT, 8); /* V2SF. */
VECTOR_MODES (FLOAT, 16); /* V4SF V2DF. */
+VECTOR_MODE (FLOAT, DF, 1); /* V1DF. */
/* Oct Int: 256-bit integer mode needed for 32-byte vector arguments. */
INT_MODE (OI, 32);
[(set_attr "type" "neon_minmax<q>")]
)
-;; Move into low-half clearing high half to 0.
+;; vec_concat gives a new vector with the low elements from operand 1, and
+;; the high elements from operand 2. That is to say, given op1 = { a, b }
+;; op2 = { c, d }, vec_concat (op1, op2) = { a, b, c, d }.
+;; What that means, is that the RTL descriptions of the below patterns
+;; need to change depending on endianness.
-(define_insn "move_lo_quad_<mode>"
+;; Move to the low architectural bits of the register.
+;; On little-endian this is { operand, zeroes }
+;; On big-endian this is { zeroes, operand }
+
+(define_insn "move_lo_quad_internal_<mode>"
[(set (match_operand:VQ 0 "register_operand" "=w,w,w")
(vec_concat:VQ
(match_operand:<VHALF> 1 "register_operand" "w,r,r")
(vec_duplicate:<VHALF> (const_int 0))))]
- "TARGET_SIMD"
+ "TARGET_SIMD && !BYTES_BIG_ENDIAN"
"@
dup\\t%d0, %1.d[0]
fmov\\t%d0, %1
(set_attr "length" "4")]
)
-;; Move into high-half.
+(define_insn "move_lo_quad_internal_be_<mode>"
+ [(set (match_operand:VQ 0 "register_operand" "=w,w,w")
+ (vec_concat:VQ
+ (vec_duplicate:<VHALF> (const_int 0))
+ (match_operand:<VHALF> 1 "register_operand" "w,r,r")))]
+ "TARGET_SIMD && BYTES_BIG_ENDIAN"
+ "@
+ dup\\t%d0, %1.d[0]
+ fmov\\t%d0, %1
+ dup\\t%d0, %1"
+ [(set_attr "type" "neon_dup<q>,f_mcr,neon_dup<q>")
+ (set_attr "simd" "yes,*,yes")
+ (set_attr "fp" "*,yes,*")
+ (set_attr "length" "4")]
+)
+
+(define_expand "move_lo_quad_<mode>"
+ [(match_operand:VQ 0 "register_operand")
+ (match_operand:VQ 1 "register_operand")]
+ "TARGET_SIMD"
+{
+ if (BYTES_BIG_ENDIAN)
+ emit_insn (gen_move_lo_quad_internal_be_<mode> (operands[0], operands[1]));
+ else
+ emit_insn (gen_move_lo_quad_internal_<mode> (operands[0], operands[1]));
+ DONE;
+}
+)
+
+;; Move operand1 to the high architectural bits of the register, keeping
+;; the low architectural bits of operand2.
+;; For little-endian this is { operand2, operand1 }
+;; For big-endian this is { operand1, operand2 }
(define_insn "aarch64_simd_move_hi_quad_<mode>"
[(set (match_operand:VQ 0 "register_operand" "+w,w")
(match_dup 0)
(match_operand:VQ 2 "vect_par_cnst_lo_half" ""))
(match_operand:<VHALF> 1 "register_operand" "w,r")))]
- "TARGET_SIMD"
+ "TARGET_SIMD && !BYTES_BIG_ENDIAN"
"@
ins\\t%0.d[1], %1.d[0]
ins\\t%0.d[1], %1"
- [(set_attr "type" "neon_ins")
- (set_attr "length" "4")]
+ [(set_attr "type" "neon_ins")]
+)
+
+(define_insn "aarch64_simd_move_hi_quad_be_<mode>"
+ [(set (match_operand:VQ 0 "register_operand" "+w,w")
+ (vec_concat:VQ
+ (match_operand:<VHALF> 1 "register_operand" "w,r")
+ (vec_select:<VHALF>
+ (match_dup 0)
+ (match_operand:VQ 2 "vect_par_cnst_hi_half" ""))))]
+ "TARGET_SIMD && BYTES_BIG_ENDIAN"
+ "@
+ ins\\t%0.d[1], %1.d[0]
+ ins\\t%0.d[1], %1"
+ [(set_attr "type" "neon_ins")]
)
(define_expand "move_hi_quad_<mode>"
(match_operand:<VHALF> 1 "register_operand" "")]
"TARGET_SIMD"
{
- rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, false);
- emit_insn (gen_aarch64_simd_move_hi_quad_<mode> (operands[0],
- operands[1], p));
+ rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, BYTES_BIG_ENDIAN);
+ if (BYTES_BIG_ENDIAN)
+ emit_insn (gen_aarch64_simd_move_hi_quad_be_<mode> (operands[0],
+ operands[1], p));
+ else
+ emit_insn (gen_aarch64_simd_move_hi_quad_<mode> (operands[0],
+ operands[1], p));
DONE;
})
(vec_concat:<VDBL>
(match_operand:VDIC 1 "register_operand" "w")
(match_operand:VDIC 2 "aarch64_simd_imm_zero" "Dz")))]
- "TARGET_SIMD"
+ "TARGET_SIMD && !BYTES_BIG_ENDIAN"
"mov\\t%0.8b, %1.8b"
[(set_attr "type" "neon_move<q>")]
)
-(define_insn_and_split "aarch64_combine<mode>"
+(define_insn "*aarch64_combinez_be<mode>"
+ [(set (match_operand:<VDBL> 0 "register_operand" "=&w")
+ (vec_concat:<VDBL>
+ (match_operand:VDIC 2 "aarch64_simd_imm_zero" "Dz")
+ (match_operand:VDIC 1 "register_operand" "w")))]
+ "TARGET_SIMD && BYTES_BIG_ENDIAN"
+ "mov\\t%0.8b, %1.8b"
+ [(set_attr "type" "neon_move<q>")]
+)
+
+(define_expand "aarch64_combine<mode>"
+ [(match_operand:<VDBL> 0 "register_operand")
+ (match_operand:VDC 1 "register_operand")
+ (match_operand:VDC 2 "register_operand")]
+ "TARGET_SIMD"
+{
+ rtx op1, op2;
+ if (BYTES_BIG_ENDIAN)
+ {
+ op1 = operands[2];
+ op2 = operands[1];
+ }
+ else
+ {
+ op1 = operands[1];
+ op2 = operands[2];
+ }
+ emit_insn (gen_aarch64_combine_internal<mode> (operands[0], op1, op2));
+ DONE;
+}
+)
+
+(define_insn_and_split "aarch64_combine_internal<mode>"
[(set (match_operand:<VDBL> 0 "register_operand" "=&w")
(vec_concat:<VDBL> (match_operand:VDC 1 "register_operand" "w")
(match_operand:VDC 2 "register_operand" "w")))]
"&& reload_completed"
[(const_int 0)]
{
- aarch64_split_simd_combine (operands[0], operands[1], operands[2]);
+ if (BYTES_BIG_ENDIAN)
+ aarch64_split_simd_combine (operands[0], operands[2], operands[1]);
+ else
+ aarch64_split_simd_combine (operands[0], operands[1], operands[2]);
DONE;
}
[(set_attr "type" "multiple")]
)
(define_expand "aarch64_simd_combine<mode>"
- [(set (match_operand:<VDBL> 0 "register_operand" "=&w")
- (vec_concat:<VDBL> (match_operand:VDC 1 "register_operand" "w")
- (match_operand:VDC 2 "register_operand" "w")))]
+ [(match_operand:<VDBL> 0 "register_operand")
+ (match_operand:VDC 1 "register_operand")
+ (match_operand:VDC 2 "register_operand")]
"TARGET_SIMD"
{
emit_insn (gen_move_lo_quad_<Vdbl> (operands[0], operands[1]));
(define_expand "aarch64_sqdmulh_lane<mode>"
[(match_operand:SD_HSI 0 "register_operand" "")
(match_operand:SD_HSI 1 "register_operand" "")
- (match_operand:<VCONQ> 2 "register_operand" "")
+ (match_operand:<VCOND> 2 "register_operand" "")
(match_operand:SI 3 "immediate_operand" "")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCONQ>mode));
- operands[3] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[3])));
+ aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
emit_insn (gen_aarch64_sqdmulh_lane<mode>_internal (operands[0],
operands[1],
operands[2],
(define_expand "aarch64_sqrdmulh_lane<mode>"
[(match_operand:SD_HSI 0 "register_operand" "")
(match_operand:SD_HSI 1 "register_operand" "")
- (match_operand:<VCONQ> 2 "register_operand" "")
+ (match_operand:<VCOND> 2 "register_operand" "")
(match_operand:SI 3 "immediate_operand" "")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCONQ>mode));
- operands[3] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[3])));
+ aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
emit_insn (gen_aarch64_sqrdmulh_lane<mode>_internal (operands[0],
operands[1],
operands[2],
(unspec:SD_HSI
[(match_operand:SD_HSI 1 "register_operand" "w")
(vec_select:<VEL>
- (match_operand:<VCONQ> 2 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 2 "register_operand" "<vwx>")
(parallel [(match_operand:SI 3 "immediate_operand" "i")]))]
VQDMULH))]
"TARGET_SIMD"
"*
- operands[3] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[3])));
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
return \"sq<r>dmulh\\t%<v>0, %<v>1, %2.<v>[%3]\";"
[(set_attr "type" "neon_sat_mul_<Vetype>_scalar<q>")]
)
(sign_extend:<VWIDE>
(vec_duplicate:VD_HSI
(vec_select:<VEL>
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 3 "register_operand" "<vwx>")
+ (parallel [(match_operand:SI 4 "immediate_operand" "i")])))
+ ))
+ (const_int 1))))]
+ "TARGET_SIMD"
+ {
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[4])));
+ return
+ "sqdml<SBINQOPS:as>l\\t%<vw2>0<Vmwtype>, %<v>2<Vmtype>, %3.<Vetype>[%4]";
+ }
+ [(set_attr "type" "neon_sat_mla_<Vetype>_scalar_long")]
+)
+
+(define_insn "aarch64_sqdml<SBINQOPS:as>l_laneq<mode>_internal"
+ [(set (match_operand:<VWIDE> 0 "register_operand" "=w")
+ (SBINQOPS:<VWIDE>
+ (match_operand:<VWIDE> 1 "register_operand" "0")
+ (ss_ashift:<VWIDE>
+ (mult:<VWIDE>
+ (sign_extend:<VWIDE>
+ (match_operand:VD_HSI 2 "register_operand" "w"))
+ (sign_extend:<VWIDE>
+ (vec_duplicate:VD_HSI
+ (vec_select:<VEL>
+ (match_operand:<VCONQ> 3 "register_operand" "<vwx>")
(parallel [(match_operand:SI 4 "immediate_operand" "i")])))
))
(const_int 1))))]
(match_operand:SD_HSI 2 "register_operand" "w"))
(sign_extend:<VWIDE>
(vec_select:<VEL>
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 3 "register_operand" "<vwx>")
+ (parallel [(match_operand:SI 4 "immediate_operand" "i")])))
+ )
+ (const_int 1))))]
+ "TARGET_SIMD"
+ {
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[4])));
+ return
+ "sqdml<SBINQOPS:as>l\\t%<vw2>0<Vmwtype>, %<v>2<Vmtype>, %3.<Vetype>[%4]";
+ }
+ [(set_attr "type" "neon_sat_mla_<Vetype>_scalar_long")]
+)
+
+(define_insn "aarch64_sqdml<SBINQOPS:as>l_laneq<mode>_internal"
+ [(set (match_operand:<VWIDE> 0 "register_operand" "=w")
+ (SBINQOPS:<VWIDE>
+ (match_operand:<VWIDE> 1 "register_operand" "0")
+ (ss_ashift:<VWIDE>
+ (mult:<VWIDE>
+ (sign_extend:<VWIDE>
+ (match_operand:SD_HSI 2 "register_operand" "w"))
+ (sign_extend:<VWIDE>
+ (vec_select:<VEL>
+ (match_operand:<VCONQ> 3 "register_operand" "<vwx>")
(parallel [(match_operand:SI 4 "immediate_operand" "i")])))
)
(const_int 1))))]
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "0")
(match_operand:VSD_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCON>mode) / 2);
- operands[4] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[4])));
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[4])));
emit_insn (gen_aarch64_sqdmlal_lane<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4]));
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "0")
(match_operand:VSD_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCONQ> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCON>mode));
- operands[4] = GEN_INT (ENDIAN_LANE_N (<VCON>mode, INTVAL (operands[4])));
- emit_insn (gen_aarch64_sqdmlal_lane<mode>_internal (operands[0], operands[1],
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCONQ>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[4])));
+ emit_insn (gen_aarch64_sqdmlal_laneq<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4]));
DONE;
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "0")
(match_operand:VSD_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCON>mode) / 2);
- operands[4] = GEN_INT (ENDIAN_LANE_N (<VCON>mode, INTVAL (operands[4])));
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[4])));
emit_insn (gen_aarch64_sqdmlsl_lane<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4]));
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "0")
(match_operand:VSD_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCONQ> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCON>mode));
- operands[4] = GEN_INT (ENDIAN_LANE_N (<VCON>mode, INTVAL (operands[4])));
- emit_insn (gen_aarch64_sqdmlsl_lane<mode>_internal (operands[0], operands[1],
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCONQ>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[4])));
+ emit_insn (gen_aarch64_sqdmlsl_laneq<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4]));
DONE;
(sign_extend:<VWIDE>
(vec_duplicate:<VHALF>
(vec_select:<VEL>
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 3 "register_operand" "<vwx>")
+ (parallel [(match_operand:SI 4 "immediate_operand" "i")])
+ ))))
+ (const_int 1))))]
+ "TARGET_SIMD"
+ {
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[4])));
+ return
+ "sqdml<SBINQOPS:as>l2\\t%<vw2>0<Vmwtype>, %<v>2<Vmtype>, %3.<Vetype>[%4]";
+ }
+ [(set_attr "type" "neon_sat_mla_<Vetype>_scalar_long")]
+)
+
+(define_insn "aarch64_sqdml<SBINQOPS:as>l2_laneq<mode>_internal"
+ [(set (match_operand:<VWIDE> 0 "register_operand" "=w")
+ (SBINQOPS:<VWIDE>
+ (match_operand:<VWIDE> 1 "register_operand" "0")
+ (ss_ashift:<VWIDE>
+ (mult:<VWIDE>
+ (sign_extend:<VWIDE>
+ (vec_select:<VHALF>
+ (match_operand:VQ_HSI 2 "register_operand" "w")
+ (match_operand:VQ_HSI 5 "vect_par_cnst_hi_half" "")))
+ (sign_extend:<VWIDE>
+ (vec_duplicate:<VHALF>
+ (vec_select:<VEL>
+ (match_operand:<VCONQ> 3 "register_operand" "<vwx>")
(parallel [(match_operand:SI 4 "immediate_operand" "i")])
))))
(const_int 1))))]
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "w")
(match_operand:VQ_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, true);
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<MODE>mode) / 2);
- operands[4] = GEN_INT (ENDIAN_LANE_N (<MODE>mode, INTVAL (operands[4])));
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[4])));
emit_insn (gen_aarch64_sqdmlal2_lane<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4], p));
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "w")
(match_operand:VQ_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCONQ> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, true);
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<MODE>mode));
- operands[4] = GEN_INT (ENDIAN_LANE_N (<MODE>mode, INTVAL (operands[4])));
- emit_insn (gen_aarch64_sqdmlal2_lane<mode>_internal (operands[0], operands[1],
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCONQ>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[4])));
+ emit_insn (gen_aarch64_sqdmlal2_laneq<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4], p));
DONE;
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "w")
(match_operand:VQ_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, true);
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<MODE>mode) / 2);
- operands[4] = GEN_INT (ENDIAN_LANE_N (<MODE>mode, INTVAL (operands[4])));
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[4])));
emit_insn (gen_aarch64_sqdmlsl2_lane<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4], p));
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:<VWIDE> 1 "register_operand" "w")
(match_operand:VQ_HSI 2 "register_operand" "w")
- (match_operand:<VCON> 3 "register_operand" "<vwx>")
+ (match_operand:<VCONQ> 3 "register_operand" "<vwx>")
(match_operand:SI 4 "immediate_operand" "i")]
"TARGET_SIMD"
{
rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, true);
- aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<MODE>mode));
- operands[4] = GEN_INT (ENDIAN_LANE_N (<MODE>mode, INTVAL (operands[4])));
- emit_insn (gen_aarch64_sqdmlsl2_lane<mode>_internal (operands[0], operands[1],
+ aarch64_simd_lane_bounds (operands[4], 0, GET_MODE_NUNITS (<VCONQ>mode));
+ operands[4] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[4])));
+ emit_insn (gen_aarch64_sqdmlsl2_laneq<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
operands[4], p));
DONE;
(sign_extend:<VWIDE>
(vec_duplicate:VD_HSI
(vec_select:<VEL>
- (match_operand:<VCON> 2 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 2 "register_operand" "<vwx>")
+ (parallel [(match_operand:SI 3 "immediate_operand" "i")])))
+ ))
+ (const_int 1)))]
+ "TARGET_SIMD"
+ {
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
+ return "sqdmull\\t%<vw2>0<Vmwtype>, %<v>1<Vmtype>, %2.<Vetype>[%3]";
+ }
+ [(set_attr "type" "neon_sat_mul_<Vetype>_scalar_long")]
+)
+
+(define_insn "aarch64_sqdmull_laneq<mode>_internal"
+ [(set (match_operand:<VWIDE> 0 "register_operand" "=w")
+ (ss_ashift:<VWIDE>
+ (mult:<VWIDE>
+ (sign_extend:<VWIDE>
+ (match_operand:VD_HSI 1 "register_operand" "w"))
+ (sign_extend:<VWIDE>
+ (vec_duplicate:VD_HSI
+ (vec_select:<VEL>
+ (match_operand:<VCONQ> 2 "register_operand" "<vwx>")
(parallel [(match_operand:SI 3 "immediate_operand" "i")])))
))
(const_int 1)))]
(match_operand:SD_HSI 1 "register_operand" "w"))
(sign_extend:<VWIDE>
(vec_select:<VEL>
- (match_operand:<VCON> 2 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 2 "register_operand" "<vwx>")
+ (parallel [(match_operand:SI 3 "immediate_operand" "i")]))
+ ))
+ (const_int 1)))]
+ "TARGET_SIMD"
+ {
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
+ return "sqdmull\\t%<vw2>0<Vmwtype>, %<v>1<Vmtype>, %2.<Vetype>[%3]";
+ }
+ [(set_attr "type" "neon_sat_mul_<Vetype>_scalar_long")]
+)
+
+(define_insn "aarch64_sqdmull_laneq<mode>_internal"
+ [(set (match_operand:<VWIDE> 0 "register_operand" "=w")
+ (ss_ashift:<VWIDE>
+ (mult:<VWIDE>
+ (sign_extend:<VWIDE>
+ (match_operand:SD_HSI 1 "register_operand" "w"))
+ (sign_extend:<VWIDE>
+ (vec_select:<VEL>
+ (match_operand:<VCONQ> 2 "register_operand" "<vwx>")
(parallel [(match_operand:SI 3 "immediate_operand" "i")]))
))
(const_int 1)))]
(define_expand "aarch64_sqdmull_lane<mode>"
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:VSD_HSI 1 "register_operand" "w")
- (match_operand:<VCON> 2 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 2 "register_operand" "<vwx>")
(match_operand:SI 3 "immediate_operand" "i")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCON>mode) / 2);
- operands[3] = GEN_INT (ENDIAN_LANE_N (<VCON>mode, INTVAL (operands[3])));
+ aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
emit_insn (gen_aarch64_sqdmull_lane<mode>_internal (operands[0], operands[1],
operands[2], operands[3]));
DONE;
(define_expand "aarch64_sqdmull_laneq<mode>"
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:VD_HSI 1 "register_operand" "w")
- (match_operand:<VCON> 2 "register_operand" "<vwx>")
+ (match_operand:<VCONQ> 2 "register_operand" "<vwx>")
(match_operand:SI 3 "immediate_operand" "i")]
"TARGET_SIMD"
{
- aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCON>mode));
+ aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCONQ>mode));
operands[3] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[3])));
- emit_insn (gen_aarch64_sqdmull_lane<mode>_internal
+ emit_insn (gen_aarch64_sqdmull_laneq<mode>_internal
(operands[0], operands[1], operands[2], operands[3]));
DONE;
})
(define_expand "aarch64_sqdmull2<mode>"
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:VQ_HSI 1 "register_operand" "w")
- (match_operand:<VCON> 2 "register_operand" "w")]
+ (match_operand:VQ_HSI 2 "register_operand" "w")]
"TARGET_SIMD"
{
rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, true);
(sign_extend:<VWIDE>
(vec_duplicate:<VHALF>
(vec_select:<VEL>
- (match_operand:<VCON> 2 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 2 "register_operand" "<vwx>")
+ (parallel [(match_operand:SI 3 "immediate_operand" "i")])))
+ ))
+ (const_int 1)))]
+ "TARGET_SIMD"
+ {
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
+ return "sqdmull2\\t%<vw2>0<Vmwtype>, %<v>1<Vmtype>, %2.<Vetype>[%3]";
+ }
+ [(set_attr "type" "neon_sat_mul_<Vetype>_scalar_long")]
+)
+
+(define_insn "aarch64_sqdmull2_laneq<mode>_internal"
+ [(set (match_operand:<VWIDE> 0 "register_operand" "=w")
+ (ss_ashift:<VWIDE>
+ (mult:<VWIDE>
+ (sign_extend:<VWIDE>
+ (vec_select:<VHALF>
+ (match_operand:VQ_HSI 1 "register_operand" "w")
+ (match_operand:VQ_HSI 4 "vect_par_cnst_hi_half" "")))
+ (sign_extend:<VWIDE>
+ (vec_duplicate:<VHALF>
+ (vec_select:<VEL>
+ (match_operand:<VCONQ> 2 "register_operand" "<vwx>")
(parallel [(match_operand:SI 3 "immediate_operand" "i")])))
))
(const_int 1)))]
(define_expand "aarch64_sqdmull2_lane<mode>"
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:VQ_HSI 1 "register_operand" "w")
- (match_operand:<VCON> 2 "register_operand" "<vwx>")
+ (match_operand:<VCOND> 2 "register_operand" "<vwx>")
(match_operand:SI 3 "immediate_operand" "i")]
"TARGET_SIMD"
{
rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, true);
- aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<MODE>mode) / 2);
- operands[3] = GEN_INT (ENDIAN_LANE_N (<MODE>mode, INTVAL (operands[3])));
+ aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCOND>mode));
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCOND>mode, INTVAL (operands[3])));
emit_insn (gen_aarch64_sqdmull2_lane<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
p));
(define_expand "aarch64_sqdmull2_laneq<mode>"
[(match_operand:<VWIDE> 0 "register_operand" "=w")
(match_operand:VQ_HSI 1 "register_operand" "w")
- (match_operand:<VCON> 2 "register_operand" "<vwx>")
+ (match_operand:<VCONQ> 2 "register_operand" "<vwx>")
(match_operand:SI 3 "immediate_operand" "i")]
"TARGET_SIMD"
{
rtx p = aarch64_simd_vect_par_cnst_half (<MODE>mode, true);
- aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<MODE>mode));
- operands[3] = GEN_INT (ENDIAN_LANE_N (<MODE>mode, INTVAL (operands[3])));
- emit_insn (gen_aarch64_sqdmull2_lane<mode>_internal (operands[0], operands[1],
+ aarch64_simd_lane_bounds (operands[3], 0, GET_MODE_NUNITS (<VCONQ>mode));
+ operands[3] = GEN_INT (ENDIAN_LANE_N (<VCONQ>mode, INTVAL (operands[3])));
+ emit_insn (gen_aarch64_sqdmull2_laneq<mode>_internal (operands[0], operands[1],
operands[2], operands[3],
p));
DONE;
|| mode == V16QImode || mode == V2DImode
|| mode == V2SImode || mode == V4HImode
|| mode == V8QImode || mode == V2SFmode
- || mode == V4SFmode || mode == V2DFmode))
+ || mode == V4SFmode || mode == V2DFmode
+ || mode == V1DFmode))
return true;
return false;
;; Arithmetic right shift using SISD or Integer instruction
(define_insn "*aarch64_ashr_sisd_or_int_<mode>3"
- [(set (match_operand:GPI 0 "register_operand" "=w,w,r")
+ [(set (match_operand:GPI 0 "register_operand" "=w,&w,&w,r")
(ashiftrt:GPI
- (match_operand:GPI 1 "register_operand" "w,w,r")
- (match_operand:QI 2 "aarch64_reg_or_shift_imm_di" "Us<cmode>,w,rUs<cmode>")))]
+ (match_operand:GPI 1 "register_operand" "w,w,w,r")
+ (match_operand:QI 2 "aarch64_reg_or_shift_imm_di" "Us<cmode>,w,0,rUs<cmode>")))]
""
"@
sshr\t%<rtn>0<vas>, %<rtn>1<vas>, %2
#
+ #
asr\t%<w>0, %<w>1, %<w>2"
- [(set_attr "simd" "yes,yes,no")
- (set_attr "type" "neon_shift_imm<q>,neon_shift_reg<q>,shift_reg")]
+ [(set_attr "simd" "yes,yes,yes,no")
+ (set_attr "type" "neon_shift_imm<q>,neon_shift_reg<q>,neon_shift_reg<q>,shift_reg")]
)
(define_split
(match_operand:DI 1 "aarch64_simd_register")
(match_operand:QI 2 "aarch64_simd_register")))]
"TARGET_SIMD && reload_completed"
- [(set (match_dup 2)
+ [(set (match_dup 3)
(unspec:QI [(match_dup 2)] UNSPEC_SISD_NEG))
(set (match_dup 0)
- (unspec:DI [(match_dup 1) (match_dup 2)] UNSPEC_SISD_SSHL))]
- ""
+ (unspec:DI [(match_dup 1) (match_dup 3)] UNSPEC_SISD_SSHL))]
+{
+ operands[3] = gen_lowpart (QImode, operands[0]);
+}
)
(define_split
(match_operand:SI 1 "aarch64_simd_register")
(match_operand:QI 2 "aarch64_simd_register")))]
"TARGET_SIMD && reload_completed"
- [(set (match_dup 2)
+ [(set (match_dup 3)
(unspec:QI [(match_dup 2)] UNSPEC_SISD_NEG))
(set (match_dup 0)
- (unspec:SI [(match_dup 1) (match_dup 2)] UNSPEC_SSHL_2S))]
- ""
+ (unspec:SI [(match_dup 1) (match_dup 3)] UNSPEC_SSHL_2S))]
+{
+ operands[3] = gen_lowpart (QImode, operands[0]);
+}
)
(define_insn "*aarch64_sisd_ushl"
}
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
-vqdmlal_high_lane_s16 (int32x4_t __a, int16x8_t __b, int16x8_t __c,
+vqdmlal_high_lane_s16 (int32x4_t __a, int16x8_t __b, int16x4_t __c,
int const __d)
{
return __builtin_aarch64_sqdmlal2_lanev8hi (__a, __b, __c, __d);
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
vqdmlal_lane_s16 (int32x4_t __a, int16x4_t __b, int16x4_t __c, int const __d)
{
- int16x8_t __tmp = vcombine_s16 (__c, vcreate_s16 (__AARCH64_INT64_C (0)));
- return __builtin_aarch64_sqdmlal_lanev4hi (__a, __b, __tmp, __d);
+ return __builtin_aarch64_sqdmlal_lanev4hi (__a, __b, __c, __d);
}
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
}
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
-vqdmlal_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x4_t __c,
+vqdmlal_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x2_t __c,
int const __d)
{
return __builtin_aarch64_sqdmlal2_lanev4si (__a, __b, __c, __d);
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
vqdmlal_lane_s32 (int64x2_t __a, int32x2_t __b, int32x2_t __c, int const __d)
{
- int32x4_t __tmp = vcombine_s32 (__c, vcreate_s32 (__AARCH64_INT64_C (0)));
- return __builtin_aarch64_sqdmlal_lanev2si (__a, __b, __tmp, __d);
+ return __builtin_aarch64_sqdmlal_lanev2si (__a, __b, __c, __d);
}
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
}
__extension__ static __inline int32x1_t __attribute__ ((__always_inline__))
-vqdmlalh_lane_s16 (int32x1_t __a, int16x1_t __b, int16x8_t __c, const int __d)
+vqdmlalh_lane_s16 (int32x1_t __a, int16x1_t __b, int16x4_t __c, const int __d)
{
return __builtin_aarch64_sqdmlal_lanehi (__a, __b, __c, __d);
}
}
__extension__ static __inline int64x1_t __attribute__ ((__always_inline__))
-vqdmlals_lane_s32 (int64x1_t __a, int32x1_t __b, int32x4_t __c, const int __d)
+vqdmlals_lane_s32 (int64x1_t __a, int32x1_t __b, int32x2_t __c, const int __d)
{
return __builtin_aarch64_sqdmlal_lanesi (__a, __b, __c, __d);
}
}
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
-vqdmlsl_high_lane_s16 (int32x4_t __a, int16x8_t __b, int16x8_t __c,
+vqdmlsl_high_lane_s16 (int32x4_t __a, int16x8_t __b, int16x4_t __c,
int const __d)
{
return __builtin_aarch64_sqdmlsl2_lanev8hi (__a, __b, __c, __d);
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
vqdmlsl_lane_s16 (int32x4_t __a, int16x4_t __b, int16x4_t __c, int const __d)
{
- int16x8_t __tmp = vcombine_s16 (__c, vcreate_s16 (__AARCH64_INT64_C (0)));
- return __builtin_aarch64_sqdmlsl_lanev4hi (__a, __b, __tmp, __d);
+ return __builtin_aarch64_sqdmlsl_lanev4hi (__a, __b, __c, __d);
}
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
}
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
-vqdmlsl_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x4_t __c,
+vqdmlsl_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x2_t __c,
int const __d)
{
return __builtin_aarch64_sqdmlsl2_lanev4si (__a, __b, __c, __d);
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
vqdmlsl_lane_s32 (int64x2_t __a, int32x2_t __b, int32x2_t __c, int const __d)
{
- int32x4_t __tmp = vcombine_s32 (__c, vcreate_s32 (__AARCH64_INT64_C (0)));
- return __builtin_aarch64_sqdmlsl_lanev2si (__a, __b, __tmp, __d);
+ return __builtin_aarch64_sqdmlsl_lanev2si (__a, __b, __c, __d);
}
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
}
__extension__ static __inline int32x1_t __attribute__ ((__always_inline__))
-vqdmlslh_lane_s16 (int32x1_t __a, int16x1_t __b, int16x8_t __c, const int __d)
+vqdmlslh_lane_s16 (int32x1_t __a, int16x1_t __b, int16x4_t __c, const int __d)
{
return __builtin_aarch64_sqdmlsl_lanehi (__a, __b, __c, __d);
}
}
__extension__ static __inline int64x1_t __attribute__ ((__always_inline__))
-vqdmlsls_lane_s32 (int64x1_t __a, int32x1_t __b, int32x4_t __c, const int __d)
+vqdmlsls_lane_s32 (int64x1_t __a, int32x1_t __b, int32x2_t __c, const int __d)
{
return __builtin_aarch64_sqdmlsl_lanesi (__a, __b, __c, __d);
}
}
__extension__ static __inline int16x1_t __attribute__ ((__always_inline__))
-vqdmulhh_lane_s16 (int16x1_t __a, int16x8_t __b, const int __c)
+vqdmulhh_lane_s16 (int16x1_t __a, int16x4_t __b, const int __c)
{
return __builtin_aarch64_sqdmulh_lanehi (__a, __b, __c);
}
}
__extension__ static __inline int32x1_t __attribute__ ((__always_inline__))
-vqdmulhs_lane_s32 (int32x1_t __a, int32x4_t __b, const int __c)
+vqdmulhs_lane_s32 (int32x1_t __a, int32x2_t __b, const int __c)
{
return __builtin_aarch64_sqdmulh_lanesi (__a, __b, __c);
}
}
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
-vqdmull_high_lane_s16 (int16x8_t __a, int16x8_t __b, int const __c)
+vqdmull_high_lane_s16 (int16x8_t __a, int16x4_t __b, int const __c)
{
return __builtin_aarch64_sqdmull2_lanev8hi (__a, __b,__c);
}
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
vqdmull_lane_s16 (int16x4_t __a, int16x4_t __b, int const __c)
{
- int16x8_t __tmp = vcombine_s16 (__b, vcreate_s16 (__AARCH64_INT64_C (0)));
- return __builtin_aarch64_sqdmull_lanev4hi (__a, __tmp, __c);
+ return __builtin_aarch64_sqdmull_lanev4hi (__a, __b, __c);
}
__extension__ static __inline int32x4_t __attribute__ ((__always_inline__))
}
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
-vqdmull_high_lane_s32 (int32x4_t __a, int32x4_t __b, int const __c)
+vqdmull_high_lane_s32 (int32x4_t __a, int32x2_t __b, int const __c)
{
return __builtin_aarch64_sqdmull2_lanev4si (__a, __b, __c);
}
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
vqdmull_lane_s32 (int32x2_t __a, int32x2_t __b, int const __c)
{
- int32x4_t __tmp = vcombine_s32 (__b, vcreate_s32 (__AARCH64_INT64_C (0)));
- return __builtin_aarch64_sqdmull_lanev2si (__a, __tmp, __c);
+ return __builtin_aarch64_sqdmull_lanev2si (__a, __b, __c);
}
__extension__ static __inline int64x2_t __attribute__ ((__always_inline__))
}
__extension__ static __inline int32x1_t __attribute__ ((__always_inline__))
-vqdmullh_lane_s16 (int16x1_t __a, int16x8_t __b, const int __c)
+vqdmullh_lane_s16 (int16x1_t __a, int16x4_t __b, const int __c)
{
return __builtin_aarch64_sqdmull_lanehi (__a, __b, __c);
}
}
__extension__ static __inline int64x1_t __attribute__ ((__always_inline__))
-vqdmulls_lane_s32 (int32x1_t __a, int32x4_t __b, const int __c)
+vqdmulls_lane_s32 (int32x1_t __a, int32x2_t __b, const int __c)
{
return __builtin_aarch64_sqdmull_lanesi (__a, __b, __c);
}
}
__extension__ static __inline int16x1_t __attribute__ ((__always_inline__))
-vqrdmulhh_lane_s16 (int16x1_t __a, int16x8_t __b, const int __c)
+vqrdmulhh_lane_s16 (int16x1_t __a, int16x4_t __b, const int __c)
{
return __builtin_aarch64_sqrdmulh_lanehi (__a, __b, __c);
}
}
__extension__ static __inline int32x1_t __attribute__ ((__always_inline__))
-vqrdmulhs_lane_s32 (int32x1_t __a, int32x4_t __b, const int __c)
+vqrdmulhs_lane_s32 (int32x1_t __a, int32x2_t __b, const int __c)
{
return __builtin_aarch64_sqrdmulh_lanesi (__a, __b, __c);
}
(SI "SI") (HI "HI")
(QI "QI")])
-;; Define container mode for lane selection.
-(define_mode_attr VCOND [(V4HI "V4HI") (V8HI "V4HI")
+;; 64-bit container modes the inner or scalar source mode.
+(define_mode_attr VCOND [(HI "V4HI") (SI "V2SI")
+ (V4HI "V4HI") (V8HI "V4HI")
(V2SI "V2SI") (V4SI "V2SI")
(DI "DI") (V2DI "DI")
(V2SF "V2SF") (V4SF "V2SF")
(V2DF "DF")])
-;; Define container mode for lane selection.
+;; 128-bit container modes the inner or scalar source mode.
(define_mode_attr VCONQ [(V8QI "V16QI") (V16QI "V16QI")
(V4HI "V8HI") (V8HI "V8HI")
(V2SI "V4SI") (V4SI "V4SI")
(V2DF "V2DF") (SI "V4SI")
(HI "V8HI") (QI "V16QI")])
-;; Define container mode for lane selection.
-(define_mode_attr VCON [(V8QI "V16QI") (V16QI "V16QI")
- (V4HI "V8HI") (V8HI "V8HI")
- (V2SI "V4SI") (V4SI "V4SI")
- (DI "V2DI") (V2DI "V2DI")
- (V2SF "V4SF") (V4SF "V4SF")
- (V2DF "V2DF") (SI "V4SI")
- (HI "V8HI") (QI "V16QI")])
-
;; Half modes of all vector modes.
(define_mode_attr VHALF [(V8QI "V4QI") (V16QI "V8QI")
(V4HI "V2HI") (V8HI "V4HI")
}
break;
+ case BARRIER:
+ /* __builtin_unreachable can expand to no code at all,
+ leaving (barrier) RTXes in the instruction stream. */
+ goto close_shadow_notrapb;
+
case JUMP_INSN:
case CALL_INSN:
case CODE_LABEL:
n = emit_insn_before (gen_trapb (), i);
PUT_MODE (n, TImode);
PUT_MODE (i, TImode);
+ close_shadow_notrapb:
trap_pending = 0;
shadow.used.i = 0;
shadow.used.fp = 0;
insn = PREV_INSN (insn);
/* Find the last cbranchsi4_insn in basic block BB. */
- if (INSN_CODE (insn) != CODE_FOR_cbranchsi4_insn)
+ if (insn == BB_HEAD (bb)
+ || INSN_CODE (insn) != CODE_FOR_cbranchsi4_insn)
continue;
/* Get the register with which we are comparing. */
-/* ARM NEON intrinsics include file. This file is generated automatically
- using neon-gen.ml. Please do not edit manually.
+/* ARM NEON intrinsics include file.
Copyright (C) 2006-2014 Free Software Foundation, Inc.
Contributed by CodeSourcery.
return (poly16x8_t)__builtin_neon_vbslv8hi ((int16x8_t) __a, (int16x8_t) __b, (int16x8_t) __c);
}
+/* For big-endian, the shuffle masks for ZIP, UZP and TRN must be changed as
+ follows. (nelt = the number of elements within a vector.)
+
+ Firstly, a value of N within a mask, becomes (N ^ (nelt - 1)), as gcc vector
+ extension's indexing scheme is reversed *within each vector* (relative to the
+ neon intrinsics view), but without changing which of the two vectors.
+
+ Secondly, the elements within each mask are reversed, as the mask is itself a
+ vector, and will itself be loaded in reverse order (again, relative to the
+ neon intrinsics view, i.e. that would result from a "vld1" instruction). */
+
__extension__ static __inline int8x8x2_t __attribute__ ((__always_inline__))
vtrn_s8 (int8x8_t __a, int8x8_t __b)
{
int8x8x2_t __rv;
- __rv.val[0] = (int8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 8, 2, 10, 4, 12, 6, 14 });
- __rv.val[1] = (int8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 1, 9, 3, 11, 5, 13, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 9, 1, 11, 3, 13, 5, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 0, 10, 2, 12, 4, 14, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 8, 2, 10, 4, 12, 6, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 1, 9, 3, 11, 5, 13, 7, 15 });
+#endif
return __rv;
}
vtrn_s16 (int16x4_t __a, int16x4_t __b)
{
int16x4x2_t __rv;
- __rv.val[0] = (int16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 2, 6 });
- __rv.val[1] = (int16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 5, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 5, 1, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 0, 6, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 2, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 5, 3, 7 });
+#endif
return __rv;
}
vtrn_u8 (uint8x8_t __a, uint8x8_t __b)
{
uint8x8x2_t __rv;
- __rv.val[0] = (uint8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 8, 2, 10, 4, 12, 6, 14 });
- __rv.val[1] = (uint8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 1, 9, 3, 11, 5, 13, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 9, 1, 11, 3, 13, 5, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 0, 10, 2, 12, 4, 14, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 8, 2, 10, 4, 12, 6, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 1, 9, 3, 11, 5, 13, 7, 15 });
+#endif
return __rv;
}
vtrn_u16 (uint16x4_t __a, uint16x4_t __b)
{
uint16x4x2_t __rv;
- __rv.val[0] = (uint16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 2, 6 });
- __rv.val[1] = (uint16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 5, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 5, 1, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 0, 6, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 2, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 5, 3, 7 });
+#endif
return __rv;
}
vtrn_p8 (poly8x8_t __a, poly8x8_t __b)
{
poly8x8x2_t __rv;
- __rv.val[0] = (poly8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 8, 2, 10, 4, 12, 6, 14 });
- __rv.val[1] = (poly8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 1, 9, 3, 11, 5, 13, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 9, 1, 11, 3, 13, 5, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 0, 10, 2, 12, 4, 14, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 8, 2, 10, 4, 12, 6, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 1, 9, 3, 11, 5, 13, 7, 15 });
+#endif
return __rv;
}
vtrn_p16 (poly16x4_t __a, poly16x4_t __b)
{
poly16x4x2_t __rv;
- __rv.val[0] = (poly16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 2, 6 });
- __rv.val[1] = (poly16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 5, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 5, 1, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 0, 6, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 2, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 5, 3, 7 });
+#endif
return __rv;
}
vtrn_s32 (int32x2_t __a, int32x2_t __b)
{
int32x2x2_t __rv;
- __rv.val[0] = (int32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (int32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vtrn_f32 (float32x2_t __a, float32x2_t __b)
{
float32x2x2_t __rv;
- __rv.val[0] = (float32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (float32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vtrn_u32 (uint32x2_t __a, uint32x2_t __b)
{
uint32x2x2_t __rv;
- __rv.val[0] = (uint32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (uint32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vtrnq_s8 (int8x16_t __a, int8x16_t __b)
{
int8x16x2_t __rv;
- __rv.val[0] = (int8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 16, 2, 18, 4, 20, 6, 22, 8, 24, 10, 26, 12, 28, 14, 30 });
- __rv.val[1] = (int8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 1, 17, 3, 19, 5, 21, 7, 23, 9, 25, 11, 27, 13, 29, 15, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 17, 1, 19, 3, 21, 5, 23, 7, 25, 9, 27, 11, 29, 13, 31, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 0, 18, 2, 20, 4, 22, 6, 24, 8, 26, 10, 28, 12, 30, 14 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 16, 2, 18, 4, 20, 6, 22, 8, 24, 10, 26, 12, 28, 14, 30 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 1, 17, 3, 19, 5, 21, 7, 23, 9, 25, 11, 27, 13, 29, 15, 31 });
+#endif
return __rv;
}
vtrnq_s16 (int16x8_t __a, int16x8_t __b)
{
int16x8x2_t __rv;
- __rv.val[0] = (int16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 8, 2, 10, 4, 12, 6, 14 });
- __rv.val[1] = (int16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 1, 9, 3, 11, 5, 13, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 9, 1, 11, 3, 13, 5, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 0, 10, 2, 12, 4, 14, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 8, 2, 10, 4, 12, 6, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 1, 9, 3, 11, 5, 13, 7, 15 });
+#endif
return __rv;
}
vtrnq_s32 (int32x4_t __a, int32x4_t __b)
{
int32x4x2_t __rv;
- __rv.val[0] = (int32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 2, 6 });
- __rv.val[1] = (int32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 5, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 5, 1, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 0, 6, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 2, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 5, 3, 7 });
+#endif
return __rv;
}
vtrnq_f32 (float32x4_t __a, float32x4_t __b)
{
float32x4x2_t __rv;
- __rv.val[0] = (float32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 2, 6 });
- __rv.val[1] = (float32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 5, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 5, 1, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 0, 6, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 2, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 5, 3, 7 });
+#endif
return __rv;
}
vtrnq_u8 (uint8x16_t __a, uint8x16_t __b)
{
uint8x16x2_t __rv;
- __rv.val[0] = (uint8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 16, 2, 18, 4, 20, 6, 22, 8, 24, 10, 26, 12, 28, 14, 30 });
- __rv.val[1] = (uint8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 1, 17, 3, 19, 5, 21, 7, 23, 9, 25, 11, 27, 13, 29, 15, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 17, 1, 19, 3, 21, 5, 23, 7, 25, 9, 27, 11, 29, 13, 31, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 0, 18, 2, 20, 4, 22, 6, 24, 8, 26, 10, 28, 12, 30, 14 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 16, 2, 18, 4, 20, 6, 22, 8, 24, 10, 26, 12, 28, 14, 30 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 1, 17, 3, 19, 5, 21, 7, 23, 9, 25, 11, 27, 13, 29, 15, 31 });
+#endif
return __rv;
}
vtrnq_u16 (uint16x8_t __a, uint16x8_t __b)
{
uint16x8x2_t __rv;
- __rv.val[0] = (uint16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 8, 2, 10, 4, 12, 6, 14 });
- __rv.val[1] = (uint16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 1, 9, 3, 11, 5, 13, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 9, 1, 11, 3, 13, 5, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 0, 10, 2, 12, 4, 14, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 8, 2, 10, 4, 12, 6, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 1, 9, 3, 11, 5, 13, 7, 15 });
+#endif
return __rv;
}
vtrnq_u32 (uint32x4_t __a, uint32x4_t __b)
{
uint32x4x2_t __rv;
- __rv.val[0] = (uint32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 2, 6 });
- __rv.val[1] = (uint32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 5, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 5, 1, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 0, 6, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 2, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 5, 3, 7 });
+#endif
return __rv;
}
vtrnq_p8 (poly8x16_t __a, poly8x16_t __b)
{
poly8x16x2_t __rv;
- __rv.val[0] = (poly8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 16, 2, 18, 4, 20, 6, 22, 8, 24, 10, 26, 12, 28, 14, 30 });
- __rv.val[1] = (poly8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 1, 17, 3, 19, 5, 21, 7, 23, 9, 25, 11, 27, 13, 29, 15, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 17, 1, 19, 3, 21, 5, 23, 7, 25, 9, 27, 11, 29, 13, 31, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 0, 18, 2, 20, 4, 22, 6, 24, 8, 26, 10, 28, 12, 30, 14 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 16, 2, 18, 4, 20, 6, 22, 8, 24, 10, 26, 12, 28, 14, 30 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 1, 17, 3, 19, 5, 21, 7, 23, 9, 25, 11, 27, 13, 29, 15, 31 });
+#endif
return __rv;
}
vtrnq_p16 (poly16x8_t __a, poly16x8_t __b)
{
poly16x8x2_t __rv;
- __rv.val[0] = (poly16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 8, 2, 10, 4, 12, 6, 14 });
- __rv.val[1] = (poly16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 1, 9, 3, 11, 5, 13, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 9, 1, 11, 3, 13, 5, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 0, 10, 2, 12, 4, 14, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 8, 2, 10, 4, 12, 6, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 1, 9, 3, 11, 5, 13, 7, 15 });
+#endif
return __rv;
}
vzip_s8 (int8x8_t __a, int8x8_t __b)
{
int8x8x2_t __rv;
- __rv.val[0] = (int8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 8, 1, 9, 2, 10, 3, 11 });
- __rv.val[1] = (int8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 4, 12, 5, 13, 6, 14, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 12, 4, 13, 5, 14, 6, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 0, 9, 1, 10, 2, 11, 3 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 8, 1, 9, 2, 10, 3, 11 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 4, 12, 5, 13, 6, 14, 7, 15 });
+#endif
return __rv;
}
vzip_s16 (int16x4_t __a, int16x4_t __b)
{
int16x4x2_t __rv;
- __rv.val[0] = (int16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 1, 5 });
- __rv.val[1] = (int16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 2, 6, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 6, 2, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 0, 5, 1 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 1, 5 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 2, 6, 3, 7 });
+#endif
return __rv;
}
vzip_u8 (uint8x8_t __a, uint8x8_t __b)
{
uint8x8x2_t __rv;
- __rv.val[0] = (uint8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 8, 1, 9, 2, 10, 3, 11 });
- __rv.val[1] = (uint8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 4, 12, 5, 13, 6, 14, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 12, 4, 13, 5, 14, 6, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 0, 9, 1, 10, 2, 11, 3 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 8, 1, 9, 2, 10, 3, 11 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 4, 12, 5, 13, 6, 14, 7, 15 });
+#endif
return __rv;
}
vzip_u16 (uint16x4_t __a, uint16x4_t __b)
{
uint16x4x2_t __rv;
- __rv.val[0] = (uint16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 1, 5 });
- __rv.val[1] = (uint16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 2, 6, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 6, 2, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 0, 5, 1 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 1, 5 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 2, 6, 3, 7 });
+#endif
return __rv;
}
vzip_p8 (poly8x8_t __a, poly8x8_t __b)
{
poly8x8x2_t __rv;
- __rv.val[0] = (poly8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 8, 1, 9, 2, 10, 3, 11 });
- __rv.val[1] = (poly8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 4, 12, 5, 13, 6, 14, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 12, 4, 13, 5, 14, 6, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 0, 9, 1, 10, 2, 11, 3 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 8, 1, 9, 2, 10, 3, 11 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 4, 12, 5, 13, 6, 14, 7, 15 });
+#endif
return __rv;
}
vzip_p16 (poly16x4_t __a, poly16x4_t __b)
{
poly16x4x2_t __rv;
- __rv.val[0] = (poly16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 1, 5 });
- __rv.val[1] = (poly16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 2, 6, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 6, 2, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 0, 5, 1 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 4, 1, 5 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 2, 6, 3, 7 });
+#endif
return __rv;
}
vzip_s32 (int32x2_t __a, int32x2_t __b)
{
int32x2x2_t __rv;
- __rv.val[0] = (int32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (int32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vzip_f32 (float32x2_t __a, float32x2_t __b)
{
float32x2x2_t __rv;
- __rv.val[0] = (float32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (float32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vzip_u32 (uint32x2_t __a, uint32x2_t __b)
{
uint32x2x2_t __rv;
- __rv.val[0] = (uint32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (uint32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vzipq_s8 (int8x16_t __a, int8x16_t __b)
{
int8x16x2_t __rv;
- __rv.val[0] = (int8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 16, 1, 17, 2, 18, 3, 19, 4, 20, 5, 21, 6, 22, 7, 23 });
- __rv.val[1] = (int8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 8, 24, 9, 25, 10, 26, 11, 27, 12, 28, 13, 29, 14, 30, 15, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 24, 8, 25, 9, 26, 10, 27, 11, 28, 12, 29, 13, 30, 14, 31, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 0, 17, 1, 18, 2, 19, 3, 20, 4, 21, 5, 22, 6, 23, 7 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 16, 1, 17, 2, 18, 3, 19, 4, 20, 5, 21, 6, 22, 7, 23 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 8, 24, 9, 25, 10, 26, 11, 27, 12, 28, 13, 29, 14, 30, 15, 31 });
+#endif
return __rv;
}
vzipq_s16 (int16x8_t __a, int16x8_t __b)
{
int16x8x2_t __rv;
- __rv.val[0] = (int16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 8, 1, 9, 2, 10, 3, 11 });
- __rv.val[1] = (int16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 4, 12, 5, 13, 6, 14, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 12, 4, 13, 5, 14, 6, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 0, 9, 1, 10, 2, 11, 3 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 8, 1, 9, 2, 10, 3, 11 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 4, 12, 5, 13, 6, 14, 7, 15 });
+#endif
return __rv;
}
vzipq_s32 (int32x4_t __a, int32x4_t __b)
{
int32x4x2_t __rv;
- __rv.val[0] = (int32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 1, 5 });
- __rv.val[1] = (int32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 2, 6, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 6, 2, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 0, 5, 1 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 1, 5 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 2, 6, 3, 7 });
+#endif
return __rv;
}
vzipq_f32 (float32x4_t __a, float32x4_t __b)
{
float32x4x2_t __rv;
- __rv.val[0] = (float32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 1, 5 });
- __rv.val[1] = (float32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 2, 6, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 6, 2, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 0, 5, 1 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 1, 5 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 2, 6, 3, 7 });
+#endif
return __rv;
}
vzipq_u8 (uint8x16_t __a, uint8x16_t __b)
{
uint8x16x2_t __rv;
- __rv.val[0] = (uint8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 16, 1, 17, 2, 18, 3, 19, 4, 20, 5, 21, 6, 22, 7, 23 });
- __rv.val[1] = (uint8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 8, 24, 9, 25, 10, 26, 11, 27, 12, 28, 13, 29, 14, 30, 15, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 24, 8, 25, 9, 26, 10, 27, 11, 28, 12, 29, 13, 30, 14, 31, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 0, 17, 1, 18, 2, 19, 3, 20, 4, 21, 5, 22, 6, 23, 7 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 16, 1, 17, 2, 18, 3, 19, 4, 20, 5, 21, 6, 22, 7, 23 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 8, 24, 9, 25, 10, 26, 11, 27, 12, 28, 13, 29, 14, 30, 15, 31 });
+#endif
return __rv;
}
vzipq_u16 (uint16x8_t __a, uint16x8_t __b)
{
uint16x8x2_t __rv;
- __rv.val[0] = (uint16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 8, 1, 9, 2, 10, 3, 11 });
- __rv.val[1] = (uint16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 4, 12, 5, 13, 6, 14, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 12, 4, 13, 5, 14, 6, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 0, 9, 1, 10, 2, 11, 3 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 8, 1, 9, 2, 10, 3, 11 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 4, 12, 5, 13, 6, 14, 7, 15 });
+#endif
return __rv;
}
vzipq_u32 (uint32x4_t __a, uint32x4_t __b)
{
uint32x4x2_t __rv;
- __rv.val[0] = (uint32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 1, 5 });
- __rv.val[1] = (uint32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 2, 6, 3, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 6, 2, 7, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 0, 5, 1 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 4, 1, 5 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 2, 6, 3, 7 });
+#endif
return __rv;
}
vzipq_p8 (poly8x16_t __a, poly8x16_t __b)
{
poly8x16x2_t __rv;
- __rv.val[0] = (poly8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 16, 1, 17, 2, 18, 3, 19, 4, 20, 5, 21, 6, 22, 7, 23 });
- __rv.val[1] = (poly8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 8, 24, 9, 25, 10, 26, 11, 27, 12, 28, 13, 29, 14, 30, 15, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 24, 8, 25, 9, 26, 10, 27, 11, 28, 12, 29, 13, 30, 14, 31, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 0, 17, 1, 18, 2, 19, 3, 20, 4, 21, 5, 22, 6, 23, 7 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 16, 1, 17, 2, 18, 3, 19, 4, 20, 5, 21, 6, 22, 7, 23 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 8, 24, 9, 25, 10, 26, 11, 27, 12, 28, 13, 29, 14, 30, 15, 31 });
+#endif
return __rv;
}
vzipq_p16 (poly16x8_t __a, poly16x8_t __b)
{
poly16x8x2_t __rv;
- __rv.val[0] = (poly16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 8, 1, 9, 2, 10, 3, 11 });
- __rv.val[1] = (poly16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 4, 12, 5, 13, 6, 14, 7, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 12, 4, 13, 5, 14, 6, 15, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 0, 9, 1, 10, 2, 11, 3 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 8, 1, 9, 2, 10, 3, 11 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 4, 12, 5, 13, 6, 14, 7, 15 });
+#endif
return __rv;
}
vuzp_s8 (int8x8_t __a, int8x8_t __b)
{
int8x8x2_t __rv;
- __rv.val[0] = (int8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 2, 4, 6, 8, 10, 12, 14 });
- __rv.val[1] = (int8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 1, 3, 5, 7, 9, 11, 13, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 9, 11, 13, 15, 1, 3, 5, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 10, 12, 14, 0, 2, 4, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15 });
+#endif
return __rv;
}
vuzp_s16 (int16x4_t __a, int16x4_t __b)
{
int16x4x2_t __rv;
- __rv.val[0] = (int16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 2, 4, 6 });
- __rv.val[1] = (int16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 3, 5, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 5, 7, 1, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 6, 0, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 2, 4, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 3, 5, 7 });
+#endif
return __rv;
}
vuzp_s32 (int32x2_t __a, int32x2_t __b)
{
int32x2x2_t __rv;
- __rv.val[0] = (int32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (int32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vuzp_f32 (float32x2_t __a, float32x2_t __b)
{
float32x2x2_t __rv;
- __rv.val[0] = (float32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (float32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vuzp_u8 (uint8x8_t __a, uint8x8_t __b)
{
uint8x8x2_t __rv;
- __rv.val[0] = (uint8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 2, 4, 6, 8, 10, 12, 14 });
- __rv.val[1] = (uint8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 1, 3, 5, 7, 9, 11, 13, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 9, 11, 13, 15, 1, 3, 5, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 10, 12, 14, 0, 2, 4, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15 });
+#endif
return __rv;
}
vuzp_u16 (uint16x4_t __a, uint16x4_t __b)
{
uint16x4x2_t __rv;
- __rv.val[0] = (uint16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 2, 4, 6 });
- __rv.val[1] = (uint16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 3, 5, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 5, 7, 1, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 6, 0, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 2, 4, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 3, 5, 7 });
+#endif
return __rv;
}
vuzp_u32 (uint32x2_t __a, uint32x2_t __b)
{
uint32x2x2_t __rv;
- __rv.val[0] = (uint32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
- __rv.val[1] = (uint32x2_t) __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 3, 1 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 2, 0 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x2_t) { 0, 2 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x2_t) { 1, 3 });
+#endif
return __rv;
}
vuzp_p8 (poly8x8_t __a, poly8x8_t __b)
{
poly8x8x2_t __rv;
- __rv.val[0] = (poly8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 0, 2, 4, 6, 8, 10, 12, 14 });
- __rv.val[1] = (poly8x8_t) __builtin_shuffle (__a, __b, (uint8x8_t) { 1, 3, 5, 7, 9, 11, 13, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 9, 11, 13, 15, 1, 3, 5, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 8, 10, 12, 14, 0, 2, 4, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x8_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15 });
+#endif
return __rv;
}
vuzp_p16 (poly16x4_t __a, poly16x4_t __b)
{
poly16x4x2_t __rv;
- __rv.val[0] = (poly16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 2, 4, 6 });
- __rv.val[1] = (poly16x4_t) __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 3, 5, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 5, 7, 1, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 4, 6, 0, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x4_t) { 0, 2, 4, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x4_t) { 1, 3, 5, 7 });
+#endif
return __rv;
}
vuzpq_s8 (int8x16_t __a, int8x16_t __b)
{
int8x16x2_t __rv;
- __rv.val[0] = (int8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30 });
- __rv.val[1] = (int8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 17, 19, 21, 23, 25, 27, 29, 31, 1, 3, 5, 7, 9, 11, 13, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 18, 20, 22, 24, 26, 28, 30, 0, 2, 4, 6, 8, 10, 12, 14 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31 });
+#endif
return __rv;
}
vuzpq_s16 (int16x8_t __a, int16x8_t __b)
{
int16x8x2_t __rv;
- __rv.val[0] = (int16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 2, 4, 6, 8, 10, 12, 14 });
- __rv.val[1] = (int16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 1, 3, 5, 7, 9, 11, 13, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 9, 11, 13, 15, 1, 3, 5, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 10, 12, 14, 0, 2, 4, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15 });
+#endif
return __rv;
}
vuzpq_s32 (int32x4_t __a, int32x4_t __b)
{
int32x4x2_t __rv;
- __rv.val[0] = (int32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 2, 4, 6 });
- __rv.val[1] = (int32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 3, 5, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 5, 7, 1, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 6, 0, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 2, 4, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 3, 5, 7 });
+#endif
return __rv;
}
vuzpq_f32 (float32x4_t __a, float32x4_t __b)
{
float32x4x2_t __rv;
- __rv.val[0] = (float32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 2, 4, 6 });
- __rv.val[1] = (float32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 3, 5, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 5, 7, 1, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 6, 0, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 2, 4, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 3, 5, 7 });
+#endif
return __rv;
}
vuzpq_u8 (uint8x16_t __a, uint8x16_t __b)
{
uint8x16x2_t __rv;
- __rv.val[0] = (uint8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30 });
- __rv.val[1] = (uint8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 17, 19, 21, 23, 25, 27, 29, 31, 1, 3, 5, 7, 9, 11, 13, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 18, 20, 22, 24, 26, 28, 30, 0, 2, 4, 6, 8, 10, 12, 14 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31 });
+#endif
return __rv;
}
vuzpq_u16 (uint16x8_t __a, uint16x8_t __b)
{
uint16x8x2_t __rv;
- __rv.val[0] = (uint16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 2, 4, 6, 8, 10, 12, 14 });
- __rv.val[1] = (uint16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 1, 3, 5, 7, 9, 11, 13, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 9, 11, 13, 15, 1, 3, 5, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 10, 12, 14, 0, 2, 4, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15 });
+#endif
return __rv;
}
vuzpq_u32 (uint32x4_t __a, uint32x4_t __b)
{
uint32x4x2_t __rv;
- __rv.val[0] = (uint32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 2, 4, 6 });
- __rv.val[1] = (uint32x4_t) __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 3, 5, 7 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 5, 7, 1, 3 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 4, 6, 0, 2 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint32x4_t) { 0, 2, 4, 6 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint32x4_t) { 1, 3, 5, 7 });
+#endif
return __rv;
}
vuzpq_p8 (poly8x16_t __a, poly8x16_t __b)
{
poly8x16x2_t __rv;
- __rv.val[0] = (poly8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30 });
- __rv.val[1] = (poly8x16_t) __builtin_shuffle (__a, __b, (uint8x16_t) { 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 17, 19, 21, 23, 25, 27, 29, 31, 1, 3, 5, 7, 9, 11, 13, 15 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 16, 18, 20, 22, 24, 26, 28, 30, 0, 2, 4, 6, 8, 10, 12, 14 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint8x16_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31 });
+#endif
return __rv;
}
vuzpq_p16 (poly16x8_t __a, poly16x8_t __b)
{
poly16x8x2_t __rv;
- __rv.val[0] = (poly16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 0, 2, 4, 6, 8, 10, 12, 14 });
- __rv.val[1] = (poly16x8_t) __builtin_shuffle (__a, __b, (uint16x8_t) { 1, 3, 5, 7, 9, 11, 13, 15 });
+#ifdef __ARM_BIG_ENDIAN
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 9, 11, 13, 15, 1, 3, 5, 7 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 8, 10, 12, 14, 0, 2, 4, 6 });
+#else
+ __rv.val[0] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 0, 2, 4, 6, 8, 10, 12, 14 });
+ __rv.val[1] = __builtin_shuffle (__a, __b, (uint16x8_t)
+ { 1, 3, 5, 7, 9, 11, 13, 15 });
+#endif
return __rv;
}
+++ /dev/null
-(* ARM NEON documentation generator.
-
- Copyright (C) 2006-2014 Free Software Foundation, Inc.
- Contributed by CodeSourcery.
-
- This file is part of GCC.
-
- GCC is free software; you can redistribute it and/or modify it under
- the terms of the GNU General Public License as published by the Free
- Software Foundation; either version 3, or (at your option) any later
- version.
-
- GCC is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or
- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- for more details.
-
- You should have received a copy of the GNU General Public License
- along with GCC; see the file COPYING3. If not see
- <http://www.gnu.org/licenses/>.
-
- This is an O'Caml program. The O'Caml compiler is available from:
-
- http://caml.inria.fr/
-
- Or from your favourite OS's friendly packaging system. Tested with version
- 3.09.2, though other versions will probably work too.
-
- Compile with:
- ocamlc -c neon.ml
- ocamlc -o neon-docgen neon.cmo neon-docgen.ml
-
- Run with:
- /path/to/neon-docgen /path/to/gcc/doc/arm-neon-intrinsics.texi
-*)
-
-open Neon
-
-(* The combined "ops" and "reinterp" table. *)
-let ops_reinterp = reinterp @ ops
-
-(* Helper functions for extracting things from the "ops" table. *)
-let single_opcode desired_opcode () =
- List.fold_left (fun got_so_far ->
- fun row ->
- match row with
- (opcode, _, _, _, _, _) ->
- if opcode = desired_opcode then row :: got_so_far
- else got_so_far
- ) [] ops_reinterp
-
-let multiple_opcodes desired_opcodes () =
- List.fold_left (fun got_so_far ->
- fun desired_opcode ->
- (single_opcode desired_opcode ()) @ got_so_far)
- [] desired_opcodes
-
-let ldx_opcode number () =
- List.fold_left (fun got_so_far ->
- fun row ->
- match row with
- (opcode, _, _, _, _, _) ->
- match opcode with
- Vldx n | Vldx_lane n | Vldx_dup n when n = number ->
- row :: got_so_far
- | _ -> got_so_far
- ) [] ops_reinterp
-
-let stx_opcode number () =
- List.fold_left (fun got_so_far ->
- fun row ->
- match row with
- (opcode, _, _, _, _, _) ->
- match opcode with
- Vstx n | Vstx_lane n when n = number ->
- row :: got_so_far
- | _ -> got_so_far
- ) [] ops_reinterp
-
-let tbl_opcode () =
- List.fold_left (fun got_so_far ->
- fun row ->
- match row with
- (opcode, _, _, _, _, _) ->
- match opcode with
- Vtbl _ -> row :: got_so_far
- | _ -> got_so_far
- ) [] ops_reinterp
-
-let tbx_opcode () =
- List.fold_left (fun got_so_far ->
- fun row ->
- match row with
- (opcode, _, _, _, _, _) ->
- match opcode with
- Vtbx _ -> row :: got_so_far
- | _ -> got_so_far
- ) [] ops_reinterp
-
-(* The groups of intrinsics. *)
-let intrinsic_groups =
- [ "Addition", single_opcode Vadd;
- "Multiplication", single_opcode Vmul;
- "Multiply-accumulate", single_opcode Vmla;
- "Multiply-subtract", single_opcode Vmls;
- "Fused-multiply-accumulate", single_opcode Vfma;
- "Fused-multiply-subtract", single_opcode Vfms;
- "Round to integral (to nearest, ties to even)", single_opcode Vrintn;
- "Round to integral (to nearest, ties away from zero)", single_opcode Vrinta;
- "Round to integral (towards +Inf)", single_opcode Vrintp;
- "Round to integral (towards -Inf)", single_opcode Vrintm;
- "Round to integral (towards 0)", single_opcode Vrintz;
- "Subtraction", single_opcode Vsub;
- "Comparison (equal-to)", single_opcode Vceq;
- "Comparison (greater-than-or-equal-to)", single_opcode Vcge;
- "Comparison (less-than-or-equal-to)", single_opcode Vcle;
- "Comparison (greater-than)", single_opcode Vcgt;
- "Comparison (less-than)", single_opcode Vclt;
- "Comparison (absolute greater-than-or-equal-to)", single_opcode Vcage;
- "Comparison (absolute less-than-or-equal-to)", single_opcode Vcale;
- "Comparison (absolute greater-than)", single_opcode Vcagt;
- "Comparison (absolute less-than)", single_opcode Vcalt;
- "Test bits", single_opcode Vtst;
- "Absolute difference", single_opcode Vabd;
- "Absolute difference and accumulate", single_opcode Vaba;
- "Maximum", single_opcode Vmax;
- "Minimum", single_opcode Vmin;
- "Pairwise add", single_opcode Vpadd;
- "Pairwise add, single_opcode widen and accumulate", single_opcode Vpada;
- "Folding maximum", single_opcode Vpmax;
- "Folding minimum", single_opcode Vpmin;
- "Reciprocal step", multiple_opcodes [Vrecps; Vrsqrts];
- "Vector shift left", single_opcode Vshl;
- "Vector shift left by constant", single_opcode Vshl_n;
- "Vector shift right by constant", single_opcode Vshr_n;
- "Vector shift right by constant and accumulate", single_opcode Vsra_n;
- "Vector shift right and insert", single_opcode Vsri;
- "Vector shift left and insert", single_opcode Vsli;
- "Absolute value", single_opcode Vabs;
- "Negation", single_opcode Vneg;
- "Bitwise not", single_opcode Vmvn;
- "Count leading sign bits", single_opcode Vcls;
- "Count leading zeros", single_opcode Vclz;
- "Count number of set bits", single_opcode Vcnt;
- "Reciprocal estimate", single_opcode Vrecpe;
- "Reciprocal square-root estimate", single_opcode Vrsqrte;
- "Get lanes from a vector", single_opcode Vget_lane;
- "Set lanes in a vector", single_opcode Vset_lane;
- "Create vector from literal bit pattern", single_opcode Vcreate;
- "Set all lanes to the same value",
- multiple_opcodes [Vdup_n; Vmov_n; Vdup_lane];
- "Combining vectors", single_opcode Vcombine;
- "Splitting vectors", multiple_opcodes [Vget_high; Vget_low];
- "Conversions", multiple_opcodes [Vcvt; Vcvt_n];
- "Move, single_opcode narrowing", single_opcode Vmovn;
- "Move, single_opcode long", single_opcode Vmovl;
- "Table lookup", tbl_opcode;
- "Extended table lookup", tbx_opcode;
- "Multiply, lane", single_opcode Vmul_lane;
- "Long multiply, lane", single_opcode Vmull_lane;
- "Saturating doubling long multiply, lane", single_opcode Vqdmull_lane;
- "Saturating doubling multiply high, lane", single_opcode Vqdmulh_lane;
- "Multiply-accumulate, lane", single_opcode Vmla_lane;
- "Multiply-subtract, lane", single_opcode Vmls_lane;
- "Vector multiply by scalar", single_opcode Vmul_n;
- "Vector long multiply by scalar", single_opcode Vmull_n;
- "Vector saturating doubling long multiply by scalar",
- single_opcode Vqdmull_n;
- "Vector saturating doubling multiply high by scalar",
- single_opcode Vqdmulh_n;
- "Vector multiply-accumulate by scalar", single_opcode Vmla_n;
- "Vector multiply-subtract by scalar", single_opcode Vmls_n;
- "Vector extract", single_opcode Vext;
- "Reverse elements", multiple_opcodes [Vrev64; Vrev32; Vrev16];
- "Bit selection", single_opcode Vbsl;
- "Transpose elements", single_opcode Vtrn;
- "Zip elements", single_opcode Vzip;
- "Unzip elements", single_opcode Vuzp;
- "Element/structure loads, VLD1 variants", ldx_opcode 1;
- "Element/structure stores, VST1 variants", stx_opcode 1;
- "Element/structure loads, VLD2 variants", ldx_opcode 2;
- "Element/structure stores, VST2 variants", stx_opcode 2;
- "Element/structure loads, VLD3 variants", ldx_opcode 3;
- "Element/structure stores, VST3 variants", stx_opcode 3;
- "Element/structure loads, VLD4 variants", ldx_opcode 4;
- "Element/structure stores, VST4 variants", stx_opcode 4;
- "Logical operations (AND)", single_opcode Vand;
- "Logical operations (OR)", single_opcode Vorr;
- "Logical operations (exclusive OR)", single_opcode Veor;
- "Logical operations (AND-NOT)", single_opcode Vbic;
- "Logical operations (OR-NOT)", single_opcode Vorn;
- "Reinterpret casts", single_opcode Vreinterp ]
-
-(* Given an intrinsic shape, produce a string to document the corresponding
- operand shapes. *)
-let rec analyze_shape shape =
- let rec n_things n thing =
- match n with
- 0 -> []
- | n -> thing :: (n_things (n - 1) thing)
- in
- let rec analyze_shape_elt reg_no elt =
- match elt with
- Dreg -> "@var{d" ^ (string_of_int reg_no) ^ "}"
- | Qreg -> "@var{q" ^ (string_of_int reg_no) ^ "}"
- | Corereg -> "@var{r" ^ (string_of_int reg_no) ^ "}"
- | Immed -> "#@var{0}"
- | VecArray (1, elt) ->
- let elt_regexp = analyze_shape_elt 0 elt in
- "@{" ^ elt_regexp ^ "@}"
- | VecArray (n, elt) ->
- let rec f m =
- match m with
- 0 -> []
- | m -> (analyze_shape_elt (m - 1) elt) :: (f (m - 1))
- in
- let ops = List.rev (f n) in
- "@{" ^ (commas (fun x -> x) ops "") ^ "@}"
- | (PtrTo elt | CstPtrTo elt) ->
- "[" ^ (analyze_shape_elt reg_no elt) ^ "]"
- | Element_of_dreg -> (analyze_shape_elt reg_no Dreg) ^ "[@var{0}]"
- | Element_of_qreg -> (analyze_shape_elt reg_no Qreg) ^ "[@var{0}]"
- | All_elements_of_dreg -> (analyze_shape_elt reg_no Dreg) ^ "[]"
- | Alternatives alts -> (analyze_shape_elt reg_no (List.hd alts))
- in
- match shape with
- All (n, elt) -> commas (analyze_shape_elt 0) (n_things n elt) ""
- | Long -> (analyze_shape_elt 0 Qreg) ^ ", " ^ (analyze_shape_elt 0 Dreg) ^
- ", " ^ (analyze_shape_elt 0 Dreg)
- | Long_noreg elt -> (analyze_shape_elt 0 elt) ^ ", " ^
- (analyze_shape_elt 0 elt)
- | Wide -> (analyze_shape_elt 0 Qreg) ^ ", " ^ (analyze_shape_elt 0 Qreg) ^
- ", " ^ (analyze_shape_elt 0 Dreg)
- | Wide_noreg elt -> analyze_shape (Long_noreg elt)
- | Narrow -> (analyze_shape_elt 0 Dreg) ^ ", " ^ (analyze_shape_elt 0 Qreg) ^
- ", " ^ (analyze_shape_elt 0 Qreg)
- | Use_operands elts -> commas (analyze_shape_elt 0) (Array.to_list elts) ""
- | By_scalar Dreg ->
- analyze_shape (Use_operands [| Dreg; Dreg; Element_of_dreg |])
- | By_scalar Qreg ->
- analyze_shape (Use_operands [| Qreg; Qreg; Element_of_dreg |])
- | By_scalar _ -> assert false
- | Wide_lane ->
- analyze_shape (Use_operands [| Qreg; Dreg; Element_of_dreg |])
- | Wide_scalar ->
- analyze_shape (Use_operands [| Qreg; Dreg; Element_of_dreg |])
- | Pair_result elt ->
- let elt_regexp = analyze_shape_elt 0 elt in
- let elt_regexp' = analyze_shape_elt 1 elt in
- elt_regexp ^ ", " ^ elt_regexp'
- | Unary_scalar _ -> "FIXME Unary_scalar"
- | Binary_imm elt -> analyze_shape (Use_operands [| elt; elt; Immed |])
- | Narrow_imm -> analyze_shape (Use_operands [| Dreg; Qreg; Immed |])
- | Long_imm -> analyze_shape (Use_operands [| Qreg; Dreg; Immed |])
-
-(* Document a single intrinsic. *)
-let describe_intrinsic first chan
- (elt_ty, (_, features, shape, name, munge, _)) =
- let c_arity, new_elt_ty = munge shape elt_ty in
- let c_types = strings_of_arity c_arity in
- Printf.fprintf chan "@itemize @bullet\n";
- let item_code = if first then "@item" else "@itemx" in
- Printf.fprintf chan "%s %s %s_%s (" item_code (List.hd c_types)
- (intrinsic_name name) (string_of_elt elt_ty);
- Printf.fprintf chan "%s)\n" (commas (fun ty -> ty) (List.tl c_types) "");
- if not (List.exists (fun feature -> feature = No_op) features) then
- begin
- let print_one_insn name =
- Printf.fprintf chan "@code{";
- let no_suffix = (new_elt_ty = NoElts) in
- let name_with_suffix =
- if no_suffix then name
- else name ^ "." ^ (string_of_elt_dots new_elt_ty)
- in
- let possible_operands = analyze_all_shapes features shape
- analyze_shape
- in
- let rec print_one_possible_operand op =
- Printf.fprintf chan "%s %s}" name_with_suffix op
- in
- (* If the intrinsic expands to multiple instructions, we assume
- they are all of the same form. *)
- print_one_possible_operand (List.hd possible_operands)
- in
- let rec print_insns names =
- match names with
- [] -> ()
- | [name] -> print_one_insn name
- | name::names -> (print_one_insn name;
- Printf.fprintf chan " @emph{or} ";
- print_insns names)
- in
- let insn_names = get_insn_names features name in
- Printf.fprintf chan "@*@emph{Form of expected instruction(s):} ";
- print_insns insn_names;
- Printf.fprintf chan "\n"
- end;
- Printf.fprintf chan "@end itemize\n";
- Printf.fprintf chan "\n\n"
-
-(* Document a group of intrinsics. *)
-let document_group chan (group_title, group_extractor) =
- (* Extract the rows in question from the ops table and then turn them
- into a list of intrinsics. *)
- let intrinsics =
- List.fold_left (fun got_so_far ->
- fun row ->
- match row with
- (_, _, _, _, _, elt_tys) ->
- List.fold_left (fun got_so_far' ->
- fun elt_ty ->
- (elt_ty, row) :: got_so_far')
- got_so_far elt_tys
- ) [] (group_extractor ())
- in
- (* Emit the title for this group. *)
- Printf.fprintf chan "@subsubsection %s\n\n" group_title;
- (* Emit a description of each intrinsic. *)
- List.iter (describe_intrinsic true chan) intrinsics;
- (* Close this group. *)
- Printf.fprintf chan "\n\n"
-
-let gnu_header chan =
- List.iter (fun s -> Printf.fprintf chan "%s\n" s) [
- "@c Copyright (C) 2006-2014 Free Software Foundation, Inc.";
- "@c This is part of the GCC manual.";
- "@c For copying conditions, see the file gcc.texi.";
- "";
- "@c This file is generated automatically using gcc/config/arm/neon-docgen.ml";
- "@c Please do not edit manually."]
-
-let crypto_doc =
-"
-@itemize @bullet
-@item poly128_t vldrq_p128(poly128_t const *)
-@end itemize
-
-@itemize @bullet
-@item void vstrq_p128(poly128_t *, poly128_t)
-@end itemize
-
-@itemize @bullet
-@item uint64x1_t vceq_p64 (poly64x1_t, poly64x1_t)
-@end itemize
-
-@itemize @bullet
-@item uint64x1_t vtst_p64 (poly64x1_t, poly64x1_t)
-@end itemize
-
-@itemize @bullet
-@item uint32_t vsha1h_u32 (uint32_t)
-@*@emph{Form of expected instruction(s):} @code{sha1h.32 @var{q0}, @var{q1}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha1cq_u32 (uint32x4_t, uint32_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha1c.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha1pq_u32 (uint32x4_t, uint32_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha1p.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha1mq_u32 (uint32x4_t, uint32_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha1m.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha1su0q_u32 (uint32x4_t, uint32x4_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha1su0.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha1su1q_u32 (uint32x4_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha1su1.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha256hq_u32 (uint32x4_t, uint32x4_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha256h.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha256h2q_u32 (uint32x4_t, uint32x4_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha256h2.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha256su0q_u32 (uint32x4_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha256su0.32 @var{q0}, @var{q1}}
-@end itemize
-
-@itemize @bullet
-@item uint32x4_t vsha256su1q_u32 (uint32x4_t, uint32x4_t, uint32x4_t)
-@*@emph{Form of expected instruction(s):} @code{sha256su1.32 @var{q0}, @var{q1}, @var{q2}}
-@end itemize
-
-@itemize @bullet
-@item poly128_t vmull_p64 (poly64_t a, poly64_t b)
-@*@emph{Form of expected instruction(s):} @code{vmull.p64 @var{q0}, @var{d1}, @var{d2}}
-@end itemize
-
-@itemize @bullet
-@item poly128_t vmull_high_p64 (poly64x2_t a, poly64x2_t b)
-@*@emph{Form of expected instruction(s):} @code{vmull.p64 @var{q0}, @var{d1}, @var{d2}}
-@end itemize
-"
-
-(* Program entry point. *)
-let _ =
- if Array.length Sys.argv <> 2 then
- failwith "Usage: neon-docgen <output filename>"
- else
- let file = Sys.argv.(1) in
- try
- let chan = open_out file in
- gnu_header chan;
- List.iter (document_group chan) intrinsic_groups;
- Printf.fprintf chan "%s\n" crypto_doc;
- close_out chan
- with Sys_error sys ->
- failwith ("Could not create output file " ^ file ^ ": " ^ sys)
+++ /dev/null
-(* Auto-generate ARM Neon intrinsics header file.
- Copyright (C) 2006-2014 Free Software Foundation, Inc.
- Contributed by CodeSourcery.
-
- This file is part of GCC.
-
- GCC is free software; you can redistribute it and/or modify it under
- the terms of the GNU General Public License as published by the Free
- Software Foundation; either version 3, or (at your option) any later
- version.
-
- GCC is distributed in the hope that it will be useful, but WITHOUT ANY
- WARRANTY; without even the implied warranty of MERCHANTABILITY or
- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
- for more details.
-
- You should have received a copy of the GNU General Public License
- along with GCC; see the file COPYING3. If not see
- <http://www.gnu.org/licenses/>.
-
- This is an O'Caml program. The O'Caml compiler is available from:
-
- http://caml.inria.fr/
-
- Or from your favourite OS's friendly packaging system. Tested with version
- 3.09.2, though other versions will probably work too.
-
- Compile with:
- ocamlc -c neon.ml
- ocamlc -o neon-gen neon.cmo neon-gen.ml
-
- Run with:
- ./neon-gen > arm_neon.h
-*)
-
-open Neon
-
-(* The format codes used in the following functions are documented at:
- http://caml.inria.fr/pub/docs/manual-ocaml/libref/Format.html\
- #6_printflikefunctionsforprettyprinting
- (one line, remove the backslash.)
-*)
-
-(* Following functions can be used to approximate GNU indentation style. *)
-let start_function () =
- Format.printf "@[<v 0>";
- ref 0
-
-let end_function nesting =
- match !nesting with
- 0 -> Format.printf "@;@;@]"
- | _ -> failwith ("Bad nesting (ending function at level "
- ^ (string_of_int !nesting) ^ ")")
-
-let open_braceblock nesting =
- begin match !nesting with
- 0 -> Format.printf "@,@<0>{@[<v 2>@,"
- | _ -> Format.printf "@,@[<v 2> @<0>{@[<v 2>@,"
- end;
- incr nesting
-
-let close_braceblock nesting =
- decr nesting;
- match !nesting with
- 0 -> Format.printf "@]@,@<0>}"
- | _ -> Format.printf "@]@,@<0>}@]"
-
-let print_function arity fnname body =
- let ffmt = start_function () in
- Format.printf "__extension__ static __inline ";
- let inl = "__attribute__ ((__always_inline__))" in
- begin match arity with
- Arity0 ret ->
- Format.printf "%s %s@,%s (void)" (string_of_vectype ret) inl fnname
- | Arity1 (ret, arg0) ->
- Format.printf "%s %s@,%s (%s __a)" (string_of_vectype ret) inl fnname
- (string_of_vectype arg0)
- | Arity2 (ret, arg0, arg1) ->
- Format.printf "%s %s@,%s (%s __a, %s __b)"
- (string_of_vectype ret) inl fnname (string_of_vectype arg0)
- (string_of_vectype arg1)
- | Arity3 (ret, arg0, arg1, arg2) ->
- Format.printf "%s %s@,%s (%s __a, %s __b, %s __c)"
- (string_of_vectype ret) inl fnname (string_of_vectype arg0)
- (string_of_vectype arg1) (string_of_vectype arg2)
- | Arity4 (ret, arg0, arg1, arg2, arg3) ->
- Format.printf "%s %s@,%s (%s __a, %s __b, %s __c, %s __d)"
- (string_of_vectype ret) inl fnname (string_of_vectype arg0)
- (string_of_vectype arg1) (string_of_vectype arg2)
- (string_of_vectype arg3)
- end;
- open_braceblock ffmt;
- let rec print_lines = function
- [] -> ()
- | "" :: lines -> print_lines lines
- | [line] -> Format.printf "%s" line
- | line::lines -> Format.printf "%s@," line ; print_lines lines in
- print_lines body;
- close_braceblock ffmt;
- end_function ffmt
-
-let union_string num elts base =
- let itype = inttype_for_array num elts in
- let iname = string_of_inttype itype
- and sname = string_of_vectype (T_arrayof (num, elts)) in
- Printf.sprintf "union { %s __i; %s __o; } %s" sname iname base
-
-let rec signed_ctype = function
- T_uint8x8 | T_poly8x8 -> T_int8x8
- | T_uint8x16 | T_poly8x16 -> T_int8x16
- | T_uint16x4 | T_poly16x4 -> T_int16x4
- | T_uint16x8 | T_poly16x8 -> T_int16x8
- | T_uint32x2 -> T_int32x2
- | T_uint32x4 -> T_int32x4
- | T_uint64x1 -> T_int64x1
- | T_uint64x2 -> T_int64x2
- | T_poly64x2 -> T_int64x2
- (* Cast to types defined by mode in arm.c, not random types pulled in from
- the <stdint.h> header in use. This fixes incompatible pointer errors when
- compiling with C++. *)
- | T_uint8 | T_int8 -> T_intQI
- | T_uint16 | T_int16 -> T_intHI
- | T_uint32 | T_int32 -> T_intSI
- | T_uint64 | T_int64 -> T_intDI
- | T_float16 -> T_floatHF
- | T_float32 -> T_floatSF
- | T_poly8 -> T_intQI
- | T_poly16 -> T_intHI
- | T_poly64 -> T_intDI
- | T_poly128 -> T_intTI
- | T_arrayof (n, elt) -> T_arrayof (n, signed_ctype elt)
- | T_ptrto elt -> T_ptrto (signed_ctype elt)
- | T_const elt -> T_const (signed_ctype elt)
- | x -> x
-
-let add_cast ctype cval =
- let stype = signed_ctype ctype in
- if ctype <> stype then
- Printf.sprintf "(%s) %s" (string_of_vectype stype) cval
- else
- cval
-
-let cast_for_return to_ty = "(" ^ (string_of_vectype to_ty) ^ ")"
-
-(* Return a tuple of a list of declarations to go at the start of the function,
- and a list of statements needed to return THING. *)
-let return arity thing =
- match arity with
- Arity0 (ret) | Arity1 (ret, _) | Arity2 (ret, _, _) | Arity3 (ret, _, _, _)
- | Arity4 (ret, _, _, _, _) ->
- begin match ret with
- T_arrayof (num, vec) ->
- let uname = union_string num vec "__rv" in
- [uname ^ ";"], ["__rv.__o = " ^ thing ^ ";"; "return __rv.__i;"]
- | T_void ->
- [], [thing ^ ";"]
- | _ ->
- [], ["return " ^ (cast_for_return ret) ^ thing ^ ";"]
- end
-
-let mask_shape_for_shuffle = function
- All (num, reg) -> All (num, reg)
- | Pair_result reg -> All (2, reg)
- | _ -> failwith "mask_for_shuffle"
-
-let mask_elems shuffle shape elttype part =
- let elem_size = elt_width elttype in
- let num_elems =
- match regmap shape 0 with
- Dreg -> 64 / elem_size
- | Qreg -> 128 / elem_size
- | _ -> failwith "mask_elems" in
- shuffle elem_size num_elems part
-
-(* Return a tuple of a list of declarations 0and a list of statements needed
- to implement an intrinsic using __builtin_shuffle. SHUFFLE is a function
- which returns a list of elements suitable for using as a mask. *)
-
-let shuffle_fn shuffle shape arity elttype =
- let mshape = mask_shape_for_shuffle shape in
- let masktype = type_for_elt mshape (unsigned_of_elt elttype) 0 in
- let masktype_str = string_of_vectype masktype in
- let shuffle_res = type_for_elt mshape elttype 0 in
- let shuffle_res_str = string_of_vectype shuffle_res in
- match arity with
- Arity0 (ret) | Arity1 (ret, _) | Arity2 (ret, _, _) | Arity3 (ret, _, _, _)
- | Arity4 (ret, _, _, _, _) ->
- begin match ret with
- T_arrayof (num, vec) ->
- let elems1 = mask_elems shuffle mshape elttype `lo
- and elems2 = mask_elems shuffle mshape elttype `hi in
- let mask1 = (String.concat ", " (List.map string_of_int elems1))
- and mask2 = (String.concat ", " (List.map string_of_int elems2)) in
- let shuf1 = Printf.sprintf
- "__rv.val[0] = (%s) __builtin_shuffle (__a, __b, (%s) { %s });"
- shuffle_res_str masktype_str mask1
- and shuf2 = Printf.sprintf
- "__rv.val[1] = (%s) __builtin_shuffle (__a, __b, (%s) { %s });"
- shuffle_res_str masktype_str mask2 in
- [Printf.sprintf "%s __rv;" (string_of_vectype ret);],
- [shuf1; shuf2; "return __rv;"]
- | _ ->
- let elems = mask_elems shuffle mshape elttype `lo in
- let mask = (String.concat ", " (List.map string_of_int elems)) in
- let shuf = Printf.sprintf
- "return (%s) __builtin_shuffle (__a, (%s) { %s });" shuffle_res_str masktype_str mask in
- [""],
- [shuf]
- end
-
-let rec element_type ctype =
- match ctype with
- T_arrayof (_, v) -> element_type v
- | _ -> ctype
-
-let params ps =
- let pdecls = ref [] in
- let ptype t p =
- match t with
- T_arrayof (num, elts) ->
- let uname = union_string num elts (p ^ "u") in
- let decl = Printf.sprintf "%s = { %s };" uname p in
- pdecls := decl :: !pdecls;
- p ^ "u.__o"
- | _ -> add_cast t p in
- let plist = match ps with
- Arity0 _ -> []
- | Arity1 (_, t1) -> [ptype t1 "__a"]
- | Arity2 (_, t1, t2) -> [ptype t1 "__a"; ptype t2 "__b"]
- | Arity3 (_, t1, t2, t3) -> [ptype t1 "__a"; ptype t2 "__b"; ptype t3 "__c"]
- | Arity4 (_, t1, t2, t3, t4) ->
- [ptype t1 "__a"; ptype t2 "__b"; ptype t3 "__c"; ptype t4 "__d"] in
- !pdecls, plist
-
-let modify_params features plist =
- let is_flipped =
- List.exists (function Flipped _ -> true | _ -> false) features in
- if is_flipped then
- match plist with
- [ a; b ] -> [ b; a ]
- | _ ->
- failwith ("Don't know how to flip args " ^ (String.concat ", " plist))
- else
- plist
-
-(* !!! Decide whether to add an extra information word based on the shape
- form. *)
-let extra_word shape features paramlist bits =
- let use_word =
- match shape with
- All _ | Long | Long_noreg _ | Wide | Wide_noreg _ | Narrow
- | By_scalar _ | Wide_scalar | Wide_lane | Binary_imm _ | Long_imm
- | Narrow_imm -> true
- | _ -> List.mem InfoWord features
- in
- if use_word then
- paramlist @ [string_of_int bits]
- else
- paramlist
-
-(* Bit 0 represents signed (1) vs unsigned (0), or float (1) vs poly (0).
- Bit 1 represents floats & polynomials (1), or ordinary integers (0).
- Bit 2 represents rounding (1) vs none (0). *)
-let infoword_value elttype features =
- let bits01 =
- match elt_class elttype with
- Signed | ConvClass (Signed, _) | ConvClass (_, Signed) -> 0b001
- | Poly -> 0b010
- | Float -> 0b011
- | _ -> 0b000
- and rounding_bit = if List.mem Rounding features then 0b100 else 0b000 in
- bits01 lor rounding_bit
-
-(* "Cast" type operations will throw an exception in mode_of_elt (actually in
- elt_width, called from there). Deal with that here, and generate a suffix
- with multiple modes (<to><from>). *)
-let rec mode_suffix elttype shape =
- try
- let mode = mode_of_elt elttype shape in
- string_of_mode mode
- with MixedMode (dst, src) ->
- let dstmode = mode_of_elt ~argpos:0 dst shape
- and srcmode = mode_of_elt ~argpos:1 src shape in
- string_of_mode dstmode ^ string_of_mode srcmode
-
-let get_shuffle features =
- try
- match List.find (function Use_shuffle _ -> true | _ -> false) features with
- Use_shuffle fn -> Some fn
- | _ -> None
- with Not_found -> None
-
-let print_feature_test_start features =
- try
- match List.find (fun feature ->
- match feature with Requires_feature _ -> true
- | Requires_arch _ -> true
- | Requires_FP_bit _ -> true
- | _ -> false)
- features with
- Requires_feature feature ->
- Format.printf "#ifdef __ARM_FEATURE_%s@\n" feature
- | Requires_arch arch ->
- Format.printf "#if __ARM_ARCH >= %d@\n" arch
- | Requires_FP_bit bit ->
- Format.printf "#if ((__ARM_FP & 0x%X) != 0)@\n"
- (1 lsl bit)
- | _ -> assert false
- with Not_found -> assert true
-
-let print_feature_test_end features =
- let feature =
- List.exists (function Requires_feature _ -> true
- | Requires_arch _ -> true
- | Requires_FP_bit _ -> true
- | _ -> false) features in
- if feature then Format.printf "#endif@\n"
-
-
-let print_variant opcode features shape name (ctype, asmtype, elttype) =
- let bits = infoword_value elttype features in
- let modesuf = mode_suffix elttype shape in
- let pdecls, paramlist = params ctype in
- let rdecls, stmts =
- match get_shuffle features with
- Some shuffle -> shuffle_fn shuffle shape ctype elttype
- | None ->
- let paramlist' = modify_params features paramlist in
- let paramlist'' = extra_word shape features paramlist' bits in
- let parstr = String.concat ", " paramlist'' in
- let builtin = Printf.sprintf "__builtin_neon_%s%s (%s)"
- (builtin_name features name) modesuf parstr in
- return ctype builtin in
- let body = pdecls @ rdecls @ stmts
- and fnname = (intrinsic_name name) ^ "_" ^ (string_of_elt elttype) in
- begin
- print_feature_test_start features;
- print_function ctype fnname body;
- print_feature_test_end features;
- end
-
-(* When this function processes the element types in the ops table, it rewrites
- them in a list of tuples (a,b,c):
- a : C type as an "arity", e.g. Arity1 (T_poly8x8, T_poly8x8)
- b : Asm type : a single, processed element type, e.g. P16. This is the
- type which should be attached to the asm opcode.
- c : Variant type : the unprocessed type for this variant (e.g. in add
- instructions which don't care about the sign, b might be i16 and c
- might be s16.)
-*)
-
-let print_op (opcode, features, shape, name, munge, types) =
- let sorted_types = List.sort compare types in
- let munged_types = List.map
- (fun elt -> let c, asm = munge shape elt in c, asm, elt) sorted_types in
- List.iter
- (fun variant -> print_variant opcode features shape name variant)
- munged_types
-
-let print_ops ops =
- List.iter print_op ops
-
-(* Output type definitions. Table entries are:
- cbase : "C" name for the type.
- abase : "ARM" base name for the type (i.e. int in int8x8_t).
- esize : element size.
- enum : element count.
- alevel: architecture level at which available.
-*)
-
-type fpulevel = CRYPTO | ALL
-
-let deftypes () =
- let typeinfo = [
- (* Doubleword vector types. *)
- "__builtin_neon_qi", "int", 8, 8, ALL;
- "__builtin_neon_hi", "int", 16, 4, ALL;
- "__builtin_neon_si", "int", 32, 2, ALL;
- "__builtin_neon_di", "int", 64, 1, ALL;
- "__builtin_neon_hf", "float", 16, 4, ALL;
- "__builtin_neon_sf", "float", 32, 2, ALL;
- "__builtin_neon_poly8", "poly", 8, 8, ALL;
- "__builtin_neon_poly16", "poly", 16, 4, ALL;
- "__builtin_neon_poly64", "poly", 64, 1, CRYPTO;
- "__builtin_neon_uqi", "uint", 8, 8, ALL;
- "__builtin_neon_uhi", "uint", 16, 4, ALL;
- "__builtin_neon_usi", "uint", 32, 2, ALL;
- "__builtin_neon_udi", "uint", 64, 1, ALL;
-
- (* Quadword vector types. *)
- "__builtin_neon_qi", "int", 8, 16, ALL;
- "__builtin_neon_hi", "int", 16, 8, ALL;
- "__builtin_neon_si", "int", 32, 4, ALL;
- "__builtin_neon_di", "int", 64, 2, ALL;
- "__builtin_neon_sf", "float", 32, 4, ALL;
- "__builtin_neon_poly8", "poly", 8, 16, ALL;
- "__builtin_neon_poly16", "poly", 16, 8, ALL;
- "__builtin_neon_poly64", "poly", 64, 2, CRYPTO;
- "__builtin_neon_uqi", "uint", 8, 16, ALL;
- "__builtin_neon_uhi", "uint", 16, 8, ALL;
- "__builtin_neon_usi", "uint", 32, 4, ALL;
- "__builtin_neon_udi", "uint", 64, 2, ALL
- ] in
- List.iter
- (fun (cbase, abase, esize, enum, fpulevel) ->
- let attr =
- match enum with
- 1 -> ""
- | _ -> Printf.sprintf "\t__attribute__ ((__vector_size__ (%d)))"
- (esize * enum / 8) in
- if fpulevel == CRYPTO then
- Format.printf "#ifdef __ARM_FEATURE_CRYPTO\n";
- Format.printf "typedef %s %s%dx%d_t%s;@\n" cbase abase esize enum attr;
- if fpulevel == CRYPTO then
- Format.printf "#endif\n";)
- typeinfo;
- Format.print_newline ();
- (* Extra types not in <stdint.h>. *)
- Format.printf "typedef float float32_t;\n";
- Format.printf "typedef __builtin_neon_poly8 poly8_t;\n";
- Format.printf "typedef __builtin_neon_poly16 poly16_t;\n";
- Format.printf "#ifdef __ARM_FEATURE_CRYPTO\n";
- Format.printf "typedef __builtin_neon_poly64 poly64_t;\n";
- Format.printf "typedef __builtin_neon_poly128 poly128_t;\n";
- Format.printf "#endif\n"
-
-(* Output structs containing arrays, for load & store instructions etc.
- poly128_t is deliberately not included here because it has no array types
- defined for it. *)
-
-let arrtypes () =
- let typeinfo = [
- "int", 8, ALL; "int", 16, ALL;
- "int", 32, ALL; "int", 64, ALL;
- "uint", 8, ALL; "uint", 16, ALL;
- "uint", 32, ALL; "uint", 64, ALL;
- "float", 32, ALL; "poly", 8, ALL;
- "poly", 16, ALL; "poly", 64, CRYPTO
- ] in
- let writestruct elname elsize regsize arrsize fpulevel =
- let elnum = regsize / elsize in
- let structname =
- Printf.sprintf "%s%dx%dx%d_t" elname elsize elnum arrsize in
- let sfmt = start_function () in
- Format.printf "%stypedef struct %s"
- (if fpulevel == CRYPTO then "#ifdef __ARM_FEATURE_CRYPTO\n" else "") structname;
- open_braceblock sfmt;
- Format.printf "%s%dx%d_t val[%d];" elname elsize elnum arrsize;
- close_braceblock sfmt;
- Format.printf " %s;%s" structname (if fpulevel == CRYPTO then "\n#endif\n" else "");
- end_function sfmt;
- in
- for n = 2 to 4 do
- List.iter
- (fun (elname, elsize, alevel) ->
- writestruct elname elsize 64 n alevel;
- writestruct elname elsize 128 n alevel)
- typeinfo
- done
-
-let print_lines = List.iter (fun s -> Format.printf "%s@\n" s)
-
-(* Do it. *)
-
-let _ =
- print_lines [
-"/* ARM NEON intrinsics include file. This file is generated automatically";
-" using neon-gen.ml. Please do not edit manually.";
-"";
-" Copyright (C) 2006-2014 Free Software Foundation, Inc.";
-" Contributed by CodeSourcery.";
-"";
-" This file is part of GCC.";
-"";
-" GCC is free software; you can redistribute it and/or modify it";
-" under the terms of the GNU General Public License as published";
-" by the Free Software Foundation; either version 3, or (at your";
-" option) any later version.";
-"";
-" GCC is distributed in the hope that it will be useful, but WITHOUT";
-" ANY WARRANTY; without even the implied warranty of MERCHANTABILITY";
-" or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public";
-" License for more details.";
-"";
-" Under Section 7 of GPL version 3, you are granted additional";
-" permissions described in the GCC Runtime Library Exception, version";
-" 3.1, as published by the Free Software Foundation.";
-"";
-" You should have received a copy of the GNU General Public License and";
-" a copy of the GCC Runtime Library Exception along with this program;";
-" see the files COPYING3 and COPYING.RUNTIME respectively. If not, see";
-" <http://www.gnu.org/licenses/>. */";
-"";
-"#ifndef _GCC_ARM_NEON_H";
-"#define _GCC_ARM_NEON_H 1";
-"";
-"#ifndef __ARM_NEON__";
-"#error You must enable NEON instructions (e.g. -mfloat-abi=softfp -mfpu=neon) to use arm_neon.h";
-"#else";
-"";
-"#ifdef __cplusplus";
-"extern \"C\" {";
-"#endif";
-"";
-"#include <stdint.h>";
-""];
- deftypes ();
- arrtypes ();
- Format.print_newline ();
- print_ops ops;
- Format.print_newline ();
- print_ops reinterp;
- print_ops reinterpq;
- Format.printf "%s" crypto_intrinsics;
- print_lines [
-"#ifdef __cplusplus";
-"}";
-"#endif";
-"#endif";
-"#endif"]
(define_insn "x86_64_shrd"
[(set (match_operand:DI 0 "nonimmediate_operand" "+r*m")
- (ior:DI (ashiftrt:DI (match_dup 0)
+ (ior:DI (lshiftrt:DI (match_dup 0)
(match_operand:QI 2 "nonmemory_operand" "Jc"))
(ashift:DI (match_operand:DI 1 "register_operand" "r")
(minus:QI (const_int 64) (match_dup 2)))))
(define_insn "x86_shrd"
[(set (match_operand:SI 0 "nonimmediate_operand" "+r*m")
- (ior:SI (ashiftrt:SI (match_dup 0)
+ (ior:SI (lshiftrt:SI (match_dup 0)
(match_operand:QI 2 "nonmemory_operand" "Ic"))
(ashift:SI (match_operand:SI 1 "register_operand" "r")
(minus:QI (const_int 32) (match_dup 2)))))
[(set (match_dup 3) (match_dup 4))
(parallel
[(set (match_dup 4)
- (ior:DWIH (ashiftrt:DWIH (match_dup 4) (match_dup 2))
+ (ior:DWIH (lshiftrt:DWIH (match_dup 4) (match_dup 2))
(ashift:DWIH (match_dup 5)
(minus:QI (match_dup 6) (match_dup 2)))))
(clobber (reg:CC FLAGS_REG))])
(parallel
[(set (match_dup 5)
- (ior:DWIH (ashiftrt:DWIH (match_dup 5) (match_dup 2))
+ (ior:DWIH (lshiftrt:DWIH (match_dup 5) (match_dup 2))
(ashift:DWIH (match_dup 3)
(minus:QI (match_dup 6) (match_dup 2)))))
(clobber (reg:CC FLAGS_REG))])]
{
if (GET_CODE (op3) == SCRATCH)
op3 = gen_reg_rtx (V4SFmode);
- emit_insn (gen_vsx_xxsldwi_v4sf (op3, op1, op1, op2));
+ emit_insn (gen_vsx_xxsldwi_v4sf (op3, op1, op1, GEN_INT (ele)));
tmp = op3;
}
emit_insn (gen_vsx_xscvspdp_scalar2 (op0, tmp));
+2014-07-01 Paul Pluzhnikov <ppluzhnikov@google.com>
+
+ PR c++/58753
+ PR c++/58930
+ PR c++/58704
+
+ Backported from mainline
+ 2014-05-20 Paolo Carlini <paolo.carlini@oracle.com>
+
+ * typeck2.c (digest_nsdmi_init): New.
+ * parser.c (cp_parser_late_parse_one_default_arg): Use it.
+ * init.c (get_nsdmi): Likewise.
+ * cp-tree.h (digest_nsdmi_init): Declare.
+
+2014-06-30 Edward Smith-Rowland <3dw4rd@verizon.net>
+
+ PR c++/58781
+ PR c++/60249
+ PR c++/59867
+ * parser.c (cp_parser_userdef_string_literal()): Take a tree
+ not a cp_token*. (cp_parser_string_literal(): Don't hack
+ the token stream!
+
+2014-06-30 Jason Merrill <jason@redhat.com>
+
+ PR c++/61647
+ * pt.c (type_dependent_expression_p): Check BASELINK_OPTYPE.
+
+ PR c++/61566
+ * mangle.c (decl_mangling_context): Look through a TEMPLATE_DECL.
+
+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.
+
+2014-06-30 Jason Merrill <jason@redhat.com>
+
+ PR c++/61539
+ * pt.c (unify_one_argument): Type/expression mismatch just causes
+ deduction failure.
+
+ DR 1030
+ PR c++/51253
+ PR c++/61382
+ * cp-tree.h (CALL_EXPR_LIST_INIT_P): New.
+ * call.c (struct z_candidate): Add flags field.
+ (add_candidate): Add flags parm.
+ (add_function_candidate, add_conv_candidate, build_builtin_candidate)
+ (add_template_candidate_real): Pass it.
+ (build_over_call): Set CALL_EXPR_LIST_INIT_P.
+ * tree.c (build_aggr_init_expr): Copy it.
+ * semantics.c (simplify_aggr_init_expr): Copy it.
+ * cp-gimplify.c (cp_gimplify_expr): Handle it.
+
+ PR c++/61488
+ * pt.c (check_valid_ptrmem_cst_expr): Fix for template context.
+
+ PR c++/61500
+ * tree.c (lvalue_kind): Handle MEMBER_REF and DOTSTAR_EXPR.
+
+2014-06-30 Igor Zamyatin <igor.zamyatin@intel.com>
+
+ PR middle-end/57541
+ * cp-array-notation.c (expand_sec_reduce_builtin):
+ Check that bultin argument is correct.
+ * call.c (build_cxx_call): Check for 0 arguments in builtin call.
+
+2014-06-27 Jason Merrill <jason@redhat.com>
+
+ PR c++/61433
+ * error.c (dump_template_bindings): Don't tsubst in a clone.
+
+2014-06-27 Paolo Carlini <paolo.carlini@oracle.com>
+
+ PR c++/61614
+ * semantics.c (finish_compound_literal): Revert r204228.
+
+2014-06-26 Adam Butcher <adam@jessamine.co.uk>
+
+ PR c++/61537
+ * parser.c (cp_parser_elaborated_type_specifier): Only consider template
+ parameter lists outside of function parameter scope.
+
+2014-06-25 Jason Merrill <jason@redhat.com>
+
+ PR c++/61242
+ * call.c (build_aggr_conv): Ignore passed in flags.
+ (build_array_conv, build_complex_conv): Likewise.
+
2014-06-24 Jakub Jelinek <jakub@redhat.com>
* parser.c (cp_parser_omp_for_loop): For
static void maybe_handle_implicit_object (conversion **);
static struct z_candidate *add_candidate
(struct z_candidate **, tree, tree, const vec<tree, va_gc> *, size_t,
- conversion **, tree, tree, int, struct rejection_reason *);
+ conversion **, tree, tree, int, struct rejection_reason *, int);
static tree source_type (conversion *);
static void add_warning (struct z_candidate *, struct z_candidate *);
static bool reference_compatible_p (tree, tree);
sequence from the type returned by FN to the desired destination
type. */
conversion *second_conv;
- int viable;
struct rejection_reason *reason;
/* If FN is a member function, the binfo indicating the path used to
qualify the name of FN at the call site. This path is used to
tree explicit_targs;
candidate_warning *warnings;
z_candidate *next;
+ int viable;
+
+ /* The flags active in add_candidate. */
+ int flags;
};
/* Returns true iff T is a null pointer constant in the sense of
if (ctor == error_mark_node)
return NULL;
- flags |= LOOKUP_NO_NARROWING;
+ /* The conversions within the init-list aren't affected by the enclosing
+ context; they're always simple copy-initialization. */
+ flags = LOOKUP_IMPLICIT|LOOKUP_NO_NARROWING;
for (; field; field = next_initializable_field (DECL_CHAIN (field)))
{
return NULL;
}
+ flags = LOOKUP_IMPLICIT|LOOKUP_NO_NARROWING;
+
FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (ctor), i, val)
{
conversion *sub
if (len != 2)
return NULL;
+ flags = LOOKUP_IMPLICIT|LOOKUP_NO_NARROWING;
+
FOR_EACH_CONSTRUCTOR_VALUE (CONSTRUCTOR_ELTS (ctor), i, val)
{
conversion *sub
tree fn, tree first_arg, const vec<tree, va_gc> *args,
size_t num_convs, conversion **convs,
tree access_path, tree conversion_path,
- int viable, struct rejection_reason *reason)
+ int viable, struct rejection_reason *reason,
+ int flags)
{
struct z_candidate *cand = (struct z_candidate *)
conversion_obstack_alloc (sizeof (struct z_candidate));
cand->viable = viable;
cand->reason = reason;
cand->next = *candidates;
+ cand->flags = flags;
*candidates = cand;
return cand;
out:
return add_candidate (candidates, fn, orig_first_arg, args, len, convs,
- access_path, conversion_path, viable, reason);
+ access_path, conversion_path, viable, reason, flags);
}
/* Create an overload candidate for the conversion function FN which will
}
return add_candidate (candidates, totype, first_arg, arglist, len, convs,
- access_path, conversion_path, viable, reason);
+ access_path, conversion_path, viable, reason, flags);
}
static void
num_convs, convs,
/*access_path=*/NULL_TREE,
/*conversion_path=*/NULL_TREE,
- viable, reason);
+ viable, reason, flags);
}
static bool
return cand;
fail:
return add_candidate (candidates, tmpl, first_arg, arglist, nargs, NULL,
- access_path, conversion_path, 0, reason);
+ access_path, conversion_path, 0, reason, flags);
}
return error_mark_node;
}
- return build_cxx_call (fn, nargs, argarray, complain|decltype_flag);
+ tree call = build_cxx_call (fn, nargs, argarray, complain|decltype_flag);
+ if (TREE_CODE (call) == CALL_EXPR
+ && (cand->flags & LOOKUP_LIST_INIT_CTOR))
+ CALL_EXPR_LIST_INIT_P (call) = true;
+ return call;
}
/* Build and return a call to FN, using NARGS arguments in ARGARRAY.
|| bif == BUILT_IN_CILKPLUS_SEC_REDUCE
|| bif == BUILT_IN_CILKPLUS_SEC_REDUCE_MUTATING)
{
+ if (call_expr_nargs (fn) == 0)
+ {
+ error_at (EXPR_LOCATION (fn), "Invalid builtin arguments");
+ return error_mark_node;
+ }
/* for bif == BUILT_IN_CILKPLUS_SEC_REDUCE_ALL_ZERO or
BUILT_IN_CILKPLUS_SEC_REDUCE_ANY_ZERO or
BUILT_IN_CILKPLUS_SEC_REDUCE_ANY_NONZERO or
if (!find_rank (location, an_builtin_fn, an_builtin_fn, true, &rank))
return error_mark_node;
if (rank == 0)
- return an_builtin_fn;
+ {
+ error_at (location, "Invalid builtin arguments");
+ return error_mark_node;
+ }
else if (rank > 1
&& (an_type == BUILT_IN_CILKPLUS_SEC_REDUCE_MAX_IND
|| an_type == BUILT_IN_CILKPLUS_SEC_REDUCE_MIN_IND))
&& !seen_error ())
return (enum gimplify_status) gimplify_cilk_spawn (expr_p);
+ /* DR 1030 says that we need to evaluate the elements of an
+ initializer-list in forward order even when it's used as arguments to
+ a constructor. So if the target wants to evaluate them in reverse
+ order and there's more than one argument other than 'this', gimplify
+ them in order. */
+ ret = GS_OK;
+ if (PUSH_ARGS_REVERSED && CALL_EXPR_LIST_INIT_P (*expr_p)
+ && call_expr_nargs (*expr_p) > 2)
+ {
+ int nargs = call_expr_nargs (*expr_p);
+ location_t loc = EXPR_LOC_OR_LOC (*expr_p, input_location);
+ for (int i = 1; i < nargs; ++i)
+ {
+ enum gimplify_status t
+ = gimplify_arg (&CALL_EXPR_ARG (*expr_p, i), pre_p, loc);
+ if (t == GS_ERROR)
+ ret = GS_ERROR;
+ }
+ }
+ break;
+
default:
ret = (enum gimplify_status) c_gimplify_expr (expr_p, pre_p, post_p);
break;
/* Finalize an implicitly determined clause. */
void
-cxx_omp_finish_clause (tree c)
+cxx_omp_finish_clause (tree c, gimple_seq *)
{
tree decl, inner_type;
bool make_shared = false;
FNDECL_USED_AUTO (in FUNCTION_DECL)
DECLTYPE_FOR_LAMBDA_PROXY (in DECLTYPE_TYPE)
REF_PARENTHESIZED_P (in COMPONENT_REF, SCOPE_REF)
+ AGGR_INIT_ZERO_FIRST (in AGGR_INIT_EXPR)
3: (TREE_REFERENCE_EXPR) (in NON_LVALUE_EXPR) (commented-out).
ICS_BAD_FLAG (in _CONV)
FN_TRY_BLOCK_P (in TRY_BLOCK)
IDENTIFIER_CTOR_OR_DTOR_P (in IDENTIFIER_NODE)
BIND_EXPR_BODY_BLOCK (in BIND_EXPR)
DECL_NON_TRIVIALLY_INITIALIZED_P (in VAR_DECL)
+ CALL_EXPR_LIST_INIT_P (in CALL_EXPR, AGGR_INIT_EXPR)
4: TREE_HAS_CONSTRUCTOR (in INDIRECT_REF, SAVE_EXPR, CONSTRUCTOR,
or FIELD_DECL).
IDENTIFIER_TYPENAME_P (in IDENTIFIER_NODE)
should be performed at instantiation time. */
#define KOENIG_LOOKUP_P(NODE) TREE_LANG_FLAG_0 (CALL_EXPR_CHECK (NODE))
+/* True if CALL_EXPR expresses list-initialization of an object. */
+#define CALL_EXPR_LIST_INIT_P(NODE) \
+ TREE_LANG_FLAG_3 (TREE_CHECK2 ((NODE),CALL_EXPR,AGGR_INIT_EXPR))
+
/* Indicates whether a string literal has been parenthesized. Such
usages are disallowed in certain circumstances. */
B b{1,2}, not B b({1,2}) or B b = {1,2}. */
#define CONSTRUCTOR_IS_DIRECT_INIT(NODE) (TREE_LANG_FLAG_0 (CONSTRUCTOR_CHECK (NODE)))
+#define DIRECT_LIST_INIT_P(NODE) \
+ (BRACE_ENCLOSED_INITIALIZER_P (NODE) && CONSTRUCTOR_IS_DIRECT_INIT (NODE))
+
/* True if NODE represents a conversion for direct-initialization in a
template. Set by perform_implicit_conversion_flags. */
#define IMPLICIT_CONV_EXPR_DIRECT_INIT(NODE) \
PARM_DECLs in cp_tree_equal. */
extern int comparing_specializations;
+/* A type-qualifier, or bitmask therefore, using the TYPE_QUAL
+ constants. */
+
+typedef int cp_cv_quals;
+
/* In parser.c. */
/* Nonzero if we are parsing an unevaluated operand: an operand to
extern int cp_unevaluated_operand;
extern tree cp_convert_range_for (tree, tree, tree, bool);
extern bool parsing_nsdmi (void);
+extern void inject_this_parameter (tree, cp_cv_quals);
/* in pt.c */
extern GTY(()) operator_name_info_t assignment_operator_name_info
[(int) MAX_TREE_CODES];
-/* A type-qualifier, or bitmask therefore, using the TYPE_QUAL
- constants. */
-
-typedef int cp_cv_quals;
-
/* Non-static member functions have an optional virt-specifier-seq.
There is a VIRT_SPEC value for each virt-specifier.
They can be combined by bitwise-or to form the complete set of
extern tree build_zero_init (tree, tree, bool);
extern tree build_value_init (tree, tsubst_flags_t);
extern tree build_value_init_noctor (tree, tsubst_flags_t);
+extern tree get_nsdmi (tree, bool);
extern tree build_offset_ref (tree, tree, bool,
tsubst_flags_t);
extern tree throw_bad_array_new_length (void);
extern void check_narrowing (tree, tree);
extern tree digest_init (tree, tree, tsubst_flags_t);
extern tree digest_init_flags (tree, tree, int);
+extern tree digest_nsdmi_init (tree, tree);
extern tree build_scoped_ref (tree, tree, tree *);
extern tree build_x_arrow (location_t, tree,
tsubst_flags_t);
extern tree cxx_omp_clause_copy_ctor (tree, tree, tree);
extern tree cxx_omp_clause_assign_op (tree, tree, tree);
extern tree cxx_omp_clause_dtor (tree, tree);
-extern void cxx_omp_finish_clause (tree);
+extern void cxx_omp_finish_clause (tree, gimple_seq *);
extern bool cxx_omp_privatize_by_reference (const_tree);
/* in name-lookup.c */
if (vec_safe_is_empty (typenames) || uses_template_parms (args))
return;
+ /* Don't try to print typenames when we're processing a clone. */
+ if (current_function_decl
+ && !DECL_LANG_SPECIFIC (current_function_decl))
+ return;
+
FOR_EACH_VEC_SAFE_ELT (typenames, i, t)
{
if (need_semicolon)
}
}
+/* Return the non-static data initializer for FIELD_DECL MEMBER. */
+
+tree
+get_nsdmi (tree member, bool in_ctor)
+{
+ tree init;
+ tree save_ccp = current_class_ptr;
+ tree save_ccr = current_class_ref;
+ if (!in_ctor)
+ inject_this_parameter (DECL_CONTEXT (member), TYPE_UNQUALIFIED);
+ if (DECL_LANG_SPECIFIC (member) && DECL_TEMPLATE_INFO (member))
+ {
+ /* Do deferred instantiation of the NSDMI. */
+ init = (tsubst_copy_and_build
+ (DECL_INITIAL (DECL_TI_TEMPLATE (member)),
+ DECL_TI_ARGS (member),
+ tf_warning_or_error, member, /*function_p=*/false,
+ /*integral_constant_expression_p=*/false));
+
+ init = digest_nsdmi_init (member, init);
+ }
+ else
+ {
+ init = DECL_INITIAL (member);
+ if (init && TREE_CODE (init) == DEFAULT_ARG)
+ {
+ error ("constructor required before non-static data member "
+ "for %qD has been parsed", member);
+ DECL_INITIAL (member) = error_mark_node;
+ init = NULL_TREE;
+ }
+ /* Strip redundant TARGET_EXPR so we don't need to remap it, and
+ so the aggregate init code below will see a CONSTRUCTOR. */
+ if (init && TREE_CODE (init) == TARGET_EXPR
+ && !VOID_TYPE_P (TREE_TYPE (TARGET_EXPR_INITIAL (init))))
+ init = TARGET_EXPR_INITIAL (init);
+ init = break_out_target_exprs (init);
+ }
+ current_class_ptr = save_ccp;
+ current_class_ref = save_ccr;
+ return init;
+}
+
/* Initialize MEMBER, a FIELD_DECL, with INIT, a TREE_LIST of
arguments. If TREE_LIST is void_type_node, an empty initializer
list was given; if NULL_TREE no initializer was given. */
/* Use the non-static data member initializer if there was no
mem-initializer for this field. */
if (init == NULL_TREE)
- {
- if (DECL_LANG_SPECIFIC (member) && DECL_TEMPLATE_INFO (member))
- /* Do deferred instantiation of the NSDMI. */
- init = (tsubst_copy_and_build
- (DECL_INITIAL (DECL_TI_TEMPLATE (member)),
- DECL_TI_ARGS (member),
- tf_warning_or_error, member, /*function_p=*/false,
- /*integral_constant_expression_p=*/false));
- else
- {
- init = DECL_INITIAL (member);
- if (init && TREE_CODE (init) == DEFAULT_ARG)
- {
- error ("constructor required before non-static data member "
- "for %qD has been parsed", member);
- init = NULL_TREE;
- }
- /* Strip redundant TARGET_EXPR so we don't need to remap it, and
- so the aggregate init code below will see a CONSTRUCTOR. */
- if (init && TREE_CODE (init) == TARGET_EXPR
- && !VOID_TYPE_P (TREE_TYPE (TARGET_EXPR_INITIAL (init))))
- init = TARGET_EXPR_INITIAL (init);
- init = break_out_target_exprs (init);
- }
- }
+ init = get_nsdmi (member, /*ctor*/true);
if (init == error_mark_node)
return;
if (tcontext != NULL_TREE)
return tcontext;
+ if (TREE_CODE (decl) == TEMPLATE_DECL
+ && DECL_TEMPLATE_RESULT (decl))
+ decl = DECL_TEMPLATE_RESULT (decl);
+
if (TREE_CODE (decl) == TYPE_DECL
&& LAMBDA_TYPE_P (TREE_TYPE (decl)))
{
static tree cp_parser_userdef_char_literal
(cp_parser *);
static tree cp_parser_userdef_string_literal
- (cp_token *);
+ (tree);
static tree cp_parser_userdef_numeric_literal
(cp_parser *);
{
tree literal = build_userdef_literal (suffix_id, value,
OT_NONE, NULL_TREE);
- tok->u.value = literal;
- return cp_parser_userdef_string_literal (tok);
+ value = cp_parser_userdef_string_literal (literal);
}
}
else
as arguments. */
static tree
-cp_parser_userdef_string_literal (cp_token *token)
+cp_parser_userdef_string_literal (tree literal)
{
- tree literal = token->u.value;
tree suffix_id = USERDEF_LITERAL_SUFFIX_ID (literal);
tree name = cp_literal_operator_id (IDENTIFIER_POINTER (suffix_id));
tree value = USERDEF_LITERAL_VALUE (literal);
return cp_parser_make_typename_type (parser, parser->scope,
identifier,
token->location);
+
+ /* Template parameter lists apply only if we are not within a
+ function parameter list. */
+ bool template_parm_lists_apply
+ = parser->num_template_parameter_lists;
+ if (template_parm_lists_apply)
+ for (cp_binding_level *s = current_binding_level;
+ s && s->kind != sk_template_parms;
+ s = s->level_chain)
+ if (s->kind == sk_function_parms)
+ template_parm_lists_apply = false;
+
/* Look up a qualified name in the usual way. */
if (parser->scope)
{
decl = (cp_parser_maybe_treat_template_as_class
(decl, /*tag_name_p=*/is_friend
- && parser->num_template_parameter_lists));
+ && template_parm_lists_apply));
if (TREE_CODE (decl) != TYPE_DECL)
{
if (TREE_CODE (TREE_TYPE (decl)) != TYPENAME_TYPE)
{
- bool allow_template = (parser->num_template_parameter_lists
- || DECL_SELF_REFERENCE_P (decl));
- type = check_elaborated_type_specifier (tag_type, decl,
+ bool allow_template = (template_parm_lists_apply
+ || DECL_SELF_REFERENCE_P (decl));
+ type = check_elaborated_type_specifier (tag_type, decl,
allow_template);
if (type == error_mark_node)
ts = ts_global;
template_p =
- (parser->num_template_parameter_lists
+ (template_parm_lists_apply
&& (cp_parser_next_token_starts_class_definition_p (parser)
|| cp_lexer_next_token_is (parser->lexer, CPP_SEMICOLON)));
/* An unqualified name was used to reference this type, so
there were no qualifying templates. */
- if (!cp_parser_check_template_parameters (parser,
- /*num_templates=*/0,
- token->location,
- /*declarator=*/NULL))
+ if (template_parm_lists_apply
+ && !cp_parser_check_template_parameters (parser,
+ /*num_templates=*/0,
+ token->location,
+ /*declarator=*/NULL))
return error_mark_node;
type = xref_tag (tag_type, identifier, ts, template_p);
}
/* Used by handling of trailing-return-types and NSDMI, in which 'this'
is in scope even though it isn't real. */
-static void
+void
inject_this_parameter (tree ctype, cp_cv_quals quals)
{
tree this_parm;
ok = false;
}
if (!ok)
- error ("literal operator template %qD has invalid parameter list."
- " Expected non-type template argument pack <char...>"
- " or <typename CharT, CharT...>",
- decl);
+ {
+ if (cxx_dialect >= cxx1y)
+ error ("literal operator template %qD has invalid parameter list."
+ " Expected non-type template argument pack <char...>"
+ " or <typename CharT, CharT...>",
+ decl);
+ else
+ error ("literal operator template %qD has invalid parameter list."
+ " Expected non-type template argument pack <char...>",
+ decl);
+ }
}
/* Register member declarations. */
if (member_p && !friend_p && decl && !DECL_CLASS_TEMPLATE_P (decl))
parsed_arg = check_default_argument (parmtype, parsed_arg,
tf_warning_or_error);
else
- {
- int flags = LOOKUP_IMPLICIT;
- if (BRACE_ENCLOSED_INITIALIZER_P (parsed_arg)
- && CONSTRUCTOR_IS_DIRECT_INIT (parsed_arg))
- flags = LOOKUP_NORMAL;
- parsed_arg = digest_init_flags (TREE_TYPE (decl), parsed_arg, flags);
- if (TREE_CODE (parsed_arg) == TARGET_EXPR)
- /* This represents the whole initialization. */
- TARGET_EXPR_DIRECT_INIT_P (parsed_arg) = true;
- }
+ parsed_arg = digest_nsdmi_init (decl, parsed_arg);
}
/* If the token stream has not been completely used up, then
return true;
if (cxx_dialect >= cxx11 && null_member_pointer_value_p (expr))
return true;
+ if (processing_template_decl
+ && TREE_CODE (expr) == ADDR_EXPR
+ && TREE_CODE (TREE_OPERAND (expr, 0)) == OFFSET_REF)
+ return true;
if (complain & tf_error)
{
error ("%qE is not a valid template argument for type %qT",
maybe_adjust_types_for_deduction (strict, &parm, &arg, arg_expr);
}
else
- gcc_assert ((TYPE_P (parm) || TREE_CODE (parm) == TEMPLATE_DECL)
- == (TYPE_P (arg) || TREE_CODE (arg) == TEMPLATE_DECL));
+ if ((TYPE_P (parm) || TREE_CODE (parm) == TEMPLATE_DECL)
+ != (TYPE_P (arg) || TREE_CODE (arg) == TEMPLATE_DECL))
+ return unify_template_argument_mismatch (explain_p, parm, arg);
/* For deduction from an init-list we need the actual list. */
if (arg_expr && BRACE_ENCLOSED_INITIALIZER_P (arg_expr))
return true;
if (BASELINK_P (expression))
- expression = BASELINK_FUNCTIONS (expression);
+ {
+ if (BASELINK_OPTYPE (expression)
+ && dependent_type_p (BASELINK_OPTYPE (expression)))
+ return true;
+ expression = BASELINK_FUNCTIONS (expression);
+ }
if (TREE_CODE (expression) == TEMPLATE_ID_EXPR)
{
if ((!at_function_scope_p () || CP_TYPE_CONST_P (type))
&& TREE_CODE (type) == ARRAY_TYPE
&& !TYPE_HAS_NONTRIVIAL_DESTRUCTOR (type)
- && !cp_unevaluated_operand
&& initializer_constant_valid_p (compound_literal, type))
{
tree decl = create_temporary_var (type);
aggr_init_expr_nargs (aggr_init_expr),
AGGR_INIT_EXPR_ARGP (aggr_init_expr));
TREE_NOTHROW (call_expr) = TREE_NOTHROW (aggr_init_expr);
+ CALL_EXPR_LIST_INIT_P (call_expr) = CALL_EXPR_LIST_INIT_P (aggr_init_expr);
if (style == ctor)
{
break;
}
}
+ else
+ t = fold_convert (TREE_TYPE (OMP_CLAUSE_DECL (c)), t);
}
OMP_CLAUSE_LINEAR_STEP (c) = t;
}
case IMAGPART_EXPR:
return lvalue_kind (TREE_OPERAND (ref, 0));
+ case MEMBER_REF:
+ case DOTSTAR_EXPR:
+ if (TREE_CODE (ref) == MEMBER_REF)
+ op1_lvalue_kind = clk_ordinary;
+ else
+ op1_lvalue_kind = lvalue_kind (TREE_OPERAND (ref, 0));
+ if (TYPE_PTRMEMFUNC_P (TREE_TYPE (TREE_OPERAND (ref, 1))))
+ op1_lvalue_kind = clk_none;
+ return op1_lvalue_kind;
+
case COMPONENT_REF:
op1_lvalue_kind = lvalue_kind (TREE_OPERAND (ref, 0));
/* Look at the member designator. */
TREE_SIDE_EFFECTS (rval) = 1;
AGGR_INIT_VIA_CTOR_P (rval) = is_ctor;
TREE_NOTHROW (rval) = TREE_NOTHROW (init);
+ CALL_EXPR_LIST_INIT_P (rval) = CALL_EXPR_LIST_INIT_P (init);
}
else
rval = init;
{
return digest_init_r (type, init, false, flags, tf_warning_or_error);
}
+
+/* Process the initializer INIT for an NSDMI DECL (a FIELD_DECL). */
+tree
+digest_nsdmi_init (tree decl, tree init)
+{
+ gcc_assert (TREE_CODE (decl) == FIELD_DECL);
+
+ int flags = LOOKUP_IMPLICIT;
+ if (DIRECT_LIST_INIT_P (init))
+ flags = LOOKUP_NORMAL;
+ init = digest_init_flags (TREE_TYPE (decl), init, flags);
+ if (TREE_CODE (init) == TARGET_EXPR)
+ /* This represents the whole initialization. */
+ TARGET_EXPR_DIRECT_INIT_P (init) = true;
+ return init;
+}
\f
/* Set of flags used within process_init_constructor to describe the
initializers. */
@c This is part of the GCC manual.
@c For copying conditions, see the file gcc.texi.
-@c This file is generated automatically using gcc/config/arm/neon-docgen.ml
-@c Please do not edit manually.
@subsubsection Addition
@itemize @bullet
@end html
@anchor{aarch64-x-x}
@heading aarch64*-*-*
-Pre 2.24 binutils does not have support for selecting -mabi and does not
-support ILP32. If GCC 4.9 or later is built with pre 2.24, GCC will not
-support option -mabi=ilp32.
+Binutils pre 2.24 does not have support for selecting @option{-mabi} and
+does not support ILP32. If it is used to build GCC 4.9 or later, GCC will
+not support option @option{-mabi=ilp32}.
@html
<hr />
optab lrotate_optab = rotl_optab;
optab rrotate_optab = rotr_optab;
enum machine_mode op1_mode;
+ enum machine_mode scalar_mode = mode;
int attempt;
bool speed = optimize_insn_for_speed_p ();
+ if (VECTOR_MODE_P (mode))
+ scalar_mode = GET_MODE_INNER (mode);
op1 = amount;
op1_mode = GET_MODE (op1);
{
if (CONST_INT_P (op1)
&& ((unsigned HOST_WIDE_INT) INTVAL (op1) >=
- (unsigned HOST_WIDE_INT) GET_MODE_BITSIZE (mode)))
+ (unsigned HOST_WIDE_INT) GET_MODE_BITSIZE (scalar_mode)))
op1 = GEN_INT ((unsigned HOST_WIDE_INT) INTVAL (op1)
- % GET_MODE_BITSIZE (mode));
+ % GET_MODE_BITSIZE (scalar_mode));
else if (GET_CODE (op1) == SUBREG
&& subreg_lowpart_p (op1)
&& SCALAR_INT_MODE_P (GET_MODE (SUBREG_REG (op1)))
amount instead. */
if (rotate
&& CONST_INT_P (op1)
- && IN_RANGE (INTVAL (op1), GET_MODE_BITSIZE (mode) / 2 + left,
- GET_MODE_BITSIZE (mode) - 1))
+ && IN_RANGE (INTVAL (op1), GET_MODE_BITSIZE (scalar_mode) / 2 + left,
+ GET_MODE_BITSIZE (scalar_mode) - 1))
{
- op1 = GEN_INT (GET_MODE_BITSIZE (mode) - INTVAL (op1));
+ op1 = GEN_INT (GET_MODE_BITSIZE (scalar_mode) - INTVAL (op1));
left = !left;
code = left ? LROTATE_EXPR : RROTATE_EXPR;
}
if (code == LSHIFT_EXPR
&& CONST_INT_P (op1)
&& INTVAL (op1) > 0
- && INTVAL (op1) < GET_MODE_PRECISION (mode)
+ && INTVAL (op1) < GET_MODE_PRECISION (scalar_mode)
&& INTVAL (op1) < MAX_BITS_PER_WORD
&& (shift_cost (speed, mode, INTVAL (op1))
> INTVAL (op1) * add_cost (speed, mode))
if (op1 == const0_rtx)
return shifted;
else if (CONST_INT_P (op1))
- other_amount = GEN_INT (GET_MODE_BITSIZE (mode)
+ other_amount = GEN_INT (GET_MODE_BITSIZE (scalar_mode)
- INTVAL (op1));
else
{
other_amount
= simplify_gen_unary (NEG, GET_MODE (op1),
op1, GET_MODE (op1));
- HOST_WIDE_INT mask = GET_MODE_PRECISION (mode) - 1;
+ HOST_WIDE_INT mask = GET_MODE_PRECISION (scalar_mode) - 1;
other_amount
= simplify_gen_binary (AND, GET_MODE (op1), other_amount,
gen_int_mode (mask, GET_MODE (op1)));
+2014-07-07 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/61459
+ PR fortran/58883
+ * trans-expr.c (fcncall_realloc_result): Use the natural type
+ for the address expression of 'res_desc'.
+
+2014-07-07 Dominique d'Humieres <dominiq@lps.ens.fr>
+ Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/41936
+ * trans-expr.c (gfc_conv_expr_reference): Deallocate array
+ components.
+
+2014-07-02 Jakub Jelinek <jakub@redhat.com>
+ Fritz Reese <Reese-Fritz@zai.com>
+
+ * decl.c (variable_decl): Reject old style initialization
+ for derived type components.
+
+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.
+
2014-06-15 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Backport from trunk.
cpp_define (pfile, "_LANGUAGE_FORTRAN=1");
if (gfc_option.gfc_flag_openmp)
- cpp_define (pfile, "_OPENMP=201107");
+ cpp_define (pfile, "_OPENMP=201307");
/* The defines below are necessary for the TARGET_* macros.
if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
"initialization at %C"))
return MATCH_ERROR;
+ else if (gfc_current_state () == COMP_DERIVED)
+ {
+ gfc_error ("Invalid old style initialization for derived type "
+ "component at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
return match_old_style_init (name);
}
}
static void
-show_namelist (gfc_namelist *n)
+show_omp_namelist (int list_type, gfc_omp_namelist *n)
{
- for (; n->next; n = n->next)
- fprintf (dumpfile, "%s,", n->sym->name);
- fprintf (dumpfile, "%s", n->sym->name);
+ for (; n; n = n->next)
+ {
+ if (list_type == OMP_LIST_REDUCTION)
+ switch (n->u.reduction_op)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ fprintf (dumpfile, "%s:",
+ gfc_op2string ((gfc_intrinsic_op) n->u.reduction_op));
+ break;
+ case OMP_REDUCTION_MAX: fputs ("max:", dumpfile); break;
+ case OMP_REDUCTION_MIN: fputs ("min:", dumpfile); break;
+ case OMP_REDUCTION_IAND: fputs ("iand:", dumpfile); break;
+ case OMP_REDUCTION_IOR: fputs ("ior:", dumpfile); break;
+ case OMP_REDUCTION_IEOR: fputs ("ieor:", dumpfile); break;
+ case OMP_REDUCTION_USER:
+ if (n->udr)
+ fprintf (dumpfile, "%s:", n->udr->udr->name);
+ break;
+ default: break;
+ }
+ else if (list_type == OMP_LIST_DEPEND)
+ switch (n->u.depend_op)
+ {
+ case OMP_DEPEND_IN: fputs ("in:", dumpfile); break;
+ case OMP_DEPEND_OUT: fputs ("out:", dumpfile); break;
+ case OMP_DEPEND_INOUT: fputs ("inout:", dumpfile); break;
+ default: break;
+ }
+ else if (list_type == OMP_LIST_MAP)
+ switch (n->u.map_op)
+ {
+ case OMP_MAP_ALLOC: fputs ("alloc:", dumpfile); break;
+ case OMP_MAP_TO: fputs ("to:", dumpfile); break;
+ case OMP_MAP_FROM: fputs ("from:", dumpfile); break;
+ case OMP_MAP_TOFROM: fputs ("tofrom:", dumpfile); break;
+ default: break;
+ }
+ fprintf (dumpfile, "%s", n->sym->name);
+ if (n->expr)
+ {
+ fputc (':', dumpfile);
+ show_expr (n->expr);
+ }
+ if (n->next)
+ fputc (',', dumpfile);
+ }
}
/* Show a single OpenMP directive node and everything underneath it
{
case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
case EXEC_OMP_BARRIER: name = "BARRIER"; break;
+ case EXEC_OMP_CANCEL: name = "CANCEL"; break;
+ case EXEC_OMP_CANCELLATION_POINT: name = "CANCELLATION POINT"; break;
case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
case EXEC_OMP_FLUSH: name = "FLUSH"; break;
case EXEC_OMP_DO: name = "DO"; break;
+ case EXEC_OMP_DO_SIMD: name = "DO SIMD"; break;
case EXEC_OMP_MASTER: name = "MASTER"; break;
case EXEC_OMP_ORDERED: name = "ORDERED"; break;
case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_DO_SIMD: name = "PARALLEL DO SIMD"; break;
case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
+ case EXEC_OMP_SIMD: name = "SIMD"; break;
case EXEC_OMP_SINGLE: name = "SINGLE"; break;
case EXEC_OMP_TASK: name = "TASK"; break;
+ case EXEC_OMP_TASKGROUP: name = "TASKGROUP"; break;
case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
case EXEC_OMP_TASKYIELD: name = "TASKYIELD"; break;
case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
fprintf (dumpfile, "!$OMP %s", name);
switch (c->op)
{
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
if (c->ext.omp_namelist)
{
fputs (" (", dumpfile);
- show_namelist (c->ext.omp_namelist);
+ show_omp_namelist (OMP_LIST_NUM, c->ext.omp_namelist);
fputc (')', dumpfile);
}
return;
{
int list_type;
+ switch (omp_clauses->cancel)
+ {
+ case OMP_CANCEL_UNKNOWN:
+ break;
+ case OMP_CANCEL_PARALLEL:
+ fputs (" PARALLEL", dumpfile);
+ break;
+ case OMP_CANCEL_SECTIONS:
+ fputs (" SECTIONS", dumpfile);
+ break;
+ case OMP_CANCEL_DO:
+ fputs (" DO", dumpfile);
+ break;
+ case OMP_CANCEL_TASKGROUP:
+ fputs (" TASKGROUP", dumpfile);
+ break;
+ }
if (omp_clauses->if_expr)
{
fputs (" IF(", dumpfile);
if (omp_clauses->lists[list_type] != NULL
&& list_type != OMP_LIST_COPYPRIVATE)
{
- const char *type;
- if (list_type >= OMP_LIST_REDUCTION_FIRST)
+ const char *type = NULL;
+ switch (list_type)
{
- switch (list_type)
- {
- case OMP_LIST_PLUS: type = "+"; break;
- case OMP_LIST_MULT: type = "*"; break;
- case OMP_LIST_SUB: type = "-"; break;
- case OMP_LIST_AND: type = ".AND."; break;
- case OMP_LIST_OR: type = ".OR."; break;
- case OMP_LIST_EQV: type = ".EQV."; break;
- case OMP_LIST_NEQV: type = ".NEQV."; break;
- case OMP_LIST_MAX: type = "MAX"; break;
- case OMP_LIST_MIN: type = "MIN"; break;
- case OMP_LIST_IAND: type = "IAND"; break;
- case OMP_LIST_IOR: type = "IOR"; break;
- case OMP_LIST_IEOR: type = "IEOR"; break;
- default:
- gcc_unreachable ();
- }
- fprintf (dumpfile, " REDUCTION(%s:", type);
+ case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
+ case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
+ case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
+ case OMP_LIST_SHARED: type = "SHARED"; break;
+ case OMP_LIST_COPYIN: type = "COPYIN"; break;
+ case OMP_LIST_UNIFORM: type = "UNIFORM"; break;
+ case OMP_LIST_ALIGNED: type = "ALIGNED"; break;
+ case OMP_LIST_LINEAR: type = "LINEAR"; break;
+ case OMP_LIST_REDUCTION: type = "REDUCTION"; break;
+ case OMP_LIST_DEPEND: type = "DEPEND"; break;
+ default:
+ gcc_unreachable ();
}
- else
- {
- switch (list_type)
- {
- case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
- case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
- case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
- case OMP_LIST_SHARED: type = "SHARED"; break;
- case OMP_LIST_COPYIN: type = "COPYIN"; break;
- default:
- gcc_unreachable ();
- }
- fprintf (dumpfile, " %s(", type);
- }
- show_namelist (omp_clauses->lists[list_type]);
+ fprintf (dumpfile, " %s(", type);
+ show_omp_namelist (list_type, omp_clauses->lists[list_type]);
fputc (')', dumpfile);
}
+ if (omp_clauses->safelen_expr)
+ {
+ fputs (" SAFELEN(", dumpfile);
+ show_expr (omp_clauses->safelen_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->simdlen_expr)
+ {
+ fputs (" SIMDLEN(", dumpfile);
+ show_expr (omp_clauses->simdlen_expr);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->inbranch)
+ fputs (" INBRANCH", dumpfile);
+ if (omp_clauses->notinbranch)
+ fputs (" NOTINBRANCH", dumpfile);
+ if (omp_clauses->proc_bind != OMP_PROC_BIND_UNKNOWN)
+ {
+ const char *type;
+ switch (omp_clauses->proc_bind)
+ {
+ case OMP_PROC_BIND_MASTER: type = "MASTER"; break;
+ case OMP_PROC_BIND_SPREAD: type = "SPREAD"; break;
+ case OMP_PROC_BIND_CLOSE: type = "CLOSE"; break;
+ default:
+ gcc_unreachable ();
+ }
+ fprintf (dumpfile, " PROC_BIND(%s)", type);
+ }
+ if (omp_clauses->num_teams)
+ {
+ fputs (" NUM_TEAMS(", dumpfile);
+ show_expr (omp_clauses->num_teams);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->device)
+ {
+ fputs (" DEVICE(", dumpfile);
+ show_expr (omp_clauses->device);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->thread_limit)
+ {
+ fputs (" THREAD_LIMIT(", dumpfile);
+ show_expr (omp_clauses->thread_limit);
+ fputc (')', dumpfile);
+ }
+ if (omp_clauses->dist_sched_kind != OMP_SCHED_NONE)
+ {
+ fprintf (dumpfile, " DIST_SCHEDULE (static");
+ if (omp_clauses->dist_chunk_size)
+ {
+ fputc (',', dumpfile);
+ show_expr (omp_clauses->dist_chunk_size);
+ }
+ fputc (')', dumpfile);
+ }
}
fputc ('\n', dumpfile);
if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
show_code (level + 1, c->block->next);
if (c->op == EXEC_OMP_ATOMIC)
return;
+ fputc ('\n', dumpfile);
code_indent (level, 0);
fprintf (dumpfile, "!$OMP END %s", name);
if (omp_clauses != NULL)
if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
{
fputs (" COPYPRIVATE(", dumpfile);
- show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
+ show_omp_namelist (OMP_LIST_COPYPRIVATE,
+ omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
fputc (')', dumpfile);
}
else if (omp_clauses->nowait)
break;
case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
static void gfc_init_ts (void);
static tree gfc_builtin_function (tree);
+/* Handle an "omp declare target" attribute; arguments as in
+ struct attribute_spec.handler. */
+static tree
+gfc_handle_omp_declare_target_attribute (tree *, tree, tree, int, bool *)
+{
+ return NULL_TREE;
+}
+
+/* Table of valid Fortran attributes. */
+static const struct attribute_spec gfc_attribute_table[] =
+{
+ /* { name, min_len, max_len, decl_req, type_req, fn_type_req, handler,
+ affects_type_identity } */
+ { "omp declare target", 0, 0, true, false, false,
+ gfc_handle_omp_declare_target_attribute, false },
+ { NULL, 0, 0, false, false, false, NULL, false }
+};
+
#undef LANG_HOOKS_NAME
#undef LANG_HOOKS_INIT
#undef LANG_HOOKS_FINISH
#undef LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR
#undef LANG_HOOKS_OMP_CLAUSE_COPY_CTOR
#undef LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP
+#undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR
#undef LANG_HOOKS_OMP_CLAUSE_DTOR
+#undef LANG_HOOKS_OMP_FINISH_CLAUSE
#undef LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR
#undef LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE
#undef LANG_HOOKS_OMP_PRIVATE_OUTER_REF
#undef LANG_HOOKS_BUILTIN_FUNCTION
#undef LANG_HOOKS_BUILTIN_FUNCTION
#undef LANG_HOOKS_GET_ARRAY_DESCR_INFO
+#undef LANG_HOOKS_ATTRIBUTE_TABLE
/* Define lang hooks. */
#define LANG_HOOKS_NAME "GNU Fortran"
#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR gfc_omp_clause_default_ctor
#define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR gfc_omp_clause_copy_ctor
#define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP gfc_omp_clause_assign_op
+#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor
#define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor
+#define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause
#define LANG_HOOKS_OMP_DISREGARD_VALUE_EXPR gfc_omp_disregard_value_expr
#define LANG_HOOKS_OMP_PRIVATE_DEBUG_CLAUSE gfc_omp_private_debug_clause
#define LANG_HOOKS_OMP_PRIVATE_OUTER_REF gfc_omp_private_outer_ref
#define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
gfc_omp_firstprivatize_type_sizes
-#define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function
-#define LANG_HOOKS_GET_ARRAY_DESCR_INFO gfc_get_array_descr_info
+#define LANG_HOOKS_BUILTIN_FUNCTION gfc_builtin_function
+#define LANG_HOOKS_GET_ARRAY_DESCR_INFO gfc_get_array_descr_info
+#define LANG_HOOKS_ATTRIBUTE_TABLE gfc_attribute_table
struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
#include "../sync-builtins.def"
#undef DEF_SYNC_BUILTIN
- if (gfc_option.gfc_flag_openmp || flag_tree_parallelize_loops)
+ if (gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd
+ || flag_tree_parallelize_loops)
{
#undef DEF_GOMP_BUILTIN
#define DEF_GOMP_BUILTIN(code, name, type, attr) \
BUILT_IN_TRAP, NULL, ATTR_NOTHROW_LEAF_LIST);
TREE_THIS_VOLATILE (builtin_decl_explicit (BUILT_IN_TRAP)) = 1;
+ ftype = build_varargs_function_type_list (ptr_type_node, const_ptr_type_node,
+ size_type_node, NULL_TREE);
+ gfc_define_builtin ("__builtin_assume_aligned", ftype,
+ BUILT_IN_ASSUME_ALIGNED,
+ "__builtin_assume_aligned",
+ ATTR_CONST_NOTHROW_LEAF_LIST);
+
gfc_define_builtin ("__emutls_get_address",
builtin_types[BT_FN_PTR_PTR],
BUILT_IN_EMUTLS_GET_ADDRESS,
/* Dummy function for code callback, for use when we really
don't want to do anything. */
-static int
-dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
- int *walk_subtrees ATTRIBUTE_UNUSED,
- void *data ATTRIBUTE_UNUSED)
+int
+gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
+ int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
{
return 0;
}
optimize_reduction (gfc_namespace *ns)
{
current_ns = ns;
- gfc_code_walker (&ns->code, dummy_code_callback, callback_reduction, NULL);
+ gfc_code_walker (&ns->code, gfc_dummy_code_callback,
+ callback_reduction, NULL);
/* BLOCKs are handled in the expression walker below. */
for (ns = ns->contained; ns; ns = ns->sibling)
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
in_omp_workshare = false;
in_omp_workshare = true;
/* Fall through */
-
+
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_END_SINGLE:
+ case EXEC_OMP_SIMD:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ 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:
+ case EXEC_OMP_TARGET_UPDATE:
case EXEC_OMP_TASK:
+ 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:
/* Come to this label only from the
EXEC_OMP_PARALLEL_* cases above. */
if (co->ext.omp_clauses)
{
+ gfc_omp_namelist *n;
+ static int list_types[]
+ = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
+ OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
+ size_t idx;
WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
+ WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
+ WALK_SUBEXPR (co->ext.omp_clauses->device);
+ WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
+ WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
+ for (idx = 0;
+ idx < sizeof (list_types) / sizeof (list_types[0]);
+ idx++)
+ for (n = co->ext.omp_clauses->lists[list_types[idx]];
+ n; n = n->next)
+ WALK_SUBEXPR (n->expr);
}
break;
default:
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
- ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL,
- ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
+ ST_OMP_TASKWAIT, ST_OMP_TASKYIELD, ST_OMP_CANCEL, ST_OMP_CANCELLATION_POINT,
+ ST_OMP_TASKGROUP, ST_OMP_END_TASKGROUP, ST_OMP_SIMD, ST_OMP_END_SIMD,
+ ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
+ ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
+ 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,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
+ ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
+ ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
}
gfc_statement;
variable for SELECT_TYPE or ASSOCIATE. */
unsigned select_type_temporary:1, associate_var:1;
+ /* This is omp_{out,in,priv,orig} artificial variable in
+ !$OMP DECLARE REDUCTION. */
+ unsigned omp_udr_artificial_var:1;
+
+ /* Mentioned in OMP DECLARE TARGET. */
+ unsigned omp_declare_target:1;
+
/* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */
unsigned ext_attr:EXT_ATTR_NUM;
#define gfc_get_namelist() XCNEW (gfc_namelist)
+typedef enum
+{
+ OMP_REDUCTION_NONE = -1,
+ OMP_REDUCTION_PLUS = INTRINSIC_PLUS,
+ OMP_REDUCTION_MINUS = INTRINSIC_MINUS,
+ OMP_REDUCTION_TIMES = INTRINSIC_TIMES,
+ OMP_REDUCTION_AND = INTRINSIC_AND,
+ OMP_REDUCTION_OR = INTRINSIC_OR,
+ OMP_REDUCTION_EQV = INTRINSIC_EQV,
+ OMP_REDUCTION_NEQV = INTRINSIC_NEQV,
+ OMP_REDUCTION_MAX = GFC_INTRINSIC_END,
+ OMP_REDUCTION_MIN,
+ OMP_REDUCTION_IAND,
+ OMP_REDUCTION_IOR,
+ OMP_REDUCTION_IEOR,
+ OMP_REDUCTION_USER
+}
+gfc_omp_reduction_op;
+
+typedef enum
+{
+ OMP_DEPEND_IN,
+ OMP_DEPEND_OUT,
+ OMP_DEPEND_INOUT
+}
+gfc_omp_depend_op;
+
+typedef enum
+{
+ OMP_MAP_ALLOC,
+ OMP_MAP_TO,
+ OMP_MAP_FROM,
+ OMP_MAP_TOFROM
+}
+gfc_omp_map_op;
+
+/* For use in OpenMP clauses in case we need extra information
+ (aligned clause alignment, linear clause step, etc.). */
+
+typedef struct gfc_omp_namelist
+{
+ struct gfc_symbol *sym;
+ struct gfc_expr *expr;
+ union
+ {
+ gfc_omp_reduction_op reduction_op;
+ gfc_omp_depend_op depend_op;
+ gfc_omp_map_op map_op;
+ } u;
+ struct gfc_omp_namelist_udr *udr;
+ struct gfc_omp_namelist *next;
+}
+gfc_omp_namelist;
+
+#define gfc_get_omp_namelist() XCNEW (gfc_omp_namelist)
+
enum
{
OMP_LIST_PRIVATE,
OMP_LIST_COPYPRIVATE,
OMP_LIST_SHARED,
OMP_LIST_COPYIN,
- OMP_LIST_PLUS,
- OMP_LIST_REDUCTION_FIRST = OMP_LIST_PLUS,
- 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 = OMP_LIST_IEOR,
+ OMP_LIST_UNIFORM,
+ OMP_LIST_ALIGNED,
+ OMP_LIST_LINEAR,
+ OMP_LIST_DEPEND,
+ OMP_LIST_MAP,
+ OMP_LIST_TO,
+ OMP_LIST_FROM,
+ OMP_LIST_REDUCTION,
OMP_LIST_NUM
};
OMP_DEFAULT_FIRSTPRIVATE
};
+enum gfc_omp_proc_bind_kind
+{
+ OMP_PROC_BIND_UNKNOWN,
+ OMP_PROC_BIND_MASTER,
+ OMP_PROC_BIND_SPREAD,
+ OMP_PROC_BIND_CLOSE
+};
+
+enum gfc_omp_cancel_kind
+{
+ OMP_CANCEL_UNKNOWN,
+ OMP_CANCEL_PARALLEL,
+ OMP_CANCEL_SECTIONS,
+ OMP_CANCEL_DO,
+ OMP_CANCEL_TASKGROUP
+};
+
typedef struct gfc_omp_clauses
{
struct gfc_expr *if_expr;
struct gfc_expr *final_expr;
struct gfc_expr *num_threads;
- gfc_namelist *lists[OMP_LIST_NUM];
+ gfc_omp_namelist *lists[OMP_LIST_NUM];
enum gfc_omp_sched_kind sched_kind;
struct gfc_expr *chunk_size;
enum gfc_omp_default_sharing default_sharing;
int collapse;
bool nowait, ordered, untied, mergeable;
+ bool inbranch, notinbranch;
+ enum gfc_omp_cancel_kind cancel;
+ enum gfc_omp_proc_bind_kind proc_bind;
+ struct gfc_expr *safelen_expr;
+ struct gfc_expr *simdlen_expr;
+ struct gfc_expr *num_teams;
+ struct gfc_expr *device;
+ struct gfc_expr *thread_limit;
+ enum gfc_omp_sched_kind dist_sched_kind;
+ struct gfc_expr *dist_chunk_size;
}
gfc_omp_clauses;
#define gfc_get_omp_clauses() XCNEW (gfc_omp_clauses)
+/* Node in the linked list used for storing !$omp declare simd constructs. */
+
+typedef struct gfc_omp_declare_simd
+{
+ struct gfc_omp_declare_simd *next;
+ locus where; /* Where the !$omp declare simd construct occurred. */
+
+ gfc_symbol *proc_name;
+
+ gfc_omp_clauses *clauses;
+}
+gfc_omp_declare_simd;
+#define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd)
+
+typedef struct gfc_omp_udr
+{
+ struct gfc_omp_udr *next;
+ locus where; /* Where the !$omp declare reduction construct occurred. */
+
+ const char *name;
+ gfc_typespec ts;
+ gfc_omp_reduction_op rop;
+
+ struct gfc_symbol *omp_out;
+ struct gfc_symbol *omp_in;
+ struct gfc_namespace *combiner_ns;
+
+ struct gfc_symbol *omp_priv;
+ struct gfc_symbol *omp_orig;
+ struct gfc_namespace *initializer_ns;
+}
+gfc_omp_udr;
+#define gfc_get_omp_udr() XCNEW (gfc_omp_udr)
+
+typedef struct gfc_omp_namelist_udr
+{
+ struct gfc_omp_udr *udr;
+ struct gfc_code *combiner;
+ struct gfc_code *initializer;
+}
+gfc_omp_namelist_udr;
+#define gfc_get_omp_namelist_udr() XCNEW (gfc_omp_namelist_udr)
+
/* The gfc_st_label structure is a BBT attached to a namespace that
records the usage of statement labels within that space. */
typedef struct gfc_common_head
{
locus where;
- char use_assoc, saved, threadprivate;
+ char use_assoc, saved, threadprivate, omp_declare_target;
char name[GFC_MAX_SYMBOL_LEN + 1];
struct gfc_symbol *head;
const char* binding_label;
gfc_user_op *uop;
gfc_common_head *common;
gfc_typebound_proc *tb;
+ gfc_omp_udr *omp_udr;
}
n;
}
gfc_symtree *uop_root;
/* Tree containing all the common blocks. */
gfc_symtree *common_root;
+ /* Tree containing all the OpenMP user defined reductions. */
+ gfc_symtree *omp_udr_root;
/* Tree containing type-bound procedures. */
gfc_symtree *tb_sym_root;
/* A list of USE statements in this namespace. */
gfc_use_list *use_stmts;
+ /* Linked list of !$omp declare simd constructs. */
+ struct gfc_omp_declare_simd *omp_declare_simd;
+
/* Set to 1 if namespace is a BLOCK DATA program unit. */
unsigned is_block_data:1;
/* Set to 1 if symbols in this namespace should be 'construct entities',
i.e. for BLOCK local variables. */
unsigned construct_entities:1;
+
+ /* Set to 1 for !$OMP DECLARE REDUCTION namespaces. */
+ unsigned omp_udr_ns:1;
}
gfc_namespace;
EXEC_OMP_SECTIONS, EXEC_OMP_SINGLE, EXEC_OMP_WORKSHARE,
EXEC_OMP_ATOMIC, EXEC_OMP_BARRIER, EXEC_OMP_END_NOWAIT,
EXEC_OMP_END_SINGLE, EXEC_OMP_TASK, EXEC_OMP_TASKWAIT,
- EXEC_OMP_TASKYIELD
+ EXEC_OMP_TASKYIELD, EXEC_OMP_CANCEL, EXEC_OMP_CANCELLATION_POINT,
+ EXEC_OMP_TASKGROUP, EXEC_OMP_SIMD, EXEC_OMP_DO_SIMD,
+ EXEC_OMP_PARALLEL_DO_SIMD, 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,
+ EXEC_OMP_TARGET_UPDATE
}
gfc_exec_op;
typedef enum
{
- GFC_OMP_ATOMIC_UPDATE,
- GFC_OMP_ATOMIC_READ,
- GFC_OMP_ATOMIC_WRITE,
- GFC_OMP_ATOMIC_CAPTURE
+ GFC_OMP_ATOMIC_UPDATE = 0,
+ GFC_OMP_ATOMIC_READ = 1,
+ GFC_OMP_ATOMIC_WRITE = 2,
+ GFC_OMP_ATOMIC_CAPTURE = 3,
+ GFC_OMP_ATOMIC_MASK = 3,
+ GFC_OMP_ATOMIC_SEQ_CST = 4,
+ GFC_OMP_ATOMIC_SWAP = 8
}
gfc_omp_atomic_op;
gfc_entry_list *entry;
gfc_omp_clauses *omp_clauses;
const char *omp_name;
- gfc_namelist *omp_namelist;
+ gfc_omp_namelist *omp_namelist;
bool omp_bool;
gfc_omp_atomic_op omp_atomic;
}
bool gfc_add_result (symbol_attribute *, const char *, locus *);
bool gfc_add_save (symbol_attribute *, save_state, const char *, locus *);
bool gfc_add_threadprivate (symbol_attribute *, const char *, locus *);
+bool gfc_add_omp_declare_target (symbol_attribute *, const char *, locus *);
bool gfc_add_saved_common (symbol_attribute *, locus *);
bool gfc_add_target (symbol_attribute *, locus *);
bool gfc_add_dummy (symbol_attribute *, const char *, locus *);
void gfc_free_forall_iterator (gfc_forall_iterator *);
void gfc_free_alloc_list (gfc_alloc *);
void gfc_free_namelist (gfc_namelist *);
+void gfc_free_omp_namelist (gfc_omp_namelist *);
void gfc_free_equiv (gfc_equiv *);
void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *);
void gfc_free_data (gfc_data *);
/* openmp.c */
struct gfc_omp_saved_state { void *ptrs[2]; int ints[1]; };
void gfc_free_omp_clauses (gfc_omp_clauses *);
+void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
+void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
+void gfc_free_omp_udr (gfc_omp_udr *);
+gfc_omp_udr *gfc_omp_udr_find (gfc_symtree *, gfc_typespec *);
void gfc_resolve_omp_directive (gfc_code *, gfc_namespace *);
void gfc_resolve_do_iterator (gfc_code *, gfc_symbol *);
void gfc_resolve_omp_parallel_blocks (gfc_code *, gfc_namespace *);
void gfc_resolve_omp_do_blocks (gfc_code *, gfc_namespace *);
+void gfc_resolve_omp_declare_simd (gfc_namespace *);
+void gfc_resolve_omp_udrs (gfc_symtree *);
void gfc_omp_save_and_clear_state (struct gfc_omp_saved_state *);
void gfc_omp_restore_state (struct gfc_omp_saved_state *);
/* resolve.c */
bool gfc_resolve_expr (gfc_expr *);
void gfc_resolve (gfc_namespace *);
+void gfc_resolve_code (gfc_code *, gfc_namespace *);
void gfc_resolve_blocks (gfc_code *, gfc_namespace *);
int gfc_impure_variable (gfc_symbol *);
int gfc_pure (gfc_symbol *);
typedef int (*walk_code_fn_t) (gfc_code **, int *, void *);
typedef int (*walk_expr_fn_t) (gfc_expr **, int *, void *);
+int gfc_dummy_code_callback (gfc_code **, int *, void *);
int gfc_expr_walker (gfc_expr **, walk_expr_fn_t, void *);
int gfc_code_walker (gfc_code **, walk_code_fn_t, walk_expr_fn_t, void *);
@ref{TS 29113 status} sections of the documentation.
Additionally, the GNU Fortran compilers supports the OpenMP specification
-(version 3.1, @url{http://openmp.org/@/wp/@/openmp-specifications/}).
+(version 4.0, @url{http://openmp.org/@/wp/@/openmp-specifications/}).
@node Varying Length Character Strings
@subsection Varying Length Character Strings
and environment variables that influence run-time behavior.
GNU Fortran strives to be compatible to the
-@uref{http://www.openmp.org/mp-documents/spec31.pdf,
-OpenMP Application Program Interface v3.1}.
+@uref{http://openmp.org/wp/openmp-specifications/,
+OpenMP Application Program Interface v4.0}.
To enable the processing of the OpenMP directive @code{!$omp} in
free-form source code; the @code{c$omp}, @code{*$omp} and @code{!$omp}
@code{OMP_LIB} provides the scalar default-integer
named constant @code{openmp_version} with a value of the form
@var{yyyymm}, where @code{yyyy} is the year and @var{mm} the month
-of the OpenMP version; for OpenMP v3.1 the value is @code{201107}
-and for OpenMP v4.0 the value is @code{201307}.
+of the OpenMP version; for OpenMP v4.0 the value is @code{201307}.
The following scalar integer named constants of the
kind @code{omp_sched_kind}:
&& o != NULL
&& o->state == COMP_OMP_STRUCTURED_BLOCK
&& (o->head->op == EXEC_OMP_DO
- || o->head->op == EXEC_OMP_PARALLEL_DO))
+ || o->head->op == EXEC_OMP_PARALLEL_DO
+ || o->head->op == EXEC_OMP_SIMD
+ || o->head->op == EXEC_OMP_DO_SIMD
+ || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
{
int collapse = 1;
gcc_assert (o->head->next != NULL
}
+/* Free an OpenMP namelist structure. */
+
+void
+gfc_free_omp_namelist (gfc_omp_namelist *name)
+{
+ gfc_omp_namelist *n;
+
+ for (; name; name = n)
+ {
+ gfc_free_expr (name->expr);
+ if (name->udr)
+ {
+ if (name->udr->combiner)
+ gfc_free_statement (name->udr->combiner);
+ if (name->udr->initializer)
+ gfc_free_statement (name->udr->initializer);
+ free (name->udr);
+ }
+ n = name->next;
+ free (name);
+ }
+}
+
+
/* Match a NAMELIST statement. */
match
match gfc_match_omp_eos (void);
match gfc_match_omp_atomic (void);
match gfc_match_omp_barrier (void);
+match gfc_match_omp_cancel (void);
+match gfc_match_omp_cancellation_point (void);
match gfc_match_omp_critical (void);
+match gfc_match_omp_declare_reduction (void);
+match gfc_match_omp_declare_simd (void);
+match gfc_match_omp_declare_target (void);
+match gfc_match_omp_distribute (void);
+match gfc_match_omp_distribute_parallel_do (void);
+match gfc_match_omp_distribute_parallel_do_simd (void);
+match gfc_match_omp_distribute_simd (void);
match gfc_match_omp_do (void);
+match gfc_match_omp_do_simd (void);
match gfc_match_omp_flush (void);
match gfc_match_omp_master (void);
match gfc_match_omp_ordered (void);
match gfc_match_omp_parallel (void);
match gfc_match_omp_parallel_do (void);
+match gfc_match_omp_parallel_do_simd (void);
match gfc_match_omp_parallel_sections (void);
match gfc_match_omp_parallel_workshare (void);
match gfc_match_omp_sections (void);
+match gfc_match_omp_simd (void);
match gfc_match_omp_single (void);
+match gfc_match_omp_target (void);
+match gfc_match_omp_target_data (void);
+match gfc_match_omp_target_teams (void);
+match gfc_match_omp_target_teams_distribute (void);
+match gfc_match_omp_target_teams_distribute_parallel_do (void);
+match gfc_match_omp_target_teams_distribute_parallel_do_simd (void);
+match gfc_match_omp_target_teams_distribute_simd (void);
+match gfc_match_omp_target_update (void);
match gfc_match_omp_task (void);
+match gfc_match_omp_taskgroup (void);
match gfc_match_omp_taskwait (void);
match gfc_match_omp_taskyield (void);
+match gfc_match_omp_teams (void);
+match gfc_match_omp_teams_distribute (void);
+match gfc_match_omp_teams_distribute_parallel_do (void);
+match gfc_match_omp_teams_distribute_parallel_do_simd (void);
+match gfc_match_omp_teams_distribute_simd (void);
match gfc_match_omp_threadprivate (void);
match gfc_match_omp_workshare (void);
match gfc_match_omp_end_nowait (void);
/* Don't put any single quote (') in MOD_VERSION, if you want it to be
recognized. */
#define MOD_VERSION "12"
+#define MOD_VERSION_OMP4 "12 OpenMP 4"
/* Structure that describes a position within a module file. */
static long module_pos;
static int module_line, module_column, only_flag;
static int prev_module_line, prev_module_column;
+static bool module_omp4;
static enum
{ IO_INPUT, IO_OUTPUT }
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
- AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY
+ AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET
}
ab_attribute;
minit ("CLASS_POINTER", AB_CLASS_POINTER),
minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
+ minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
minit (NULL, -1)
};
MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
if (attr->vtab)
MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
+ if (attr->omp_declare_target)
+ MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
mio_rparen ();
case AB_VTAB:
attr->vtab = 1;
break;
+ case AB_OMP_DECLARE_TARGET:
+ attr->omp_declare_target = 1;
+ break;
}
}
}
minit ("LE", INTRINSIC_LE_OS),
minit ("NOT", INTRINSIC_NOT),
minit ("PARENTHESES", INTRINSIC_PARENTHESES),
+ minit ("USER", INTRINSIC_USER),
minit (NULL, -1)
};
&& !e->symtree->n.sym->attr.dummy)
e->symtree = ns_st;
}
- else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
+ else if (e->expr_type == EXPR_FUNCTION
+ && (e->value.function.name || e->value.function.isym))
{
gfc_symbol *sym;
mio_expr (&e->value.op.op2);
break;
+ case INTRINSIC_USER:
+ /* INTRINSIC_USER should not appear in resolved expressions,
+ though for UDRs we need to stream unresolved ones. */
+ if (iomode == IO_OUTPUT)
+ write_atom (ATOM_STRING, e->value.op.uop->name);
+ else
+ {
+ char *name = read_string ();
+ const char *uop_name = find_use_name (name, true);
+ if (uop_name == NULL)
+ {
+ size_t len = strlen (name);
+ char *name2 = XCNEWVEC (char, len + 2);
+ memcpy (name2, name, len);
+ name2[len] = ' ';
+ name2[len + 1] = '\0';
+ free (name);
+ uop_name = name = name2;
+ }
+ e->value.op.uop = gfc_get_uop (uop_name);
+ free (name);
+ }
+ mio_expr (&e->value.op.op1);
+ mio_expr (&e->value.op.op2);
+ break;
+
default:
bad_module ("Bad operator");
}
flag = 1;
else if (e->ref)
flag = 2;
+ else if (e->value.function.isym == NULL)
+ flag = 3;
else
flag = 0;
mio_integer (&flag);
case 2:
mio_ref_list (&e->ref);
break;
+ case 3:
+ break;
default:
write_atom (ATOM_STRING, e->value.function.isym->name);
}
else
{
require_atom (ATOM_STRING);
- e->value.function.name = gfc_get_string (atom_string);
+ if (atom_string[0] == '\0')
+ e->value.function.name = NULL;
+ else
+ e->value.function.name = gfc_get_string (atom_string);
free (atom_string);
mio_integer (&flag);
case 2:
mio_ref_list (&e->ref);
break;
+ case 3:
+ break;
default:
require_atom (ATOM_STRING);
e->value.function.isym = gfc_find_function (atom_string);
mio_rparen ();
}
+static const mstring omp_declare_simd_clauses[] =
+{
+ minit ("INBRANCH", 0),
+ minit ("NOTINBRANCH", 1),
+ minit ("SIMDLEN", 2),
+ minit ("UNIFORM", 3),
+ minit ("LINEAR", 4),
+ minit ("ALIGNED", 5),
+ minit (NULL, -1)
+};
+
+/* Handle !$omp declare simd. */
+
+static void
+mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
+{
+ if (iomode == IO_OUTPUT)
+ {
+ if (*odsp == NULL)
+ return;
+ }
+ else if (peek_atom () != ATOM_LPAREN)
+ return;
+
+ gfc_omp_declare_simd *ods = *odsp;
+
+ mio_lparen ();
+ if (iomode == IO_OUTPUT)
+ {
+ write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
+ if (ods->clauses)
+ {
+ gfc_omp_namelist *n;
+
+ if (ods->clauses->inbranch)
+ mio_name (0, omp_declare_simd_clauses);
+ if (ods->clauses->notinbranch)
+ mio_name (1, omp_declare_simd_clauses);
+ if (ods->clauses->simdlen_expr)
+ {
+ mio_name (2, omp_declare_simd_clauses);
+ mio_expr (&ods->clauses->simdlen_expr);
+ }
+ for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
+ {
+ mio_name (3, omp_declare_simd_clauses);
+ mio_symbol_ref (&n->sym);
+ }
+ for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
+ {
+ mio_name (4, omp_declare_simd_clauses);
+ mio_symbol_ref (&n->sym);
+ mio_expr (&n->expr);
+ }
+ for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ {
+ mio_name (5, omp_declare_simd_clauses);
+ mio_symbol_ref (&n->sym);
+ mio_expr (&n->expr);
+ }
+ }
+ }
+ else
+ {
+ gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
+
+ require_atom (ATOM_NAME);
+ *odsp = ods = gfc_get_omp_declare_simd ();
+ ods->where = gfc_current_locus;
+ ods->proc_name = ns->proc_name;
+ if (peek_atom () == ATOM_NAME)
+ {
+ ods->clauses = gfc_get_omp_clauses ();
+ ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
+ ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
+ ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
+ }
+ while (peek_atom () == ATOM_NAME)
+ {
+ gfc_omp_namelist *n;
+ int t = mio_name (0, omp_declare_simd_clauses);
+
+ switch (t)
+ {
+ case 0: ods->clauses->inbranch = true; break;
+ case 1: ods->clauses->notinbranch = true; break;
+ case 2: mio_expr (&ods->clauses->simdlen_expr); break;
+ case 3:
+ case 4:
+ case 5:
+ *ptrs[t - 3] = n = gfc_get_omp_namelist ();
+ ptrs[t - 3] = &n->next;
+ mio_symbol_ref (&n->sym);
+ if (t != 3)
+ mio_expr (&n->expr);
+ break;
+ }
+ }
+ }
+
+ mio_omp_declare_simd (ns, &ods->next);
+
+ mio_rparen ();
+}
+
+
+static const mstring omp_declare_reduction_stmt[] =
+{
+ minit ("ASSIGN", 0),
+ minit ("CALL", 1),
+ minit (NULL, -1)
+};
+
+
+static void
+mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
+ gfc_namespace *ns, bool is_initializer)
+{
+ if (iomode == IO_OUTPUT)
+ {
+ if ((*sym1)->module == NULL)
+ {
+ (*sym1)->module = module_name;
+ (*sym2)->module = module_name;
+ }
+ mio_symbol_ref (sym1);
+ mio_symbol_ref (sym2);
+ if (ns->code->op == EXEC_ASSIGN)
+ {
+ mio_name (0, omp_declare_reduction_stmt);
+ mio_expr (&ns->code->expr1);
+ mio_expr (&ns->code->expr2);
+ }
+ else
+ {
+ int flag;
+ mio_name (1, omp_declare_reduction_stmt);
+ mio_symtree_ref (&ns->code->symtree);
+ mio_actual_arglist (&ns->code->ext.actual);
+
+ flag = ns->code->resolved_isym != NULL;
+ mio_integer (&flag);
+ if (flag)
+ write_atom (ATOM_STRING, ns->code->resolved_isym->name);
+ else
+ mio_symbol_ref (&ns->code->resolved_sym);
+ }
+ }
+ else
+ {
+ pointer_info *p1 = mio_symbol_ref (sym1);
+ pointer_info *p2 = mio_symbol_ref (sym2);
+ gfc_symbol *sym;
+ gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
+ gcc_assert (p1->u.rsym.sym == NULL);
+ /* Add hidden symbols to the symtree. */
+ pointer_info *q = get_integer (p1->u.rsym.ns);
+ q->u.pointer = (void *) ns;
+ sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
+ sym->ts = udr->ts;
+ sym->module = gfc_get_string (p1->u.rsym.module);
+ associate_integer_pointer (p1, sym);
+ sym->attr.omp_udr_artificial_var = 1;
+ gcc_assert (p2->u.rsym.sym == NULL);
+ sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
+ sym->ts = udr->ts;
+ sym->module = gfc_get_string (p2->u.rsym.module);
+ associate_integer_pointer (p2, sym);
+ sym->attr.omp_udr_artificial_var = 1;
+ if (mio_name (0, omp_declare_reduction_stmt) == 0)
+ {
+ ns->code = gfc_get_code (EXEC_ASSIGN);
+ mio_expr (&ns->code->expr1);
+ mio_expr (&ns->code->expr2);
+ }
+ else
+ {
+ int flag;
+ ns->code = gfc_get_code (EXEC_CALL);
+ mio_symtree_ref (&ns->code->symtree);
+ mio_actual_arglist (&ns->code->ext.actual);
+
+ mio_integer (&flag);
+ if (flag)
+ {
+ require_atom (ATOM_STRING);
+ ns->code->resolved_isym = gfc_find_subroutine (atom_string);
+ free (atom_string);
+ }
+ else
+ mio_symbol_ref (&ns->code->resolved_sym);
+ }
+ ns->code->loc = gfc_current_locus;
+ ns->omp_udr_ns = 1;
+ }
+}
+
/* Unlike most other routines, the address of the symbol node is already
fixed on input and the name/module has already been filled in.
if (sym->attr.flavor == FL_DERIVED)
mio_integer (&(sym->hash_value));
+ if (sym->formal_ns
+ && sym->formal_ns->proc_name == sym
+ && sym->formal_ns->entries == NULL)
+ {
+ if (module_omp4)
+ mio_omp_declare_simd (sym->formal_ns,
+ &sym->formal_ns->omp_declare_simd);
+ else if (iomode == IO_OUTPUT)
+ gcc_assert (sym->formal_ns->omp_declare_simd == NULL);
+ }
+
mio_rparen ();
}
}
+/* This function loads OpenMP user defined reductions. */
+static void
+load_omp_udrs (void)
+{
+ mio_lparen ();
+ while (peek_atom () != ATOM_RPAREN)
+ {
+ const char *name, *newname;
+ char *altname;
+ gfc_typespec ts;
+ gfc_symtree *st;
+ gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
+
+ mio_lparen ();
+ mio_pool_string (&name);
+ mio_typespec (&ts);
+ if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
+ {
+ const char *p = name + sizeof ("operator ") - 1;
+ if (strcmp (p, "+") == 0)
+ rop = OMP_REDUCTION_PLUS;
+ else if (strcmp (p, "*") == 0)
+ rop = OMP_REDUCTION_TIMES;
+ else if (strcmp (p, "-") == 0)
+ rop = OMP_REDUCTION_MINUS;
+ else if (strcmp (p, ".and.") == 0)
+ rop = OMP_REDUCTION_AND;
+ else if (strcmp (p, ".or.") == 0)
+ rop = OMP_REDUCTION_OR;
+ else if (strcmp (p, ".eqv.") == 0)
+ rop = OMP_REDUCTION_EQV;
+ else if (strcmp (p, ".neqv.") == 0)
+ rop = OMP_REDUCTION_NEQV;
+ }
+ altname = NULL;
+ if (rop == OMP_REDUCTION_USER && name[0] == '.')
+ {
+ size_t len = strlen (name + 1);
+ altname = XALLOCAVEC (char, len);
+ gcc_assert (name[len] == '.');
+ memcpy (altname, name + 1, len - 1);
+ altname[len - 1] = '\0';
+ }
+ newname = name;
+ if (rop == OMP_REDUCTION_USER)
+ newname = find_use_name (altname ? altname : name, !!altname);
+ else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
+ newname = NULL;
+ if (newname == NULL)
+ {
+ skip_list (1);
+ continue;
+ }
+ if (altname && newname != altname)
+ {
+ size_t len = strlen (newname);
+ altname = XALLOCAVEC (char, len + 3);
+ altname[0] = '.';
+ memcpy (altname + 1, newname, len);
+ altname[len + 1] = '.';
+ altname[len + 2] = '\0';
+ name = gfc_get_string (altname);
+ }
+ st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
+ gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
+ if (udr)
+ {
+ require_atom (ATOM_INTEGER);
+ pointer_info *p = get_integer (atom_int);
+ if (strcmp (p->u.rsym.module, udr->omp_out->module))
+ {
+ gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
+ "module %s at %L",
+ p->u.rsym.module, &gfc_current_locus);
+ gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
+ "%s at %L",
+ udr->omp_out->module, &udr->where);
+ }
+ skip_list (1);
+ continue;
+ }
+ udr = gfc_get_omp_udr ();
+ udr->name = name;
+ udr->rop = rop;
+ udr->ts = ts;
+ udr->where = gfc_current_locus;
+ udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
+ udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
+ mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
+ false);
+ if (peek_atom () != ATOM_RPAREN)
+ {
+ udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
+ udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
+ mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
+ udr->initializer_ns, true);
+ }
+ if (st)
+ {
+ udr->next = st->n.omp_udr;
+ st->n.omp_udr = udr;
+ }
+ else
+ {
+ st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
+ st->n.omp_udr = udr;
+ }
+ mio_rparen ();
+ }
+ mio_rparen ();
+}
+
+
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
static void
read_module (void)
{
- module_locus operator_interfaces, user_operators, extensions;
+ module_locus operator_interfaces, user_operators, extensions, omp_udrs;
const char *p;
char name[GFC_MAX_SYMBOL_LEN + 1];
int i;
get_module_locus (&extensions);
skip_list ();
+ /* Skip OpenMP UDRs. */
+ get_module_locus (&omp_udrs);
+ if (module_omp4)
+ skip_list ();
+
mio_lparen ();
/* Create the fixup nodes for all the symbols. */
load_commons ();
load_equiv ();
+ if (module_omp4)
+ {
+ /* Load OpenMP user defined reductions. */
+ set_module_locus (&omp_udrs);
+ load_omp_udrs ();
+ }
+
/* At this point, we read those symbols that are needed but haven't
been loaded yet. If one symbol requires another, the other gets
marked as NEEDED if its previous state was UNUSED. */
}
+static void
+write_omp_udr (gfc_omp_udr *udr)
+{
+ switch (udr->rop)
+ {
+ case OMP_REDUCTION_USER:
+ /* Non-operators can't be used outside of the module. */
+ if (udr->name[0] != '.')
+ return;
+ else
+ {
+ gfc_symtree *st;
+ size_t len = strlen (udr->name + 1);
+ char *name = XALLOCAVEC (char, len);
+ memcpy (name, udr->name, len - 1);
+ name[len - 1] = '\0';
+ st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+ /* If corresponding user operator is private, don't write
+ the UDR. */
+ if (st != NULL)
+ {
+ gfc_user_op *uop = st->n.uop;
+ if (!check_access (uop->access, uop->ns->default_access))
+ return;
+ }
+ }
+ break;
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ /* If corresponding operator is private, don't write the UDR. */
+ if (!check_access (gfc_current_ns->operator_access[udr->rop],
+ gfc_current_ns->default_access))
+ return;
+ break;
+ default:
+ break;
+ }
+ if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
+ {
+ /* If derived type is private, don't write the UDR. */
+ if (!gfc_check_symbol_access (udr->ts.u.derived))
+ return;
+ }
+
+ mio_lparen ();
+ mio_pool_string (&udr->name);
+ mio_typespec (&udr->ts);
+ mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
+ if (udr->initializer_ns)
+ mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
+ udr->initializer_ns, true);
+ mio_rparen ();
+}
+
+
+static void
+write_omp_udrs (gfc_symtree *st)
+{
+ if (st == NULL)
+ return;
+
+ write_omp_udrs (st->left);
+ gfc_omp_udr *udr;
+ for (udr = st->n.omp_udr; udr; udr = udr->next)
+ write_omp_udr (udr);
+ write_omp_udrs (st->right);
+}
+
+
/* Type for the temporary tree used when writing secondary symbols. */
struct sorted_pointer_info
write_char ('\n');
write_char ('\n');
+ if (module_omp4)
+ {
+ mio_lparen ();
+ write_omp_udrs (gfc_current_ns->omp_udr_root);
+ mio_rparen ();
+ write_char ('\n');
+ write_char ('\n');
+ }
+ else
+ gcc_assert (gfc_current_ns->omp_udr_root == NULL);
+
/* Write symbol information. First we traverse all symbols in the
primary namespace, writing those that need to be written.
Sometimes writing one symbol will cause another to need to be
}
+/* Set module_omp4 if any symbol has !$OMP DECLARE SIMD directives. */
+
+static void
+find_omp_declare_simd (gfc_symtree *st)
+{
+ gfc_symbol *sym = st->n.sym;
+ if (sym->formal_ns
+ && sym->formal_ns->proc_name == sym
+ && sym->formal_ns->omp_declare_simd)
+ module_omp4 = true;
+ else if (sym->attr.omp_declare_target)
+ module_omp4 = true;
+}
+
+
/* Given module, dump it to disk. If there was an error while
processing the module, dump_flag will be set to zero and we delete
the module file, even if it was already there. */
if (gfc_cpp_makedep ())
gfc_cpp_add_target (filename);
+ module_omp4 = false;
+ if (gfc_current_ns->omp_udr_root)
+ module_omp4 = true;
+ else
+ gfc_traverse_symtree (gfc_current_ns->sym_root, find_omp_declare_simd);
+
/* Write the module to the temporary file. */
module_fp = gzopen (filename_tmp, "w");
if (module_fp == NULL)
filename_tmp, xstrerror (errno));
gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
- MOD_VERSION, gfc_source_file);
+ module_omp4 ? MOD_VERSION_OMP4 : MOD_VERSION, gfc_source_file);
/* Write the module itself. */
iomode = IO_OUTPUT;
read_module_to_tmpbuf ();
gzclose (module_fp);
+ module_omp4 = false;
+
/* Skip the first line of the module, after checking that this is
a gfortran module file. */
line = 0;
if (strcmp (atom_name, " version") != 0
|| module_char () != ' '
|| parse_atom () != ATOM_STRING
- || strcmp (atom_string, MOD_VERSION))
+ || (strcmp (atom_string, MOD_VERSION)
+ && strcmp (atom_string, MOD_VERSION_OMP4)))
gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
" because it was created by a different"
" version of GNU Fortran", filename);
+ if (strcmp (atom_string, MOD_VERSION_OMP4) == 0)
+ module_omp4 = true;
+
free (atom_string);
}
#include "coretypes.h"
#include "flags.h"
#include "gfortran.h"
+#include "arith.h"
#include "match.h"
#include "parse.h"
#include "pointer-set.h"
gfc_free_expr (c->final_expr);
gfc_free_expr (c->num_threads);
gfc_free_expr (c->chunk_size);
+ gfc_free_expr (c->safelen_expr);
+ gfc_free_expr (c->simdlen_expr);
+ gfc_free_expr (c->num_teams);
+ gfc_free_expr (c->device);
+ gfc_free_expr (c->thread_limit);
+ gfc_free_expr (c->dist_chunk_size);
for (i = 0; i < OMP_LIST_NUM; i++)
- gfc_free_namelist (c->lists[i]);
+ gfc_free_omp_namelist (c->lists[i]);
free (c);
}
+/* Free an !$omp declare simd construct list. */
+
+void
+gfc_free_omp_declare_simd (gfc_omp_declare_simd *ods)
+{
+ if (ods)
+ {
+ gfc_free_omp_clauses (ods->clauses);
+ free (ods);
+ }
+}
+
+void
+gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
+{
+ while (list)
+ {
+ gfc_omp_declare_simd *current = list;
+ list = list->next;
+ gfc_free_omp_declare_simd (current);
+ }
+}
+
+/* Free an !$omp declare reduction. */
+
+void
+gfc_free_omp_udr (gfc_omp_udr *omp_udr)
+{
+ if (omp_udr)
+ {
+ gfc_free_omp_udr (omp_udr->next);
+ gfc_free_namespace (omp_udr->combiner_ns);
+ if (omp_udr->initializer_ns)
+ gfc_free_namespace (omp_udr->initializer_ns);
+ free (omp_udr);
+ }
+}
+
+
+static gfc_omp_udr *
+gfc_find_omp_udr (gfc_namespace *ns, const char *name, gfc_typespec *ts)
+{
+ gfc_symtree *st;
+
+ if (ns == NULL)
+ ns = gfc_current_ns;
+ do
+ {
+ gfc_omp_udr *omp_udr;
+
+ st = gfc_find_symtree (ns->omp_udr_root, name);
+ if (st != NULL)
+ for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+ if (ts == NULL)
+ return omp_udr;
+ else if (gfc_compare_types (&omp_udr->ts, ts))
+ {
+ if (ts->type == BT_CHARACTER)
+ {
+ if (omp_udr->ts.u.cl->length == NULL)
+ return omp_udr;
+ if (ts->u.cl->length == NULL)
+ continue;
+ if (gfc_compare_expr (omp_udr->ts.u.cl->length,
+ ts->u.cl->length,
+ INTRINSIC_EQ) != 0)
+ continue;
+ }
+ return omp_udr;
+ }
+
+ /* Don't escape an interface block. */
+ if (ns && !ns->has_import_set
+ && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ break;
+
+ ns = ns->parent;
+ }
+ while (ns != NULL);
+
+ return NULL;
+}
+
+
/* Match a variable/common block list and construct a namelist from it. */
static match
-gfc_match_omp_variable_list (const char *str, gfc_namelist **list,
- bool allow_common)
+gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
+ bool allow_common, bool *end_colon = NULL,
+ gfc_omp_namelist ***headp = NULL,
+ bool allow_sections = false)
{
- gfc_namelist *head, *tail, *p;
- locus old_loc;
+ gfc_omp_namelist *head, *tail, *p;
+ locus old_loc, cur_loc;
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *sym;
match m;
for (;;)
{
+ cur_loc = gfc_current_locus;
m = gfc_match_symbol (&sym, 1);
switch (m)
{
case MATCH_YES:
+ gfc_expr *expr;
+ expr = NULL;
+ if (allow_sections && gfc_peek_ascii_char () == '(')
+ {
+ gfc_current_locus = cur_loc;
+ m = gfc_match_variable (&expr, 0);
+ switch (m)
+ {
+ case MATCH_ERROR:
+ goto cleanup;
+ case MATCH_NO:
+ goto syntax;
+ default:
+ break;
+ }
+ }
gfc_set_sym_referenced (sym);
- p = gfc_get_namelist ();
+ p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
tail = tail->next;
}
tail->sym = sym;
+ tail->expr = expr;
goto next_item;
case MATCH_NO:
break;
for (sym = st->n.common->head; sym; sym = sym->common_next)
{
gfc_set_sym_referenced (sym);
- p = gfc_get_namelist ();
+ p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
else
}
next_item:
+ if (end_colon && gfc_match_char (':') == MATCH_YES)
+ {
+ *end_colon = true;
+ break;
+ }
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
list = &(*list)->next;
*list = head;
+ if (headp)
+ *headp = list;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in OpenMP variable list at %C");
cleanup:
- gfc_free_namelist (head);
+ gfc_free_omp_namelist (head);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
-#define OMP_CLAUSE_PRIVATE (1 << 0)
-#define OMP_CLAUSE_FIRSTPRIVATE (1 << 1)
-#define OMP_CLAUSE_LASTPRIVATE (1 << 2)
-#define OMP_CLAUSE_COPYPRIVATE (1 << 3)
-#define OMP_CLAUSE_SHARED (1 << 4)
-#define OMP_CLAUSE_COPYIN (1 << 5)
-#define OMP_CLAUSE_REDUCTION (1 << 6)
-#define OMP_CLAUSE_IF (1 << 7)
-#define OMP_CLAUSE_NUM_THREADS (1 << 8)
-#define OMP_CLAUSE_SCHEDULE (1 << 9)
-#define OMP_CLAUSE_DEFAULT (1 << 10)
-#define OMP_CLAUSE_ORDERED (1 << 11)
-#define OMP_CLAUSE_COLLAPSE (1 << 12)
-#define OMP_CLAUSE_UNTIED (1 << 13)
-#define OMP_CLAUSE_FINAL (1 << 14)
-#define OMP_CLAUSE_MERGEABLE (1 << 15)
+#define OMP_CLAUSE_PRIVATE (1U << 0)
+#define OMP_CLAUSE_FIRSTPRIVATE (1U << 1)
+#define OMP_CLAUSE_LASTPRIVATE (1U << 2)
+#define OMP_CLAUSE_COPYPRIVATE (1U << 3)
+#define OMP_CLAUSE_SHARED (1U << 4)
+#define OMP_CLAUSE_COPYIN (1U << 5)
+#define OMP_CLAUSE_REDUCTION (1U << 6)
+#define OMP_CLAUSE_IF (1U << 7)
+#define OMP_CLAUSE_NUM_THREADS (1U << 8)
+#define OMP_CLAUSE_SCHEDULE (1U << 9)
+#define OMP_CLAUSE_DEFAULT (1U << 10)
+#define OMP_CLAUSE_ORDERED (1U << 11)
+#define OMP_CLAUSE_COLLAPSE (1U << 12)
+#define OMP_CLAUSE_UNTIED (1U << 13)
+#define OMP_CLAUSE_FINAL (1U << 14)
+#define OMP_CLAUSE_MERGEABLE (1U << 15)
+#define OMP_CLAUSE_ALIGNED (1U << 16)
+#define OMP_CLAUSE_DEPEND (1U << 17)
+#define OMP_CLAUSE_INBRANCH (1U << 18)
+#define OMP_CLAUSE_LINEAR (1U << 19)
+#define OMP_CLAUSE_NOTINBRANCH (1U << 20)
+#define OMP_CLAUSE_PROC_BIND (1U << 21)
+#define OMP_CLAUSE_SAFELEN (1U << 22)
+#define OMP_CLAUSE_SIMDLEN (1U << 23)
+#define OMP_CLAUSE_UNIFORM (1U << 24)
+#define OMP_CLAUSE_DEVICE (1U << 25)
+#define OMP_CLAUSE_MAP (1U << 26)
+#define OMP_CLAUSE_TO (1U << 27)
+#define OMP_CLAUSE_FROM (1U << 28)
+#define OMP_CLAUSE_NUM_TEAMS (1U << 29)
+#define OMP_CLAUSE_THREAD_LIMIT (1U << 30)
+#define OMP_CLAUSE_DIST_SCHEDULE (1U << 31)
/* Match OpenMP directive clauses. MASK is a bitmask of
clauses that are allowed for a particular directive. */
static match
-gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
+gfc_match_omp_clauses (gfc_omp_clauses **cp, unsigned int mask,
+ bool first = true, bool needs_space = true)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
- bool needs_space = true, first = true;
*cp = NULL;
while (1)
if ((mask & OMP_CLAUSE_REDUCTION)
&& gfc_match ("reduction ( ") == MATCH_YES)
{
- int reduction = OMP_LIST_NUM;
- char buffer[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
+ char buffer[GFC_MAX_SYMBOL_LEN + 3];
if (gfc_match_char ('+') == MATCH_YES)
- reduction = OMP_LIST_PLUS;
+ rop = OMP_REDUCTION_PLUS;
else if (gfc_match_char ('*') == MATCH_YES)
- reduction = OMP_LIST_MULT;
+ rop = OMP_REDUCTION_TIMES;
else if (gfc_match_char ('-') == MATCH_YES)
- reduction = OMP_LIST_SUB;
+ rop = OMP_REDUCTION_MINUS;
else if (gfc_match (".and.") == MATCH_YES)
- reduction = OMP_LIST_AND;
+ rop = OMP_REDUCTION_AND;
else if (gfc_match (".or.") == MATCH_YES)
- reduction = OMP_LIST_OR;
+ rop = OMP_REDUCTION_OR;
else if (gfc_match (".eqv.") == MATCH_YES)
- reduction = OMP_LIST_EQV;
+ rop = OMP_REDUCTION_EQV;
else if (gfc_match (".neqv.") == MATCH_YES)
- reduction = OMP_LIST_NEQV;
+ rop = OMP_REDUCTION_NEQV;
+ if (rop != OMP_REDUCTION_NONE)
+ snprintf (buffer, sizeof buffer,
+ "operator %s", gfc_op2string ((gfc_intrinsic_op) rop));
+ else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
+ {
+ buffer[0] = '.';
+ strcat (buffer, ".");
+ }
else if (gfc_match_name (buffer) == MATCH_YES)
{
gfc_symbol *sym;
|| sym->attr.if_source != IFSRC_UNKNOWN
|| sym == sym->ns->proc_name)
{
- gfc_error_now ("%s is not INTRINSIC procedure name "
- "at %C", buffer);
sym = NULL;
+ n = NULL;
}
else
n = sym->name;
}
- if (strcmp (n, "max") == 0)
- reduction = OMP_LIST_MAX;
+ if (n == NULL)
+ rop = OMP_REDUCTION_NONE;
+ else if (strcmp (n, "max") == 0)
+ rop = OMP_REDUCTION_MAX;
else if (strcmp (n, "min") == 0)
- reduction = OMP_LIST_MIN;
+ rop = OMP_REDUCTION_MIN;
else if (strcmp (n, "iand") == 0)
- reduction = OMP_LIST_IAND;
+ rop = OMP_REDUCTION_IAND;
else if (strcmp (n, "ior") == 0)
- reduction = OMP_LIST_IOR;
+ rop = OMP_REDUCTION_IOR;
else if (strcmp (n, "ieor") == 0)
- reduction = OMP_LIST_IEOR;
- if (reduction != OMP_LIST_NUM
+ rop = OMP_REDUCTION_IEOR;
+ if (rop != OMP_REDUCTION_NONE
&& sym != NULL
&& ! sym->attr.intrinsic
&& ! sym->attr.use_assoc
&& ((sym->attr.flavor == FL_UNKNOWN
- && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
+ && !gfc_add_flavor (&sym->attr, FL_PROCEDURE,
+ sym->name, NULL))
|| !gfc_add_intrinsic (&sym->attr, NULL)))
+ rop = OMP_REDUCTION_NONE;
+ }
+ gfc_omp_udr *udr = gfc_find_omp_udr (gfc_current_ns, buffer, NULL);
+ gfc_omp_namelist **head = NULL;
+ if (rop == OMP_REDUCTION_NONE && udr)
+ rop = OMP_REDUCTION_USER;
+
+ if (gfc_match_omp_variable_list (" :",
+ &c->lists[OMP_LIST_REDUCTION],
+ false, NULL, &head) == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ if (rop == OMP_REDUCTION_NONE)
{
- gfc_free_omp_clauses (c);
- return MATCH_ERROR;
+ n = *head;
+ *head = NULL;
+ gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
+ "at %L", buffer, &old_loc);
+ gfc_free_omp_namelist (n);
}
+ else
+ for (n = *head; n; n = n->next)
+ {
+ n->u.reduction_op = rop;
+ if (udr)
+ {
+ n->udr = gfc_get_omp_namelist_udr ();
+ n->udr->udr = udr;
+ }
+ }
+ continue;
}
- if (reduction != OMP_LIST_NUM
- && gfc_match_omp_variable_list (" :", &c->lists[reduction],
- false)
- == MATCH_YES)
- continue;
else
gfc_current_locus = old_loc;
}
continue;
}
}
+ if ((mask & OMP_CLAUSE_INBRANCH) && !c->inbranch && !c->notinbranch
+ && gfc_match ("inbranch") == MATCH_YES)
+ {
+ c->inbranch = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NOTINBRANCH) && !c->notinbranch && !c->inbranch
+ && gfc_match ("notinbranch") == MATCH_YES)
+ {
+ c->notinbranch = needs_space = true;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_PROC_BIND)
+ && c->proc_bind == OMP_PROC_BIND_UNKNOWN)
+ {
+ if (gfc_match ("proc_bind ( master )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_MASTER;
+ else if (gfc_match ("proc_bind ( spread )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_SPREAD;
+ else if (gfc_match ("proc_bind ( close )") == MATCH_YES)
+ c->proc_bind = OMP_PROC_BIND_CLOSE;
+ if (c->proc_bind != OMP_PROC_BIND_UNKNOWN)
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_SAFELEN) && c->safelen_expr == NULL
+ && gfc_match ("safelen ( %e )", &c->safelen_expr) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_SIMDLEN) && c->simdlen_expr == NULL
+ && gfc_match ("simdlen ( %e )", &c->simdlen_expr) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_UNIFORM)
+ && gfc_match_omp_variable_list ("uniform (",
+ &c->lists[OMP_LIST_UNIFORM], false)
+ == MATCH_YES)
+ continue;
+ bool end_colon = false;
+ gfc_omp_namelist **head = NULL;
+ old_loc = gfc_current_locus;
+ if ((mask & OMP_CLAUSE_ALIGNED)
+ && gfc_match_omp_variable_list ("aligned (",
+ &c->lists[OMP_LIST_ALIGNED], false,
+ &end_colon, &head)
+ == MATCH_YES)
+ {
+ gfc_expr *alignment = NULL;
+ gfc_omp_namelist *n;
+
+ if (end_colon
+ && gfc_match (" %e )", &alignment) != MATCH_YES)
+ {
+ gfc_free_omp_namelist (*head);
+ gfc_current_locus = old_loc;
+ *head = NULL;
+ break;
+ }
+ for (n = *head; n; n = n->next)
+ if (n->next && alignment)
+ n->expr = gfc_copy_expr (alignment);
+ else
+ n->expr = alignment;
+ continue;
+ }
+ end_colon = false;
+ head = NULL;
+ old_loc = gfc_current_locus;
+ if ((mask & OMP_CLAUSE_LINEAR)
+ && gfc_match_omp_variable_list ("linear (",
+ &c->lists[OMP_LIST_LINEAR], false,
+ &end_colon, &head)
+ == MATCH_YES)
+ {
+ gfc_expr *step = NULL;
+
+ if (end_colon
+ && gfc_match (" %e )", &step) != MATCH_YES)
+ {
+ gfc_free_omp_namelist (*head);
+ gfc_current_locus = old_loc;
+ *head = NULL;
+ break;
+ }
+ else if (!end_colon)
+ {
+ step = gfc_get_constant_expr (BT_INTEGER,
+ gfc_default_integer_kind,
+ &old_loc);
+ mpz_set_si (step->value.integer, 1);
+ }
+ (*head)->expr = step;
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_DEPEND)
+ && gfc_match ("depend ( ") == MATCH_YES)
+ {
+ match m = MATCH_YES;
+ gfc_omp_depend_op depend_op = OMP_DEPEND_OUT;
+ if (gfc_match ("inout") == MATCH_YES)
+ depend_op = OMP_DEPEND_INOUT;
+ else if (gfc_match ("in") == MATCH_YES)
+ depend_op = OMP_DEPEND_IN;
+ else if (gfc_match ("out") == MATCH_YES)
+ depend_op = OMP_DEPEND_OUT;
+ else
+ m = MATCH_NO;
+ head = NULL;
+ if (m == MATCH_YES
+ && gfc_match_omp_variable_list (" : ",
+ &c->lists[OMP_LIST_DEPEND],
+ false, NULL, &head, true)
+ == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ n->u.depend_op = depend_op;
+ continue;
+ }
+ else
+ gfc_current_locus = old_loc;
+ }
+ if ((mask & OMP_CLAUSE_DIST_SCHEDULE)
+ && c->dist_sched_kind == OMP_SCHED_NONE
+ && gfc_match ("dist_schedule ( static") == MATCH_YES)
+ {
+ match m = MATCH_NO;
+ c->dist_sched_kind = OMP_SCHED_STATIC;
+ m = gfc_match (" , %e )", &c->dist_chunk_size);
+ if (m != MATCH_YES)
+ m = gfc_match_char (')');
+ if (m != MATCH_YES)
+ {
+ c->dist_sched_kind = OMP_SCHED_NONE;
+ gfc_current_locus = old_loc;
+ }
+ else
+ continue;
+ }
+ if ((mask & OMP_CLAUSE_NUM_TEAMS) && c->num_teams == NULL
+ && gfc_match ("num_teams ( %e )", &c->num_teams) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_DEVICE) && c->device == NULL
+ && gfc_match ("device ( %e )", &c->device) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_THREAD_LIMIT) && c->thread_limit == NULL
+ && gfc_match ("thread_limit ( %e )", &c->thread_limit) == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_MAP)
+ && gfc_match ("map ( ") == MATCH_YES)
+ {
+ gfc_omp_map_op map_op = OMP_MAP_TOFROM;
+ if (gfc_match ("alloc : ") == MATCH_YES)
+ map_op = OMP_MAP_ALLOC;
+ else if (gfc_match ("tofrom : ") == MATCH_YES)
+ map_op = OMP_MAP_TOFROM;
+ else if (gfc_match ("to : ") == MATCH_YES)
+ map_op = OMP_MAP_TO;
+ else if (gfc_match ("from : ") == MATCH_YES)
+ map_op = OMP_MAP_FROM;
+ head = NULL;
+ if (gfc_match_omp_variable_list ("", &c->lists[OMP_LIST_MAP],
+ false, NULL, &head, true)
+ == MATCH_YES)
+ {
+ gfc_omp_namelist *n;
+ for (n = *head; n; n = n->next)
+ n->u.map_op = map_op;
+ continue;
+ }
+ else
+ gfc_current_locus = old_loc;
+ }
+ if ((mask & OMP_CLAUSE_TO)
+ && gfc_match_omp_variable_list ("to (",
+ &c->lists[OMP_LIST_TO], false,
+ NULL, &head, true)
+ == MATCH_YES)
+ continue;
+ if ((mask & OMP_CLAUSE_FROM)
+ && gfc_match_omp_variable_list ("from (",
+ &c->lists[OMP_LIST_FROM], false,
+ NULL, &head, true)
+ == MATCH_YES)
+ continue;
break;
}
#define OMP_PARALLEL_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
| OMP_CLAUSE_COPYIN | OMP_CLAUSE_REDUCTION | OMP_CLAUSE_IF \
- | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT)
+ | OMP_CLAUSE_NUM_THREADS | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_PROC_BIND)
+#define OMP_DECLARE_SIMD_CLAUSES \
+ (OMP_CLAUSE_SIMDLEN | OMP_CLAUSE_LINEAR | OMP_CLAUSE_UNIFORM \
+ | OMP_CLAUSE_ALIGNED | OMP_CLAUSE_INBRANCH | OMP_CLAUSE_NOTINBRANCH)
#define OMP_DO_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
#define OMP_SECTIONS_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE \
| OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION)
+#define OMP_SIMD_CLAUSES \
+ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_LASTPRIVATE | OMP_CLAUSE_REDUCTION \
+ | OMP_CLAUSE_COLLAPSE | OMP_CLAUSE_SAFELEN | OMP_CLAUSE_LINEAR \
+ | OMP_CLAUSE_ALIGNED)
#define OMP_TASK_CLAUSES \
(OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
| OMP_CLAUSE_IF | OMP_CLAUSE_DEFAULT | OMP_CLAUSE_UNTIED \
- | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE)
-
-match
-gfc_match_omp_parallel (void)
-{
- gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_PARALLEL;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
-}
+ | OMP_CLAUSE_FINAL | OMP_CLAUSE_MERGEABLE | OMP_CLAUSE_DEPEND)
+#define OMP_TARGET_CLAUSES \
+ (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
+#define OMP_TARGET_DATA_CLAUSES \
+ (OMP_CLAUSE_DEVICE | OMP_CLAUSE_MAP | OMP_CLAUSE_IF)
+#define OMP_TARGET_UPDATE_CLAUSES \
+ (OMP_CLAUSE_DEVICE | OMP_CLAUSE_IF | OMP_CLAUSE_TO | OMP_CLAUSE_FROM)
+#define OMP_TEAMS_CLAUSES \
+ (OMP_CLAUSE_NUM_TEAMS | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_DEFAULT \
+ | OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_SHARED \
+ | OMP_CLAUSE_REDUCTION)
+#define OMP_DISTRIBUTE_CLAUSES \
+ (OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_COLLAPSE \
+ | OMP_CLAUSE_DIST_SCHEDULE)
-match
-gfc_match_omp_task (void)
+static match
+match_omp (gfc_exec_op op, unsigned int mask)
{
gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_TASK_CLAUSES) != MATCH_YES)
+ if (gfc_match_omp_clauses (&c, mask) != MATCH_YES)
return MATCH_ERROR;
- new_st.op = EXEC_OMP_TASK;
+ new_st.op = op;
new_st.ext.omp_clauses = c;
return MATCH_YES;
}
match
-gfc_match_omp_taskwait (void)
+gfc_match_omp_critical (void)
{
+ char n[GFC_MAX_SYMBOL_LEN+1];
+
+ if (gfc_match (" ( %n )", n) != MATCH_YES)
+ n[0] = '\0';
if (gfc_match_omp_eos () != MATCH_YES)
{
- gfc_error ("Unexpected junk after TASKWAIT clause at %C");
+ gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
return MATCH_ERROR;
}
- new_st.op = EXEC_OMP_TASKWAIT;
- new_st.ext.omp_clauses = NULL;
+ new_st.op = EXEC_OMP_CRITICAL;
+ new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
return MATCH_YES;
}
match
-gfc_match_omp_taskyield (void)
+gfc_match_omp_distribute (void)
{
- if (gfc_match_omp_eos () != MATCH_YES)
- {
- gfc_error ("Unexpected junk after TASKYIELD clause at %C");
- return MATCH_ERROR;
- }
- new_st.op = EXEC_OMP_TASKYIELD;
- new_st.ext.omp_clauses = NULL;
- return MATCH_YES;
+ return match_omp (EXEC_OMP_DISTRIBUTE, OMP_DISTRIBUTE_CLAUSES);
}
match
-gfc_match_omp_critical (void)
+gfc_match_omp_distribute_parallel_do (void)
{
- char n[GFC_MAX_SYMBOL_LEN+1];
+ return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO,
+ OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES);
+}
- if (gfc_match (" ( %n )", n) != MATCH_YES)
- n[0] = '\0';
- if (gfc_match_omp_eos () != MATCH_YES)
- {
- gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
- return MATCH_ERROR;
- }
- new_st.op = EXEC_OMP_CRITICAL;
- new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
- return MATCH_YES;
+
+match
+gfc_match_omp_distribute_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD,
+ (OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~OMP_CLAUSE_ORDERED);
+}
+
+
+match
+gfc_match_omp_distribute_simd (void)
+{
+ return match_omp (EXEC_OMP_DISTRIBUTE_SIMD,
+ OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
}
match
gfc_match_omp_do (void)
{
- gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_DO_CLAUSES) != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_DO;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
+ return match_omp (EXEC_OMP_DO, OMP_DO_CLAUSES);
+}
+
+
+match
+gfc_match_omp_do_simd (void)
+{
+ return match_omp (EXEC_OMP_DO_SIMD, ((OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~OMP_CLAUSE_ORDERED));
}
match
gfc_match_omp_flush (void)
{
- gfc_namelist *list = NULL;
+ gfc_omp_namelist *list = NULL;
gfc_match_omp_variable_list (" (", &list, true);
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP FLUSH statement at %C");
- gfc_free_namelist (list);
+ gfc_free_omp_namelist (list);
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_FLUSH;
match
-gfc_match_omp_threadprivate (void)
+gfc_match_omp_declare_simd (void)
+{
+ locus where = gfc_current_locus;
+ gfc_symbol *proc_name;
+ gfc_omp_clauses *c;
+ gfc_omp_declare_simd *ods;
+
+ if (gfc_match (" ( %s ) ", &proc_name) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_omp_clauses (&c, OMP_DECLARE_SIMD_CLAUSES, true,
+ false) != MATCH_YES)
+ return MATCH_ERROR;
+
+ ods = gfc_get_omp_declare_simd ();
+ ods->where = where;
+ ods->proc_name = proc_name;
+ ods->clauses = c;
+ ods->next = gfc_current_ns->omp_declare_simd;
+ gfc_current_ns->omp_declare_simd = ods;
+ return MATCH_YES;
+}
+
+
+static bool
+match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
{
- locus old_loc;
- char n[GFC_MAX_SYMBOL_LEN+1];
- gfc_symbol *sym;
match m;
+ locus old_loc = gfc_current_locus;
+ char sname[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_symbol *sym;
+ gfc_namespace *ns = gfc_current_ns;
+ gfc_expr *lvalue = NULL, *rvalue = NULL;
gfc_symtree *st;
+ gfc_actual_arglist *arglist;
- old_loc = gfc_current_locus;
-
- m = gfc_match (" (");
+ m = gfc_match (" %v =", &lvalue);
if (m != MATCH_YES)
- return m;
-
- for (;;)
+ gfc_current_locus = old_loc;
+ else
{
- m = gfc_match_symbol (&sym, 0);
- switch (m)
+ m = gfc_match (" %e )", &rvalue);
+ if (m == MATCH_YES)
{
- case MATCH_YES:
- if (sym->attr.in_common)
- gfc_error_now ("Threadprivate variable at %C is an element of "
- "a COMMON block");
- else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
- goto cleanup;
- goto next_item;
- case MATCH_NO:
- break;
- case MATCH_ERROR:
- goto cleanup;
+ ns->code = gfc_get_code (EXEC_ASSIGN);
+ ns->code->expr1 = lvalue;
+ ns->code->expr2 = rvalue;
+ ns->code->loc = old_loc;
+ return true;
}
- m = gfc_match (" / %n /", n);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO || n[0] == '\0')
- goto syntax;
+ gfc_current_locus = old_loc;
+ gfc_free_expr (lvalue);
+ }
- st = gfc_find_symtree (gfc_current_ns->common_root, n);
- if (st == NULL)
+ m = gfc_match (" %n", sname);
+ if (m != MATCH_YES)
+ return false;
+
+ if (strcmp (sname, omp_sym1->name) == 0
+ || strcmp (sname, omp_sym2->name) == 0)
+ return false;
+
+ gfc_current_ns = ns->parent;
+ if (gfc_get_ha_sym_tree (sname, &st))
+ return false;
+
+ sym = st->n.sym;
+ if (sym->attr.flavor != FL_PROCEDURE
+ && sym->attr.flavor != FL_UNKNOWN)
+ return false;
+
+ if (!sym->attr.generic
+ && !sym->attr.subroutine
+ && !sym->attr.function)
+ {
+ if (!(sym->attr.external && !sym->attr.referenced))
{
- gfc_error ("COMMON block /%s/ not found at %C", n);
- goto cleanup;
+ /* ...create a symbol in this scope... */
+ if (sym->ns != gfc_current_ns
+ && gfc_get_sym_tree (sname, NULL, &st, false) == 1)
+ return false;
+
+ if (sym != st->n.sym)
+ sym = st->n.sym;
}
- st->n.common->threadprivate = 1;
- for (sym = st->n.common->head; sym; sym = sym->common_next)
- if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
- goto cleanup;
- next_item:
- if (gfc_match_char (')') == MATCH_YES)
- break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
+ /* ...and then to try to make the symbol into a subroutine. */
+ if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
+ return false;
}
- return MATCH_YES;
+ gfc_set_sym_referenced (sym);
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () != '(')
+ return false;
-syntax:
+ gfc_current_ns = ns;
+ m = gfc_match_actual_arglist (1, &arglist);
+ if (m != MATCH_YES)
+ return false;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ return false;
+
+ ns->code = gfc_get_code (EXEC_CALL);
+ ns->code->symtree = st;
+ ns->code->ext.actual = arglist;
+ ns->code->loc = old_loc;
+ return true;
+}
+
+static bool
+gfc_omp_udr_predef (gfc_omp_reduction_op rop, const char *name,
+ gfc_typespec *ts, const char **n)
+{
+ if (!gfc_numeric_ts (ts) && ts->type != BT_LOGICAL)
+ return false;
+
+ switch (rop)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_TIMES:
+ return ts->type != BT_LOGICAL;
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ return ts->type == BT_LOGICAL;
+ case OMP_REDUCTION_USER:
+ if (name[0] != '.' && (ts->type == BT_INTEGER || ts->type == BT_REAL))
+ {
+ gfc_symbol *sym;
+
+ gfc_find_symbol (name, NULL, 1, &sym);
+ if (sym != NULL)
+ {
+ if (sym->attr.intrinsic)
+ *n = sym->name;
+ else if ((sym->attr.flavor != FL_UNKNOWN
+ && sym->attr.flavor != FL_PROCEDURE)
+ || sym->attr.external
+ || sym->attr.generic
+ || sym->attr.entry
+ || sym->attr.result
+ || sym->attr.dummy
+ || sym->attr.subroutine
+ || sym->attr.pointer
+ || sym->attr.target
+ || sym->attr.cray_pointer
+ || sym->attr.cray_pointee
+ || (sym->attr.proc != PROC_UNKNOWN
+ && sym->attr.proc != PROC_INTRINSIC)
+ || sym->attr.if_source != IFSRC_UNKNOWN
+ || sym == sym->ns->proc_name)
+ *n = NULL;
+ else
+ *n = sym->name;
+ }
+ else
+ *n = name;
+ if (*n
+ && (strcmp (*n, "max") == 0 || strcmp (*n, "min") == 0))
+ return true;
+ else if (*n
+ && ts->type == BT_INTEGER
+ && (strcmp (*n, "iand") == 0
+ || strcmp (*n, "ior") == 0
+ || strcmp (*n, "ieor") == 0))
+ return true;
+ }
+ break;
+ default:
+ break;
+ }
+ return false;
+}
+
+gfc_omp_udr *
+gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
+{
+ gfc_omp_udr *omp_udr;
+
+ if (st == NULL)
+ return NULL;
+
+ for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+ if (omp_udr->ts.type == ts->type
+ || ((omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
+ && (ts->type == BT_DERIVED && ts->type == BT_CLASS)))
+ {
+ if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
+ {
+ if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
+ return omp_udr;
+ }
+ else if (omp_udr->ts.kind == ts->kind)
+ {
+ if (omp_udr->ts.type == BT_CHARACTER)
+ {
+ if (omp_udr->ts.u.cl->length == NULL
+ || ts->u.cl->length == NULL)
+ return omp_udr;
+ if (omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ return omp_udr;
+ if (ts->u.cl->length->expr_type != EXPR_CONSTANT)
+ return omp_udr;
+ if (omp_udr->ts.u.cl->length->ts.type != BT_INTEGER)
+ return omp_udr;
+ if (ts->u.cl->length->ts.type != BT_INTEGER)
+ return omp_udr;
+ if (gfc_compare_expr (omp_udr->ts.u.cl->length,
+ ts->u.cl->length, INTRINSIC_EQ) != 0)
+ continue;
+ }
+ return omp_udr;
+ }
+ }
+ return NULL;
+}
+
+match
+gfc_match_omp_declare_reduction (void)
+{
+ match m;
+ gfc_intrinsic_op op;
+ char name[GFC_MAX_SYMBOL_LEN + 3];
+ auto_vec<gfc_typespec, 5> tss;
+ gfc_typespec ts;
+ unsigned int i;
+ gfc_symtree *st;
+ locus where = gfc_current_locus;
+ locus end_loc = gfc_current_locus;
+ bool end_loc_set = false;
+ gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ return MATCH_ERROR;
+
+ m = gfc_match (" %o : ", &op);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_YES)
+ {
+ snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
+ rop = (gfc_omp_reduction_op) op;
+ }
+ else
+ {
+ m = gfc_match_defined_op_name (name + 1, 1);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_YES)
+ {
+ name[0] = '.';
+ strcat (name, ".");
+ if (gfc_match (" : ") != MATCH_YES)
+ return MATCH_ERROR;
+ }
+ else
+ {
+ if (gfc_match (" %n : ", name) != MATCH_YES)
+ return MATCH_ERROR;
+ }
+ rop = OMP_REDUCTION_USER;
+ }
+
+ m = gfc_match_type_spec (&ts);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+ /* Treat len=: the same as len=*. */
+ if (ts.type == BT_CHARACTER)
+ ts.deferred = false;
+ tss.safe_push (ts);
+
+ while (gfc_match_char (',') == MATCH_YES)
+ {
+ m = gfc_match_type_spec (&ts);
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+ tss.safe_push (ts);
+ }
+ if (gfc_match_char (':') != MATCH_YES)
+ return MATCH_ERROR;
+
+ st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
+ for (i = 0; i < tss.length (); i++)
+ {
+ gfc_symtree *omp_out, *omp_in;
+ gfc_symtree *omp_priv = NULL, *omp_orig = NULL;
+ gfc_namespace *combiner_ns, *initializer_ns = NULL;
+ gfc_omp_udr *prev_udr, *omp_udr;
+ const char *predef_name = NULL;
+
+ omp_udr = gfc_get_omp_udr ();
+ omp_udr->name = gfc_get_string (name);
+ omp_udr->rop = rop;
+ omp_udr->ts = tss[i];
+ omp_udr->where = where;
+
+ gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
+ combiner_ns->proc_name = combiner_ns->parent->proc_name;
+
+ gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
+ gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
+ combiner_ns->omp_udr_ns = 1;
+ omp_out->n.sym->ts = tss[i];
+ omp_in->n.sym->ts = tss[i];
+ omp_out->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_in->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_out->n.sym->attr.flavor = FL_VARIABLE;
+ omp_in->n.sym->attr.flavor = FL_VARIABLE;
+ gfc_commit_symbols ();
+ omp_udr->combiner_ns = combiner_ns;
+ omp_udr->omp_out = omp_out->n.sym;
+ omp_udr->omp_in = omp_in->n.sym;
+
+ locus old_loc = gfc_current_locus;
+
+ if (!match_udr_expr (omp_out, omp_in))
+ {
+ syntax:
+ gfc_current_locus = old_loc;
+ gfc_current_ns = combiner_ns->parent;
+ gfc_free_omp_udr (omp_udr);
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" initializer ( ") == MATCH_YES)
+ {
+ gfc_current_ns = combiner_ns->parent;
+ initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
+ gfc_current_ns = initializer_ns;
+ initializer_ns->proc_name = initializer_ns->parent->proc_name;
+
+ gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
+ gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
+ initializer_ns->omp_udr_ns = 1;
+ omp_priv->n.sym->ts = tss[i];
+ omp_orig->n.sym->ts = tss[i];
+ omp_priv->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_orig->n.sym->attr.omp_udr_artificial_var = 1;
+ omp_priv->n.sym->attr.flavor = FL_VARIABLE;
+ omp_orig->n.sym->attr.flavor = FL_VARIABLE;
+ gfc_commit_symbols ();
+ omp_udr->initializer_ns = initializer_ns;
+ omp_udr->omp_priv = omp_priv->n.sym;
+ omp_udr->omp_orig = omp_orig->n.sym;
+
+ if (!match_udr_expr (omp_priv, omp_orig))
+ goto syntax;
+ }
+
+ gfc_current_ns = combiner_ns->parent;
+ if (!end_loc_set)
+ {
+ end_loc_set = true;
+ end_loc = gfc_current_locus;
+ }
+ gfc_current_locus = old_loc;
+
+ prev_udr = gfc_omp_udr_find (st, &tss[i]);
+ if (gfc_omp_udr_predef (rop, name, &tss[i], &predef_name)
+ /* Don't error on !$omp declare reduction (min : integer : ...)
+ just yet, there could be integer :: min afterwards,
+ making it valid. When the UDR is resolved, we'll get
+ to it again. */
+ && (rop != OMP_REDUCTION_USER || name[0] == '.'))
+ {
+ if (predef_name)
+ gfc_error_now ("Redefinition of predefined %s "
+ "!$OMP DECLARE REDUCTION at %L",
+ predef_name, &where);
+ else
+ gfc_error_now ("Redefinition of predefined "
+ "!$OMP DECLARE REDUCTION at %L", &where);
+ }
+ else if (prev_udr)
+ {
+ gfc_error_now ("Redefinition of !$OMP DECLARE REDUCTION at %L",
+ &where);
+ gfc_error_now ("Previous !$OMP DECLARE REDUCTION at %L",
+ &prev_udr->where);
+ }
+ else if (st)
+ {
+ omp_udr->next = st->n.omp_udr;
+ st->n.omp_udr = omp_udr;
+ }
+ else
+ {
+ st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
+ st->n.omp_udr = omp_udr;
+ }
+ }
+
+ if (end_loc_set)
+ {
+ gfc_current_locus = end_loc;
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$OMP DECLARE REDUCTION at %C");
+ gfc_current_locus = where;
+ return MATCH_ERROR;
+ }
+
+ return MATCH_YES;
+ }
+ gfc_clear_error ();
+ return MATCH_ERROR;
+}
+
+
+match
+gfc_match_omp_declare_target (void)
+{
+ locus old_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (" (");
+
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && m == MATCH_YES)
+ {
+ gfc_error ("Only the !$OMP DECLARE TARGET form without "
+ "list is allowed in interface block at %C");
+ goto cleanup;
+ }
+
+ if (m == MATCH_NO
+ && gfc_current_ns->proc_name
+ && gfc_match_omp_eos () == MATCH_YES)
+ {
+ if (!gfc_add_omp_declare_target (&gfc_current_ns->proc_name->attr,
+ gfc_current_ns->proc_name->name,
+ &old_loc))
+ goto cleanup;
+ return MATCH_YES;
+ }
+
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_YES:
+ if (sym->attr.in_common)
+ gfc_error_now ("OMP DECLARE TARGET on a variable at %C is an "
+ "element of a COMMON block");
+ else if (!gfc_add_omp_declare_target (&sym->attr, sym->name,
+ &sym->declared_at))
+ goto cleanup;
+ goto next_item;
+ case MATCH_NO:
+ break;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO || n[0] == '\0')
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+ st->n.common->omp_declare_target = 1;
+ for (sym = st->n.common->head; sym; sym = sym->common_next)
+ if (!gfc_add_omp_declare_target (&sym->attr, sym->name,
+ &sym->declared_at))
+ goto cleanup;
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after !$OMP DECLARE TARGET at %C");
+ goto cleanup;
+ }
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in !$OMP DECLARE TARGET list at %C");
+
+cleanup:
+ gfc_current_locus = old_loc;
+ return MATCH_ERROR;
+}
+
+
+match
+gfc_match_omp_threadprivate (void)
+{
+ locus old_loc;
+ char n[GFC_MAX_SYMBOL_LEN+1];
+ gfc_symbol *sym;
+ match m;
+ gfc_symtree *st;
+
+ old_loc = gfc_current_locus;
+
+ m = gfc_match (" (");
+ if (m != MATCH_YES)
+ return m;
+
+ for (;;)
+ {
+ m = gfc_match_symbol (&sym, 0);
+ switch (m)
+ {
+ case MATCH_YES:
+ if (sym->attr.in_common)
+ gfc_error_now ("Threadprivate variable at %C is an element of "
+ "a COMMON block");
+ else if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
+ goto cleanup;
+ goto next_item;
+ case MATCH_NO:
+ break;
+ case MATCH_ERROR:
+ goto cleanup;
+ }
+
+ m = gfc_match (" / %n /", n);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO || n[0] == '\0')
+ goto syntax;
+
+ st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ if (st == NULL)
+ {
+ gfc_error ("COMMON block /%s/ not found at %C", n);
+ goto cleanup;
+ }
+ st->n.common->threadprivate = 1;
+ for (sym = st->n.common->head; sym; sym = sym->common_next)
+ if (!gfc_add_threadprivate (&sym->attr, sym->name, &sym->declared_at))
+ goto cleanup;
+
+ next_item:
+ if (gfc_match_char (')') == MATCH_YES)
+ break;
+ if (gfc_match_char (',') != MATCH_YES)
+ goto syntax;
+ }
+
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after OMP THREADPRIVATE at %C");
+ goto cleanup;
+ }
+
+ return MATCH_YES;
+
+syntax:
gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
cleanup:
match
+gfc_match_omp_parallel (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL, OMP_PARALLEL_CLAUSES);
+}
+
+
+match
gfc_match_omp_parallel_do (void)
{
- gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES)
- != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_PARALLEL_DO;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
+ return match_omp (EXEC_OMP_PARALLEL_DO,
+ OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
+}
+
+
+match
+gfc_match_omp_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_PARALLEL_DO_SIMD,
+ (OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~OMP_CLAUSE_ORDERED);
}
match
gfc_match_omp_parallel_sections (void)
{
- gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES)
- != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_PARALLEL_SECTIONS;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
+ return match_omp (EXEC_OMP_PARALLEL_SECTIONS,
+ OMP_PARALLEL_CLAUSES | OMP_SECTIONS_CLAUSES);
}
match
gfc_match_omp_parallel_workshare (void)
{
- gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_PARALLEL_CLAUSES) != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_PARALLEL_WORKSHARE;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
+ return match_omp (EXEC_OMP_PARALLEL_WORKSHARE, OMP_PARALLEL_CLAUSES);
}
match
gfc_match_omp_sections (void)
{
- gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_SECTIONS_CLAUSES) != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_SECTIONS;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
+ return match_omp (EXEC_OMP_SECTIONS, OMP_SECTIONS_CLAUSES);
+}
+
+
+match
+gfc_match_omp_simd (void)
+{
+ return match_omp (EXEC_OMP_SIMD, OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_single (void)
+{
+ return match_omp (EXEC_OMP_SINGLE,
+ OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE);
+}
+
+
+match
+gfc_match_omp_task (void)
+{
+ return match_omp (EXEC_OMP_TASK, OMP_TASK_CLAUSES);
+}
+
+
+match
+gfc_match_omp_taskwait (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after TASKWAIT clause at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_TASKWAIT;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_taskyield (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after TASKYIELD clause at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_TASKYIELD;
+ new_st.ext.omp_clauses = NULL;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_target (void)
+{
+ return match_omp (EXEC_OMP_TARGET, OMP_TARGET_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_data (void)
+{
+ return match_omp (EXEC_OMP_TARGET_DATA, OMP_TARGET_DATA_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams_distribute (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams_distribute_parallel_do (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_teams_distribute_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
+ (OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES | OMP_PARALLEL_CLAUSES
+ | OMP_DO_CLAUSES | OMP_SIMD_CLAUSES)
+ & ~OMP_CLAUSE_ORDERED);
+}
+
+
+match
+gfc_match_omp_target_teams_distribute_simd (void)
+{
+ return match_omp (EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD,
+ OMP_TARGET_CLAUSES | OMP_TEAMS_CLAUSES
+ | OMP_DISTRIBUTE_CLAUSES | OMP_SIMD_CLAUSES);
+}
+
+
+match
+gfc_match_omp_target_update (void)
+{
+ return match_omp (EXEC_OMP_TARGET_UPDATE, OMP_TARGET_UPDATE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_teams (void)
+{
+ return match_omp (EXEC_OMP_TEAMS, OMP_TEAMS_CLAUSES);
+}
+
+
+match
+gfc_match_omp_teams_distribute (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE,
+ OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES);
+}
+
+
+match
+gfc_match_omp_teams_distribute_parallel_do (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO,
+ OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
+ | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES);
+}
+
+
+match
+gfc_match_omp_teams_distribute_parallel_do_simd (void)
+{
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
+ (OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
+ | OMP_PARALLEL_CLAUSES | OMP_DO_CLAUSES
+ | OMP_SIMD_CLAUSES) & ~OMP_CLAUSE_ORDERED);
}
match
-gfc_match_omp_single (void)
+gfc_match_omp_teams_distribute_simd (void)
{
- gfc_omp_clauses *c;
- if (gfc_match_omp_clauses (&c, OMP_CLAUSE_PRIVATE | OMP_CLAUSE_FIRSTPRIVATE)
- != MATCH_YES)
- return MATCH_ERROR;
- new_st.op = EXEC_OMP_SINGLE;
- new_st.ext.omp_clauses = c;
- return MATCH_YES;
+ return match_omp (EXEC_OMP_TEAMS_DISTRIBUTE_SIMD,
+ OMP_TEAMS_CLAUSES | OMP_DISTRIBUTE_CLAUSES
+ | OMP_SIMD_CLAUSES);
}
gfc_match_omp_atomic (void)
{
gfc_omp_atomic_op op = GFC_OMP_ATOMIC_UPDATE;
- if (gfc_match ("% update") == MATCH_YES)
- op = GFC_OMP_ATOMIC_UPDATE;
- else if (gfc_match ("% read") == MATCH_YES)
- op = GFC_OMP_ATOMIC_READ;
- else if (gfc_match ("% write") == MATCH_YES)
- op = GFC_OMP_ATOMIC_WRITE;
- else if (gfc_match ("% capture") == MATCH_YES)
- op = GFC_OMP_ATOMIC_CAPTURE;
+ int seq_cst = 0;
+ if (gfc_match ("% seq_cst") == MATCH_YES)
+ seq_cst = 1;
+ locus old_loc = gfc_current_locus;
+ if (seq_cst && gfc_match_char (',') == MATCH_YES)
+ seq_cst = 2;
+ if (seq_cst == 2
+ || gfc_match_space () == MATCH_YES)
+ {
+ gfc_gobble_whitespace ();
+ if (gfc_match ("update") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_UPDATE;
+ else if (gfc_match ("read") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_READ;
+ else if (gfc_match ("write") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_WRITE;
+ else if (gfc_match ("capture") == MATCH_YES)
+ op = GFC_OMP_ATOMIC_CAPTURE;
+ else
+ {
+ if (seq_cst == 2)
+ gfc_current_locus = old_loc;
+ goto finish;
+ }
+ if (!seq_cst
+ && (gfc_match (", seq_cst") == MATCH_YES
+ || gfc_match ("% seq_cst") == MATCH_YES))
+ seq_cst = 1;
+ }
+ finish:
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP ATOMIC statement at %C");
return MATCH_ERROR;
}
new_st.op = EXEC_OMP_ATOMIC;
+ if (seq_cst)
+ op = (gfc_omp_atomic_op) (op | GFC_OMP_ATOMIC_SEQ_CST);
new_st.ext.omp_atomic = op;
return MATCH_YES;
}
match
+gfc_match_omp_taskgroup (void)
+{
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP TASKGROUP statement at %C");
+ return MATCH_ERROR;
+ }
+ new_st.op = EXEC_OMP_TASKGROUP;
+ return MATCH_YES;
+}
+
+
+static enum gfc_omp_cancel_kind
+gfc_match_omp_cancel_kind (void)
+{
+ if (gfc_match_space () != MATCH_YES)
+ return OMP_CANCEL_UNKNOWN;
+ if (gfc_match ("parallel") == MATCH_YES)
+ return OMP_CANCEL_PARALLEL;
+ if (gfc_match ("sections") == MATCH_YES)
+ return OMP_CANCEL_SECTIONS;
+ if (gfc_match ("do") == MATCH_YES)
+ return OMP_CANCEL_DO;
+ if (gfc_match ("taskgroup") == MATCH_YES)
+ return OMP_CANCEL_TASKGROUP;
+ return OMP_CANCEL_UNKNOWN;
+}
+
+
+match
+gfc_match_omp_cancel (void)
+{
+ gfc_omp_clauses *c;
+ enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
+ if (kind == OMP_CANCEL_UNKNOWN)
+ return MATCH_ERROR;
+ if (gfc_match_omp_clauses (&c, OMP_CLAUSE_IF, false) != MATCH_YES)
+ return MATCH_ERROR;
+ c->cancel = kind;
+ new_st.op = EXEC_OMP_CANCEL;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_cancellation_point (void)
+{
+ gfc_omp_clauses *c;
+ enum gfc_omp_cancel_kind kind = gfc_match_omp_cancel_kind ();
+ if (kind == OMP_CANCEL_UNKNOWN)
+ return MATCH_ERROR;
+ if (gfc_match_omp_eos () != MATCH_YES)
+ {
+ gfc_error ("Unexpected junk after $OMP CANCELLATION POINT statement "
+ "at %C");
+ return MATCH_ERROR;
+ }
+ c = gfc_get_omp_clauses ();
+ c->cancel = kind;
+ new_st.op = EXEC_OMP_CANCELLATION_POINT;
+ new_st.ext.omp_clauses = c;
+ return MATCH_YES;
+}
+
+
+match
gfc_match_omp_end_nowait (void)
{
bool nowait = false;
}
+struct resolve_omp_udr_callback_data
+{
+ gfc_symbol *sym1, *sym2;
+};
+
+
+static int
+resolve_omp_udr_callback (gfc_expr **e, int *, void *data)
+{
+ struct resolve_omp_udr_callback_data *rcd
+ = (struct resolve_omp_udr_callback_data *) data;
+ if ((*e)->expr_type == EXPR_VARIABLE
+ && ((*e)->symtree->n.sym == rcd->sym1
+ || (*e)->symtree->n.sym == rcd->sym2))
+ {
+ gfc_ref *ref = gfc_get_ref ();
+ ref->type = REF_ARRAY;
+ ref->u.ar.where = (*e)->where;
+ ref->u.ar.as = (*e)->symtree->n.sym->as;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.dimen = 0;
+ ref->next = (*e)->ref;
+ (*e)->ref = ref;
+ }
+ return 0;
+}
+
+
+static int
+resolve_omp_udr_callback2 (gfc_expr **e, int *, void *)
+{
+ if ((*e)->expr_type == EXPR_FUNCTION
+ && (*e)->value.function.isym == NULL)
+ {
+ gfc_symbol *sym = (*e)->symtree->n.sym;
+ if (!sym->attr.intrinsic
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ gfc_error ("Implicitly declared function %s used in "
+ "!$OMP DECLARE REDUCTION at %L ", sym->name, &(*e)->where);
+ }
+ return 0;
+}
+
+
+static gfc_code *
+resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
+ gfc_symbol *sym1, gfc_symbol *sym2)
+{
+ gfc_code *copy;
+ gfc_symbol sym1_copy, sym2_copy;
+
+ if (ns->code->op == EXEC_ASSIGN)
+ {
+ copy = gfc_get_code (EXEC_ASSIGN);
+ copy->expr1 = gfc_copy_expr (ns->code->expr1);
+ copy->expr2 = gfc_copy_expr (ns->code->expr2);
+ }
+ else
+ {
+ copy = gfc_get_code (EXEC_CALL);
+ copy->symtree = ns->code->symtree;
+ copy->ext.actual = gfc_copy_actual_arglist (ns->code->ext.actual);
+ }
+ copy->loc = ns->code->loc;
+ sym1_copy = *sym1;
+ sym2_copy = *sym2;
+ *sym1 = *n->sym;
+ *sym2 = *n->sym;
+ sym1->name = sym1_copy.name;
+ sym2->name = sym2_copy.name;
+ ns->proc_name = ns->parent->proc_name;
+ if (n->sym->attr.dimension)
+ {
+ struct resolve_omp_udr_callback_data rcd;
+ rcd.sym1 = sym1;
+ rcd.sym2 = sym2;
+ gfc_code_walker (©, gfc_dummy_code_callback,
+ resolve_omp_udr_callback, &rcd);
+ }
+ gfc_resolve_code (copy, gfc_current_ns);
+ if (copy->op == EXEC_CALL && copy->resolved_isym == NULL)
+ {
+ gfc_symbol *sym = copy->resolved_sym;
+ if (sym
+ && !sym->attr.intrinsic
+ && sym->attr.if_source == IFSRC_UNKNOWN)
+ gfc_error ("Implicitly declared subroutine %s used in "
+ "!$OMP DECLARE REDUCTION at %L ", sym->name,
+ ©->loc);
+ }
+ gfc_code_walker (©, gfc_dummy_code_callback,
+ resolve_omp_udr_callback2, NULL);
+ *sym1 = sym1_copy;
+ *sym2 = sym2_copy;
+ return copy;
+}
+
+
/* OpenMP directive resolving routines. */
static void
-resolve_omp_clauses (gfc_code *code)
+resolve_omp_clauses (gfc_code *code, locus *where,
+ gfc_omp_clauses *omp_clauses, gfc_namespace *ns)
{
- gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
- gfc_namelist *n;
+ gfc_omp_namelist *n;
int list;
static const char *clause_names[]
= { "PRIVATE", "FIRSTPRIVATE", "LASTPRIVATE", "COPYPRIVATE", "SHARED",
- "COPYIN", "REDUCTION" };
+ "COPYIN", "UNIFORM", "ALIGNED", "LINEAR", "DEPEND", "MAP",
+ "TO", "FROM", "REDUCTION" };
if (omp_clauses == NULL)
return;
for (n = omp_clauses->lists[list]; n; n = n->next)
{
n->sym->mark = 0;
- if (n->sym->attr.flavor == FL_VARIABLE || n->sym->attr.proc_pointer)
- continue;
+ if (n->sym->attr.flavor == FL_VARIABLE
+ || n->sym->attr.proc_pointer
+ || (!code && (!n->sym->attr.dummy || n->sym->ns != ns)))
+ {
+ if (!code && (!n->sym->attr.dummy || n->sym->ns != ns))
+ gfc_error ("Variable '%s' is not a dummy argument at %L",
+ n->sym->name, where);
+ continue;
+ }
if (n->sym->attr.flavor == FL_PROCEDURE
&& n->sym->result == n->sym
&& n->sym->attr.function)
}
}
gfc_error ("Object '%s' is not a variable at %L", n->sym->name,
- &code->loc);
+ where);
}
for (list = 0; list < OMP_LIST_NUM; list++)
- if (list != OMP_LIST_FIRSTPRIVATE && list != OMP_LIST_LASTPRIVATE)
+ if (list != OMP_LIST_FIRSTPRIVATE
+ && list != OMP_LIST_LASTPRIVATE
+ && list != OMP_LIST_ALIGNED
+ && list != OMP_LIST_DEPEND
+ && list != OMP_LIST_MAP
+ && list != OMP_LIST_FROM
+ && list != OMP_LIST_TO)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
else
n->sym->mark = 1;
}
if (n->sym->mark)
{
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
n->sym->mark = 0;
}
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
else
n->sym->mark = 1;
}
{
if (n->sym->mark)
gfc_error ("Symbol '%s' present on multiple clauses at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
+ else
+ n->sym->mark = 1;
+ }
+
+ for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ n->sym->mark = 0;
+
+ for (n = omp_clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
+ {
+ if (n->sym->mark)
+ gfc_error ("Symbol '%s' present on multiple clauses at %L",
+ n->sym->name, where);
else
n->sym->mark = 1;
}
+
+ for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
+ n->sym->mark = 0;
+ for (n = omp_clauses->lists[OMP_LIST_FROM]; n; n = n->next)
+ if (n->expr == NULL)
+ n->sym->mark = 1;
+ for (n = omp_clauses->lists[OMP_LIST_TO]; n; n = n->next)
+ {
+ if (n->expr == NULL && n->sym->mark)
+ gfc_error ("Symbol '%s' present on both FROM and TO clauses at %L",
+ n->sym->name, where);
+ else
+ n->sym->mark = 1;
+ }
+
for (list = 0; list < OMP_LIST_NUM; list++)
if ((n = omp_clauses->lists[list]) != NULL)
{
const char *name;
- if (list < OMP_LIST_REDUCTION_FIRST)
+ if (list < OMP_LIST_NUM)
name = clause_names[list];
- else if (list <= OMP_LIST_REDUCTION_LAST)
- name = clause_names[OMP_LIST_REDUCTION_FIRST];
else
gcc_unreachable ();
{
if (!n->sym->attr.threadprivate)
gfc_error ("Non-THREADPRIVATE object '%s' in COPYIN clause"
- " at %L", n->sym->name, &code->loc);
- if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
- gfc_error ("COPYIN clause object '%s' at %L has ALLOCATABLE components",
- n->sym->name, &code->loc);
+ " at %L", n->sym->name, where);
}
break;
case OMP_LIST_COPYPRIVATE:
{
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in COPYPRIVATE clause "
- "at %L", n->sym->name, &code->loc);
- if (n->sym->ts.type == BT_DERIVED && n->sym->ts.u.derived->attr.alloc_comp)
- gfc_error ("COPYPRIVATE clause object '%s' at %L has ALLOCATABLE components",
- n->sym->name, &code->loc);
+ "at %L", n->sym->name, where);
+ if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
+ gfc_error ("INTENT(IN) POINTER '%s' in COPYPRIVATE clause "
+ "at %L", n->sym->name, where);
}
break;
case OMP_LIST_SHARED:
{
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in SHARED clause at "
- "%L", n->sym->name, &code->loc);
+ "%L", n->sym->name, where);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in SHARED clause at %L",
- n->sym->name, &code->loc);
+ n->sym->name, where);
+ if (n->sym->attr.associate_var)
+ gfc_error ("ASSOCIATE name '%s' in SHARED clause at %L",
+ n->sym->name, where);
+ }
+ break;
+ case OMP_LIST_ALIGNED:
+ for (; n != NULL; n = n->next)
+ {
+ if (!n->sym->attr.pointer
+ && !n->sym->attr.allocatable
+ && !n->sym->attr.cray_pointer
+ && (n->sym->ts.type != BT_DERIVED
+ || (n->sym->ts.u.derived->from_intmod
+ != INTMOD_ISO_C_BINDING)
+ || (n->sym->ts.u.derived->intmod_sym_id
+ != ISOCBINDING_PTR)))
+ gfc_error ("'%s' in ALIGNED clause must be POINTER, "
+ "ALLOCATABLE, Cray pointer or C_PTR at %L",
+ n->sym->name, where);
+ else if (n->expr)
+ {
+ gfc_expr *expr = n->expr;
+ int alignment = 0;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER
+ || expr->rank != 0
+ || gfc_extract_int (expr, &alignment)
+ || alignment <= 0)
+ gfc_error ("'%s' in ALIGNED clause at %L requires a scalar "
+ "positive constant integer alignment "
+ "expression", n->sym->name, where);
+ }
}
break;
+ case OMP_LIST_DEPEND:
+ case OMP_LIST_MAP:
+ case OMP_LIST_TO:
+ case OMP_LIST_FROM:
+ for (; n != NULL; n = n->next)
+ if (n->expr)
+ {
+ if (!gfc_resolve_expr (n->expr)
+ || n->expr->expr_type != EXPR_VARIABLE
+ || n->expr->ref == NULL
+ || n->expr->ref->next
+ || n->expr->ref->type != REF_ARRAY)
+ gfc_error ("'%s' in %s clause at %L is not a proper "
+ "array section", n->sym->name, name, where);
+ else if (n->expr->ref->u.ar.codimen)
+ gfc_error ("Coarrays not supported in %s clause at %L",
+ name, where);
+ else
+ {
+ int i;
+ gfc_array_ref *ar = &n->expr->ref->u.ar;
+ for (i = 0; i < ar->dimen; i++)
+ if (ar->stride[i])
+ {
+ gfc_error ("Stride should not be specified for "
+ "array section in %s clause at %L",
+ name, where);
+ break;
+ }
+ else if (ar->dimen_type[i] != DIMEN_ELEMENT
+ && ar->dimen_type[i] != DIMEN_RANGE)
+ {
+ gfc_error ("'%s' in %s clause at %L is not a "
+ "proper array section",
+ n->sym->name, name, where);
+ break;
+ }
+ else if (list == OMP_LIST_DEPEND
+ && ar->start[i]
+ && ar->start[i]->expr_type == EXPR_CONSTANT
+ && ar->end[i]
+ && ar->end[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (ar->start[i]->value.integer,
+ ar->end[i]->value.integer) > 0)
+ {
+ gfc_error ("'%s' in DEPEND clause at %L is a zero "
+ "size array section", n->sym->name,
+ where);
+ break;
+ }
+ }
+ }
+ if (list != OMP_LIST_DEPEND)
+ for (n = omp_clauses->lists[list]; n != NULL; n = n->next)
+ {
+ n->sym->attr.referenced = 1;
+ if (n->sym->attr.threadprivate)
+ gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ if (n->sym->attr.cray_pointee)
+ gfc_error ("Cray pointee '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ }
+ break;
default:
for (; n != NULL; n = n->next)
{
+ bool bad = false;
if (n->sym->attr.threadprivate)
gfc_error ("THREADPRIVATE object '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
if (n->sym->attr.cray_pointee)
gfc_error ("Cray pointee '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
+ if (n->sym->attr.associate_var)
+ gfc_error ("ASSOCIATE name '%s' in %s clause at %L",
+ n->sym->name, name, where);
if (list != OMP_LIST_PRIVATE)
{
- if (n->sym->attr.pointer
- && list >= OMP_LIST_REDUCTION_FIRST
- && list <= OMP_LIST_REDUCTION_LAST)
+ if (n->sym->attr.proc_pointer && list == OMP_LIST_REDUCTION)
+ gfc_error ("Procedure pointer '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ if (n->sym->attr.pointer && list == OMP_LIST_REDUCTION)
gfc_error ("POINTER object '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
- /* Variables in REDUCTION-clauses must be of intrinsic type (flagged below). */
- if ((list < OMP_LIST_REDUCTION_FIRST || list > OMP_LIST_REDUCTION_LAST)
- && n->sym->ts.type == BT_DERIVED
- && n->sym->ts.u.derived->attr.alloc_comp)
- gfc_error ("%s clause object '%s' has ALLOCATABLE components at %L",
- name, n->sym->name, &code->loc);
- if (n->sym->attr.cray_pointer
- && list >= OMP_LIST_REDUCTION_FIRST
- && list <= OMP_LIST_REDUCTION_LAST)
+ n->sym->name, name, where);
+ if (n->sym->attr.cray_pointer && list == OMP_LIST_REDUCTION)
gfc_error ("Cray pointer '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
}
if (n->sym->as && n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array '%s' in %s clause at %L",
- n->sym->name, name, &code->loc);
- if (n->sym->attr.in_namelist
- && (list < OMP_LIST_REDUCTION_FIRST
- || list > OMP_LIST_REDUCTION_LAST))
+ n->sym->name, name, where);
+ if (n->sym->attr.in_namelist && list != OMP_LIST_REDUCTION)
gfc_error ("Variable '%s' in %s clause is used in "
"NAMELIST statement at %L",
- n->sym->name, name, &code->loc);
+ n->sym->name, name, where);
+ if (n->sym->attr.pointer && n->sym->attr.intent == INTENT_IN)
+ switch (list)
+ {
+ case OMP_LIST_PRIVATE:
+ case OMP_LIST_LASTPRIVATE:
+ case OMP_LIST_LINEAR:
+ /* case OMP_LIST_REDUCTION: */
+ gfc_error ("INTENT(IN) POINTER '%s' in %s clause at %L",
+ n->sym->name, name, where);
+ break;
+ default:
+ break;
+ }
switch (list)
{
- case OMP_LIST_PLUS:
- case OMP_LIST_MULT:
- case OMP_LIST_SUB:
- if (!gfc_numeric_ts (&n->sym->ts))
- gfc_error ("%c REDUCTION variable '%s' at %L must be of numeric type, got %s",
- list == OMP_LIST_PLUS ? '+'
- : list == OMP_LIST_MULT ? '*' : '-',
- n->sym->name, &code->loc,
- gfc_typename (&n->sym->ts));
+ case OMP_LIST_REDUCTION:
+ switch (n->u.reduction_op)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_MINUS:
+ if (!gfc_numeric_ts (&n->sym->ts))
+ bad = true;
+ break;
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ if (n->sym->ts.type != BT_LOGICAL)
+ bad = true;
+ break;
+ case OMP_REDUCTION_MAX:
+ case OMP_REDUCTION_MIN:
+ if (n->sym->ts.type != BT_INTEGER
+ && n->sym->ts.type != BT_REAL)
+ bad = true;
+ break;
+ case OMP_REDUCTION_IAND:
+ case OMP_REDUCTION_IOR:
+ case OMP_REDUCTION_IEOR:
+ if (n->sym->ts.type != BT_INTEGER)
+ bad = true;
+ break;
+ case OMP_REDUCTION_USER:
+ bad = true;
+ break;
+ default:
+ break;
+ }
+ if (!bad)
+ n->udr = NULL;
+ else
+ {
+ const char *udr_name = NULL;
+ if (n->udr)
+ {
+ udr_name = n->udr->udr->name;
+ n->udr->udr
+ = gfc_find_omp_udr (NULL, udr_name,
+ &n->sym->ts);
+ if (n->udr->udr == NULL)
+ {
+ free (n->udr);
+ n->udr = NULL;
+ }
+ }
+ if (n->udr == NULL)
+ {
+ if (udr_name == NULL)
+ switch (n->u.reduction_op)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ udr_name = gfc_op2string ((gfc_intrinsic_op)
+ n->u.reduction_op);
+ break;
+ case OMP_REDUCTION_MAX:
+ udr_name = "max";
+ break;
+ case OMP_REDUCTION_MIN:
+ udr_name = "min";
+ break;
+ case OMP_REDUCTION_IAND:
+ udr_name = "iand";
+ break;
+ case OMP_REDUCTION_IOR:
+ udr_name = "ior";
+ break;
+ case OMP_REDUCTION_IEOR:
+ udr_name = "ieor";
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ gfc_error ("!$OMP DECLARE REDUCTION %s not found "
+ "for type %s at %L", udr_name,
+ gfc_typename (&n->sym->ts), where);
+ }
+ else
+ {
+ gfc_omp_udr *udr = n->udr->udr;
+ n->u.reduction_op = OMP_REDUCTION_USER;
+ n->udr->combiner
+ = resolve_omp_udr_clause (n, udr->combiner_ns,
+ udr->omp_out,
+ udr->omp_in);
+ if (udr->initializer_ns)
+ n->udr->initializer
+ = resolve_omp_udr_clause (n,
+ udr->initializer_ns,
+ udr->omp_priv,
+ udr->omp_orig);
+ }
+ }
break;
- case OMP_LIST_AND:
- case OMP_LIST_OR:
- case OMP_LIST_EQV:
- case OMP_LIST_NEQV:
- if (n->sym->ts.type != BT_LOGICAL)
- gfc_error ("%s REDUCTION variable '%s' must be LOGICAL "
- "at %L",
- list == OMP_LIST_AND ? ".AND."
- : list == OMP_LIST_OR ? ".OR."
- : list == OMP_LIST_EQV ? ".EQV." : ".NEQV.",
- n->sym->name, &code->loc);
- break;
- case OMP_LIST_MAX:
- case OMP_LIST_MIN:
- if (n->sym->ts.type != BT_INTEGER
- && n->sym->ts.type != BT_REAL)
- gfc_error ("%s REDUCTION variable '%s' must be "
- "INTEGER or REAL at %L",
- list == OMP_LIST_MAX ? "MAX" : "MIN",
- n->sym->name, &code->loc);
- break;
- case OMP_LIST_IAND:
- case OMP_LIST_IOR:
- case OMP_LIST_IEOR:
+ case OMP_LIST_LINEAR:
if (n->sym->ts.type != BT_INTEGER)
- gfc_error ("%s REDUCTION variable '%s' must be INTEGER "
- "at %L",
- list == OMP_LIST_IAND ? "IAND"
- : list == OMP_LIST_MULT ? "IOR" : "IEOR",
- n->sym->name, &code->loc);
+ gfc_error ("LINEAR variable '%s' must be INTEGER "
+ "at %L", n->sym->name, where);
+ else if (!code && !n->sym->attr.value)
+ gfc_error ("LINEAR dummy argument '%s' must have VALUE "
+ "attribute at %L", n->sym->name, where);
+ else if (n->expr)
+ {
+ gfc_expr *expr = n->expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER
+ || expr->rank != 0)
+ gfc_error ("'%s' in LINEAR clause at %L requires "
+ "a scalar integer linear-step expression",
+ n->sym->name, where);
+ else if (!code && expr->expr_type != EXPR_CONSTANT)
+ gfc_error ("'%s' in LINEAR clause at %L requires "
+ "a constant integer linear-step expression",
+ n->sym->name, where);
+ }
break;
/* Workaround for PR middle-end/26316, nothing really needs
to be done here for OMP_LIST_PRIVATE. */
case OMP_LIST_PRIVATE:
- gcc_assert (code->op != EXEC_NOP);
+ gcc_assert (code && code->op != EXEC_NOP);
default:
break;
}
break;
}
}
+ if (omp_clauses->safelen_expr)
+ {
+ gfc_expr *expr = omp_clauses->safelen_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("SAFELEN clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->simdlen_expr)
+ {
+ gfc_expr *expr = omp_clauses->simdlen_expr;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("SIMDLEN clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->num_teams)
+ {
+ gfc_expr *expr = omp_clauses->num_teams;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("NUM_TEAMS clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->device)
+ {
+ gfc_expr *expr = omp_clauses->device;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("DEVICE clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->dist_chunk_size)
+ {
+ gfc_expr *expr = omp_clauses->dist_chunk_size;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("DIST_SCHEDULE clause's chunk_size at %L requires "
+ "a scalar INTEGER expression", &expr->where);
+ }
+ if (omp_clauses->thread_limit)
+ {
+ gfc_expr *expr = omp_clauses->thread_limit;
+ if (!gfc_resolve_expr (expr)
+ || expr->ts.type != BT_INTEGER || expr->rank != 0)
+ gfc_error ("THREAD_LIMIT clause at %L requires a scalar "
+ "INTEGER expression", &expr->where);
+ }
}
gfc_code *atomic_code = code;
gfc_symbol *var;
gfc_expr *expr2, *expr2_tmp;
+ gfc_omp_atomic_op aop
+ = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic & GFC_OMP_ATOMIC_MASK);
code = code->block->next;
gcc_assert (code->op == EXEC_ASSIGN);
- gcc_assert ((atomic_code->ext.omp_atomic != GFC_OMP_ATOMIC_CAPTURE
- && code->next == NULL)
- || (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE
+ gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) && code->next == NULL)
+ || ((aop == GFC_OMP_ATOMIC_CAPTURE)
&& code->next != NULL
&& code->next->op == EXEC_ASSIGN
&& code->next->next == NULL));
expr2 = is_conversion (code->expr2, false);
if (expr2 == NULL)
{
- if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_READ
- || atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_WRITE)
+ if (aop == GFC_OMP_ATOMIC_READ || aop == GFC_OMP_ATOMIC_WRITE)
expr2 = is_conversion (code->expr2, true);
if (expr2 == NULL)
expr2 = code->expr2;
}
- switch (atomic_code->ext.omp_atomic)
+ switch (aop)
{
case GFC_OMP_ATOMIC_READ:
if (expr2->expr_type != EXPR_VARIABLE
break;
}
- if (expr2->expr_type == EXPR_OP)
+ if (var->attr.allocatable)
+ {
+ gfc_error ("!$OMP ATOMIC with ALLOCATABLE variable at %L",
+ &code->loc);
+ return;
+ }
+
+ if (aop == GFC_OMP_ATOMIC_CAPTURE
+ && code->next == NULL
+ && code->expr2->rank == 0
+ && !expr_references_sym (code->expr2, var, NULL))
+ atomic_code->ext.omp_atomic
+ = (gfc_omp_atomic_op) (atomic_code->ext.omp_atomic
+ | GFC_OMP_ATOMIC_SWAP);
+ else if (expr2->expr_type == EXPR_OP)
{
gfc_expr *v = NULL, *e, *c;
gfc_intrinsic_op op = expr2->value.op.op;
&& arg->expr->symtree->n.sym == var)
var_arg = arg;
else if (expr_references_sym (arg->expr, var, NULL))
- gfc_error ("!$OMP ATOMIC intrinsic arguments except one must not "
- "reference '%s' at %L", var->name, &arg->expr->where);
+ {
+ gfc_error ("!$OMP ATOMIC intrinsic arguments except one must "
+ "not reference '%s' at %L",
+ var->name, &arg->expr->where);
+ return;
+ }
if (arg->expr->rank != 0)
- gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
- "at %L", &arg->expr->where);
+ {
+ gfc_error ("!$OMP ATOMIC intrinsic arguments must be scalar "
+ "at %L", &arg->expr->where);
+ return;
+ }
}
if (var_arg == NULL)
}
}
else
- gfc_error ("!$OMP ATOMIC assignment must have an operator or intrinsic "
- "on right hand side at %L", &expr2->where);
+ gfc_error ("!$OMP ATOMIC assignment must have an operator or "
+ "intrinsic on right hand side at %L", &expr2->where);
- if (atomic_code->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE && code->next)
+ if (aop == GFC_OMP_ATOMIC_CAPTURE && code->next)
{
code = code->next;
if (code->expr1->expr_type != EXPR_VARIABLE
{
struct omp_context ctx;
gfc_omp_clauses *omp_clauses = code->ext.omp_clauses;
- gfc_namelist *n;
+ gfc_omp_namelist *n;
int list;
ctx.code = code;
omp_current_ctx = &ctx;
for (list = 0; list < OMP_LIST_NUM; list++)
- for (n = omp_clauses->lists[list]; n; n = n->next)
- pointer_set_insert (ctx.sharing_clauses, n->sym);
+ switch (list)
+ {
+ case OMP_LIST_SHARED:
+ case OMP_LIST_PRIVATE:
+ case OMP_LIST_FIRSTPRIVATE:
+ case OMP_LIST_LASTPRIVATE:
+ case OMP_LIST_REDUCTION:
+ case OMP_LIST_LINEAR:
+ for (n = omp_clauses->lists[list]; n; n = n->next)
+ pointer_set_insert (ctx.sharing_clauses, n->sym);
+ break;
+ default:
+ break;
+ }
- if (code->op == EXEC_OMP_PARALLEL_DO)
- gfc_resolve_omp_do_blocks (code, ns);
- else
- gfc_resolve_blocks (code->block, ns);
+ switch (code->op)
+ {
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ 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:
+ 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:
+ gfc_resolve_omp_do_blocks (code, ns);
+ break;
+ default:
+ gfc_resolve_blocks (code->block, ns);
+ }
omp_current_ctx = ctx.previous;
pointer_set_destroy (ctx.sharing_clauses);
if (! pointer_set_insert (omp_current_ctx->private_iterators, sym))
{
gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses;
- gfc_namelist *p;
+ gfc_omp_namelist *p;
- p = gfc_get_namelist ();
+ p = gfc_get_omp_namelist ();
p->sym = sym;
p->next = omp_clauses->lists[OMP_LIST_PRIVATE];
omp_clauses->lists[OMP_LIST_PRIVATE] = p;
{
gfc_code *do_code, *c;
int list, i, collapse;
- gfc_namelist *n;
+ gfc_omp_namelist *n;
gfc_symbol *dovar;
+ const char *name;
+ bool is_simd = false;
+
+ switch (code->op)
+ {
+ case EXEC_OMP_DISTRIBUTE: name = "!$OMP DISTRIBUTE"; break;
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ name = "!$OMP DISTRIBUTE PARALLEL DO";
+ break;
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ name = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ name = "!$OMP DISTRIBUTE SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_DO: name = "!$OMP DO"; break;
+ case EXEC_OMP_DO_SIMD: name = "!$OMP DO SIMD"; is_simd = true; break;
+ case EXEC_OMP_PARALLEL_DO: name = "!$OMP PARALLEL DO"; break;
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ name = "!$OMP PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_SIMD: name = "!$OMP SIMD"; is_simd = true; break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ name = "!$OMP TARGET TEAMS_DISTRIBUTE";
+ break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ name = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ name = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE: name = "!$OMP TEAMS_DISTRIBUTE"; break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ name = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ is_simd = true;
+ break;
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ name = "!$OMP TEAMS DISTRIBUTE SIMD";
+ is_simd = true;
+ break;
+ default: gcc_unreachable ();
+ }
if (code->ext.omp_clauses)
- resolve_omp_clauses (code);
+ resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
do_code = code->block->next;
collapse = code->ext.omp_clauses->collapse;
{
if (do_code->op == EXEC_DO_WHILE)
{
- gfc_error ("!$OMP DO cannot be a DO WHILE or DO without loop control "
- "at %L", &do_code->loc);
+ gfc_error ("%s cannot be a DO WHILE or DO without loop control "
+ "at %L", name, &do_code->loc);
+ break;
+ }
+ if (do_code->op == EXEC_DO_CONCURRENT)
+ {
+ gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
+ &do_code->loc);
break;
}
gcc_assert (do_code->op == EXEC_DO);
if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
- gfc_error ("!$OMP DO iteration variable must be of type integer at %L",
- &do_code->loc);
+ gfc_error ("%s iteration variable must be of type integer at %L",
+ name, &do_code->loc);
dovar = do_code->ext.iterator->var->symtree->n.sym;
if (dovar->attr.threadprivate)
- gfc_error ("!$OMP DO iteration variable must not be THREADPRIVATE "
- "at %L", &do_code->loc);
+ gfc_error ("%s iteration variable must not be THREADPRIVATE "
+ "at %L", name, &do_code->loc);
if (code->ext.omp_clauses)
for (list = 0; list < OMP_LIST_NUM; list++)
- if (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
+ if (!is_simd
+ ? (list != OMP_LIST_PRIVATE && list != OMP_LIST_LASTPRIVATE)
+ : code->ext.omp_clauses->collapse > 1
+ ? (list != OMP_LIST_LASTPRIVATE)
+ : (list != OMP_LIST_LINEAR))
for (n = code->ext.omp_clauses->lists[list]; n; n = n->next)
if (dovar == n->sym)
{
- gfc_error ("!$OMP DO iteration variable present on clause "
- "other than PRIVATE or LASTPRIVATE at %L",
- &do_code->loc);
+ if (!is_simd)
+ gfc_error ("%s iteration variable present on clause "
+ "other than PRIVATE or LASTPRIVATE at %L",
+ name, &do_code->loc);
+ else if (code->ext.omp_clauses->collapse > 1)
+ gfc_error ("%s iteration variable present on clause "
+ "other than LASTPRIVATE at %L",
+ name, &do_code->loc);
+ else
+ gfc_error ("%s iteration variable present on clause "
+ "other than LINEAR at %L",
+ name, &do_code->loc);
break;
}
if (i > 1)
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->end)
|| gfc_find_sym_in_expr (ivar, do_code->ext.iterator->step))
{
- gfc_error ("!$OMP DO collapsed loops don't form rectangular iteration space at %L",
- &do_code->loc);
+ gfc_error ("%s collapsed loops don't form rectangular "
+ "iteration space at %L", name, &do_code->loc);
break;
}
if (j < i)
for (c = do_code->next; c; c = c->next)
if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
{
- gfc_error ("collapsed !$OMP DO loops not perfectly nested at %L",
- &c->loc);
+ gfc_error ("collapsed %s loops not perfectly nested at %L",
+ name, &c->loc);
break;
}
if (c)
do_code = do_code->block;
if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
{
- gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
- &code->loc);
+ gfc_error ("not enough DO loops for collapsed %s at %L",
+ name, &code->loc);
break;
}
do_code = do_code->next;
if (do_code == NULL
|| (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
{
- gfc_error ("not enough DO loops for collapsed !$OMP DO at %L",
- &code->loc);
+ gfc_error ("not enough DO loops for collapsed %s at %L",
+ name, &code->loc);
break;
}
}
switch (code->op)
{
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_SIMD:
+ 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:
+ 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:
resolve_omp_do (code);
break;
- case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_CANCEL:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ case EXEC_OMP_TARGET_TEAMS:
case EXEC_OMP_TASK:
+ case EXEC_OMP_TEAMS:
+ case EXEC_OMP_WORKSHARE:
+ if (code->ext.omp_clauses)
+ resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
+ break;
+ case EXEC_OMP_TARGET_UPDATE:
if (code->ext.omp_clauses)
- resolve_omp_clauses (code);
+ resolve_omp_clauses (code, &code->loc, code->ext.omp_clauses, NULL);
+ if (code->ext.omp_clauses == NULL
+ || (code->ext.omp_clauses->lists[OMP_LIST_TO] == NULL
+ && code->ext.omp_clauses->lists[OMP_LIST_FROM] == NULL))
+ gfc_error ("OMP TARGET UPDATE at %L requires at least one TO or "
+ "FROM clause", &code->loc);
break;
case EXEC_OMP_ATOMIC:
resolve_omp_atomic (code);
break;
}
}
+
+/* Resolve !$omp declare simd constructs in NS. */
+
+void
+gfc_resolve_omp_declare_simd (gfc_namespace *ns)
+{
+ gfc_omp_declare_simd *ods;
+
+ for (ods = ns->omp_declare_simd; ods; ods = ods->next)
+ {
+ if (ods->proc_name != ns->proc_name)
+ gfc_error ("!$OMP DECLARE SIMD should refer to containing procedure "
+ "'%s' at %L", ns->proc_name->name, &ods->where);
+ if (ods->clauses)
+ resolve_omp_clauses (NULL, &ods->where, ods->clauses, ns);
+ }
+}
+
+struct omp_udr_callback_data
+{
+ gfc_omp_udr *omp_udr;
+ bool is_initializer;
+};
+
+static int
+omp_udr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ struct omp_udr_callback_data *cd = (struct omp_udr_callback_data *) data;
+ if ((*e)->expr_type == EXPR_VARIABLE)
+ {
+ if (cd->is_initializer)
+ {
+ if ((*e)->symtree->n.sym != cd->omp_udr->omp_priv
+ && (*e)->symtree->n.sym != cd->omp_udr->omp_orig)
+ gfc_error ("Variable other than OMP_PRIV or OMP_ORIG used in "
+ "INITIALIZER clause of !$OMP DECLARE REDUCTION at %L",
+ &(*e)->where);
+ }
+ else
+ {
+ if ((*e)->symtree->n.sym != cd->omp_udr->omp_out
+ && (*e)->symtree->n.sym != cd->omp_udr->omp_in)
+ gfc_error ("Variable other than OMP_OUT or OMP_IN used in "
+ "combiner of !$OMP DECLARE REDUCTION at %L",
+ &(*e)->where);
+ }
+ }
+ return 0;
+}
+
+/* Resolve !$omp declare reduction constructs. */
+
+static void
+gfc_resolve_omp_udr (gfc_omp_udr *omp_udr)
+{
+ gfc_actual_arglist *a;
+ const char *predef_name = NULL;
+
+ switch (omp_udr->rop)
+ {
+ case OMP_REDUCTION_PLUS:
+ case OMP_REDUCTION_TIMES:
+ case OMP_REDUCTION_MINUS:
+ case OMP_REDUCTION_AND:
+ case OMP_REDUCTION_OR:
+ case OMP_REDUCTION_EQV:
+ case OMP_REDUCTION_NEQV:
+ case OMP_REDUCTION_MAX:
+ case OMP_REDUCTION_USER:
+ break;
+ default:
+ gfc_error ("Invalid operator for !$OMP DECLARE REDUCTION %s at %L",
+ omp_udr->name, &omp_udr->where);
+ return;
+ }
+
+ if (gfc_omp_udr_predef (omp_udr->rop, omp_udr->name,
+ &omp_udr->ts, &predef_name))
+ {
+ if (predef_name)
+ gfc_error_now ("Redefinition of predefined %s "
+ "!$OMP DECLARE REDUCTION at %L",
+ predef_name, &omp_udr->where);
+ else
+ gfc_error_now ("Redefinition of predefined "
+ "!$OMP DECLARE REDUCTION at %L", &omp_udr->where);
+ return;
+ }
+
+ if (omp_udr->ts.type == BT_CHARACTER
+ && omp_udr->ts.u.cl->length
+ && omp_udr->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("CHARACTER length in !$OMP DECLARE REDUCTION %s not "
+ "constant at %L", omp_udr->name, &omp_udr->where);
+ return;
+ }
+
+ struct omp_udr_callback_data cd;
+ cd.omp_udr = omp_udr;
+ cd.is_initializer = false;
+ gfc_code_walker (&omp_udr->combiner_ns->code, gfc_dummy_code_callback,
+ omp_udr_callback, &cd);
+ if (omp_udr->combiner_ns->code->op == EXEC_CALL)
+ {
+ for (a = omp_udr->combiner_ns->code->ext.actual; a; a = a->next)
+ if (a->expr == NULL)
+ break;
+ if (a)
+ gfc_error ("Subroutine call with alternate returns in combiner "
+ "of !$OMP DECLARE REDUCTION at %L",
+ &omp_udr->combiner_ns->code->loc);
+ }
+ if (omp_udr->initializer_ns)
+ {
+ cd.is_initializer = true;
+ gfc_code_walker (&omp_udr->initializer_ns->code, gfc_dummy_code_callback,
+ omp_udr_callback, &cd);
+ if (omp_udr->initializer_ns->code->op == EXEC_CALL)
+ {
+ for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
+ if (a->expr == NULL)
+ break;
+ if (a)
+ gfc_error ("Subroutine call with alternate returns in "
+ "INITIALIZER clause of !$OMP DECLARE REDUCTION "
+ "at %L", &omp_udr->initializer_ns->code->loc);
+ for (a = omp_udr->initializer_ns->code->ext.actual; a; a = a->next)
+ if (a->expr
+ && a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym == omp_udr->omp_priv
+ && a->expr->ref == NULL)
+ break;
+ if (a == NULL)
+ gfc_error ("One of actual subroutine arguments in INITIALIZER "
+ "clause of !$OMP DECLARE REDUCTION must be OMP_PRIV "
+ "at %L", &omp_udr->initializer_ns->code->loc);
+ }
+ }
+ else if (omp_udr->ts.type == BT_DERIVED
+ && !gfc_has_default_initializer (omp_udr->ts.u.derived))
+ {
+ gfc_error ("Missing INITIALIZER clause for !$OMP DECLARE REDUCTION "
+ "of derived type without default initializer at %L",
+ &omp_udr->where);
+ return;
+ }
+}
+
+void
+gfc_resolve_omp_udrs (gfc_symtree *st)
+{
+ gfc_omp_udr *omp_udr;
+
+ if (st == NULL)
+ return;
+ gfc_resolve_omp_udrs (st->left);
+ gfc_resolve_omp_udrs (st->right);
+ for (omp_udr = st->n.omp_udr; omp_udr; omp_udr = omp_udr->next)
+ gfc_resolve_omp_udr (omp_udr);
+}
}
+/* Like match_word, but if str is matched, set a flag that it
+ was matched. */
+static match
+match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
+ bool *simd_matched)
+{
+ match m;
+
+ if (str != NULL)
+ {
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+ *simd_matched = true;
+ }
+
+ m = (*subr) ();
+
+ if (m != MATCH_YES)
+ {
+ gfc_current_locus = *old_locus;
+ reject_statement ();
+ }
+
+ return m;
+}
+
+
/* Load symbols from all USE statements encountered in this scoping unit. */
static void
if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
return st; \
else \
- undo_new_statement (); \
+ undo_new_statement (); \
} while (0);
return ST_NONE;
}
+/* Like match, but set a flag simd_matched if keyword matched. */
+#define matchs(keyword, subr, st) \
+ do { \
+ if (match_word_omp_simd (keyword, subr, &old_locus, \
+ &simd_matched) == MATCH_YES) \
+ return st; \
+ else \
+ undo_new_statement (); \
+ } while (0);
+
+/* Like match, but don't match anything if not -fopenmp. */
+#define matcho(keyword, subr, st) \
+ do { \
+ if (!gfc_option.gfc_flag_openmp) \
+ ; \
+ else if (match_word (keyword, subr, &old_locus) \
+ == MATCH_YES) \
+ return st; \
+ else \
+ undo_new_statement (); \
+ } while (0);
+
static gfc_statement
decode_omp_directive (void)
{
locus old_locus;
char c;
+ bool simd_matched = false;
gfc_enforce_clean_symbol_state ();
c = gfc_peek_ascii_char ();
+ /* match is for directives that should be recognized only if
+ -fopenmp, matchs for directives that should be recognized
+ if either -fopenmp or -fopenmp-simd. */
switch (c)
{
case 'a':
- match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+ matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
break;
case 'b':
- match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+ matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
break;
case 'c':
- match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
+ matcho ("cancellation% point", gfc_match_omp_cancellation_point,
+ ST_OMP_CANCELLATION_POINT);
+ matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
+ matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
break;
case 'd':
- match ("do", gfc_match_omp_do, ST_OMP_DO);
+ matchs ("declare reduction", gfc_match_omp_declare_reduction,
+ ST_OMP_DECLARE_REDUCTION);
+ matchs ("declare simd", gfc_match_omp_declare_simd,
+ ST_OMP_DECLARE_SIMD);
+ matcho ("declare target", gfc_match_omp_declare_target,
+ ST_OMP_DECLARE_TARGET);
+ matchs ("distribute parallel do simd",
+ gfc_match_omp_distribute_parallel_do_simd,
+ ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
+ ST_OMP_DISTRIBUTE_PARALLEL_DO);
+ matchs ("distribute simd", gfc_match_omp_distribute_simd,
+ ST_OMP_DISTRIBUTE_SIMD);
+ matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
+ matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
+ matcho ("do", gfc_match_omp_do, ST_OMP_DO);
break;
case 'e':
- match ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
- match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
- match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
- match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
- match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
- match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
- match ("end parallel sections", gfc_match_omp_eos,
- ST_OMP_END_PARALLEL_SECTIONS);
- match ("end parallel workshare", gfc_match_omp_eos,
- ST_OMP_END_PARALLEL_WORKSHARE);
- match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
- match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
- match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
- match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
- match ("end workshare", gfc_match_omp_end_nowait,
- ST_OMP_END_WORKSHARE);
+ matcho ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
+ matcho ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+ matchs ("end distribute parallel do simd", gfc_match_omp_eos,
+ ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("end distribute parallel do", gfc_match_omp_eos,
+ ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
+ matchs ("end distribute simd", gfc_match_omp_eos,
+ ST_OMP_END_DISTRIBUTE_SIMD);
+ matcho ("end distribute", gfc_match_omp_eos, ST_OMP_END_DISTRIBUTE);
+ matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
+ matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+ matchs ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
+ matcho ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
+ matcho ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+ matchs ("end parallel do simd", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_DO_SIMD);
+ matcho ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
+ matcho ("end parallel sections", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_SECTIONS);
+ matcho ("end parallel workshare", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_WORKSHARE);
+ matcho ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
+ matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
+ matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+ matcho ("end target data", gfc_match_omp_eos, ST_OMP_END_TARGET_DATA);
+ matchs ("end target teams distribute parallel do simd",
+ gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("end target teams distribute parallel do", gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("end target teams distribute simd", gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("end target teams distribute", gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
+ matcho ("end target teams", gfc_match_omp_eos, ST_OMP_END_TARGET_TEAMS);
+ matcho ("end target", gfc_match_omp_eos, ST_OMP_END_TARGET);
+ matcho ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
+ matcho ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
+ matchs ("end teams distribute parallel do simd", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("end teams distribute parallel do", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("end teams distribute simd", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("end teams distribute", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE);
+ matcho ("end teams", gfc_match_omp_eos, ST_OMP_END_TEAMS);
+ matcho ("end workshare", gfc_match_omp_end_nowait,
+ ST_OMP_END_WORKSHARE);
break;
case 'f':
- match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
+ matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
break;
case 'm':
- match ("master", gfc_match_omp_master, ST_OMP_MASTER);
+ matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
break;
case 'o':
- match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
+ matcho ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
break;
case 'p':
- match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
- match ("parallel sections", gfc_match_omp_parallel_sections,
- ST_OMP_PARALLEL_SECTIONS);
- match ("parallel workshare", gfc_match_omp_parallel_workshare,
- ST_OMP_PARALLEL_WORKSHARE);
- match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
+ matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
+ ST_OMP_PARALLEL_DO_SIMD);
+ matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
+ matcho ("parallel sections", gfc_match_omp_parallel_sections,
+ ST_OMP_PARALLEL_SECTIONS);
+ matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
+ ST_OMP_PARALLEL_WORKSHARE);
+ matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
break;
case 's':
- match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
- match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
- match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
+ matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
+ matcho ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+ matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
+ matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
break;
case 't':
- match ("task", gfc_match_omp_task, ST_OMP_TASK);
- match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
- match ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
- match ("threadprivate", gfc_match_omp_threadprivate,
- ST_OMP_THREADPRIVATE);
+ matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
+ matchs ("target teams distribute parallel do simd",
+ gfc_match_omp_target_teams_distribute_parallel_do_simd,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("target teams distribute parallel do",
+ gfc_match_omp_target_teams_distribute_parallel_do,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("target teams distribute simd",
+ gfc_match_omp_target_teams_distribute_simd,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE);
+ matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
+ matcho ("target update", gfc_match_omp_target_update,
+ ST_OMP_TARGET_UPDATE);
+ matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
+ matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
+ matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
+ matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
+ matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
+ matchs ("teams distribute parallel do simd",
+ gfc_match_omp_teams_distribute_parallel_do_simd,
+ ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("teams distribute parallel do",
+ gfc_match_omp_teams_distribute_parallel_do,
+ ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
+ ST_OMP_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("teams distribute", gfc_match_omp_teams_distribute,
+ ST_OMP_TEAMS_DISTRIBUTE);
+ matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
+ matcho ("threadprivate", gfc_match_omp_threadprivate,
+ ST_OMP_THREADPRIVATE);
break;
case 'w':
- match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
+ matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
break;
}
/* All else has failed, so give up. See if any of the matchers has
- stored an error message of some sort. */
+ stored an error message of some sort. Don't error out if
+ not -fopenmp and simd_matched is false, i.e. if a directive other
+ than one marked with match has been seen. */
- if (gfc_error_check () == 0)
- gfc_error_now ("Unclassifiable OpenMP directive at %C");
+ if (gfc_option.gfc_flag_openmp || simd_matched)
+ {
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable OpenMP directive at %C");
+ }
reject_statement ();
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.gfc_flag_openmp)
+ else if (c == '$'
+ && (gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd))
{
int i;
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.gfc_flag_openmp)
+ else if (c == '$'
+ && (gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd))
{
for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
- case ST_ERROR_STOP: case ST_SYNC_ALL: case ST_SYNC_IMAGES: \
- case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
+ case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
+ case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
+ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK
/* Statements that mark other executable statements. */
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
- case ST_OMP_TASK: case ST_CRITICAL
+ case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
+ case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
+ case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
+ case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
+ case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
+ case ST_CRITICAL
/* Declaration statements */
#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
- case ST_PROCEDURE
+ case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
+ case ST_OMP_DECLARE_TARGET
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
case ST_OMP_BARRIER:
p = "!$OMP BARRIER";
break;
+ case ST_OMP_CANCEL:
+ p = "!$OMP CANCEL";
+ break;
+ case ST_OMP_CANCELLATION_POINT:
+ p = "!$OMP CANCELLATION POINT";
+ break;
case ST_OMP_CRITICAL:
p = "!$OMP CRITICAL";
break;
+ case ST_OMP_DECLARE_REDUCTION:
+ p = "!$OMP DECLARE REDUCTION";
+ break;
+ case ST_OMP_DECLARE_SIMD:
+ p = "!$OMP DECLARE SIMD";
+ break;
+ case ST_OMP_DECLARE_TARGET:
+ p = "!$OMP DECLARE TARGET";
+ break;
+ case ST_OMP_DISTRIBUTE:
+ p = "!$OMP DISTRIBUTE";
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_DISTRIBUTE_SIMD:
+ p = "!$OMP DISTRIBUTE SIMD";
+ break;
case ST_OMP_DO:
p = "!$OMP DO";
break;
+ case ST_OMP_DO_SIMD:
+ p = "!$OMP DO SIMD";
+ break;
case ST_OMP_END_ATOMIC:
p = "!$OMP END ATOMIC";
break;
case ST_OMP_END_CRITICAL:
p = "!$OMP END CRITICAL";
break;
+ case ST_OMP_END_DISTRIBUTE:
+ p = "!$OMP END DISTRIBUTE";
+ break;
+ case ST_OMP_END_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP END DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_END_DISTRIBUTE_SIMD:
+ p = "!$OMP END DISTRIBUTE SIMD";
+ break;
case ST_OMP_END_DO:
p = "!$OMP END DO";
break;
+ case ST_OMP_END_DO_SIMD:
+ p = "!$OMP END DO SIMD";
+ break;
+ case ST_OMP_END_SIMD:
+ p = "!$OMP END SIMD";
+ break;
case ST_OMP_END_MASTER:
p = "!$OMP END MASTER";
break;
case ST_OMP_END_PARALLEL_DO:
p = "!$OMP END PARALLEL DO";
break;
+ case ST_OMP_END_PARALLEL_DO_SIMD:
+ p = "!$OMP END PARALLEL DO SIMD";
+ break;
case ST_OMP_END_PARALLEL_SECTIONS:
p = "!$OMP END PARALLEL SECTIONS";
break;
case ST_OMP_END_TASK:
p = "!$OMP END TASK";
break;
+ case ST_OMP_END_TARGET:
+ p = "!$OMP END TARGET";
+ break;
+ case ST_OMP_END_TARGET_DATA:
+ p = "!$OMP END TARGET DATA";
+ break;
+ case ST_OMP_END_TARGET_TEAMS:
+ p = "!$OMP END TARGET TEAMS";
+ break;
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
+ break;
+ case ST_OMP_END_TASKGROUP:
+ p = "!$OMP END TASKGROUP";
+ break;
+ case ST_OMP_END_TEAMS:
+ p = "!$OMP END TEAMS";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE:
+ p = "!$OMP END TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP END TEAMS DISTRIBUTE SIMD";
+ break;
case ST_OMP_END_WORKSHARE:
p = "!$OMP END WORKSHARE";
break;
case ST_OMP_PARALLEL_DO:
p = "!$OMP PARALLEL DO";
break;
+ case ST_OMP_PARALLEL_DO_SIMD:
+ p = "!$OMP PARALLEL DO SIMD";
+ break;
case ST_OMP_PARALLEL_SECTIONS:
p = "!$OMP PARALLEL SECTIONS";
break;
case ST_OMP_SECTION:
p = "!$OMP SECTION";
break;
+ case ST_OMP_SIMD:
+ p = "!$OMP SIMD";
+ break;
case ST_OMP_SINGLE:
p = "!$OMP SINGLE";
break;
+ case ST_OMP_TARGET:
+ p = "!$OMP TARGET";
+ break;
+ case ST_OMP_TARGET_DATA:
+ p = "!$OMP TARGET DATA";
+ break;
+ case ST_OMP_TARGET_TEAMS:
+ p = "!$OMP TARGET TEAMS";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
+ break;
+ case ST_OMP_TARGET_UPDATE:
+ p = "!$OMP TARGET UPDATE";
+ break;
case ST_OMP_TASK:
p = "!$OMP TASK";
break;
+ case ST_OMP_TASKGROUP:
+ p = "!$OMP TASKGROUP";
+ break;
case ST_OMP_TASKWAIT:
p = "!$OMP TASKWAIT";
break;
case ST_OMP_TASKYIELD:
p = "!$OMP TASKYIELD";
break;
+ case ST_OMP_TEAMS:
+ p = "!$OMP TEAMS";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ p = "!$OMP TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP TEAMS DISTRIBUTE SIMD";
+ break;
case ST_OMP_THREADPRIVATE:
p = "!$OMP THREADPRIVATE";
break;
pop_state ();
st = next_statement ();
- if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
+ gfc_statement omp_end_st = ST_OMP_END_DO;
+ switch (omp_st)
+ {
+ case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
+ break;
+ case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
+ case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
+ case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
+ case ST_OMP_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
+ break;
+ default: gcc_unreachable ();
+ }
+ if (st == omp_end_st)
{
if (new_st.op == EXEC_OMP_END_NOWAIT)
cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
np = new_level (cp);
np->op = cp->op;
np->block = NULL;
- count = 1 + (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE);
+ count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_CAPTURE);
while (count)
{
gfc_warning_check ();
st = next_statement ();
}
- else if (cp->ext.omp_atomic == GFC_OMP_ATOMIC_CAPTURE)
+ else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_CAPTURE)
gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
return st;
}
case ST_OMP_SINGLE:
omp_end_st = ST_OMP_END_SINGLE;
break;
+ case ST_OMP_TARGET:
+ omp_end_st = ST_OMP_END_TARGET;
+ break;
+ case ST_OMP_TARGET_DATA:
+ omp_end_st = ST_OMP_END_TARGET_DATA;
+ break;
+ case ST_OMP_TARGET_TEAMS:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
+ break;
case ST_OMP_TASK:
omp_end_st = ST_OMP_END_TASK;
break;
+ case ST_OMP_TASKGROUP:
+ omp_end_st = ST_OMP_END_TASKGROUP;
+ break;
+ case ST_OMP_TEAMS:
+ omp_end_st = ST_OMP_END_TEAMS;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
+ break;
+ case ST_OMP_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_DISTRIBUTE;
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
+ break;
case ST_OMP_WORKSHARE:
omp_end_st = ST_OMP_END_WORKSHARE;
break;
break;
case ST_OMP_PARALLEL_DO:
+ case ST_OMP_PARALLEL_DO_SIMD:
st = parse_omp_do (st);
continue;
case ST_OMP_CRITICAL:
case ST_OMP_MASTER:
case ST_OMP_SINGLE:
+ case ST_OMP_TARGET:
+ case ST_OMP_TARGET_DATA:
+ case ST_OMP_TARGET_TEAMS:
+ case ST_OMP_TEAMS:
case ST_OMP_TASK:
+ case ST_OMP_TASKGROUP:
parse_omp_structured_block (st, false);
break;
parse_omp_structured_block (st, true);
break;
+ case ST_OMP_DISTRIBUTE:
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case ST_OMP_DISTRIBUTE_SIMD:
case ST_OMP_DO:
+ case ST_OMP_DO_SIMD:
case ST_OMP_PARALLEL_DO:
+ case ST_OMP_PARALLEL_DO_SIMD:
+ case ST_OMP_SIMD:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
st = parse_omp_do (st);
if (st == ST_IMPLIED_ENDDO)
return st;
seq_type;
/* Stack to keep track of the nesting of blocks as we move through the
- code. See resolve_branch() and resolve_code(). */
+ code. See resolve_branch() and gfc_resolve_code(). */
typedef struct code_stack
{
/* See if function is already resolved. */
- if (expr->value.function.name != NULL)
+ if (expr->value.function.name != NULL
+ || expr->value.function.isym != NULL)
{
if (expr->ts.type == BT_UNKNOWN)
expr->ts = sym->ts;
if (check_assumed_size_reference (sym, e))
return false;
- /* Deal with forward references to entries during resolve_code, to
+ /* Deal with forward references to entries during gfc_resolve_code, to
satisfy, at least partially, 12.5.2.5. */
if (gfc_current_ns->entries
&& current_entry_id == sym->entry_id
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
DO code nodes. */
-static void resolve_code (gfc_code *, gfc_namespace *);
-
void
gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
{
case EXEC_OMP_ATOMIC:
case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ 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:
+ case EXEC_OMP_TARGET_UPDATE:
case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_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:
case EXEC_OMP_WORKSHARE:
break;
gfc_internal_error ("gfc_resolve_blocks(): Bad block type");
}
- resolve_code (b->next, ns);
+ gfc_resolve_code (b->next, ns);
}
}
The pointer assignments are taken care of by the intrinsic
assignment of the structure itself. This function recursively adds
defined assignments where required. The recursion is accomplished
- by calling resolve_code.
+ by calling gfc_resolve_code.
When the lhs in a defined assignment has intent INOUT, we need a
temporary for the lhs. In pseudo-code:
comp1, comp2, (*code)->loc);
/* Convert the assignment if there is a defined assignment for
- this type. Otherwise, using the call from resolve_code,
+ this type. Otherwise, using the call from gfc_resolve_code,
recurse into its components. */
- resolve_code (this_code, ns);
+ gfc_resolve_code (this_code, ns);
if (this_code->op == EXEC_ASSIGN_CALL)
{
/* Given a block of code, recursively resolve everything pointed to by this
code block. */
-static void
-resolve_code (gfc_code *code, gfc_namespace *ns)
+void
+gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
{
int omp_workshare_save;
int forall_save, do_concurrent_save;
break;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
+ 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:
case EXEC_OMP_TASK:
+ 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:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_parallel_blocks (code, ns);
break;
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_SIMD:
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_SELECT_TYPE:
case EXEC_DO_WHILE:
if (code->expr1 == NULL)
- gfc_internal_error ("resolve_code(): No expression on DO WHILE");
+ gfc_internal_error ("gfc_resolve_code(): No expression on "
+ "DO WHILE");
if (t
&& (code->expr1->rank != 0
|| code->expr1->ts.type != BT_LOGICAL))
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ 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:
+ case EXEC_OMP_TARGET_UPDATE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_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:
case EXEC_OMP_WORKSHARE:
gfc_resolve_omp_directive (code, ns);
break;
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
- case EXEC_OMP_TASK:
omp_workshare_save = omp_workshare_flag;
omp_workshare_flag = 0;
gfc_resolve_omp_directive (code, ns);
break;
default:
- gfc_internal_error ("resolve_code(): Bad statement code");
+ gfc_internal_error ("gfc_resolve_code(): Bad statement code");
}
}
}
/* Constraints on deferred type parameter. */
- if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+ if (sym->ts.deferred
+ && !(sym->attr.pointer
+ || sym->attr.allocatable
+ || sym->attr.omp_udr_artificial_var))
{
gfc_error ("Entity '%s' at %L has a deferred type parameter and "
"requires either the pointer or allocatable attribute",
dummy arguments. */
e = sym->ts.u.cl->length;
if (e == NULL && !sym->attr.dummy && !sym->attr.result
- && !sym->ts.deferred && !sym->attr.select_type_temporary)
+ && !sym->ts.deferred && !sym->attr.select_type_temporary
+ && !sym->attr.omp_udr_artificial_var)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
|| sym->ns->proc_name->attr.flavor != FL_MODULE)))
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
+ /* Check omp declare target restrictions. */
+ if (sym->attr.omp_declare_target
+ && sym->attr.flavor == FL_VARIABLE
+ && !sym->attr.save
+ && !sym->ns->save_all
+ && (!sym->attr.in_common
+ && sym->module == NULL
+ && (sym->ns->proc_name == NULL
+ || sym->ns->proc_name->attr.flavor != FL_MODULE)))
+ gfc_error ("!$OMP DECLARE TARGET variable '%s' at %L isn't SAVEd",
+ sym->name, &sym->declared_at);
+
/* If we have come this far we can apply default-initializers, as
described in 14.7.5, to those variables that have not already
been assigned one. */
assign types to all intermediate expressions, make sure that all
assignments are to compatible types and figure out which names
refer to which functions or subroutines. It doesn't check code
- block, which is handled by resolve_code. */
+ block, which is handled by gfc_resolve_code. */
static void
resolve_types (gfc_namespace *ns)
gfc_resolve_uops (ns->uop_root);
+ gfc_resolve_omp_declare_simd (ns);
+
+ gfc_resolve_omp_udrs (ns->omp_udr_root);
+
gfc_current_ns = old_ns;
}
-/* Call resolve_code recursively. */
+/* Call gfc_resolve_code recursively. */
static void
resolve_codes (gfc_namespace *ns)
old_obstack = labels_obstack;
bitmap_obstack_initialize (&labels_obstack);
- resolve_code (ns->code, ns);
+ gfc_resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);
labels_obstack = old_obstack;
2) handle OpenMP conditional compilation, where
!$ should be treated as 2 spaces (for initial lines
only if followed by space). */
- if (gfc_option.gfc_flag_openmp && at_bol)
+ if ((gfc_option.gfc_flag_openmp
+ || gfc_option.gfc_flag_openmp_simd) && at_bol)
{
locus old_loc = gfc_current_locus;
if (next_char () == '$')
&& continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
- if (gfc_option.gfc_flag_openmp)
+ if (gfc_option.gfc_flag_openmp || gfc_option.gfc_flag_openmp_simd)
{
if (next_char () == '$')
{
c = line;
- if (gfc_option.gfc_flag_openmp)
+ if (gfc_option.gfc_flag_openmp || gfc_option.gfc_flag_openmp_simd)
{
if (gfc_current_form == FORM_FREE)
{
gfc_free_forall_iterator (p->ext.forall_iterator);
break;
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_END_SINGLE:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ 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:
+ case EXEC_OMP_TARGET_UPDATE:
case EXEC_OMP_TASK:
+ 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:
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
gfc_free_omp_clauses (p->ext.omp_clauses);
break;
case EXEC_OMP_FLUSH:
- gfc_free_namelist (p->ext.omp_namelist);
+ gfc_free_omp_namelist (p->ext.omp_namelist);
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_END_NOWAIT:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
break;
*asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
*contiguous = "CONTIGUOUS", *generic = "GENERIC";
static const char *threadprivate = "THREADPRIVATE";
+ static const char *omp_declare_target = "OMP DECLARE TARGET";
const char *a1, *a2;
int standard;
conf (dummy, entry);
conf (dummy, intrinsic);
conf (dummy, threadprivate);
+ conf (dummy, omp_declare_target);
conf (pointer, target);
conf (pointer, intrinsic);
conf (pointer, elemental);
conf (in_equivalence, entry);
conf (in_equivalence, allocatable);
conf (in_equivalence, threadprivate);
+ conf (in_equivalence, omp_declare_target);
conf (dummy, result);
conf (entry, result);
conf (cray_pointee, in_common);
conf (cray_pointee, in_equivalence);
conf (cray_pointee, threadprivate);
+ conf (cray_pointee, omp_declare_target);
conf (data, dummy);
conf (data, function);
conf (proc_pointer, abstract)
+ conf (entry, omp_declare_target)
+
a1 = gfc_code2string (flavors, attr->flavor);
if (attr->in_namelist
conf2 (function);
conf2 (subroutine);
conf2 (threadprivate);
+ conf2 (omp_declare_target);
if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
{
conf2 (subroutine);
conf2 (threadprivate);
conf2 (result);
+ conf2 (omp_declare_target);
if (attr->intent != INTENT_UNKNOWN)
{
bool
+gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
+ locus *where)
+{
+
+ if (check_used (attr, name, where))
+ return false;
+
+ if (attr->omp_declare_target)
+ return true;
+
+ attr->omp_declare_target = 1;
+ return check_conflict (attr, name, where);
+}
+
+
+bool
gfc_add_target (symbol_attribute *attr, locus *where)
{
if (src->threadprivate
&& !gfc_add_threadprivate (dest, NULL, where))
goto fail;
+ if (src->omp_declare_target
+ && !gfc_add_omp_declare_target (dest, NULL, where))
+ goto fail;
if (src->target && !gfc_add_target (dest, where))
goto fail;
if (src->dummy && !gfc_add_dummy (dest, NULL, where))
{
gfc_user_op *uop;
gfc_symtree *st;
+ gfc_namespace *ns = gfc_current_ns;
- st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+ if (ns->omp_udr_ns)
+ ns = ns->parent;
+ st = gfc_find_symtree (ns->uop_root, name);
if (st != NULL)
return st->n.uop;
- st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
+ st = gfc_new_symtree (&ns->uop_root, name);
uop = st->n.uop = XCNEW (gfc_user_op);
uop->name = gfc_get_string (name);
uop->access = ACCESS_UNKNOWN;
- uop->ns = gfc_current_ns;
+ uop->ns = ns;
return uop;
}
/* Try to find the symbol in ns. */
st = gfc_find_symtree (ns->sym_root, name);
+ if (st == NULL && ns->omp_udr_ns)
+ {
+ ns = ns->parent;
+ st = gfc_find_symtree (ns->sym_root, name);
+ }
+
if (st == NULL)
{
/* If not there, create a new symbol. */
}
+/* Recursive function that deletes an entire tree and all the common
+ head structures it points to. */
+
+static void
+free_omp_udr_tree (gfc_symtree * omp_udr_tree)
+{
+ if (omp_udr_tree == NULL)
+ return;
+
+ free_omp_udr_tree (omp_udr_tree->left);
+ free_omp_udr_tree (omp_udr_tree->right);
+
+ gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
+ free (omp_udr_tree);
+}
+
+
/* Recursive function that deletes an entire tree and all the user
operator nodes that it contains. */
free_sym_tree (ns->sym_root);
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
+ free_omp_udr_tree (ns->omp_udr_root);
free_tb_tree (ns->tb_sym_root);
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
+ gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
/* This helper function calculates the size in words of a full array. */
-static tree
-get_full_array_size (stmtblock_t *block, tree decl, int rank)
+tree
+gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
{
tree idx;
tree nelems;
static tree
duplicate_allocatable (tree dest, tree src, tree type, int rank,
- bool no_malloc, tree str_sz)
+ bool no_malloc, bool no_memcpy, tree str_sz)
{
tree tmp;
tree size;
gfc_add_expr_to_block (&block, tmp);
}
- tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
- tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
- fold_convert (size_type_node, size));
+ if (!no_memcpy)
+ {
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp = build_call_expr_loc (input_location, tmp, 3, dest, src,
+ fold_convert (size_type_node, size));
+ gfc_add_expr_to_block (&block, tmp);
+ }
}
else
{
gfc_init_block (&block);
if (rank)
- nelems = get_full_array_size (&block, src, rank);
+ nelems = gfc_full_array_size (&block, src, rank);
else
nelems = gfc_index_one_node;
/* We know the temporary and the value will be the same length,
so can use memcpy. */
- tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
- tmp = build_call_expr_loc (input_location,
- tmp, 3, gfc_conv_descriptor_data_get (dest),
- gfc_conv_descriptor_data_get (src),
- fold_convert (size_type_node, size));
+ if (!no_memcpy)
+ {
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp = build_call_expr_loc (input_location, tmp, 3,
+ gfc_conv_descriptor_data_get (dest),
+ gfc_conv_descriptor_data_get (src),
+ fold_convert (size_type_node, size));
+ gfc_add_expr_to_block (&block, tmp);
+ }
}
- gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do
tree
gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
{
- return duplicate_allocatable (dest, src, type, rank, false, NULL_TREE);
+ return duplicate_allocatable (dest, src, type, rank, false, false,
+ NULL_TREE);
}
tree
gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
{
- return duplicate_allocatable (dest, src, type, rank, true, NULL_TREE);
+ return duplicate_allocatable (dest, src, type, rank, true, false,
+ NULL_TREE);
+}
+
+/* Allocate dest to the same size as src, but don't copy anything. */
+
+tree
+gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
+{
+ return duplicate_allocatable (dest, src, type, rank, false, true, NULL_TREE);
}
/* Use the descriptor for an allocatable array. Since this
is a full array reference, we only need the descriptor
information from dimension = rank. */
- tmp = get_full_array_size (&fnblock, decl, rank);
+ tmp = gfc_full_array_size (&fnblock, decl, rank);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, tmp,
gfc_index_one_node);
gfc_add_expr_to_block (&fnblock, tmp);
size = size_of_string_in_bytes (c->ts.kind, len);
tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
- false, size);
+ false, false, size);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (c->attr.allocatable && !c->attr.proc_pointer
/* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
+tree gfc_full_array_size (stmtblock_t *, tree, int);
+
tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
+tree gfc_duplicate_allocatable_nocopy (tree, tree, tree, int);
+
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int);
if (com->threadprivate)
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+ if (com->omp_declare_target)
+ DECL_ATTRIBUTES (decl)
+ = tree_cons (get_identifier ("omp declare target"),
+ NULL_TREE, DECL_ATTRIBUTES (decl));
+
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
TREE_ADDRESSABLE (var_decl) = 1;
/* Fake variables are not visible from other translation units. */
TREE_PUBLIC (var_decl) = 0;
+ gfc_finish_decl_attrs (var_decl, &s->sym->attr);
/* To preserve identifier names in COMMON, chain to procedure
scope unless at top level in a module definition. */
}
+/* Handle setting of GFC_DECL_SCALAR* on DECL. */
+
+void
+gfc_finish_decl_attrs (tree decl, symbol_attribute *attr)
+{
+ if (!attr->dimension && !attr->codimension)
+ {
+ /* Handle scalar allocatable variables. */
+ if (attr->allocatable)
+ {
+ gfc_allocate_lang_decl (decl);
+ GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1;
+ }
+ /* Handle scalar pointer variables. */
+ if (attr->pointer)
+ {
+ gfc_allocate_lang_decl (decl);
+ GFC_DECL_SCALAR_POINTER (decl) = 1;
+ }
+ }
+}
+
+
/* Apply symbol attributes to a variable, and add it to the function scope. */
static void
if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+ gfc_finish_decl_attrs (decl, &sym->attr);
}
void
gfc_allocate_lang_decl (tree decl)
{
- DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
- (struct lang_decl));
+ if (DECL_LANG_SPECIFIC (decl) == NULL)
+ DECL_LANG_SPECIFIC (decl)
+ = ggc_alloc_cleared_lang_decl (sizeof (struct lang_decl));
}
/* Remember a symbol to generate initialization/cleanup code at function
list = chainon (list, attr);
}
+ if (sym_attr.omp_declare_target)
+ list = tree_cons (get_identifier ("omp declare target"),
+ NULL_TREE, list);
+
return list;
}
&& !sym->attr.select_type_temporary)
DECL_BY_REFERENCE (decl) = 1;
+ if (sym->attr.associate_var)
+ GFC_DECL_ASSOCIATE_VAR_P (decl) = 1;
+
if (sym->attr.vtab
|| (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
TREE_READONLY (decl) = 1;
if (DECL_CONTEXT (fndecl) == NULL_TREE)
pushdecl_top_level (fndecl);
+ if (sym->formal_ns
+ && sym->formal_ns->proc_name == sym
+ && sym->formal_ns->omp_declare_simd)
+ gfc_trans_omp_declare_simd (sym->formal_ns);
+
return fndecl;
}
DECL_BY_REFERENCE (parm) = 1;
gfc_finish_decl (parm);
+ gfc_finish_decl_attrs (parm, &f->sym->attr);
f->sym->backend_decl = parm;
/* Now create the read argument list. */
create_function_arglist (ns->proc_name);
+
+ if (ns->omp_declare_simd)
+ gfc_trans_omp_declare_simd (ns);
}
/* Return the decl used to hold the function return value. If
TREE_ADDRESSABLE (decl) = 1;
layout_decl (decl, 0);
+ gfc_finish_decl_attrs (decl, &sym->attr);
if (parent_flag)
gfc_add_decl_to_parent_function (decl);
/* Take the address of that value. */
se->expr = gfc_build_addr_expr (NULL_TREE, var);
+ if (expr->ts.type == BT_DERIVED && expr->rank
+ && !gfc_is_finalizable (expr->ts.u.derived, NULL)
+ && expr->ts.u.derived->attr.alloc_comp
+ && expr->expr_type != EXPR_VARIABLE)
+ {
+ tree tmp;
+
+ tmp = build_fold_indirect_ref_loc (input_location, se->expr);
+ tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank);
+
+ /* The components shall be deallocated before
+ their containing entity. */
+ gfc_prepend_expr_to_block (&se->post, tmp);
+ }
}
res_desc = gfc_evaluate_now (desc, &se->pre);
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
- se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc);
+ se->expr = gfc_build_addr_expr (NULL_TREE, res_desc);
/* Free the lhs after the function call and copy the result data to
the lhs descriptor. */
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)
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)
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
&& 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);
}
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. */
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);
}
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))
+ /* 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 (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;
+}
- if (! GFC_DESCRIPTOR_TYPE_P (type)
- || GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_ALLOCATABLE)
- return NULL;
- if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_REDUCTION)
- return NULL;
+void
+gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
+{
+ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP)
+ return;
- /* Allocatable arrays in FIRSTPRIVATE/LASTPRIVATE etc. clauses need
- to be deallocated if they were allocated. */
- return gfc_trans_dealloc_allocated (decl, false, NULL);
+ 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;
+ }
}
}
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;
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
}
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);
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;
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;
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;
gcc_assert (t);
iname = NULL;
+ e4 = NULL;
switch (OMP_CLAUSE_REDUCTION_CODE (c))
{
case PLUS_EXPR:
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 ();
}
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
/* 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
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);
}
}
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;
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;
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;
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. */
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);
&& 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);
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);
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);
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
{
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
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);
}
}
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;
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;
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;
}
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)
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;
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
}
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);
}
}
/* 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);
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;
}
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;
}
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);
}
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;
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:
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:
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;
+ }
+}
/* trans-openmp.c */
tree gfc_trans_omp_directive (gfc_code *);
+void gfc_trans_omp_declare_simd (gfc_namespace *);
/* trans-io.c */
tree gfc_trans_open (gfc_code *);
restricted);
byref = 0;
}
-
- if (sym->attr.cray_pointee)
- GFC_POINTER_TYPE_P (type) = 1;
}
else
{
if (sym->attr.allocatable || sym->attr.pointer
|| gfc_is_associate_pointer (sym))
type = gfc_build_pointer_type (sym, type);
- if (sym->attr.pointer || sym->attr.cray_pointee)
- GFC_POINTER_TYPE_P (type) = 1;
}
/* We currently pass all parameters by reference.
else if (derived->declared_at.lb)
gfc_set_decl_location (field, &derived->declared_at);
+ gfc_finish_decl_attrs (field, &c->attr);
+
DECL_PACKED (field) |= TYPE_PACKED (typenode);
gcc_assert (field);
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
case EXEC_OMP_FLUSH:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ 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:
+ case EXEC_OMP_TARGET_UPDATE:
case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_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:
case EXEC_OMP_WORKSHARE:
res = gfc_trans_omp_directive (code);
break;
/* Returns true if a variable of specified size should go on the stack. */
int gfc_can_put_var_on_stack (tree);
+/* Set GFC_DECL_SCALAR_* on decl from sym if needed. */
+void gfc_finish_decl_attrs (tree, symbol_attribute *);
+
/* Allocate the lang-specific part of a decl node. */
void gfc_allocate_lang_decl (tree);
tree gfc_omp_clause_default_ctor (tree, tree, tree);
tree gfc_omp_clause_copy_ctor (tree, tree, tree);
tree gfc_omp_clause_assign_op (tree, tree, tree);
+tree gfc_omp_clause_linear_ctor (tree, tree, tree, tree);
tree gfc_omp_clause_dtor (tree, tree);
+void gfc_omp_finish_clause (tree, gimple_seq *);
bool gfc_omp_disregard_value_expr (tree, bool);
bool gfc_omp_private_debug_clause (tree, bool);
bool gfc_omp_private_outer_ref (tree);
tree span;
/* For assumed-shape coarrays. */
tree token, caf_offset;
+ unsigned int scalar_allocatable : 1;
+ unsigned int scalar_pointer : 1;
};
#define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
#define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor)
+#define GFC_DECL_SCALAR_ALLOCATABLE(node) \
+ (DECL_LANG_SPECIFIC (node)->scalar_allocatable)
+#define GFC_DECL_SCALAR_POINTER(node) \
+ (DECL_LANG_SPECIFIC (node)->scalar_pointer)
+#define GFC_DECL_GET_SCALAR_ALLOCATABLE(node) \
+ (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_ALLOCATABLE (node) : 0)
+#define GFC_DECL_GET_SCALAR_POINTER(node) \
+ (DECL_LANG_SPECIFIC (node) ? GFC_DECL_SCALAR_POINTER (node) : 0)
#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
#define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
#define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node)
#define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node)
#define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node)
#define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node)
+#define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node)
#define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node)
/* An array descriptor. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
/* An array without a descriptor. */
#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
-/* Fortran POINTER type. */
-#define GFC_POINTER_TYPE_P(node) TYPE_LANG_FLAG_3(node)
/* Fortran CLASS type. */
#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
/* The GFC_TYPE_ARRAY_* members are present in both descriptor and
Store any side-effects in PRE_P. CALL_LOCATION is the location of
the CALL_EXPR. */
-static enum gimplify_status
+enum gimplify_status
gimplify_arg (tree *arg_p, gimple_seq *pre_p, location_t call_location)
{
bool (*test) (tree);
n = splay_tree_lookup (ctx->variables, (splay_tree_key)decl);
if (ctx->region_type == ORT_TARGET)
{
+ ret = lang_hooks.decls.omp_disregard_value_expr (decl, true);
if (n == NULL)
{
if (!lang_hooks.types.omp_mappable_type (TREE_TYPE (decl)))
omp_add_variable (ctx, decl, GOVD_MAP | flags);
}
else
- n->value |= flags;
- ret = lang_hooks.decls.omp_disregard_value_expr (decl, true);
+ {
+ /* If nothing changed, there's nothing left to do. */
+ if ((n->value & flags) == flags)
+ return ret;
+ n->value |= flags;
+ }
goto do_outer;
}
goto do_add;
case OMP_CLAUSE_MAP:
- if (OMP_CLAUSE_SIZE (c)
- && gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
- NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
+ decl = OMP_CLAUSE_DECL (c);
+ if (error_operand_p (decl))
+ {
+ remove = true;
+ break;
+ }
+ if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
+ NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
{
remove = true;
break;
}
- decl = OMP_CLAUSE_DECL (c);
if (!DECL_P (decl))
{
if (gimplify_expr (&OMP_CLAUSE_DECL (c), pre_p,
case OMP_CLAUSE_TO:
case OMP_CLAUSE_FROM:
- if (OMP_CLAUSE_SIZE (c)
- && gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
- NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
+ decl = OMP_CLAUSE_DECL (c);
+ if (error_operand_p (decl))
{
remove = true;
break;
}
- decl = OMP_CLAUSE_DECL (c);
- if (error_operand_p (decl))
+ if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
+ NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
{
remove = true;
break;
gimplify_omp_ctxp = outer_ctx;
}
+ else if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
+ && OMP_CLAUSE_LINEAR_STMT (c))
+ {
+ gimplify_omp_ctxp = ctx;
+ push_gimplify_context ();
+ if (TREE_CODE (OMP_CLAUSE_LINEAR_STMT (c)) != BIND_EXPR)
+ {
+ tree bind = build3 (BIND_EXPR, void_type_node, NULL,
+ NULL, NULL);
+ TREE_SIDE_EFFECTS (bind) = 1;
+ BIND_EXPR_BODY (bind) = OMP_CLAUSE_LINEAR_STMT (c);
+ OMP_CLAUSE_LINEAR_STMT (c) = bind;
+ }
+ gimplify_and_add (OMP_CLAUSE_LINEAR_STMT (c),
+ &OMP_CLAUSE_LINEAR_GIMPLE_SEQ (c));
+ pop_gimplify_context
+ (gimple_seq_first_stmt (OMP_CLAUSE_LINEAR_GIMPLE_SEQ (c)));
+ OMP_CLAUSE_LINEAR_STMT (c) = NULL_TREE;
+
+ gimplify_omp_ctxp = outer_ctx;
+ }
if (notice_outer)
goto do_notice;
break;
remove = true;
break;
}
+ if (gimplify_expr (&OMP_CLAUSE_ALIGNED_ALIGNMENT (c), pre_p, NULL,
+ is_gimple_val, fb_rvalue) == GS_ERROR)
+ {
+ remove = true;
+ break;
+ }
if (!is_global_var (decl)
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
omp_add_variable (ctx, decl, GOVD_ALIGNED);
gimplify_omp_ctxp = ctx;
}
+struct gimplify_adjust_omp_clauses_data
+{
+ tree *list_p;
+ gimple_seq *pre_p;
+};
+
/* For all variables that were not actually used within the context,
remove PRIVATE, SHARED, and FIRSTPRIVATE clauses. */
static int
gimplify_adjust_omp_clauses_1 (splay_tree_node n, void *data)
{
- tree *list_p = (tree *) data;
+ tree *list_p = ((struct gimplify_adjust_omp_clauses_data *) data)->list_p;
+ gimple_seq *pre_p
+ = ((struct gimplify_adjust_omp_clauses_data *) data)->pre_p;
tree decl = (tree) n->key;
unsigned flags = n->value;
enum omp_clause_code code;
OMP_CLAUSE_CHAIN (nc) = OMP_CLAUSE_CHAIN (clause);
OMP_CLAUSE_CHAIN (clause) = nc;
}
+ else
+ OMP_CLAUSE_SIZE (clause) = DECL_SIZE_UNIT (decl);
}
if (code == OMP_CLAUSE_FIRSTPRIVATE && (flags & GOVD_LASTPRIVATE) != 0)
{
OMP_CLAUSE_LASTPRIVATE_FIRSTPRIVATE (nc) = 1;
OMP_CLAUSE_CHAIN (nc) = *list_p;
OMP_CLAUSE_CHAIN (clause) = nc;
- lang_hooks.decls.omp_finish_clause (nc);
+ struct gimplify_omp_ctx *ctx = gimplify_omp_ctxp;
+ gimplify_omp_ctxp = ctx->outer_context;
+ lang_hooks.decls.omp_finish_clause (nc, pre_p);
+ gimplify_omp_ctxp = ctx;
}
*list_p = clause;
- lang_hooks.decls.omp_finish_clause (clause);
+ struct gimplify_omp_ctx *ctx = gimplify_omp_ctxp;
+ gimplify_omp_ctxp = ctx->outer_context;
+ lang_hooks.decls.omp_finish_clause (clause, pre_p);
+ gimplify_omp_ctxp = ctx;
return 0;
}
static void
-gimplify_adjust_omp_clauses (tree *list_p)
+gimplify_adjust_omp_clauses (gimple_seq *pre_p, tree *list_p)
{
struct gimplify_omp_ctx *ctx = gimplify_omp_ctxp;
tree c, decl;
OMP_CLAUSE_CHAIN (c) = nc;
c = nc;
}
+ else if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
break;
case OMP_CLAUSE_TO:
OMP_CLAUSE_SIZE (c), true);
}
}
+ else if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
break;
case OMP_CLAUSE_REDUCTION:
}
/* Add in any implicit data sharing. */
- splay_tree_foreach (ctx->variables, gimplify_adjust_omp_clauses_1, list_p);
+ struct gimplify_adjust_omp_clauses_data data;
+ data.list_p = list_p;
+ data.pre_p = pre_p;
+ splay_tree_foreach (ctx->variables, gimplify_adjust_omp_clauses_1, &data);
gimplify_omp_ctxp = ctx->outer_context;
delete_omp_context (ctx);
else
pop_gimplify_context (NULL);
- gimplify_adjust_omp_clauses (&OMP_PARALLEL_CLAUSES (expr));
+ gimplify_adjust_omp_clauses (pre_p, &OMP_PARALLEL_CLAUSES (expr));
g = gimple_build_omp_parallel (body,
OMP_PARALLEL_CLAUSES (expr),
else
pop_gimplify_context (NULL);
- gimplify_adjust_omp_clauses (&OMP_TASK_CLAUSES (expr));
+ gimplify_adjust_omp_clauses (pre_p, &OMP_TASK_CLAUSES (expr));
g = gimple_build_omp_task (body,
OMP_TASK_CLAUSES (expr),
case POSTINCREMENT_EXPR:
{
tree decl = TREE_OPERAND (t, 0);
- // c_omp_for_incr_canonicalize_ptr() should have been
- // called to massage things appropriately.
+ /* c_omp_for_incr_canonicalize_ptr() should have been
+ called to massage things appropriately. */
gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
if (orig_for_stmt != for_stmt)
case PREDECREMENT_EXPR:
case POSTDECREMENT_EXPR:
+ /* c_omp_for_incr_canonicalize_ptr() should have been
+ called to massage things appropriately. */
+ gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
if (orig_for_stmt != for_stmt)
break;
t = build_int_cst (TREE_TYPE (decl), -1);
ret = MIN (ret, tret);
if (c)
{
- OMP_CLAUSE_LINEAR_STEP (c) = TREE_OPERAND (t, 1);
+ tree step = TREE_OPERAND (t, 1);
+ tree stept = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (stept))
+ stept = sizetype;
+ step = fold_convert (stept, step);
if (TREE_CODE (t) == MINUS_EXPR)
+ step = fold_build1 (NEGATE_EXPR, stept, step);
+ OMP_CLAUSE_LINEAR_STEP (c) = step;
+ if (step != TREE_OPERAND (t, 1))
{
- t = TREE_OPERAND (t, 1);
- OMP_CLAUSE_LINEAR_STEP (c)
- = fold_build1 (NEGATE_EXPR, TREE_TYPE (t), t);
tret = gimplify_expr (&OMP_CLAUSE_LINEAR_STEP (c),
&for_pre_body, NULL,
is_gimple_val, fb_rvalue);
TREE_OPERAND (TREE_OPERAND (t, 1), 0) = var;
}
- gimplify_adjust_omp_clauses (&OMP_FOR_CLAUSES (orig_for_stmt));
+ gimplify_adjust_omp_clauses (pre_p, &OMP_FOR_CLAUSES (orig_for_stmt));
int kind;
switch (TREE_CODE (orig_for_stmt))
}
else
gimplify_and_add (OMP_BODY (expr), &body);
- gimplify_adjust_omp_clauses (&OMP_CLAUSES (expr));
+ gimplify_adjust_omp_clauses (pre_p, &OMP_CLAUSES (expr));
switch (TREE_CODE (expr))
{
gimplify_scan_omp_clauses (&OMP_TARGET_UPDATE_CLAUSES (expr), pre_p,
ORT_WORKSHARE);
- gimplify_adjust_omp_clauses (&OMP_TARGET_UPDATE_CLAUSES (expr));
+ gimplify_adjust_omp_clauses (pre_p, &OMP_TARGET_UPDATE_CLAUSES (expr));
stmt = gimple_build_omp_target (NULL, GF_OMP_TARGET_KIND_UPDATE,
OMP_TARGET_UPDATE_CLAUSES (expr));
extern void gimplify_type_sizes (tree, gimple_seq *);
extern void gimplify_one_sizepos (tree *, gimple_seq *);
extern gimple gimplify_body (tree, bool);
+extern enum gimplify_status gimplify_arg (tree *, gimple_seq *, location_t);
extern void gimplify_function_tree (tree);
extern enum gimplify_status gimplify_va_arg_expr (tree *, gimple_seq *,
gimple_seq *);
}
else if (p[1] == '*')
{
- this->lineoff_ = p - this->linebuf_;
+ this->lineoff_ = p + 2 - this->linebuf_;
Location location = this->location();
if (!this->skip_c_comment())
return Token::make_invalid_token(location);
&& DECL_FUNCTION_CODE (target) == BUILT_IN_UNREACHABLE)
|| !possible_polymorphic_call_target_p
(ie, cgraph_get_node (target)))
- {
- if (dump_file)
- fprintf (dump_file,
- "Type inconsident devirtualization: %s/%i->%s\n",
- ie->caller->name (), ie->caller->order,
- IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (target)));
- target = builtin_decl_implicit (BUILT_IN_UNREACHABLE);
- cgraph_get_create_node (target);
- }
+ target = ipa_impossible_devirt_target (ie, target);
return target;
}
}
if (targets.length () == 1)
target = targets[0]->decl;
else
- target = builtin_decl_implicit (BUILT_IN_UNREACHABLE);
+ target = ipa_impossible_devirt_target (ie, NULL_TREE);
}
else
{
if (target && !possible_polymorphic_call_target_p (ie,
cgraph_get_node (target)))
- {
- if (dump_file)
- fprintf (dump_file,
- "Type inconsident devirtualization: %s/%i->%s\n",
- ie->caller->name (), ie->caller->order,
- IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (target)));
- target = builtin_decl_implicit (BUILT_IN_UNREACHABLE);
- cgraph_get_create_node (target);
- }
+ target = ipa_impossible_devirt_target (ie, target);
return target;
}
/* Return the target to be used in cases of impossible devirtualization. IE
and target (the latter can be NULL) are dumped when dumping is enabled. */
-static tree
-impossible_devirt_target (struct cgraph_edge *ie, tree target)
+tree
+ipa_impossible_devirt_target (struct cgraph_edge *ie, tree target)
{
if (dump_file)
{
if (target)
fprintf (dump_file,
- "Type inconsident devirtualization: %s/%i->%s\n",
+ "Type inconsistent devirtualization: %s/%i->%s\n",
ie->caller->name (), ie->caller->order,
IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (target)));
else
&& DECL_FUNCTION_CODE (target) == BUILT_IN_UNREACHABLE)
|| !possible_polymorphic_call_target_p
(ie, cgraph_get_node (target)))
- target = impossible_devirt_target (ie, target);
+ target = ipa_impossible_devirt_target (ie, target);
return ipa_make_edge_direct_to_target (ie, target);
}
}
if (targets.length () == 1)
target = targets[0]->decl;
else
- target = impossible_devirt_target (ie, NULL_TREE);
+ target = ipa_impossible_devirt_target (ie, NULL_TREE);
}
else
{
if (target)
{
if (!possible_polymorphic_call_target_p (ie, cgraph_get_node (target)))
- target = impossible_devirt_target (ie, target);
+ target = ipa_impossible_devirt_target (ie, target);
return ipa_make_edge_direct_to_target (ie, target);
}
else
struct cgraph_edge *ipa_make_edge_direct_to_target (struct cgraph_edge *, tree);
tree ipa_binfo_from_known_type_jfunc (struct ipa_jump_func *);
tree ipa_intraprocedural_devirtualization (gimple);
+tree ipa_impossible_devirt_target (struct cgraph_edge *, tree);
/* Functions related to both. */
void ipa_analyze_node (struct cgraph_node *);
extern int lhd_gimplify_expr (tree *, gimple_seq *, gimple_seq *);
extern enum omp_clause_default_kind lhd_omp_predetermined_sharing (tree);
extern tree lhd_omp_assignment (tree, tree, tree);
+extern void lhd_omp_finish_clause (tree, gimple_seq *);
struct gimplify_omp_ctx;
extern void lhd_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *,
tree);
#define LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR hook_tree_tree_tree_tree_null
#define LANG_HOOKS_OMP_CLAUSE_COPY_CTOR lhd_omp_assignment
#define LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP lhd_omp_assignment
+#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR NULL
#define LANG_HOOKS_OMP_CLAUSE_DTOR hook_tree_tree_tree_null
-#define LANG_HOOKS_OMP_FINISH_CLAUSE hook_void_tree
+#define LANG_HOOKS_OMP_FINISH_CLAUSE lhd_omp_finish_clause
#define LANG_HOOKS_DECLS { \
LANG_HOOKS_GLOBAL_BINDINGS_P, \
LANG_HOOKS_OMP_CLAUSE_DEFAULT_CTOR, \
LANG_HOOKS_OMP_CLAUSE_COPY_CTOR, \
LANG_HOOKS_OMP_CLAUSE_ASSIGN_OP, \
+ LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR, \
LANG_HOOKS_OMP_CLAUSE_DTOR, \
LANG_HOOKS_OMP_FINISH_CLAUSE \
}
return build2 (MODIFY_EXPR, TREE_TYPE (dst), dst, src);
}
+/* Finalize clause C. */
+
+void
+lhd_omp_finish_clause (tree, gimple_seq *)
+{
+}
+
/* Register language specific type size variables as potentially OpenMP
firstprivate variables. */
/* Similarly, except use an assignment operator instead. */
tree (*omp_clause_assign_op) (tree clause, tree dst, tree src);
+ /* Build and return code for a constructor of DST that sets it to
+ SRC + ADD. */
+ tree (*omp_clause_linear_ctor) (tree clause, tree dst, tree src, tree add);
+
/* Build and return code destructing DECL. Return NULL if nothing
to be done. */
tree (*omp_clause_dtor) (tree clause, tree decl);
/* Do language specific checking on an implicitly determined clause. */
- void (*omp_finish_clause) (tree clause);
+ void (*omp_finish_clause) (tree clause, gimple_seq *pre_p);
};
/* Language hooks related to LTO serialization. */
}
else
{
+ if (ctx->outer)
+ {
+ scan_omp_op (&OMP_CLAUSE_DECL (c), ctx->outer);
+ decl = OMP_CLAUSE_DECL (c);
+ }
gcc_assert (!splay_tree_lookup (ctx->field_map,
(splay_tree_key) decl));
tree field
tree temp = create_tmp_var (type, NULL);
tree c = build_omp_clause (UNKNOWN_LOCATION,
OMP_CLAUSE__LOOPTEMP_);
+ insert_decl_map (&outer_ctx->cb, temp, temp);
OMP_CLAUSE_DECL (c) = temp;
OMP_CLAUSE_CHAIN (c) = gimple_omp_parallel_clauses (stmt);
gimple_omp_parallel_set_clauses (stmt, c);
return false;
}
break;
+ case GIMPLE_OMP_TARGET:
+ for (; ctx != NULL; ctx = ctx->outer)
+ if (gimple_code (ctx->stmt) == GIMPLE_OMP_TARGET
+ && gimple_omp_target_kind (ctx->stmt) == GF_OMP_TARGET_KIND_REGION)
+ {
+ const char *name;
+ switch (gimple_omp_target_kind (stmt))
+ {
+ case GF_OMP_TARGET_KIND_REGION: name = "target"; break;
+ case GF_OMP_TARGET_KIND_DATA: name = "target data"; break;
+ case GF_OMP_TARGET_KIND_UPDATE: name = "target update"; break;
+ default: gcc_unreachable ();
+ }
+ warning_at (gimple_location (stmt), 0,
+ "%s construct inside of target region", name);
+ }
+ break;
default:
break;
}
{
tree c = find_omp_clause (gimple_omp_for_clauses (ctx->stmt),
OMP_CLAUSE_SAFELEN);
- if (c
- && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c), max_vf) == -1)
+ if (c && TREE_CODE (OMP_CLAUSE_SAFELEN_EXPR (c)) != INTEGER_CST)
+ max_vf = 1;
+ else if (c && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c),
+ max_vf) == -1)
max_vf = tree_to_shwi (OMP_CLAUSE_SAFELEN_EXPR (c));
}
if (max_vf > 1)
for (c = clauses; c ; c = OMP_CLAUSE_CHAIN (c))
switch (OMP_CLAUSE_CODE (c))
{
+ case OMP_CLAUSE_LINEAR:
+ if (OMP_CLAUSE_LINEAR_ARRAY (c))
+ max_vf = 1;
+ /* FALLTHRU */
case OMP_CLAUSE_REDUCTION:
case OMP_CLAUSE_PRIVATE:
case OMP_CLAUSE_FIRSTPRIVATE:
case OMP_CLAUSE_LASTPRIVATE:
- case OMP_CLAUSE_LINEAR:
if (is_variable_sized (OMP_CLAUSE_DECL (c)))
max_vf = 1;
break;
if (pass != 0)
continue;
}
+ /* Even without corresponding firstprivate, if
+ decl is Fortran allocatable, it needs outer var
+ reference. */
+ else if (pass == 0
+ && lang_hooks.decls.omp_private_outer_ref
+ (OMP_CLAUSE_DECL (c)))
+ lastprivate_firstprivate = true;
break;
case OMP_CLAUSE_ALIGNED:
if (pass == 0)
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_LINEAR
&& gimple_omp_for_combined_into_p (ctx->stmt))
{
- tree stept = POINTER_TYPE_P (TREE_TYPE (x))
- ? sizetype : TREE_TYPE (x);
- tree t = fold_convert (stept,
- OMP_CLAUSE_LINEAR_STEP (c));
- tree c = find_omp_clause (clauses,
- OMP_CLAUSE__LOOPTEMP_);
- gcc_assert (c);
- tree l = OMP_CLAUSE_DECL (c);
+ tree t = OMP_CLAUSE_LINEAR_STEP (c);
+ tree stept = TREE_TYPE (t);
+ tree ct = find_omp_clause (clauses,
+ OMP_CLAUSE__LOOPTEMP_);
+ gcc_assert (ct);
+ tree l = OMP_CLAUSE_DECL (ct);
tree n1 = fd->loop.n1;
tree step = fd->loop.step;
tree itype = TREE_TYPE (l);
l = fold_build2 (TRUNC_DIV_EXPR, itype, l, step);
t = fold_build2 (MULT_EXPR, stept,
fold_convert (stept, l), t);
+
+ if (OMP_CLAUSE_LINEAR_ARRAY (c))
+ {
+ x = lang_hooks.decls.omp_clause_linear_ctor
+ (c, new_var, x, t);
+ gimplify_and_add (x, ilist);
+ goto do_dtor;
+ }
+
if (POINTER_TYPE_P (TREE_TYPE (x)))
x = fold_build2 (POINTER_PLUS_EXPR,
TREE_TYPE (x), x, t);
= gimple_build_assign (unshare_expr (lvar), iv);
gsi_insert_before_without_update (&gsi, g,
GSI_SAME_STMT);
- tree stept = POINTER_TYPE_P (TREE_TYPE (x))
- ? sizetype : TREE_TYPE (x);
- tree t = fold_convert (stept,
- OMP_CLAUSE_LINEAR_STEP (c));
+ tree t = OMP_CLAUSE_LINEAR_STEP (c);
enum tree_code code = PLUS_EXPR;
if (POINTER_TYPE_P (TREE_TYPE (new_var)))
code = POINTER_PLUS_EXPR;
else if (is_reference (var) && is_simd)
handle_simd_reference (clause_loc, new_vard, ilist);
x = lang_hooks.decls.omp_clause_default_ctor
- (c, new_var, unshare_expr (x));
+ (c, unshare_expr (new_var),
+ build_outer_var_ref (var, ctx));
if (x)
gimplify_and_add (x, ilist);
if (OMP_CLAUSE_REDUCTION_GIMPLE_INIT (c))
tree c = find_omp_clause (gimple_omp_for_clauses (ctx->stmt),
OMP_CLAUSE_SAFELEN);
if (c == NULL_TREE
- || compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c),
- max_vf) == 1)
+ || (TREE_CODE (OMP_CLAUSE_SAFELEN_EXPR (c)) == INTEGER_CST
+ && compare_tree_int (OMP_CLAUSE_SAFELEN_EXPR (c),
+ max_vf) == 1))
{
c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_SAFELEN);
OMP_CLAUSE_SAFELEN_EXPR (c) = build_int_cst (integer_type_node,
else
{
safelen = OMP_CLAUSE_SAFELEN_EXPR (safelen);
- if (!tree_fits_uhwi_p (safelen)
- || tree_to_uhwi (safelen) > INT_MAX)
+ if (TREE_CODE (safelen) != INTEGER_CST)
+ loop->safelen = 0;
+ else if (!tree_fits_uhwi_p (safelen)
+ || tree_to_uhwi (safelen) > INT_MAX)
loop->safelen = INT_MAX;
else
loop->safelen = tree_to_uhwi (safelen);
&& gimple_code (ctx->outer->stmt) == GIMPLE_OMP_PARALLEL
&& ctx->outer->cancellable)
{
- tree lhs = create_tmp_var (boolean_type_node, NULL);
+ tree fndecl = builtin_decl_explicit (BUILT_IN_GOMP_CANCEL);
+ tree c_bool_type = TREE_TYPE (TREE_TYPE (fndecl));
+ tree lhs = create_tmp_var (c_bool_type, NULL);
gimple_omp_return_set_lhs (omp_return, lhs);
tree fallthru_label = create_artificial_label (UNKNOWN_LOCATION);
- gimple g = gimple_build_cond (NE_EXPR, lhs, boolean_false_node,
+ gimple g = gimple_build_cond (NE_EXPR, lhs,
+ fold_convert (c_bool_type,
+ boolean_false_node),
ctx->outer->cancel_label, fallthru_label);
gimple_seq_add_stmt (body, g);
gimple_seq_add_stmt (body, gimple_build_label (fallthru_label));
OMP_CLAUSE__LOOPTEMP_);
}
else
- temp = create_tmp_var (type, NULL);
+ {
+ temp = create_tmp_var (type, NULL);
+ insert_decl_map (&ctx->outer->cb, temp, temp);
+ }
*pc = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE__LOOPTEMP_);
OMP_CLAUSE_DECL (*pc) = temp;
pc = &OMP_CLAUSE_CHAIN (*pc);
}
break;
}
- tree lhs;
- lhs = create_tmp_var (boolean_type_node, NULL);
if (DECL_FUNCTION_CODE (fndecl) == BUILT_IN_GOMP_BARRIER)
{
fndecl = builtin_decl_explicit (BUILT_IN_GOMP_BARRIER_CANCEL);
gimple_call_set_fndecl (stmt, fndecl);
gimple_call_set_fntype (stmt, TREE_TYPE (fndecl));
}
+ tree lhs;
+ lhs = create_tmp_var (TREE_TYPE (TREE_TYPE (fndecl)), NULL);
gimple_call_set_lhs (stmt, lhs);
tree fallthru_label;
fallthru_label = create_artificial_label (UNKNOWN_LOCATION);
gimple g;
g = gimple_build_label (fallthru_label);
gsi_insert_after (gsi_p, g, GSI_SAME_STMT);
- g = gimple_build_cond (NE_EXPR, lhs, boolean_false_node,
+ g = gimple_build_cond (NE_EXPR, lhs,
+ fold_convert (TREE_TYPE (lhs),
+ boolean_false_node),
cctx->cancel_label, fallthru_label);
gsi_insert_after (gsi_p, g, GSI_SAME_STMT);
break;
+2014-07-09 Edward Smith-Rowland <3dw4rd@verizon.net>
+
+ PR c++/58155 - -Wliteral-suffix warns about tokens which are skipped
+ g++.dg/cpp0x/pr58155.C: New.
+
+2014-07-09 Alan Lawrence <alan.lawrence@arm.com>
+
+ Backport r211369 from trunk.
+ 2014-06-09 Alan Lawrence <alan.lawrence@arm.com>
+
+ PR target/61062
+ * gcc.target/arm/pr48252.c (main): Expect same result as endian-neutral.
+
+2014-07-08 Jakub Jelinek <jakub@redhat.com>
+
+ PR rtl-optimization/61673
+ * gcc.c-torture/execute/pr61673.c: New test.
+
+2014-07-08 Richard Biener <rguenther@suse.de>
+
+ PR tree-optimization/61680
+ * gcc.dg/vect/pr61680.c: New testcase.
+
+ PR tree-optimization/61681
+ * gcc.dg/torture/pr61681.c: New testcase.
+
+2014-07-08 Alan Lawrence <alan.lawrence@arm.com>
+
+ Backport r211502 from mainline.
+ 2014-06-10 Alan Lawrence <alan.lawrence@arm.com>
+
+ PR target/59843
+ * gcc.dg/vect/vect-singleton_1.c: New file.
+
+2014-07-08 Jakub Jelinek <jakub@redhat.com>
+
+ PR tree-optimization/61725
+ * gcc.dg/tree-ssa/vrp93.c: New test.
+ * gcc.c-torture/execute/pr61725.c: New test.
+
+2014-07-07 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/61459
+ PR fortran/58883
+ * gfortran.dg/allocatable_function_8.f90 : New test
+
+2014-07-07 Dominique d'Humieres <dominiq@lps.ens.fr>
+ Mikael Morin <mikael@gcc.gnu.org>
+
+ PR fortran/41936
+ * gfortran.dg/class_array_15.f03: Check memory leaks.
+
+2014-07-06 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ Backport from mainline.
+ PR libgfortran/61640
+ * gfortran.dg/arrayio_16.f90: New test.
+
+2014-07-04 Jakub Jelinek <jakub@redhat.com>
+
+ PR middle-end/61654
+ * g++.dg/opt/pr61654.C: New test.
+
+ PR tree-optimization/61684
+ * gcc.c-torture/compile/pr61684.c: New test.
+
+ PR c++/61382
+ Backport from mainline
+ 2014-06-05 Andreas Schwab <schwab@suse.de>
+
+ * g++.dg/cpp0x/initlist86.C (main): Initialize i.
+
+2014-07-02 Jakub Jelinek <jakub@redhat.com>
+ Fritz Reese <Reese-Fritz@zai.com>
+
+ * gfortran.dg/oldstyle_5.f: New test.
+
+2014-07-01 Paul Pluzhnikov <ppluzhnikov@google.com>
+
+ PR c++/58753
+ PR c++/58930
+ PR c++/58704
+
+ Backported from mainline
+ 2014-05-20 Paolo Carlini <paolo.carlini@oracle.com>
+
+ * g++.dg/cpp0x/nsdmi-template11.C: New.
+ * g++.dg/cpp0x/nsdmi-template12.C: Likewise.
+ * g++.dg/cpp0x/nsdmi-template13.C: Likewise.
+
+2014-06-28 Edward Smith-Rowland <3dw4rd@verizon.net>
+
+ PR c++/58781
+ PR c++/60249
+ PR c++/59867
+ * testsuite/g++.dg/cpp0x/pr58781.C: New.
+ * testsuite/g++.dg/cpp0x/pr60249.C: New.
+ * testsuite/g++.dg/cpp1y/pr59867.C: New.
+
+2014-06-30 Bill Schmidt <wschmidt@linux.vnet.ibm.com>
+
+ * gfortran.dg/round_4.f90: Skip for powerpc*-*-linux* since the
+ test requires greater precision than the current PowerPC long
+ double implementation supports.
+
+2014-06-30 Jakub Jelinek <jakub@redhat.com>
+
+ Backported from mainline
+ 2014-06-27 Jakub Jelinek <jakub@redhat.com>
+
+ PR tree-optimization/57233
+ PR tree-optimization/61299
+ * gcc.dg/pr57233.c: New test.
+ * gcc.target/i386/pr57233.c: New test.
+ * gcc.target/i386/sse2-pr57233.c: New test.
+ * gcc.target/i386/avx-pr57233.c: New test.
+ * gcc.target/i386/avx2-pr57233.c: New test.
+ * gcc.target/i386/avx512f-pr57233.c: New test.
+ * gcc.target/i386/xop-pr57233.c: New test.
+
+ 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.
+
+2014-06-30 Sebastian Huber <sebastian.huber@embedded-brains.de>
+
+ * gcc.dg/typeof-2.c: New testcase.
+
+2014-06-30 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
+
+ * gcc.target/aarch64/vqdmulhh_lane_s16.c: New test.
+ * gcc.target/aarch64/vqdmulhs_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqrdmulhh_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqrdmulhs_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlal_high_lane_s16.c: New test.
+ * gcc.target/aarch64/vqdmlal_high_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlal_high_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlal_high_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlal_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlal_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlal_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlal_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlalh_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlals_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlsl_high_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlsl_high_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlsl_high_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlsl_high_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlsl_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlsl_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlsl_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmlslh_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmlsls_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmulh_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmulh_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmulhq_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmulhq_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmull_high_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmull_high_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmull_high_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmull_high_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmull_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmull_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmull_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmull_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqdmullh_lane_s16.c: Likewise.
+ * gcc.target/aarch64/vqdmulls_lane_s32.c: Likewise.
+ * gcc.target/aarch64/vqrdmulh_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqrdmulh_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vqrdmulhq_laneq_s16.c: Likewise.
+ * gcc.target/aarch64/vqrdmulhq_laneq_s32.c: Likewise.
+ * gcc.target/aarch64/vector_intrinsics.c: Simplify arm_neon.h include.
+ (test_vqdmlal_high_lane_s16): Fix parameter type.
+ (test_vqdmlal_high_lane_s32): Likewise.
+ (test_vqdmull_high_lane_s16): Likewise.
+ (test_vqdmull_high_lane_s32): Likewise.
+ (test_vqdmlsl_high_lane_s32): Likewise.
+ (test_vqdmlsl_high_lane_s16): Likewise.
+ * gcc.target/aarch64/scalar_intrinsics.c (test_vqdmlalh_lane_s16):
+ Fix argument type.
+ (test_vqdmlals_lane_s32): Likewise.
+ (test_vqdmlslh_lane_s16): Likewise.
+ (test_vqdmlsls_lane_s32): Likewise.
+ (test_vqdmulhh_lane_s16): Likewise.
+ (test_vqdmulhs_lane_s32): Likewise.
+ (test_vqdmullh_lane_s16): Likewise.
+ (test_vqdmulls_lane_s32): Likewise.
+ (test_vqrdmulhh_lane_s16): Likewise.
+ (test_vqrdmulhs_lane_s32): Likewise.
+
+2014-06-30 Igor Zamyatin <igor.zamyatin@intel.com>
+
+ PR middle-end/57541
+ * c-c++-common/cilk-plus/AN/pr57541.c: New case added.
+ * c-c++-common/cilk-plus/AN/pr57541-2.c: New test.
+
+2014-06-30 Thomas Preud'homme <thomas.preudhomme@arm.com>
+
+ Backport from mainline
+ 2014-06-11 Thomas Preud'homme <thomas.preudhomme@arm.com>
+
+ PR tree-optimization/61306
+ * gcc.c-torture/execute/pr61306-1.c: New test.
+ * gcc.c-torture/execute/pr61306-2.c: Likewise.
+ * gcc.c-torture/execute/pr61306-3.c: Likewise.
+
+2014-06-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ Backport from mainline.
+ PR libgfortran/61499
+ * gfortran.dg/arrayio_15.f90: New test.
+
+2014-06-27 Bill Schmidt <wschmidt@linux.vnet.ibm.com>
+
+ * gfortran.dg/nint_2.f90: Don't XFAIL for powerpc64le-*-linux*.
+
+2014-06-27 Paolo Carlini <paolo.carlini@oracle.com>
+
+ PR c++/61614
+ * g++.dg/ext/complit14.C: New.
+
+2014-06-27 Martin Jambor <mjambor@suse.cz>
+
+ PR ipa/61160
+ * g++.dg/ipa/pr61160-2.C: New test.
+ * g++.dg/ipa/pr61160-3.C: Likewise.
+
+2014-06-27 Uros Bizjak <ubizjak@gmail.com>
+
+ Backport from mainline
+ 2014-06-26 Uros Bizjak <ubizjak@gmail.com>
+
+ PR target/61586
+ * gcc.target/alpha/pr61586.c: New test.
+
+2014-06-26 Adam Butcher <adam@jessamine.co.uk>
+
+ PR c++/61537
+ * g++.dg/template/pr61537.C: New testcase.
+
+2014-06-26 Martin Jambor <mjambor@suse.cz>
+
+ * g++.dg/ipa/pr60600.C: Fix typo.
+ * g++.dg/ipa/devirt-25.C: Likewise.
+ * g++.dg/ipa/pr61540.C: Likewise.
+
+2014-06-26 Martin Jambor <mjambor@suse.cz>
+
+ * g++.dg/ipa/pr61540.C: Remove dumping test.
+
+2014-06-25 Bill Schmidt <wschmidt@linux.vnet.ibm.com>
+
+ * gfortran.dg/default_format_denormal_2.f90: Remove xfail for
+ powerpc*-*-linux*.
+
2014-06-23 Alan Modra <amodra@gmail.com>
* gcc.dg/pr61583.c: New.
2014-06-20 Martin Jambor <mjambor@suse.cz>
PR ipa/61540
- * g++.dg/ipa/pr61540.C: New test.
+ * g++.dg/ipa/pr61540.C: New test.
2014-06-17 Yufeng Zhang <yufeng.zhang@arm.com>
--- /dev/null
+/* PR middle-end/57541 */
+/* { dg-do compile } */
+/* { dg-options "-fcilkplus" } */
+
+int foo1 ()
+{
+ int a;
+ a = __sec_reduce_add (1); /* { dg-error "Invalid builtin arguments" } */
+}
+
+int foo2 ()
+{
+ int a;
+ a = __sec_reduce_add (); /* { dg-error "Invalid builtin arguments" } */
+}
+/* PR middle-end/57541 */
/* { dg-do compile } */
/* { dg-options "-fcilkplus" } */
int A[10];
-int main () {
+int foo () {
/* C compiler uses the term "undeclared" whereas C++ compiler uses
"not declared". Thus, grepping for declared seem to be the easiest. */
A[l:s:c];
}
-/* { dg-message "note: each" "defined" { target c } 10 } */
+int foo1 (int N) {
+
+ char c = (char)N;
+ short s = (short)N;
+ A[l:s:c]; /* { dg-error "declared" } */
+}
+
+
+/* { dg-message "note: each" "defined" { target c } 11 } */
--- /dev/null
+// PR c++/61242
+// { dg-do compile { target c++11 } }
+
+struct Foo
+{
+ struct A
+ {
+ const int &container;
+ const int &args;
+ };
+ static void Create (const A &);
+};
+
+int main ()
+{
+ Foo::Create ({{}, {}});
+}
--- /dev/null
+// PR c++/61382
+// { dg-do run { target c++11 } }
+
+struct A
+{
+ int i,j;
+ A(int i,int j):i(i),j(j){}
+};
+
+extern "C" int printf (const char *, ...);
+
+int main()
+{
+ int i = 0;
+ A a{i++,i++};
+ if (a.i != 0 || a.j != 1)
+ __builtin_abort();
+}
--- /dev/null
+// PR c++/61566
+// { dg-do compile { target c++11 } }
+
+struct function
+{
+ template < typename _Functor>
+ function (_Functor);
+};
+
+struct C
+{
+ template <typename T>
+ void foo (T, function = [] {});
+};
+
+void bar ()
+{
+ C c;
+ c.foo (1);
+}
--- /dev/null
+// PR c++/58930
+// { dg-do compile { target c++11 } }
+
+struct SampleModule
+{
+ explicit SampleModule (int);
+};
+
+template < typename >
+struct BaseHandler
+{
+ SampleModule module_ { 0 };
+};
+
+BaseHandler<int> a;
--- /dev/null
+// PR c++/58753
+// { dg-do compile { target c++11 } }
+
+#include <initializer_list>
+
+template <class T>
+struct X {X(std::initializer_list<int>) {}};
+
+template <class zomg>
+class T {
+ X<T> x{1};
+};
+
+int main()
+{
+ T<int> t;
+}
--- /dev/null
+// PR c++/58704
+// { dg-do compile { target c++11 } }
+
+struct A {};
+
+template<typename> struct B
+{
+ A a[1] = { };
+};
+
+B<int> b;
--- /dev/null
+// { dg-do compile { target c++11 } }
+
+#define BAZ "baz"
+
+#if 0
+
+"bar"BAZ
+
+R"(
+ bar
+)"BAZ
+
+#endif
--- /dev/null
+// PR c++/58781
+// { dg-do compile { target c++11 } }
+
+#include <cstddef>
+
+int
+operator""_s(const char32_t *a, size_t b)
+{
+ return 0;
+}
+
+int
+f()
+{
+ using a = decltype(U"\x1181"_s);
+ using b = decltype(U"\x8111"_s);
+ using c = decltype(U" \x1181"_s);
+}
--- /dev/null
+// PR c++/60249
+// { dg-do compile { target c++11 } }
+
+decltype(""_) x; // { dg-error "unable to find string literal operator" }
+
+// { dg-error "invalid type in declaration before" "invalid" { target *-*-* } 4 }
--- /dev/null
+// PR c++/61539
+// { dg-do compile { target c++11 } }
+
+template <typename _CharT> class A;
+template <typename> class B;
+template <class charT> class C;
+template <> class C<char>
+{
+ virtual void xparse (int &, const B<A<char> > &) const;
+};
+template <class T, class charT = char> class G : C<charT>
+{
+public:
+ G (void *) {}
+ void default_value (const T &);
+ void xparse (int &, const B<A<charT> > &) const;
+};
+template <class T, class charT>
+void validate (int &, const B<A<charT> > &, T *, int);
+template <class T, class charT>
+void G<T, charT>::xparse (int &p1, const B<A<charT> > &p2) const
+{
+ validate (p1, p2, (T *)0, 0);
+}
+template <class T> G<T> *value (T *) { return new G<T>(0); }
+namespace Eigen
+{
+template <typename T> struct D;
+template <typename, int, int, int = 0, int = 0, int = 0 > class F;
+template <typename _Scalar, int _Rows, int _Cols, int _Options, int _MaxRows,
+ int _MaxCols>
+struct D<F<_Scalar, _Rows, _Cols, _Options, _MaxRows, _MaxCols> >
+{
+ typedef _Scalar Scalar;
+};
+template <typename, int, int, int, int, int _MaxCols> class F
+{
+public:
+ typedef typename Eigen::D<F>::Scalar Scalar;
+ F (const Scalar &, const Scalar &, const Scalar &);
+};
+template <class... T>
+void validate (int &, const B<A<char> > &, Eigen::F<T...> *);
+}
+int main (int, char *[])
+{
+ Eigen::F<double, 3, 1> a (0, 0, 0);
+ value (&a)->default_value (Eigen::F<double, 3, 1>(0, 0, 0));
+}
--- /dev/null
+// PR c++/59867
+// { dg-do compile { target c++1y } }
+
+#include <iostream>
+using namespace std;
+
+// constant
+template<typename T, T x>
+ struct meta_value
+ {
+ typedef meta_value type;
+ typedef T value_type;
+ static const T value = x;
+ };
+
+// array
+template<typename T, T... data>
+ struct meta_array
+ {
+ typedef meta_array type;
+ typedef T item_type;
+ };
+
+// static array -> runtime array conversion utility
+template<typename T>
+ struct array_gen;
+
+template<typename T, T... xs>
+ struct array_gen<meta_array<T, xs...>>
+ {
+ static const T value[sizeof...(xs)];
+ };
+
+template<typename T, T... xs>
+ const T
+ array_gen<meta_array<T, xs...>>::value[sizeof...(xs)] = {xs...};
+
+// static string
+template<typename T, T... xs>
+ constexpr meta_array<T, xs...>
+ operator""_s()
+ {
+ static_assert(sizeof...(xs) == 3, "What's wrong with you?");
+ return meta_array<T, xs...>();
+ }
+
+int
+main()
+{
+ auto a = "123"_s;
+ const char (& xs)[3] = array_gen<decltype("123"_s)>::value;
+}
--- /dev/null
+// PR c++/61433
+// { dg-do compile { target c++11 } }
+// { dg-options "-O -fcompare-debug -fno-inline -fno-ipa-pure-const -fipa-sra" }
+
+template <class T>
+struct A
+{
+ template <class V>
+ struct B
+ {
+ int MEM;
+ };
+};
+struct D {};
+struct C: public A<int>::B<D>
+{};
+template <class T, class U, class V>
+auto k(T t, U u, V v) -> decltype (t.U::template B<V>::MEM)
+{}
+int main()
+{
+ k( C(), A<int>(), D() );
+}
--- /dev/null
+// PR c++/61614
+// { dg-options "" }
+
+int Fn (...);
+
+void
+Test ()
+{
+ int j = Fn ((const int[]) { 0 }); // OK
+ unsigned long sz = sizeof Fn ((const int[]) { 0 }); // Error
+}
dpr_Job jobL;
dpr_run(jobL);
}
-/* { dg-final { scan-ipa-dump "Type inconsident devirtualization" "cp" } } */
+/* { dg-final { scan-ipa-dump "Type inconsistent devirtualization" "cp" } } */
/* { dg-final { cleanup-ipa-dump "cp" } } */
test(d);
}
-/* { dg-final { scan-ipa-dump "Type inconsident devirtualization" "cp" } } */
+/* { dg-final { scan-ipa-dump "Type inconsistent devirtualization" "cp" } } */
/* { dg-final { cleanup-ipa-dump "cp" } } */
--- /dev/null
+/* { dg-do run } */
+/* { dg-options "-O3 --param ipa-cp-eval-threshold=1" } */
+
+extern "C" void abort (void);
+
+struct CBase {
+ virtual void BaseFunc () {}
+};
+
+struct MMixin {
+ virtual void * MixinFunc (int, void *) = 0;
+};
+
+struct CExample: CBase, public MMixin
+{
+ int stuff, magic, more_stuff;
+
+ CExample ()
+ {
+ stuff = 0;
+ magic = 0xbeef;
+ more_stuff = 0;
+ }
+ void *MixinFunc (int arg, void *arg2)
+ {
+ if (arg != 1 || arg2)
+ return 0;
+ if (magic != 0xbeef)
+ abort();
+ return this;
+ }
+};
+
+void *test (MMixin & anExample)
+{
+ return anExample.MixinFunc (1, 0);
+}
+
+int main ()
+{
+ CExample c;
+ return (test (c) != &c);
+}
--- /dev/null
+/* { dg-do run } */
+/* { dg-options "-O3" } */
+
+struct A {
+ void *p;
+ A (void *q) : p (q) {}
+ A (const A &) : p () {}
+};
+
+struct CBase {
+ virtual void BaseFunc () {}
+};
+
+struct MMixin {
+ virtual A MixinFunc (int, A) = 0;
+};
+
+struct CExample: CBase, public MMixin
+{
+ A MixinFunc (int arg, A arg2)
+ {
+ if (arg != 1 || arg2.p)
+ return 0;
+ return this;
+ }
+};
+
+void *test (MMixin & anExample)
+{
+ return anExample.MixinFunc (1, (0)).p;
+}
+
+int main ()
+{
+ CExample c;
+ return (test (c) != &c);
+}
/* { dg-do compile } */
-/* { dg-options "-O3 -fno-early-inlining -fdump-ipa-cp" } */
+/* { dg-options "-O3 -fno-early-inlining" } */
struct data {
data(int) {}
test (c);
return 0;
}
-
-/* { dg-final { scan-ipa-dump "Type inconsident devirtualization" "cp" } } */
-/* { dg-final { cleanup-ipa-dump "cp" } } */
--- /dev/null
+// PR middle-end/61654
+// { dg-do compile }
+
+class A
+{
+ virtual int a (int, int = 0) = 0;
+ int b (const int &);
+ int c;
+};
+
+class B : virtual A
+{
+ int d;
+ int a (int, int);
+};
+
+int
+A::b (const int &)
+{
+ return a ('\0');
+}
+
+int
+B::a (int, int)
+{
+ return 0 ? 0 : d;
+}
--- /dev/null
+// PR c++/61647
+
+class XX;
+
+template<typename Container, typename Key>
+struct Accessor;
+
+template<typename Container, typename Key, typename KeyStore = Key>
+class Variant {
+protected:
+ KeyStore index;
+ Container state;
+public:
+ Variant(Container st, const Key& i) : index(i), state(st) {}
+
+ template<typename T>
+ operator T() const {
+ return Accessor<Container, KeyStore>::template get<T>(state, index);
+ }
+};
+
+class AutoCleanVariant : public Variant<XX*, int> {
+public:
+ AutoCleanVariant(XX* st, int i) : Variant<XX*,int>(st,i) {}
+
+ template<typename T>
+ operator T() const {
+ return Variant<XX*, int>::operator T();
+ }
+};
--- /dev/null
+// PR c++/61537
+// { dg-do compile }
+
+struct A {};
+
+template <typename T>
+struct B
+{
+ template <typename U>
+ void f(U, struct A);
+};
+
+template <typename T>
+template <typename U>
+void B<T>::f(U, struct A)
+{
+}
+
+int main()
+{
+ B<char> b;
+ b.f(42, A());
+}
--- /dev/null
+// PR c++/61500
+
+struct X {
+ int i;
+ int j;
+
+ int foo(int X::* ptr);
+
+ template <int X::* ptr>
+ int bar();
+};
+
+int X::foo(int X::* ptr) {
+ int* p = &(this->*ptr); // OK.
+ return *p;
+}
+
+template <int X::* ptr>
+int X::bar() {
+ int* p = &(this->*ptr); // gcc 4.9.0: OK in C++98 mode, fails in C++11 mode.
+ return *p;
+}
--- /dev/null
+// PR c++/61488
+
+struct A {
+ typedef int (A::*cont_func)();
+ template <A::cont_func> void wait(int);
+ int notify();
+
+ void fix() { wait<&A::notify>(0); } // OK
+ template <int> void repair() { wait<&A::notify>(0); }
+};
--- /dev/null
+/* PR tree-optimization/61684 */
+
+int a, c;
+static int *b = 0;
+short d;
+static short **e = 0;
+
+void
+foo ()
+{
+ for (; c < 1; c++)
+ ;
+ *e = &d;
+ a = d && (c && 1) & *b;
+}
--- /dev/null
+#ifdef __INT32_TYPE__
+typedef __INT32_TYPE__ int32_t;
+#else
+typedef int int32_t;
+#endif
+
+#ifdef __UINT32_TYPE__
+typedef __UINT32_TYPE__ uint32_t;
+#else
+typedef unsigned uint32_t;
+#endif
+
+#define __fake_const_swab32(x) ((uint32_t)( \
+ (((uint32_t)(x) & (uint32_t)0x000000ffUL) << 24) | \
+ (((uint32_t)(x) & (uint32_t)0x0000ff00UL) << 8) | \
+ (((uint32_t)(x) & (uint32_t)0x00ff0000UL) >> 8) | \
+ (( (int32_t)(x) & (int32_t)0xff000000UL) >> 24)))
+
+/* Previous version of bswap optimization failed to consider sign extension
+ and as a result would replace an expression *not* doing a bswap by a
+ bswap. */
+
+__attribute__ ((noinline, noclone)) uint32_t
+fake_bswap32 (uint32_t in)
+{
+ return __fake_const_swab32 (in);
+}
+
+int
+main(void)
+{
+ if (sizeof (int32_t) * __CHAR_BIT__ != 32)
+ return 0;
+ if (sizeof (uint32_t) * __CHAR_BIT__ != 32)
+ return 0;
+ if (fake_bswap32 (0x87654321) != 0xffffff87)
+ __builtin_abort ();
+ return 0;
+}
--- /dev/null
+#ifdef __INT16_TYPE__
+typedef __INT16_TYPE__ int16_t;
+#else
+typedef short int16_t;
+#endif
+
+#ifdef __UINT32_TYPE__
+typedef __UINT32_TYPE__ uint32_t;
+#else
+typedef unsigned uint32_t;
+#endif
+
+#define __fake_const_swab32(x) ((uint32_t)( \
+ (((uint32_t) (x) & (uint32_t)0x000000ffUL) << 24) | \
+ (((uint32_t)(int16_t)(x) & (uint32_t)0x00ffff00UL) << 8) | \
+ (((uint32_t) (x) & (uint32_t)0x00ff0000UL) >> 8) | \
+ (((uint32_t) (x) & (uint32_t)0xff000000UL) >> 24)))
+
+
+/* Previous version of bswap optimization failed to consider sign extension
+ and as a result would replace an expression *not* doing a bswap by a
+ bswap. */
+
+__attribute__ ((noinline, noclone)) uint32_t
+fake_bswap32 (uint32_t in)
+{
+ return __fake_const_swab32 (in);
+}
+
+int
+main(void)
+{
+ if (sizeof (uint32_t) * __CHAR_BIT__ != 32)
+ return 0;
+ if (sizeof (int16_t) * __CHAR_BIT__ != 16)
+ return 0;
+ if (fake_bswap32 (0x81828384) != 0xff838281)
+ __builtin_abort ();
+ return 0;
+}
--- /dev/null
+short a = -1;
+int b;
+char c;
+
+int
+main ()
+{
+ c = a;
+ b = a | c;
+ if (b != -1)
+ __builtin_abort ();
+ return 0;
+}
--- /dev/null
+/* PR rtl-optimization/61673 */
+
+char e;
+
+__attribute__((noinline, noclone)) void
+bar (char x)
+{
+ if (x != 0x54 && x != (char) 0x87)
+ __builtin_abort ();
+}
+
+__attribute__((noinline, noclone)) void
+foo (const char *x)
+{
+ char d = x[0];
+ int c = d;
+ if ((c >= 0 && c <= 0x7f) == 0)
+ e = d;
+ bar (d);
+}
+
+__attribute__((noinline, noclone)) void
+baz (const char *x)
+{
+ char d = x[0];
+ int c = d;
+ if ((c >= 0 && c <= 0x7f) == 0)
+ e = d;
+}
+
+int
+main ()
+{
+ const char c[] = { 0x54, 0x87 };
+ e = 0x21;
+ foo (c);
+ if (e != 0x21)
+ __builtin_abort ();
+ foo (c + 1);
+ if (e != (char) 0x87)
+ __builtin_abort ();
+ e = 0x21;
+ baz (c);
+ if (e != 0x21)
+ __builtin_abort ();
+ baz (c + 1);
+ if (e != (char) 0x87)
+ __builtin_abort ();
+ return 0;
+}
--- /dev/null
+/* PR tree-optimization/61725 */
+
+int
+main ()
+{
+ int x;
+ for (x = -128; x <= 128; x++)
+ {
+ int a = __builtin_ffs (x);
+ if (x == 0 && a != 0)
+ __builtin_abort ();
+ }
+ return 0;
+}
--- /dev/null
+/* PR tree-optimization/57233 */
+/* { dg-do run { target { ilp32 || lp64 } } } */
+/* { dg-options "-O2" } */
+
+typedef unsigned V4 __attribute__((vector_size(4 * sizeof (int))));
+typedef unsigned V8 __attribute__((vector_size(8 * sizeof (int))));
+typedef unsigned V16 __attribute__((vector_size(16 * sizeof (int))));
+V4 a, b, g;
+V8 c, d, h;
+V16 e, f, j;
+
+__attribute__((noinline)) void
+f1 (void)
+{
+ a = (a << 2) | (a >> 30);
+}
+
+__attribute__((noinline)) void
+f2 (void)
+{
+ a = (a << 30) | (a >> 2);
+}
+
+__attribute__((noinline)) void
+f3 (void)
+{
+ a = (a << b) | (a >> (32 - b));
+}
+
+__attribute__((noinline, noclone)) void
+f4 (int x)
+{
+ a = (a << x) | (a >> (32 - x));
+}
+
+__attribute__((noinline)) void
+f5 (void)
+{
+ c = (c << 2) | (c >> 30);
+}
+
+__attribute__((noinline)) void
+f6 (void)
+{
+ c = (c << 30) | (c >> 2);
+}
+
+__attribute__((noinline)) void
+f7 (void)
+{
+ c = (c << d) | (c >> (32 - d));
+}
+
+__attribute__((noinline, noclone)) void
+f8 (int x)
+{
+ c = (c << x) | (c >> (32 - x));
+}
+
+__attribute__((noinline)) void
+f9 (void)
+{
+ e = (e << 2) | (e >> 30);
+}
+
+__attribute__((noinline)) void
+f10 (void)
+{
+ e = (e << 30) | (e >> 2);
+}
+
+__attribute__((noinline)) void
+f11 (void)
+{
+ e = (e << f) | (e >> (32 - f));
+}
+
+__attribute__((noinline, noclone)) void
+f12 (int x)
+{
+ e = (e << x) | (e >> (32 - x));
+}
+
+unsigned
+r (void)
+{
+ static unsigned x = 0xdeadbeefU;
+ static unsigned y = 0x12347654U;
+ static unsigned z = 0x1a2b3c4dU;
+ static unsigned w = 0x87654321U;
+ unsigned t = x ^ (x << 11);
+ x = y;
+ y = z;
+ z = w;
+ w = w ^ (w >> 19) ^ t ^ (t >> 8);
+ return w;
+}
+
+void
+init (unsigned int *p, int count, int mod)
+{
+ int i;
+ for (i = 0; i < count; i++)
+ {
+ unsigned int v = r ();
+ if (mod)
+ v = (v % 31) + 1;
+ p[i] = v;
+ }
+}
+
+void
+check (unsigned int *p, unsigned int *q, int count, unsigned int *s, int ss)
+{
+ int i;
+ for (i = 0; i < count; i++)
+ {
+ if (s)
+ ss = s[i];
+ if (p[i] != ((q[i] << ss) | (q[i] >> (32 - ss))))
+ __builtin_abort ();
+ }
+}
+
+int
+main ()
+{
+ init ((unsigned int *) &a, 4, 0);
+ init ((unsigned int *) &b, 4, 1);
+ init ((unsigned int *) &c, 8, 0);
+ init ((unsigned int *) &d, 8, 1);
+ init ((unsigned int *) &e, 16, 0);
+ init ((unsigned int *) &f, 16, 1);
+ g = a;
+ h = c;
+ j = e;
+ f1 ();
+ f5 ();
+ f9 ();
+ check ((unsigned int *) &a, (unsigned int *) &g, 4, 0, 2);
+ check ((unsigned int *) &c, (unsigned int *) &h, 8, 0, 2);
+ check ((unsigned int *) &e, (unsigned int *) &j, 16, 0, 2);
+ g = a;
+ h = c;
+ j = e;
+ f2 ();
+ f6 ();
+ f10 ();
+ check ((unsigned int *) &a, (unsigned int *) &g, 4, 0, 30);
+ check ((unsigned int *) &c, (unsigned int *) &h, 8, 0, 30);
+ check ((unsigned int *) &e, (unsigned int *) &j, 16, 0, 30);
+ g = a;
+ h = c;
+ j = e;
+ f3 ();
+ f7 ();
+ f11 ();
+ check ((unsigned int *) &a, (unsigned int *) &g, 4, (unsigned int *) &b, 0);
+ check ((unsigned int *) &c, (unsigned int *) &h, 8, (unsigned int *) &d, 0);
+ check ((unsigned int *) &e, (unsigned int *) &j, 16, (unsigned int *) &f, 0);
+ g = a;
+ h = c;
+ j = e;
+ f4 (5);
+ f8 (5);
+ f12 (5);
+ check ((unsigned int *) &a, (unsigned int *) &g, 4, 0, 5);
+ check ((unsigned int *) &c, (unsigned int *) &h, 8, 0, 5);
+ check ((unsigned int *) &e, (unsigned int *) &j, 16, 0, 5);
+ return 0;
+}
--- /dev/null
+/* { dg-do run } */
+
+extern void abort (void);
+
+int a = 1, *e = &a, **f = &e, *l, *p, j;
+static int b;
+long d;
+short g;
+
+void
+fn1 (int *p)
+{
+ int m;
+ if (!(*p & j))
+ {
+ int *n = &m;
+ for (d = 6; d; d--)
+ {
+ for (g = 0; g < 1; g++)
+ {
+ n = l = *f;
+ b = *p;
+ }
+ *n = 0;
+ }
+ }
+}
+
+int
+main ()
+{
+ p = *f;
+ fn1 (p);
+ if (b != 0)
+ abort ();
+ return 0;
+}
--- /dev/null
+/* PR target/29776 */
+/* PR tree-optimization/61725 */
+/* { dg-do compile } */
+/* { dg-options "-O2 -fdump-tree-vrp1" } */
+/* { dg-final { scan-tree-dump-not "link_error" "vrp1"} } */
+/* { dg-final { cleanup-tree-dump "vrp1" } } */
+
+#define A(fn, arg, min, max) \
+ if (__builtin_##fn (arg) < min || __builtin_##fn (arg) > max) \
+ link_error ();
+#define B(fn, min, max) \
+ A (fn, a, min, max) A (fn##l, b, min, max) A (fn##ll, c, min, max)
+#define C(fn, min, sub) \
+ A (fn, a, min, ((int) sizeof (a) * __CHAR_BIT__ - sub)) \
+ A (fn##l, b, min, ((int) sizeof (b) * __CHAR_BIT__ - sub)) \
+ A (fn##ll, c, min, ((int) sizeof (c) * __CHAR_BIT__ - sub))
+
+extern void link_error (void);
+
+unsigned int d;
+unsigned long e;
+unsigned long long f;
+
+void
+foo (int a, long b, long long c)
+{
+ C (ffs, 0, 0)
+ a &= 63; b &= 63; c &= 63;
+ B (ffs, 0, 6)
+ a++; b++; c++;
+ B (ffs, 1, 7)
+ a -= 2; b -= 2; c -= 2;
+ C (ffs, 0, 0)
+ a -= 63; b -= 63; c -= 63;
+ C (ffs, 1, 0)
+}
--- /dev/null
+/* Test qualifier discard of typeof for atomic types. */
+/* { dg-do compile } */
+/* { dg-options "-std=c11" } */
+
+extern int i;
+
+extern int * p;
+
+extern int _Atomic const ci;
+extern __typeof (ci) i;
+
+extern int _Atomic volatile vi;
+extern __typeof (vi) i;
+
+extern int * _Atomic restrict ri;
+extern __typeof (ri) p;
+
+void f(void)
+{
+ __auto_type aci = ci;
+ int *paci = &aci;
+
+ __auto_type avi = vi;
+ int *pavi = &avi;
+
+ __auto_type ari = ri;
+ int **pari = &ari;
+}
--- /dev/null
+/* { dg-do run } */
+
+#include "tree-vect.h"
+
+double v[4096][4];
+
+__attribute__((noinline, noclone)) void
+bar (double p[][4])
+{
+ int i;
+ double d = 172.0;
+ for (i = 0; i < 4096; i++)
+ {
+ if (p[i][0] != 6.0 || p[i][1] != 6.0 || p[i][2] != 10.0)
+ __builtin_abort ();
+ if (__builtin_fabs (p[i][3] - d) > 0.25)
+ __builtin_abort ();
+ }
+}
+
+__attribute__((noinline, noclone)) void
+foo (void)
+{
+ int i;
+ double w[4096][4], t;
+ for (i = 0; i < 4096; i++)
+ {
+ w[i][0] = v[i][0] + 2.0;
+ w[i][1] = v[i][1] + 1.0;
+ w[i][2] = v[i][2] + 4.0;
+ w[i][3] = (w[i][0] * w[i][0] + w[i][1] * w[i][1] + w[i][2] * w[i][2]);
+ }
+ bar (w);
+}
+
+int
+main ()
+{
+ int i;
+
+ check_vect ();
+
+ for (i = 0; i < 4096; i++)
+ {
+ v[i][0] = 4.0;
+ v[i][1] = 5.0;
+ v[i][2] = 6.0;
+ }
+ foo ();
+ return 0;
+}
--- /dev/null
+/* PR target/59843 ICE on function taking/returning vector of one float64_t. */
+
+/* { dg-do compile } */
+/* { dg-options "-Warray-bounds -O2 -fno-inline -std=c99" } */
+
+#define TEST(BASETYPE, VECTYPE, SUFFIX) \
+ typedef BASETYPE VECTYPE \
+ __attribute__ ((__vector_size__ (sizeof (BASETYPE)))); \
+ VECTYPE \
+ test_vadd_##SUFFIX (VECTYPE a, VECTYPE b) \
+ { \
+ return a + b; \
+ } \
+ \
+ void \
+ test_##SUFFIX (BASETYPE val) \
+ { \
+ VECTYPE var = { val }; \
+ BASETYPE v0 = var[0]; \
+ BASETYPE v1 = var[1]; /* { dg-warning "index value is out of bound" } */ \
+ }
+
+TEST (double, float64x1_t, f64)
+
+/* Original bug was for above type;
+ in a nod to completeness, test other types too. */
+
+TEST (long long, int64x1_t, s64)
+
+TEST (float, float32x1_t, f32)
+
+TEST (long, longx1_t, l)
+
+TEST (int, intx1_t, i)
+
+TEST (short, int16x1_t, s16)
+
+TEST (char, int8x1_t, s8)
/* { dg-final { scan-assembler-times "\\tsqdmlal\\ts\[0-9\]+, h\[0-9\]+, v" 1 } } */
int32x1_t
-test_vqdmlalh_lane_s16 (int32x1_t a, int16x1_t b, int16x8_t c)
+test_vqdmlalh_lane_s16 (int32x1_t a, int16x1_t b, int16x4_t c)
{
return vqdmlalh_lane_s16 (a, b, c, 3);
}
/* { dg-final { scan-assembler-times "\\tsqdmlal\\td\[0-9\]+, s\[0-9\]+, v" 1 } } */
int64x1_t
-test_vqdmlals_lane_s32 (int64x1_t a, int32x1_t b, int32x4_t c)
+test_vqdmlals_lane_s32 (int64x1_t a, int32x1_t b, int32x2_t c)
{
return vqdmlals_lane_s32 (a, b, c, 1);
}
/* { dg-final { scan-assembler-times "\\tsqdmlsl\\ts\[0-9\]+, h\[0-9\]+, v" 1 } } */
int32x1_t
-test_vqdmlslh_lane_s16 (int32x1_t a, int16x1_t b, int16x8_t c)
+test_vqdmlslh_lane_s16 (int32x1_t a, int16x1_t b, int16x4_t c)
{
return vqdmlslh_lane_s16 (a, b, c, 3);
}
/* { dg-final { scan-assembler-times "\\tsqdmlsl\\td\[0-9\]+, s\[0-9\]+, v" 1 } } */
int64x1_t
-test_vqdmlsls_lane_s32 (int64x1_t a, int32x1_t b, int32x4_t c)
+test_vqdmlsls_lane_s32 (int64x1_t a, int32x1_t b, int32x2_t c)
{
return vqdmlsls_lane_s32 (a, b, c, 1);
}
/* { dg-final { scan-assembler-times "\\tsqdmulh\\th\[0-9\]+, h\[0-9\]+, v" 1 } } */
int16x1_t
-test_vqdmulhh_lane_s16 (int16x1_t a, int16x8_t b)
+test_vqdmulhh_lane_s16 (int16x1_t a, int16x4_t b)
{
return vqdmulhh_lane_s16 (a, b, 3);
}
/* { dg-final { scan-assembler-times "\\tsqdmulh\\ts\[0-9\]+, s\[0-9\]+, v" 1 } } */
int32x1_t
-test_vqdmulhs_lane_s32 (int32x1_t a, int32x4_t b)
+test_vqdmulhs_lane_s32 (int32x1_t a, int32x2_t b)
{
- return vqdmulhs_lane_s32 (a, b, 3);
+ return vqdmulhs_lane_s32 (a, b, 1);
}
/* { dg-final { scan-assembler-times "\\tsqdmull\\ts\[0-9\]+, h\[0-9\]+, h\[0-9\]+" 1 } } */
/* { dg-final { scan-assembler-times "\\tsqdmull\\ts\[0-9\]+, h\[0-9\]+, v" 1 } } */
int32x1_t
-test_vqdmullh_lane_s16 (int16x1_t a, int16x8_t b)
+test_vqdmullh_lane_s16 (int16x1_t a, int16x4_t b)
{
return vqdmullh_lane_s16 (a, b, 3);
}
/* { dg-final { scan-assembler-times "\\tsqdmull\\td\[0-9\]+, s\[0-9\]+, v" 1 } } */
int64x1_t
-test_vqdmulls_lane_s32 (int32x1_t a, int32x4_t b)
+test_vqdmulls_lane_s32 (int32x1_t a, int32x2_t b)
{
return vqdmulls_lane_s32 (a, b, 1);
}
/* { dg-final { scan-assembler-times "\\tsqrdmulh\\th\[0-9\]+, h\[0-9\]+, v" 1 } } */
int16x1_t
-test_vqrdmulhh_lane_s16 (int16x1_t a, int16x8_t b)
+test_vqrdmulhh_lane_s16 (int16x1_t a, int16x4_t b)
{
- return vqrdmulhh_lane_s16 (a, b, 6);
+ return vqrdmulhh_lane_s16 (a, b, 3);
}
/* { dg-final { scan-assembler-times "\\tsqrdmulh\\ts\[0-9\]+, s\[0-9\]+, s\[0-9\]+" 1 } } */
/* { dg-final { scan-assembler-times "\\tsqrdmulh\\ts\[0-9\]+, s\[0-9\]+, v" 1 } } */
int32x1_t
-test_vqrdmulhs_lane_s32 (int32x1_t a, int32x4_t b)
+test_vqrdmulhs_lane_s32 (int32x1_t a, int32x2_t b)
{
- return vqrdmulhs_lane_s32 (a, b, 2);
+ return vqrdmulhs_lane_s32 (a, b, 1);
}
/* { dg-final { scan-assembler-times "\\tsuqadd\\tb\[0-9\]+" 1 } } */
/* { dg-do compile } */
/* { dg-options "-O2" } */
-#include "../../../config/aarch64/arm_neon.h"
+#include "arm_neon.h"
/* { dg-final { scan-assembler-times "\\tfmax\\tv\[0-9\]+\.2s, v\[0-9\].2s, v\[0-9\].2s" 1 } } */
/* { dg-final { scan-assembler-times "\\tsqdmlal2\\tv\[0-9\]+\.4s, v\[0-9\]+\.8h, v\[0-9\]+\.h" 3 } } */
int32x4_t
-test_vqdmlal_high_lane_s16 (int32x4_t a, int16x8_t b, int16x8_t c)
+test_vqdmlal_high_lane_s16 (int32x4_t a, int16x8_t b, int16x4_t c)
{
return vqdmlal_high_lane_s16 (a, b, c, 3);
}
/* { dg-final { scan-assembler-times "\\tsqdmlal2\\tv\[0-9\]+\.2d, v\[0-9\]+\.4s, v\[0-9\]+\.s" 3 } } */
int64x2_t
-test_vqdmlal_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x4_t __c)
+test_vqdmlal_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x2_t __c)
{
return vqdmlal_high_lane_s32 (__a, __b, __c, 1);
}
/* { dg-final { scan-assembler-times "\\tsqdmlsl2\\tv\[0-9\]+\.4s, v\[0-9\]+\.8h, v\[0-9\]+\.h" 3 } } */
int32x4_t
-test_vqdmlsl_high_lane_s16 (int32x4_t a, int16x8_t b, int16x8_t c)
+test_vqdmlsl_high_lane_s16 (int32x4_t a, int16x8_t b, int16x4_t c)
{
return vqdmlsl_high_lane_s16 (a, b, c, 3);
}
/* { dg-final { scan-assembler-times "\\tsqdmlsl2\\tv\[0-9\]+\.2d, v\[0-9\]+\.4s, v\[0-9\]+\.s" 3 } } */
int64x2_t
-test_vqdmlsl_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x4_t __c)
+test_vqdmlsl_high_lane_s32 (int64x2_t __a, int32x4_t __b, int32x2_t __c)
{
return vqdmlsl_high_lane_s32 (__a, __b, __c, 1);
}
/* { dg-final { scan-assembler-times "\\tsqdmull2\\tv\[0-9\]+\.4s, v\[0-9\]+\.8h, v\[0-9\]+\.h" 3 } } */
int32x4_t
-test_vqdmull_high_lane_s16 (int16x8_t a, int16x8_t b)
+test_vqdmull_high_lane_s16 (int16x8_t a, int16x4_t b)
{
return vqdmull_high_lane_s16 (a, b, 3);
}
/* { dg-final { scan-assembler-times "\\tsqdmull2\\tv\[0-9\]+\.2d, v\[0-9\]+\.4s, v\[0-9\]+\.s" 3 } } */
int64x2_t
-test_vqdmull_high_lane_s32 (int32x4_t __a, int32x4_t __b)
+test_vqdmull_high_lane_s32 (int32x4_t __a, int32x2_t __b)
{
return vqdmull_high_lane_s32 (__a, __b, 1);
}
--- /dev/null
+/* Test the vqdmlal_high_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmlal_high_lane_s16 (int32x4_t a, int16x8_t b, int16x4_t c)
+{
+ return vqdmlal_high_lane_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal2\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlal_high_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlal_high_lane_s32 (int64x2_t a, int32x4_t b, int32x2_t c)
+{
+ return vqdmlal_high_lane_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal2\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlal_high_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmlal_high_laneq_s16 (int32x4_t a, int16x8_t b, int16x8_t c)
+{
+ return vqdmlal_high_laneq_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal2\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlal_high_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlal_high_laneq_s32 (int64x2_t a, int32x4_t b, int32x4_t c)
+{
+ return vqdmlal_high_laneq_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal2\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlal_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmlal_lane_s16 (int32x4_t a, int16x4_t b, int16x4_t c)
+{
+ return vqdmlal_lane_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlal_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlal_lane_s32 (int64x2_t a, int32x2_t b, int32x2_t c)
+{
+ return vqdmlal_lane_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlal_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmlal_laneq_s16 (int32x4_t a, int16x4_t b, int16x8_t c)
+{
+ return vqdmlal_laneq_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlal_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlal_laneq_s32 (int64x2_t a, int32x2_t b, int32x4_t c)
+{
+ return vqdmlal_laneq_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlalh_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x1_t
+t_vqdmlalh_lane_s16 (int32x1_t a, int16x1_t b, int16x4_t c)
+{
+ return vqdmlalh_lane_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal\[ \t\]+\[sS\]\[0-9\]+, ?\[hH\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlals_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x1_t
+t_vqdmlals_lane_s32 (int64x1_t a, int32x1_t b, int32x2_t c)
+{
+ return vqdmlals_lane_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlal\[ \t\]+\[dD\]\[0-9\]+, ?\[sS\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsl_high_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmlsl_high_lane_s16 (int32x4_t a, int16x8_t b, int16x4_t c)
+{
+ return vqdmlsl_high_lane_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl2\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsl_high_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlsl_high_lane_s32 (int64x2_t a, int32x4_t b, int32x2_t c)
+{
+ return vqdmlsl_high_lane_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl2\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsl_high_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmlsl_high_laneq_s16 (int32x4_t a, int16x8_t b, int16x8_t c)
+{
+ return vqdmlsl_high_laneq_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl2\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsl_high_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlsl_high_laneq_s32 (int64x2_t a, int32x4_t b, int32x4_t c)
+{
+ return vqdmlsl_high_laneq_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl2\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsl_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmlsl_lane_s16 (int32x4_t a, int16x4_t b, int16x4_t c)
+{
+ return vqdmlsl_lane_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsl_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlsl_lane_s32 (int64x2_t a, int32x2_t b, int32x2_t c)
+{
+ return vqdmlsl_lane_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsl_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmlsl_lane_s32 (int64x2_t a, int32x2_t b, int32x4_t c)
+{
+ return vqdmlsl_laneq_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlslh_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x1_t
+t_vqdmlslh_lane_s16 (int32x1_t a, int16x1_t b, int16x4_t c)
+{
+ return vqdmlslh_lane_s16 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl\[ \t\]+\[sS\]\[0-9\]+, ?\[hH\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmlsls_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x1_t
+t_vqdmlsls_lane_s32 (int64x1_t a, int32x1_t b, int32x2_t c)
+{
+ return vqdmlsls_lane_s32 (a, b, c, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmlsl\[ \t\]+\[dD\]\[0-9\]+, ?\[sS\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmulh_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int16x4_t
+t_vqdmulh_laneq_s16 (int16x4_t a, int16x8_t b)
+{
+ return vqdmulh_laneq_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmulh\[ \t\]+\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmulh_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x2_t
+t_vqdmulh_laneq_s32 (int32x2_t a, int32x4_t b)
+{
+ return vqdmulh_laneq_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmulh\[ \t\]+\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmulhh_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do run } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+#include <stdio.h>
+
+extern void abort (void);
+
+int
+main (void)
+{
+ int16_t arg1;
+ int16x4_t arg2;
+ int16_t result;
+ int16_t actual;
+ int16_t expected;
+
+ arg1 = -32768;
+ arg2 = vcreate_s16 (0x0000ffff2489e398ULL);
+ actual = vqdmulhh_lane_s16 (arg1, arg2, 2);
+ expected = 1;
+
+ if (expected != actual)
+ {
+ fprintf (stderr, "Expected: %xd, got %xd\n", expected, actual);
+ abort ();
+ }
+
+ return 0;
+}
+
+
+/* { dg-final { scan-assembler-times "sqdmulh\[ \t\]+\[hH\]\[0-9\]+, ?\[hH\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[hH\]\\\[2\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmulhq_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int16x8_t
+t_vqdmulhq_laneq_s16 (int16x8_t a, int16x8_t b)
+{
+ return vqdmulhq_laneq_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmulh\[ \t\]+\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmulhq_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmulhq_laneq_s32 (int32x4_t a, int32x4_t b)
+{
+ return vqdmulhq_laneq_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmulh\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmulhs_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do run } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+#include <stdio.h>
+
+extern void abort (void);
+
+int
+main (void)
+{
+ int32_t arg1;
+ int32x2_t arg2;
+ int32_t result;
+ int32_t actual;
+ int32_t expected;
+
+ arg1 = 57336;
+ arg2 = vcreate_s32 (0x55897fff7fff0000ULL);
+ actual = vqdmulhs_lane_s32 (arg1, arg2, 0);
+ expected = 57334;
+
+ if (expected != actual)
+ {
+ fprintf (stderr, "Expected: %xd, got %xd\n", expected, actual);
+ abort ();
+ }
+
+ return 0;
+}
+/* { dg-final { scan-assembler-times "sqdmulh\[ \t\]+\[sS\]\[0-9\]+, ?\[sS\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_high_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmull_high_lane_s16 (int16x8_t a, int16x4_t b)
+{
+ return vqdmull_high_lane_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull2\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_high_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmull_high_lane_s32 (int32x4_t a, int32x2_t b)
+{
+ return vqdmull_high_lane_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull2\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_high_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmull_high_laneq_s16 (int16x8_t a, int16x8_t b)
+{
+ return vqdmull_high_laneq_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull2\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_high_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmull_high_laneq_s32 (int32x4_t a, int32x4_t b)
+{
+ return vqdmull_high_laneq_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull2\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmull_lane_s16 (int16x4_t a, int16x4_t b)
+{
+ return vqdmull_lane_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmull_lane_s32 (int32x2_t a, int32x2_t b)
+{
+ return vqdmull_lane_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqdmull_laneq_s16 (int16x4_t a, int16x8_t b)
+{
+ return vqdmull_laneq_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmull_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x2_t
+t_vqdmull_laneq_s32 (int32x2_t a, int32x4_t b)
+{
+ return vqdmull_laneq_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull\[ \t\]+\[vV\]\[0-9\]+\.2\[dD\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmullh_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x1_t
+t_vqdmullh_lane_s16 (int16x1_t a, int16x4_t b)
+{
+ return vqdmullh_lane_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull\[ \t\]+\[sS\]\[0-9\]+, ?\[hH\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqdmulls_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int64x1_t
+t_vqdmulls_lane_s32 (int32x1_t a, int32x2_t b)
+{
+ return vqdmulls_lane_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqdmull\[ \t\]+\[dD\]\[0-9\]+, ?\[sS\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqrdmulh_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int16x4_t
+t_vqrdmulh_laneq_s16 (int16x4_t a, int16x8_t b)
+{
+ return vqrdmulh_laneq_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqrdmulh\[ \t\]+\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.4\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqrdmulh_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x2_t
+t_vqrdmulh_laneq_s32 (int32x2_t a, int32x4_t b)
+{
+ return vqrdmulh_laneq_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqrdmulh\[ \t\]+\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.2\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqrdmulhh_lane_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do run } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+#include <stdio.h>
+
+extern void abort (void);
+
+int
+main (void)
+{
+ int16_t arg1;
+ int16x4_t arg2;
+ int16_t result;
+ int16_t actual;
+ int16_t expected;
+
+ arg1 = -32768;
+ arg2 = vcreate_s16 (0xd78e000005d78000ULL);
+ actual = vqrdmulhh_lane_s16 (arg1, arg2, 3);
+ expected = 10354;
+
+ if (expected != actual)
+ {
+ fprintf (stderr, "Expected: %xd, got %xd\n", expected, actual);
+ abort ();
+ }
+
+ return 0;
+}
+
+/* { dg-final { scan-assembler-times "sqrdmulh\[ \t\]+\[hH\]\[0-9\]+, ?\[hH\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[hH\]\\\[3\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqrdmulhq_laneq_s16 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int16x8_t
+t_vqrdmulhq_laneq_s16 (int16x8_t a, int16x8_t b)
+{
+ return vqrdmulhq_laneq_s16 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqrdmulh\[ \t\]+\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.8\[hH\], ?\[vV\]\[0-9\]+\.\[hH\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqrdmulhq_laneq_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do compile } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+
+int32x4_t
+t_vqrdmulhq_laneq_s32 (int32x4_t a, int32x4_t b)
+{
+ return vqrdmulhq_laneq_s32 (a, b, 0);
+}
+
+/* { dg-final { scan-assembler-times "sqrdmulh\[ \t\]+\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.4\[sS\], ?\[vV\]\[0-9\]+\.\[sS\]\\\[0\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* Test the vqrdmulhs_lane_s32 AArch64 SIMD intrinsic. */
+
+/* { dg-do run } */
+/* { dg-options "-save-temps -O3 -fno-inline" } */
+
+#include "arm_neon.h"
+#include <stdio.h>
+
+extern void abort (void);
+
+int
+main (void)
+{
+ int32_t arg1;
+ int32x2_t arg2;
+ int32_t result;
+ int32_t actual;
+ int32_t expected;
+
+ arg1 = -2099281921;
+ arg2 = vcreate_s32 (0x000080007fff0000ULL);
+ actual = vqrdmulhs_lane_s32 (arg1, arg2, 1);
+ expected = -32033;
+
+ if (expected != actual)
+ {
+ fprintf (stderr, "Expected: %xd, got %xd\n", expected, actual);
+ abort ();
+ }
+
+ return 0;
+}
+
+/* { dg-final { scan-assembler-times "sqrdmulh\[ \t\]+\[sS\]\[0-9\]+, ?\[sS\]\[0-9\]+, ?\[vV\]\[0-9\]+\.\[sS\]\\\[1\\\]\n" 1 } } */
+/* { dg-final { cleanup-saved-temps } } */
--- /dev/null
+/* { dg-do compile } */
+/* { dg-options "-O2 -mieee" } */
+
+void foo (int *dimensions, double **params, int hh)
+{
+ if (params[hh])
+ ;
+ else if (dimensions[hh] > 0)
+ params[hh][0] = 1.0f;
+}
uint8x8x2_t vd1, vd2;
union {uint8x8_t v; uint8_t buf[8];} d1, d2, d3, d4;
int i;
- uint8_t odd, even;
vd1 = vzip_u8(v1, vdup_n_u8(0));
vd2 = vzip_u8(v2, vdup_n_u8(0));
vst1_u8(d3.buf, vd2.val[0]);
vst1_u8(d4.buf, vd2.val[1]);
-#ifdef __ARMEL__
- odd = 1;
- even = 0;
-#else
- odd = 0;
- even = 1;
-#endif
-
for (i = 0; i < 8; i++)
- if ((i % 2 == even && d4.buf[i] != 2)
- || (i % 2 == odd && d4.buf[i] != 0))
+ if ((i % 2 == 0 && d4.buf[i] != 2)
+ || (i % 2 == 1 && d4.buf[i] != 0))
abort ();
return 0;
--- /dev/null
+/* PR tree-optimization/57233 */
+/* { dg-do run { target avx } } */
+/* { dg-options "-O2 -mavx" } */
+
+#include "avx-check.h"
+
+static void
+avx_test (void)
+{
+ do_main ();
+}
+
+#undef main
+#define main() do_main ()
+
+#include "../../gcc.dg/pr57233.c"
--- /dev/null
+/* PR tree-optimization/57233 */
+/* { dg-do run { target avx2 } } */
+/* { dg-options "-O2 -mavx2" } */
+
+#include "avx2-check.h"
+
+static void
+avx2_test (void)
+{
+ do_main ();
+}
+
+#undef main
+#define main() do_main ()
+
+#include "../../gcc.dg/pr57233.c"
--- /dev/null
+/* PR tree-optimization/57233 */
+/* { dg-do run { target avx512f } } */
+/* { dg-options "-O2 -mavx512f" } */
+
+#include "avx512f-check.h"
+
+static void
+avx512f_test (void)
+{
+ do_main ();
+}
+
+#undef main
+#define main() do_main ()
+
+#include "../../gcc.dg/pr57233.c"
--- /dev/null
+/* PR tree-optimization/57233 */
+/* { dg-do compile { target avx } } */
+/* { dg-options "-O2 -mavx -mno-xop" } */
+
+typedef unsigned V4 __attribute__((vector_size(4 * sizeof (int))));
+V4 a;
+
+__attribute__((noinline)) void
+foo (void)
+{
+ a = (a << 2) | (a >> 30);
+}
+
+/* { dg-final { scan-assembler "vpsrld\[^\n\r]*30" } } */
+/* { dg-final { scan-assembler "vpslld\[^\n\r]*2" } } */
--- /dev/null
+/* PR tree-optimization/57233 */
+/* { dg-do run { target sse2 } } */
+/* { dg-options "-O2 -msse2" } */
+
+#include "sse2-check.h"
+
+static void
+sse2_test (void)
+{
+ do_main ();
+}
+
+#undef main
+#define main() do_main ()
+
+#include "../../gcc.dg/pr57233.c"
--- /dev/null
+/* PR tree-optimization/57233 */
+/* { dg-do run { target xop } } */
+/* { dg-options "-O2 -mxop" } */
+
+#include "xop-check.h"
+
+static void
+xop_test (void)
+{
+ do_main ();
+}
+
+#undef main
+#define main() do_main ()
+
+#include "../../gcc.dg/pr57233.c"
--- /dev/null
+! { dg-do run }
+! Test the fix for PR61459 and PR58883.
+!
+! Contributed by John Wingate <johnww@tds.net>
+! and Tao Song <songtao.thu@gmail.com>
+!
+module a
+
+ implicit none
+ private
+ public :: f_segfault, f_segfault_plus, f_workaround
+ integer, dimension(2,2) :: b = reshape([1,-1,1,1],[2,2])
+
+contains
+
+ function f_segfault(x)
+ real, dimension(:), allocatable :: f_segfault
+ real, dimension(:), intent(in) :: x
+ allocate(f_segfault(2))
+ f_segfault = matmul(b,x)
+ end function f_segfault
+
+! Sefaulted without the ALLOCATE as well.
+ function f_segfault_plus(x)
+ real, dimension(:), allocatable :: f_segfault_plus
+ real, dimension(:), intent(in) :: x
+ f_segfault_plus = matmul(b,x)
+ end function f_segfault_plus
+
+ function f_workaround(x)
+ real, dimension(:), allocatable :: f_workaround
+ real, dimension(:), intent(in) :: x
+ real, dimension(:), allocatable :: tmp
+ allocate(f_workaround(2),tmp(2))
+ tmp = matmul(b,x)
+ f_workaround = tmp
+ end function f_workaround
+
+end module a
+
+program main
+ use a
+ implicit none
+ real, dimension(2) :: x = 1.0, y
+! PR61459
+ y = f_workaround (x)
+ if (any (f_segfault (x) .ne. y)) call abort
+ if (any (f_segfault_plus (x) .ne. y)) call abort
+! PR58883
+ if (any (foo () .ne. reshape([1,2,3,4,5,6,7,8],[2,4]))) call abort
+contains
+ function foo()
+ integer, allocatable :: foo(:,:)
+ integer, allocatable :: temp(:)
+
+ temp = [1,2,3,4,5,6,7,8]
+ foo = reshape(temp,[2,4])
+ end function
+end program main
--- /dev/null
+! { dg-do run }
+! PR61499
+program read_internal
+
+ integer :: x(9),i,iostat
+ character(len=512) :: iomsg
+ character(kind=1,len=30), dimension(:), allocatable, save :: source
+ allocate(source(3))
+ source=[" 1 1 -1"," 1 -1 1"," -1 1 1"] !This fails
+ read(source,*) (x(i), i=1,6)
+end program read_internal
--- /dev/null
+! { dg-do run }
+! PR61640 KIND=4 Character Array Internal Unit Read Fail
+program read_internal
+ integer :: x(9),i
+ integer :: y(9)
+ character(kind=4,len=30), dimension(3) :: source
+
+ y = reshape ((/ 1,1,-1,1,-1,1,-1,1,1 /), shape(x))
+ source=[4_" 1 1 -1",4_" 1 -1 1",4_" -1 1 1"]
+ !print *, (trim(source(i)), i=1,3)
+ read(source,*) (x(i), i=1,9) ! This read fails for KIND=4 character
+ if (any(x /= y )) call abort
+end program read_internal
! { dg-do run }
+! { dg-options "-fdump-tree-original" }
!
! Tests the fixes for three bugs with the same underlying cause. All are regressions
! that come about because class array elements end up with a different tree type
bh => bhGet(b,instance=2)
if (loc (b) .ne. loc(bh%hostNode)) call abort
end
+! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
! { dg-require-effective-target fortran_large_real }
-! { dg-do run { xfail powerpc*-apple-darwin* powerpc*-*-linux* } }
-! Test XFAILed on these platforms because the system's printf() lacks
+! { dg-do run { xfail powerpc*-apple-darwin* } }
+! Test XFAILed on this platform because the system's printf() lacks
! proper support for denormalized long doubles. See PR24685
!
! This tests that the default formats for formatted I/O of reals are
--- /dev/null
+ integer :: i, j
+ integer, dimension (10, 10) :: a
+!$omp parallel do default(none)proc_bind(master)shared(a)
+ do i = 1, 10
+ j = 4
+ do j = 1, 10
+ a(i, j) = i + j
+ end do
+ j = 8
+ end do
+!$omp end parallel do
+!$omp parallel proc_bind (close)
+!$omp parallel default(none) proc_bind (spread) firstprivate(a) private (i)
+ do i = 1, 10
+ a(i, i) = i
+ enddo
+!$omp end parallel
+!$omp endparallel
+end
TYPE(t), SAVE :: a
!$omp threadprivate(a)
- !$omp parallel copyin(a) ! { dg-error "has ALLOCATABLE components" }
+ !$omp parallel copyin(a)
! do something
!$omp end parallel
END SUBROUTINE
SUBROUTINE test_copyprivate()
TYPE(t) :: a
- !$omp single ! { dg-error "has ALLOCATABLE components" }
+ !$omp single
! do something
!$omp end single copyprivate (a)
END SUBROUTINE
SUBROUTINE test_firstprivate
TYPE(t) :: a
- !$omp parallel firstprivate(a) ! { dg-error "has ALLOCATABLE components" }
+ !$omp parallel firstprivate(a)
! do something
!$omp end parallel
END SUBROUTINE
TYPE(t) :: a
INTEGER :: i
- !$omp parallel do lastprivate(a) ! { dg-error "has ALLOCATABLE components" }
+ !$omp parallel do lastprivate(a)
DO i = 1, 1
END DO
!$omp end parallel do
TYPE(t) :: a(10)
INTEGER :: i
- !$omp parallel do reduction(+: a) ! { dg-error "must be of numeric type" }
+ !$omp parallel do reduction(+: a) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
DO i = 1, SIZE(a)
END DO
!$omp end parallel do
!$OMP PARALLEL DO REDUCTION(MAX: M) ! MAX is no longer the
! intrinsic so this
! is non-conforming
-! { dg-error "is not INTRINSIC procedure name" "" { target *-*-* } 5 } */
+! { dg-error "OMP DECLARE REDUCTION max not found" "" { target *-*-* } 5 } */
DO I = 1, 100
CALL SUB(M,I)
END DO
--- /dev/null
+! { dg-do compile }
+
+program associate1
+ type dl
+ integer :: i
+ end type
+ type dt
+ integer :: i
+ real :: a(3, 3)
+ type(dl) :: c(3, 3)
+ end type
+ integer :: v, i, j
+ real :: a(3, 3)
+ type(dt) :: b(3)
+ i = 1
+ j = 2
+ associate(k => v, l => a(i, j), m => a(i, :))
+ associate(n => b(j)%c(:, :)%i, o => a, p => b)
+!$omp parallel shared (l) ! { dg-error "ASSOCIATE name" }
+!$omp end parallel
+!$omp parallel firstprivate (m) ! { dg-error "ASSOCIATE name" }
+!$omp end parallel
+!$omp parallel reduction (+: k) ! { dg-error "ASSOCIATE name" }
+!$omp end parallel
+!$omp parallel do firstprivate (k) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+!$omp parallel do lastprivate (n) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+!$omp parallel do private (o) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+!$omp parallel do shared (p) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+!$omp task private (k) ! { dg-error "ASSOCIATE name" }
+!$omp end task
+!$omp task shared (l) ! { dg-error "ASSOCIATE name" }
+!$omp end task
+!$omp task firstprivate (m) ! { dg-error "ASSOCIATE name" }
+!$omp end task
+!$omp do private (l) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+!$omp do reduction (*: k) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+!$omp sections private(o) ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp end sections
+!$omp parallel sections firstprivate(p) ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp endparallelsections
+!$omp parallelsections lastprivate(m) ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp endparallelsections
+!$omp sections reduction(+:k) ! { dg-error "ASSOCIATE name" }
+!$omp section
+!$omp section
+!$omp end sections
+!$omp simd private (l) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+ k = 1
+!$omp simd lastprivate (m) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+ k = 1
+!$omp simd reduction (+: k) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ end do
+ k = 1
+!$omp simd linear (k : 2) ! { dg-error "ASSOCIATE name" }
+ do i = 1, 10
+ k = k + 2
+ end do
+ end associate
+ end associate
+end program
--- /dev/null
+! { dg-do compile }
+
+subroutine fn1 (x)
+ integer :: x
+!$omp declare simd (fn1) inbranch notinbranch uniform (x) ! { dg-error "Unclassifiable OpenMP directive" }
+end subroutine fn1
+subroutine fn2 (x)
+!$omp declare simd (fn100) ! { dg-error "should refer to containing procedure" }
+end subroutine fn2
--- /dev/null
+! { dg-do compile }
+
+subroutine foo (x)
+ integer :: x(5, *)
+!$omp parallel
+!$omp single
+!$omp task depend(in:x(:,5))
+!$omp end task
+!$omp task depend(in:x(5,:)) ! { dg-error "Rightmost upper bound of assumed size array section|proper array section" }
+!$omp end task
+!$omp end single
+!$omp end parallel
+end
--- /dev/null
+! { dg-do compile }
+
+subroutine foo (x)
+ integer, pointer, intent (in) :: x
+ integer :: i
+!$omp parallel private (x) ! { dg-error "INTENT.IN. POINTER" }
+!$omp end parallel
+!$omp parallel do lastprivate (x) ! { dg-error "INTENT.IN. POINTER" }
+ do i = 1, 10
+ end do
+!$omp simd linear (x) ! { dg-error "INTENT.IN. POINTER" }
+ do i = 1, 10
+ end do
+!$omp single ! { dg-error "INTENT.IN. POINTER" }
+!$omp end single copyprivate (x)
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+!
+! PR fortran/60127
+!
+! OpenMP 4.0 doesn't permit DO CONCURRENT (yet)
+!
+
+!$omp do
+do concurrent(i=1:5) ! { dg-error "OMP DO cannot be a DO CONCURRENT loop" }
+print *, 'Hello'
+end do
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-original -O2" }
+
+!$omp declare reduction (foo:integer:omp_out = omp_out + omp_in)
+ interface
+ integer function foo (x, y)
+ integer, value :: x, y
+!$omp declare simd (foo) linear (y : 2)
+ end function foo
+ end interface
+ integer :: i, a(64), b, c
+ integer, save :: d
+!$omp threadprivate (d)
+ d = 5
+ a = 6
+!$omp simd
+ do i = 1, 64
+ a(i) = foo (a(i), 2 * i)
+ end do
+ b = 0
+ c = 0
+!$omp simd reduction (+:b) reduction (foo:c)
+ do i = 1, 64
+ b = b + a(i)
+ c = c + a(i) * 2
+ end do
+ print *, b
+ b = 0
+!$omp parallel
+!$omp do simd schedule(static, 4) safelen (8) reduction (+:b)
+ do i = 1, 64
+ a(i) = a(i) + 1
+ b = b + 1
+ end do
+!$omp end parallel
+ print *, b
+ b = 0
+!$omp parallel do simd schedule(static, 4) safelen (8) &
+!$omp num_threads (4) if (.true.) reduction (+:b)
+ do i = 1, 64
+ a(i) = a(i) + 1
+ b = b + 1
+ end do
+ print *, b
+ b = 0
+!$omp parallel
+!$omp do simd schedule(static, 4) safelen (8) reduction (+:b)
+ do i = 1, 64
+ a(i) = a(i) + 1
+ b = b + 1
+ end do
+!$omp enddosimd
+!$omp end parallel
+ print *, b
+ b = 0
+!$omp parallel do simd schedule(static, 4) safelen (8) &
+!$omp num_threads (4) if (.true.) reduction (+:b)
+ do i = 1, 64
+ a(i) = a(i) + 1
+ b = b + 1
+ end do
+!$omp end parallel do simd
+!$omp atomic seq_cst
+ b = b + 1
+!$omp end atomic
+!$omp barrier
+!$omp parallel private (i)
+!$omp cancellation point parallel
+!$omp critical (bar)
+ b = b + 1
+!$omp end critical (bar)
+!$omp flush(b)
+!$omp single
+ b = b + 1
+!$omp end single
+!$omp do ordered
+ do i = 1, 10
+ !$omp atomic
+ b = b + 1
+ !$omp end atomic
+ !$omp ordered
+ print *, b
+ !$omp end ordered
+ end do
+!$omp end do
+!$omp master
+ b = b + 1
+!$omp end master
+!$omp cancel parallel
+!$omp end parallel
+!$omp parallel do schedule(runtime) num_threads(8)
+ do i = 1, 10
+ print *, b
+ end do
+!$omp end parallel do
+!$omp sections
+!$omp section
+ b = b + 1
+!$omp section
+ c = c + 1
+!$omp end sections
+ print *, b
+!$omp parallel sections firstprivate (b) if (.true.)
+!$omp section
+ b = b + 1
+!$omp section
+ c = c + 1
+!$omp endparallelsections
+!$omp workshare
+ b = 24
+!$omp end workshare
+!$omp parallel workshare num_threads (2)
+ b = b + 1
+ c = c + 1
+!$omp end parallel workshare
+ print *, b
+!$omp parallel
+!$omp single
+!$omp taskgroup
+!$omp task firstprivate (b)
+ b = b + 1
+!$omp taskyield
+!$omp end task
+!$omp task firstprivate (b)
+ b = b + 1
+!$omp end task
+!$omp taskwait
+!$omp end taskgroup
+!$omp end single
+!$omp end parallel
+ print *, a, c
+end
+
+! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp" 6 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -fopenmp-simd -fdump-tree-original -O2" }
+
+include 'openmp-simd-1.f90'
+
+! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } }
+! Includes the above taskgroup
+! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } }
+! Includes the above sections
+! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } }
+! Includes the above cancellation point
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -fno-openmp-simd -fdump-tree-original -O2" }
+
+include 'openmp-simd-1.f90'
+
+! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } }
+! Includes the above taskgroup
+! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } }
+! Includes the above sections
+! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } }
+! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } }
+! Includes the above cancellation point
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null
+! { dg-do compile }
+ procedure(foo), pointer :: ptr
+ integer :: i
+ ptr => foo
+!$omp do reduction (+ : ptr) ! { dg-error "Procedure pointer|not found" }
+ do i = 1, 10
+ end do
+!$omp simd linear (ptr) ! { dg-error "must be INTEGER" }
+ do i = 1, 10
+ end do
+contains
+ subroutine foo
+ end subroutine
+end
!$omp end parallel
!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" }
!$omp end parallel
-!$omp parallel reduction (+:l1) ! { dg-error "must be of numeric type, got LOGICAL" }
+!$omp parallel reduction (+:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (*:la1) ! { dg-error "must be of numeric type, got LOGICAL" }
+!$omp parallel reduction (*:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (-:a1) ! { dg-error "must be of numeric type, got CHARACTER" }
+!$omp parallel reduction (-:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (+:t1) ! { dg-error "must be of numeric type, got TYPE" }
+!$omp parallel reduction (+:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (*:ta1) ! { dg-error "must be of numeric type, got TYPE" }
+!$omp parallel reduction (*:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.and.:i3) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.and.:i3) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.or.:ia2) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.or.:ia2) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.eqv.:r1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.eqv.:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.neqv.:ra1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.neqv.:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.and.:d1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.and.:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.or.:da1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.or.:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.eqv.:c1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.eqv.:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.neqv.:ca1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.neqv.:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.and.:a1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.and.:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.or.:t1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.or.:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (.eqv.:ta1) ! { dg-error "must be LOGICAL" }
+!$omp parallel reduction (.eqv.:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (min:c1) ! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (min:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (max:ca1) ! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (max:l1) ! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (min:la1) ! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (min:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (max:a1) ! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (min:t1) ! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (min:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (max:ta1) ! { dg-error "must be INTEGER or REAL" }
+!$omp parallel reduction (max:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (iand:r1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (ior:ra1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (ieor:d1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ieor:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (ior:da1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (iand:c1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (ior:ca1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (ieor:l1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ieor:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (iand:la1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (ior:a1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ior:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (ieor:t1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (ieor:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
-!$omp parallel reduction (iand:ta1) ! { dg-error "must be INTEGER" }
+!$omp parallel reduction (iand:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" }
!$omp end parallel
end subroutine
integer :: i, ior
ior = 6
i = 6
-!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
!$omp end parallel
end subroutine f1
subroutine f2
end function
end interface
i = 6
-!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
i = ior (i, 3)
!$omp end parallel
end subroutine f2
use mreduction3
integer :: i
i = 6
-!$omp parallel reduction (ior:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
i = ior (i, 7)
!$omp end parallel
end subroutine f5
use mreduction3
integer :: i
i = 6
-!$omp parallel reduction (iand:i) ! { dg-error "is not INTRINSIC procedure name" }
+!$omp parallel reduction (iand:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" }
i = iand (i, 18)
!$omp end parallel
end subroutine f6
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+
+module target1
+ interface
+ subroutine dosomething (a, n, m)
+ integer :: a (:), n, m
+ !$omp declare target
+ end subroutine dosomething
+ end interface
+contains
+ subroutine foo (n, o, p, q, r, pp)
+ integer :: n, o, p, q, r, s, i, j
+ integer :: a (2:o)
+ integer, pointer :: pp
+ !$omp target data device (n + 1) if (n .ne. 6) map (tofrom: n, r)
+ !$omp target device (n + 1) if (n .ne. 6) map (from: n) map (alloc: a(2:o))
+ call dosomething (a, n, 0)
+ !$omp end target
+ !$omp target teams device (n + 1) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r)
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ !$omp end target teams
+ !$omp target teams distribute device (n + 1) num_teams (n + 4) collapse (2) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp target teams distribute device (n + 1) num_teams (n + 4) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp end target teams distribute
+ !$omp target teams distribute parallel do device (n + 1) num_teams (n + 4) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) &
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) &
+ !$omp & ordered schedule (static, 8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10 + j
+ end do
+ end do
+ !$omp target teams distribute parallel do device (n + 1) num_teams (n + 4) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) ordered schedule (static, 8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10
+ end do
+ !$omp end target teams distribute parallel do
+ !$omp target teams distribute parallel do simd device (n + 1) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) &
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) &
+ !$omp & schedule (static, 8) num_teams (n + 4) safelen(8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp target teams distribute parallel do simd device (n + 1) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) &
+ !$omp & num_teams (n + 4) safelen(16) linear(i:1) aligned (pp:4)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end target teams distribute parallel do simd
+ !$omp target teams distribute simd device (n + 1) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) &
+ !$omp & lastprivate (s) num_teams (n + 4) safelen(8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp target teams distribute simd device (n + 1) &
+ !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) lastprivate (s) &
+ !$omp & num_teams (n + 4) safelen(16) linear(i:1) aligned (pp:4)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end target teams distribute simd
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams num_teams (n + 4) thread_limit (n * 2) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r)
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ !$omp end teams
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute num_teams (n + 4) collapse (2) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute num_teams (n + 4) default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp end teams distribute
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute parallel do num_teams (n + 4) &
+ !$omp & if (n .ne. 6) default(shared) ordered schedule (static, 8) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) &
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute parallel do num_teams (n + 4)if(n.ne.6)default(shared)&
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) ordered schedule (static, 8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10
+ end do
+ !$omp end teams distribute parallel do
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute parallel do simd if(n.ne.6)default(shared)&
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) &
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) &
+ !$omp & schedule (static, 8) num_teams (n + 4) safelen(8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute parallel do simd if (n .ne. 6)default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) &
+ !$omp & num_teams (n + 4) safelen(16) linear(i:1) aligned (pp:4)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end teams distribute parallel do simd
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute simd default(shared) safelen(8) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) &
+ !$omp & lastprivate (s) num_teams (n + 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target
+ !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o))
+ !$omp teams distribute simd default(shared) aligned (pp:4) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & thread_limit (n * 2) dist_schedule (static, 4) lastprivate (s)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end teams distribute simd
+ !$omp end target
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction ( + : r )
+ !$omp distribute collapse (2) firstprivate (q) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute firstprivate (q) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp end distribute
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do if (n .ne. 6) default(shared) &
+ !$omp & ordered schedule (static, 8) private (p) firstprivate (q) &
+ !$omp & shared(n)reduction(+:r)dist_schedule(static,4)collapse(2)&
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do if(n.ne.6)default(shared)&
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) ordered schedule (static, 8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10
+ end do
+ !$omp end distribute parallel do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do simd if(n.ne.6)default(shared)&
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) collapse (2) safelen(8) &
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) &
+ !$omp & schedule (static, 8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do simd if (n .ne. 6)default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) &
+ !$omp & safelen(16) linear(i:1) aligned (pp:4)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end distribute parallel do simd
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute simd safelen(8) lastprivate(s) &
+ !$omp & private (p) firstprivate (q) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) collapse (2)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute simd aligned (pp:4) &
+ !$omp & private (p) firstprivate (q) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) lastprivate (s)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end distribute simd
+ !$omp end target teams
+ !$omp end target data
+ end subroutine
+ subroutine bar (n, o, p, r, pp)
+ integer :: n, o, p, q, r, s, i, j
+ integer :: a (2:o)
+ integer, pointer :: pp
+ common /blk/ i, j, q
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction ( + : r )
+ !$omp distribute collapse (2) firstprivate (q) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute firstprivate (q) dist_schedule (static, 4)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ end do
+ !$omp end distribute
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do if (n .ne. 6) default(shared) &
+ !$omp & ordered schedule (static, 8) private (p) firstprivate (q) &
+ !$omp & shared(n)reduction(+:r)dist_schedule(static,4)collapse(2)&
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do if(n.ne.6)default(shared)&
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) ordered schedule (static, 8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ call dosomething (a, n, p + q)
+ end do
+ !$omp ordered
+ p = q
+ !$omp end ordered
+ s = i * 10
+ end do
+ !$omp end distribute parallel do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do simd if(n.ne.6)default(shared)&
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) collapse (2) safelen(8) &
+ !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) &
+ !$omp & schedule (static, 8)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute parallel do simd if (n .ne. 6)default(shared) &
+ !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) num_threads (n + 4) &
+ !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) &
+ !$omp & safelen(16) linear(i:1) aligned (pp:4)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end distribute parallel do simd
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute simd safelen(8) lastprivate(s) &
+ !$omp & private (p) firstprivate (q) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) collapse (2)
+ do i = 1, 10
+ do j = 1, 10
+ r = r + 1
+ p = q
+ a(2+i*10+j) = p + q
+ s = i * 10 + j
+ end do
+ end do
+ !$omp end target teams
+ !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) &
+ !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) &
+ !$omp & default(shared) shared(n) private (p) reduction(+:r)
+ !$omp distribute simd aligned (pp:4) &
+ !$omp & private (p) firstprivate (q) reduction (+: r) &
+ !$omp & dist_schedule (static, 4) lastprivate (s)
+ do i = 1, 10
+ r = r + 1
+ p = q
+ a(1+i) = p + q
+ s = i * 10
+ end do
+ !$omp end distribute simd
+ !$omp end target teams
+ end subroutine
+end module
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp -ffree-line-length-160" }
+
+subroutine foo (n, s, t, u, v, w)
+ integer :: n, i, s, t, u, v, w
+ common /bar/ i
+ !$omp simd safelen(s + 1)
+ do i = 1, n
+ end do
+ !$omp do schedule (static, t * 2)
+ do i = 1, n
+ end do
+ !$omp do simd safelen(s + 1) schedule (static, t * 2)
+ do i = 1, n
+ end do
+ !$omp parallel do schedule (static, t * 2) num_threads (u - 1)
+ do i = 1, n
+ end do
+ !$omp parallel do simd safelen(s + 1) schedule (static, t * 2) num_threads (u - 1)
+ do i = 1, n
+ end do
+ !$omp distribute dist_schedule (static, v + 8)
+ do i = 1, n
+ end do
+ !$omp distribute simd dist_schedule (static, v + 8) safelen(s + 1)
+ do i = 1, n
+ end do
+ !$omp distribute parallel do simd dist_schedule (static, v + 8) safelen(s + 1) &
+ !$omp & schedule (static, t * 2) num_threads (u - 1)
+ do i = 1, n
+ end do
+ !$omp distribute parallel do dist_schedule (static, v + 8) num_threads (u - 1) &
+ !$omp & schedule (static, t * 2)
+ do i = 1, n
+ end do
+ !$omp target
+ !$omp teams distribute dist_schedule (static, v + 8) num_teams (w + 8)
+ do i = 1, n
+ end do
+ !$omp end target
+ !$omp target
+ !$omp teams distribute simd dist_schedule (static, v + 8) safelen(s + 1) &
+ !$omp & num_teams (w + 8)
+ do i = 1, n
+ end do
+ !$omp end target
+ !$omp target
+ !$omp teams distribute parallel do simd dist_schedule (static, v + 8) safelen(s + 1) &
+ !$omp & schedule (static, t * 2) num_threads (u - 1) num_teams (w + 8)
+ do i = 1, n
+ end do
+ !$omp end target
+ !$omp target
+ !$omp teams distribute parallel do dist_schedule (static, v + 8) num_threads (u - 1) &
+ !$omp & schedule (static, t * 2) num_teams (w + 8)
+ do i = 1, n
+ end do
+ !$omp end target
+ !$omp target teams distribute dist_schedule (static, v + 8) num_teams (w + 8)
+ do i = 1, n
+ end do
+ !$omp target teams distribute simd dist_schedule (static, v + 8) safelen(s + 1) &
+ !$omp & num_teams (w + 8)
+ do i = 1, n
+ end do
+ !$omp target teams distribute parallel do simd dist_schedule (static, v + 8) safelen(s + 1) &
+ !$omp & schedule (static, t * 2) num_threads (u - 1) num_teams (w + 8)
+ do i = 1, n
+ end do
+ !$omp target teams distribute parallel do dist_schedule (static, v + 8) num_threads (u - 1) &
+ !$omp & schedule (static, t * 2) num_teams (w + 8)
+ do i = 1, n
+ end do
+end subroutine
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+
+subroutine foo (r)
+ integer :: i, r
+ !$omp target
+ !$omp target teams distribute parallel do reduction (+: r) ! { dg-warning "target construct inside of target region" }
+ do i = 1, 10
+ r = r + 1
+ end do
+ !$omp end target
+end subroutine
--- /dev/null
+! { dg-do compile }
+
+subroutine f1
+!$omp declare reduction (.le.:integer:omp_out = omp_out + omp_in) ! { dg-error "Invalid operator for" }
+end subroutine f1
+subroutine f2
+!$omp declare reduction (bar:real(kind=4):omp_out = omp_out + omp_in)
+ real(kind=4) :: r
+ integer :: i
+ r = 0.0
+!$omp parallel do reduction (bar:r)
+ do i = 1, 10
+ r = r + i
+ end do
+!$omp parallel do reduction (foo:r) ! { dg-error "foo not found" }
+ do i = 1, 10
+ r = r + i
+ end do
+!$omp parallel do reduction (.gt.:r) ! { dg-error "cannot be used as a defined operator" }
+ do i = 1, 10
+ r = r + i
+ end do
+end subroutine f2
+subroutine f3
+!$omp declare reduction (foo:blah:omp_out=omp_out + omp_in) ! { dg-error "Unclassifiable OpenMP directive" }
+end subroutine f3
+subroutine f4
+!$omp declare reduction (foo:integer:a => null()) ! { dg-error "Invalid character in name" }
+!$omp declare reduction (foo:integer:omp_out = omp_in + omp_out) &
+!$omp & initializer(a => null()) ! { dg-error "Invalid character in name" }
+end subroutine f4
+subroutine f5
+ integer :: a, b
+!$omp declare reduction (foo:integer:a = b + 1) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" }
+!$omp declare reduction (bar:integer:omp_out = omp_out * omp_in) &
+!$omp & initializer(b = a + 1) ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" }
+end subroutine f5
+subroutine f6
+!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_orig=omp_priv)
+end subroutine f6
--- /dev/null
+! { dg-do compile }
+
+subroutine f6
+!$omp declare reduction (foo:real:omp_out (omp_in)) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (bar:real:omp_out = omp_in * omp_out) & ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp & initializer (omp_priv (omp_orig))
+end subroutine f6
+subroutine f7
+ integer :: a
+!$omp declare reduction (foo:integer:a (omp_out, omp_in)) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (bar:real:omp_out = omp_out.or.omp_in) ! { dg-error "Operands of logical operator" }
+!$omp declare reduction (baz:real:omp_out = omp_out + omp_in)
+!$omp & initializer (a (omp_priv, omp_orig)) ! { dg-error "Unclassifiable OpenMP directive" }
+ real :: r
+ r = 0.0
+!$omp parallel reduction (bar:r)
+!$omp end parallel
+end subroutine f7
+subroutine f8
+ interface
+ subroutine f8a (x)
+ integer :: x
+ end subroutine f8a
+ end interface
+!$omp declare reduction (baz:integer:omp_out = omp_out + omp_in) &
+!$omp & initializer (f8a (omp_orig)) ! { dg-error "One of actual subroutine arguments in INITIALIZER clause" }
+!$omp declare reduction (foo:integer:f8a) ! { dg-error "is not a variable" }
+!$omp declare reduction (bar:integer:omp_out = omp_out - omp_in) &
+!$omp & initializer (f8a) ! { dg-error "is not a variable" }
+end subroutine f8
+subroutine f9
+ type dt ! { dg-error "which is not consistent with the CALL" }
+ integer :: x = 0
+ integer :: y = 0
+ end type dt
+ integer :: i
+!$omp declare reduction (foo:integer:dt (omp_out, omp_in)) ! { dg-error "which is not consistent with the CALL" }
+!$omp declare reduction (bar:integer:omp_out = omp_out + omp_in) &
+!$omp & initializer (dt (omp_priv, omp_orig)) ! { dg-error "which is not consistent with the CALL" }
+ i = 0
+!$omp parallel reduction (foo : i)
+!$omp end parallel
+!$omp parallel reduction (bar : i)
+!$omp end parallel
+end subroutine f9
+subroutine f10
+ integer :: a, b
+!$omp declare reduction(foo:character(len=64) &
+!$omp & :omp_out(a:b) = omp_in(a:b)) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" }
+!$omp declare reduction(bar:character(len=16) &
+!$omp & :omp_out = trim(omp_out) // omp_in) &
+!$omp & initializer (omp_priv(a:b) = ' ') ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" }
+end subroutine f10
--- /dev/null
+! { dg-do compile }
+
+subroutine f1
+ type dt
+ logical :: l = .false.
+ end type
+ type dt2
+ logical :: l = .false.
+ end type
+!$omp declare reduction (foo:integer(kind = 4) & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
+!$omp & :omp_out = omp_out + omp_in)
+!$omp declare reduction (foo:integer(kind = 4) : & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
+!$omp & omp_out = omp_out + omp_in)
+!$omp declare reduction (bar:integer, &
+!$omp & real:omp_out = omp_out + omp_in)
+!$omp declare reduction (baz:integer,real,integer & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
+!$omp & : omp_out = omp_out + omp_in)
+!$omp declare reduction (id1:dt,dt2:omp_out%l=omp_out%l &
+!$omp & .or.omp_in%l)
+!$omp declare reduction (id2:dt,dt:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
+!$omp & .or.omp_in%l)
+!$omp declare reduction (id3:dt2,dt:omp_out%l=omp_out%l & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
+!$omp & .or.omp_in%l)
+!$omp declare reduction (id3:dt2:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
+!$omp & .or.omp_in%l)
+end subroutine f1
+subroutine f2
+ interface
+ subroutine f2a (x, y, z)
+ character (len = *) :: x, y
+ logical :: z
+ end subroutine
+ end interface
+ interface f2b
+ subroutine f2b (x, y, z)
+ character (len = *, kind = 1) :: x, y
+ logical :: z
+ end subroutine
+ subroutine f2c (x, y, z)
+ character (kind = 4, len = *) :: x, y
+ logical :: z
+ end subroutine
+ end interface
+!$omp declare reduction (foo:character(len=*): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (bar:character(len=:): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (baz:character(len=4): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (baz:character(len=5): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (baz:character(len=6): &
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id:character(len=*): & ! { dg-error "Previous !.OMP DECLARE REDUCTION" }
+!$omp & f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id: & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" }
+!$omp & character(len=:) : f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" }
+!$omp (id2:character(len=*), character(len=:): &
+!$omp f2a (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2a (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id3:character(len=*, kind = 1), character(kind=4, len=:): &
+!$omp f2b (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2b (omp_priv, omp_orig, .true.))
+!$omp declare reduction (id4:character(kind=4, len=4), character(kind =1, len=4): &
+!$omp f2b (omp_out, omp_in, .false.)) &
+!$omp & initializer (f2b (omp_priv, omp_orig, .true.))
+end subroutine f2
--- /dev/null
+! { dg-do compile }
+
+subroutine f3
+!$omp declare reduction ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction foo ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (foo) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (foo:integer) ! { dg-error "Unclassifiable OpenMP directive" }
+!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=0) initializer(omp_priv=0) ! { dg-error "Unexpected junk after" }
+end subroutine f3
+subroutine f4
+ implicit integer (o)
+ implicit real (b)
+!$omp declare reduction (foo:integer:omp_priv(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine omp_priv" }
+!$omp declare reduction (foo:real:bar(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine bar used" }
+!$omp declare reduction (bar:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_out (omp_priv)) ! { dg-error "Implicitly declared subroutine omp_out used" }
+!$omp declare reduction (bar:real:omp_out=omp_out+omp_in) &
+!$omp & initializer(bar (omp_priv, omp_orig)) ! { dg-error "Implicitly declared subroutine bar used" }
+!$omp declare reduction (id1:integer:omp_out=omp_orig(omp_out,omp_in)) ! { dg-error "Implicitly declared function omp_orig used" }
+!$omp declare reduction (id1:real:omp_out=foo(omp_out,omp_in)) ! { dg-error "Implicitly declared function foo used" }
+!$omp declare reduction (id2:integer:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv = omp_in (omp_orig)) ! { dg-error "Implicitly declared function omp_in used" }
+!$omp declare reduction (id2:real:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv = baz (omp_orig)) ! { dg-error "Implicitly declared function baz used" }
+ integer :: i
+ real :: r
+ i = 0
+ r = 0
+!$omp parallel reduction (foo: i, r)
+!$omp end parallel
+!$omp parallel reduction (bar: i, r)
+!$omp end parallel
+!$omp parallel reduction (id1: i, r)
+!$omp end parallel
+!$omp parallel reduction (id2: i, r)
+!$omp end parallel
+end subroutine f4
+subroutine f5
+ interface
+ subroutine f5a (x, *, y)
+ double precision :: x, y
+ end subroutine f5a
+ end interface
+!$omp declare reduction (foo:double precision: & ! { dg-error "Subroutine call with alternate returns in combiner" }
+!$omp & f5a (omp_out, *10, omp_in))
+!$omp declare reduction (bar:double precision: &
+!$omp omp_out = omp_in + omp_out) &
+!$omp & initializer (f5a (omp_priv, *20, omp_orig)) ! { dg-error "Subroutine call with alternate returns in INITIALIZER clause" }
+10 continue
+20 continue
+end subroutine f5
+subroutine f6
+ integer :: a
+!$omp declare reduction(foo:character(len=a*2) & ! { dg-error "cannot appear in the expression|not constant" }
+!$omp & :omp_out=trim(omp_out)//omp_in) &
+!$omp & initializer(omp_priv=' ')
+end subroutine f6
+subroutine f7
+ type dt1
+ integer :: a = 1
+ integer :: b
+ end type
+ type dt2
+ integer :: a = 2
+ integer :: b = 3
+ end type
+ type dt3
+ integer :: a
+ integer :: b
+ end type dt3
+!$omp declare reduction(foo:dt1,dt2:omp_out%a=omp_out%a+omp_in%a)
+!$omp declare reduction(foo:dt3:omp_out%a=omp_out%a+omp_in%a) ! { dg-error "Missing INITIALIZER clause for !.OMP DECLARE REDUCTION of derived type without default initializer" }
+end subroutine f7
--- /dev/null
+! { dg-do compile }
+
+module udr5m1
+ type dt
+ real :: r
+ end type dt
+end module udr5m1
+module udr5m2
+ use udr5m1
+ interface operator(+)
+ module procedure addm2
+ end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+ interface operator(.myadd.)
+ module procedure addm2
+ end interface
+contains
+ type(dt) function addm2 (x, y)
+ type(dt), intent (in):: x, y
+ addm2%r = x%r + y%r
+ end function
+end module udr5m2
+module udr5m3
+ use udr5m1
+ interface operator(.myadd.)
+ module procedure addm3
+ end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+ interface operator(+)
+ module procedure addm3
+ end interface
+contains
+ type(dt) function addm3 (x, y)
+ type(dt), intent (in):: x, y
+ addm3%r = x%r + y%r
+ end function
+end module udr5m3
+subroutine f1
+ use udr5m2
+ type(dt) :: d, e
+ integer :: i
+ d=dt(0.0)
+ e = dt (0.0)
+!$omp parallel do reduction (+ : d) reduction ( .myadd. : e)
+ do i=1,100
+ d=d+dt(i)
+ e=e+dt(i)
+ end do
+end subroutine f1
+subroutine f2
+ use udr5m3 ! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" }
+ use udr5m2 ! { dg-error "Ambiguous !.OMP DECLARE REDUCTION" }
+end subroutine f2
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fopenmp -ffree-line-length-160" }
+
+module udr6
+ type dt
+ integer :: i
+ end type
+end module udr6
+subroutine f1
+ use udr6, only : dt
+!$omp declare reduction (+:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
+!$omp & :omp_out = omp_out + omp_in)
+!$omp declare reduction (+:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (+:complex(kind=8):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+ interface operator(+)
+ function addf1 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: addf1
+ end function
+ end interface
+end subroutine f1
+subroutine f2
+ use udr6, only : dt
+ interface operator(-)
+ function subf2 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: subf2
+ end function
+ end interface
+!$omp declare reduction (-:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
+!$omp & :omp_out = omp_out + omp_in)
+!$omp declare reduction (-:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (-:complex(kind=8):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f2
+subroutine f3
+ use udr6, only : dt
+ interface operator(*)
+ function mulf3 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: mulf3
+ end function
+ end interface
+!$omp declare reduction (*:integer:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:real(kind=4):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:double precision:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" }
+!$omp & :omp_out = omp_out * omp_in)
+!$omp declare reduction (*:complex:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (*:complex(kind=8):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f3
+subroutine f4
+ use udr6, only : dt
+ interface operator(.and.)
+ function andf4 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: andf4
+ end function
+ end interface
+!$omp declare reduction (.neqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+ interface operator(.or.)
+ function orf4 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: orf4
+ end function
+ end interface
+!$omp declare reduction (.eqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+ interface operator(.eqv.)
+ function eqvf4 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: eqvf4
+ end function
+ end interface
+!$omp declare reduction (.or.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+ interface operator(.neqv.)
+ function neqvf4 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: neqvf4
+ end function
+ end interface
+!$omp declare reduction (.and.:logical:omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f4
+subroutine f5
+ use udr6, only : dt
+ interface operator(.and.)
+ function andf5 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: andf5
+ end function
+ end interface
+!$omp declare reduction (.neqv.:logical(kind =4):omp_out = omp_out .neqv. omp_in) ! { dg-error "Redefinition of predefined" }
+ interface operator(.or.)
+ function orf5 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: orf5
+ end function
+ end interface
+!$omp declare reduction (.eqv.:logical(kind= 4):omp_out = omp_out .eqv. omp_in) ! { dg-error "Redefinition of predefined" }
+ interface operator(.eqv.)
+ function eqvf5 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: eqvf5
+ end function
+ end interface
+!$omp declare reduction (.or.:logical(kind=4):omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" }
+ interface operator(.neqv.)
+ function neqvf5 (x, y)
+ use udr6, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: neqvf5
+ end function
+ end interface
+!$omp declare reduction (.and.:logical(kind = 4):omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" }
+end subroutine f5
+subroutine f6
+!$omp declare reduction (min:integer:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:integer:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (iand:integer:omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ior:integer:omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ieor:integer:omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:real:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:real:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+end subroutine f6
+subroutine f7
+!$omp declare reduction (min:integer(kind=2):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:integer(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (iand:integer(kind=1):omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ior:integer(kind=8):omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (ieor:integer(kind=4):omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:real(kind=4):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:real(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" }
+end subroutine f7
+subroutine f8
+ integer :: min
+!$omp declare reduction (min:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in)
+end subroutine f8
+subroutine f9
+ integer :: max
+!$omp declare reduction (max:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in)
+end subroutine f9
+subroutine f10
+ integer :: iand
+!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (iand:real:omp_out = omp_out + omp_in)
+end subroutine f10
+subroutine f11
+ integer :: ior
+!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ior:real:omp_out = omp_out + omp_in)
+end subroutine f11
+subroutine f12
+ integer :: ieor
+!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in)
+end subroutine f12
+subroutine f13
+!$omp declare reduction (min:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in)
+ integer :: min
+end subroutine f13
+subroutine f14
+!$omp declare reduction (max:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:real:omp_out = omp_out + omp_in)
+!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in)
+ integer :: max
+end subroutine f14
+subroutine f15
+!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (iand:real:omp_out = omp_out + omp_in)
+ integer :: iand
+end subroutine f15
+subroutine f16
+!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ior:real:omp_out = omp_out + omp_in)
+ integer :: ior
+end subroutine f16
+subroutine f17
+!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in)
+!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in)
+ integer :: ieor
+end subroutine f17
--- /dev/null
+! { dg-do compile }
+
+module udr7m1
+ type dt
+ real :: r
+ end type dt
+end module udr7m1
+module udr7m2
+ use udr7m1
+ interface operator(+)
+ module procedure addm2
+ end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+ interface operator(.myadd.)
+ module procedure addm2
+ end interface
+ private
+ public :: operator(+), operator(.myadd.), dt
+contains
+ type(dt) function addm2 (x, y)
+ type(dt), intent (in):: x, y
+ addm2%r = x%r + y%r
+ end function
+end module udr7m2
+module udr7m3
+ use udr7m1
+ private
+ public :: operator(.myadd.), operator(+), dt
+ interface operator(.myadd.)
+ module procedure addm3
+ end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+ interface operator(+)
+ module procedure addm3
+ end interface
+contains
+ type(dt) function addm3 (x, y)
+ type(dt), intent (in):: x, y
+ addm3%r = x%r + y%r
+ end function
+end module udr7m3
+module udr7m4
+ use udr7m1
+ private
+ interface operator(.myadd.)
+ module procedure addm4
+ end interface
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) &
+!$omp & initializer(omp_priv=dt(0.0))
+ interface operator(+)
+ module procedure addm4
+ end interface
+contains
+ type(dt) function addm4 (x, y)
+ type(dt), intent (in):: x, y
+ addm4%r = x%r + y%r
+ end function
+end module udr7m4
+subroutine f1
+ use udr7m2
+ type(dt) :: d, e
+ integer :: i
+ d=dt(0.0)
+ e = dt (0.0)
+!$omp parallel do reduction (+ : d) reduction ( .myadd. : e)
+ do i=1,100
+ d=d+dt(i)
+ e=e+dt(i)
+ end do
+end subroutine f1
+subroutine f2
+ use udr7m3 ! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" }
+ use udr7m2 ! { dg-error "Ambiguous !.OMP DECLARE REDUCTION" }
+end subroutine f2
+subroutine f3
+ use udr7m4
+ use udr7m2
+end subroutine f3
+subroutine f4
+ use udr7m3
+ use udr7m4
+end subroutine f4
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fmax-errors=1000 -fopenmp" }
+
+module m
+contains
+ function fn1 (x, y)
+ integer, intent(in) :: x, y
+ integer :: fn1
+ fn1 = x + 2 * y
+ end function
+ subroutine sub1 (x, y)
+ integer, intent(in) :: y
+ integer, intent(out) :: x
+ x = y
+ end subroutine
+ function fn2 (x)
+ integer, intent(in) :: x
+ integer :: fn2
+ fn2 = x
+ end function
+ subroutine sub2 (x, y)
+ integer, intent(in) :: y
+ integer, intent(inout) :: x
+ x = x + y
+ end subroutine
+ function fn3 (x, y)
+ integer, intent(in) :: x(:), y(:)
+ integer :: fn3(lbound(x, 1):ubound(x, 1))
+ fn3 = x + 2 * y
+ end function
+ subroutine sub3 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(out) :: x(:)
+ x = y
+ end subroutine
+ function fn4 (x)
+ integer, intent(in) :: x(:)
+ integer :: fn4(lbound(x, 1):ubound(x, 1))
+ fn4 = x
+ end function
+ subroutine sub4 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(inout) :: x(:)
+ x = x + y
+ end subroutine
+ function fn5 (x, y)
+ integer, intent(in) :: x(10), y(10)
+ integer :: fn5(10)
+ fn5 = x + 2 * y
+ end function
+ subroutine sub5 (x, y)
+ integer, intent(in) :: y(10)
+ integer, intent(out) :: x(10)
+ x = y
+ end subroutine
+ function fn6 (x)
+ integer, intent(in) :: x(10)
+ integer :: fn6(10)
+ fn6 = x
+ end function
+ subroutine sub6 (x, y)
+ integer, intent(in) :: y(10)
+ integer, intent(inout) :: x(10)
+ x = x + y
+ end subroutine
+ function fn7 (x, y)
+ integer, allocatable, intent(in) :: x(:), y(:)
+ integer, allocatable :: fn7(:)
+ fn7 = x + 2 * y
+ end function
+ subroutine sub7 (x, y)
+ integer, allocatable, intent(in) :: y(:)
+ integer, allocatable, intent(out) :: x(:)
+ x = y
+ end subroutine
+ function fn8 (x)
+ integer, allocatable, intent(in) :: x(:)
+ integer, allocatable :: fn8(:)
+ fn8 = x
+ end function
+ subroutine sub8 (x, y)
+ integer, allocatable, intent(in) :: y(:)
+ integer, allocatable, intent(inout) :: x(:)
+ x = x + y
+ end subroutine
+end module
+subroutine test1
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test1
+subroutine test2
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) &
+!$omp & initializer (sub1 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn2 (omp_orig))
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test2
+subroutine test3
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" }
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test3
+subroutine test4
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) &
+!$omp & initializer (sub1 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn2 (omp_orig))
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test4
+subroutine test5
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) &
+!$omp & initializer (sub3 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn4 (omp_orig))
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test5
+subroutine test6
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test6
+subroutine test7
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) &
+!$omp & initializer (sub3 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn4 (omp_orig))
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test7
+subroutine test8
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test8
+subroutine test9
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) &
+!$omp & initializer (sub5 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn6 (omp_orig))
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test9
+subroutine test10
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test10
+subroutine test11
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) &
+!$omp & initializer (sub5 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn6 (omp_orig))
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test11
+subroutine test12
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test12
+subroutine test13
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" }
+!$omp & fn5 (omp_out, omp_in)) & ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+!$omp initializer (omp_priv = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" }
+!$omp & fn6 (omp_orig)) ! { dg-warning "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" }
+ integer :: a(9)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test13
+subroutine test14
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" }
+ integer :: a(10)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test14
+subroutine test15
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer :: a
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test15
+subroutine test16
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) &
+!$omp & initializer (sub7 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn8 (omp_orig))
+ integer, allocatable :: a(:)
+ allocate (a(10))
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test16
+subroutine test17
+ use m
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" }
+!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" }
+ integer, allocatable :: a
+ allocate (a)
+!$omp parallel reduction (foo : a)
+!$omp end parallel
+!$omp parallel reduction (bar : a)
+!$omp end parallel
+!$omp parallel reduction (baz : a)
+!$omp end parallel
+end subroutine test17
! http://gcc.gnu.org/ml/fortran/2005-04/msg00139.html
!
! { dg-do run }
-! { dg-xfail-run-if "PR 33271, math library bug" { powerpc-ibm-aix* powerpc*-*-linux* *-*-mingw* } { "-O0" } { "" } }
+! { dg-xfail-run-if "PR 33271, math library bug" { powerpc-ibm-aix* powerpc-*-linux* powerpc64-*-linux* *-*-mingw* } { "-O0" } { "" } }
+! Note that this doesn't fail on powerpc64le-*-linux*.
real(kind=8) :: a
integer(kind=8) :: i1, i2
real :: b
--- /dev/null
+C { dg-do compile }
+ TYPE T
+ INTEGER A(2)/1,2/ ! { dg-error "Invalid old style initialization for derived type component" }
+ END TYPE
+ TYPE S
+ INTEGER B/1/ ! { dg-error "Invalid old style initialization for derived type component" }
+ END TYPE
+ END
# error _OPENMP not defined
#endif
-#if _OPENMP != 201107
+#if _OPENMP != 201307
# error _OPENMP defined to wrong value
#endif
! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "PR libfortran/58015" { *-*-solaris2.9* hppa*-*-hpux* } }
+! { dg-skip-if "IBM long double 31 bits of precision, test requires 38" { powerpc*-*-linux* } }
!
! PR fortran/35862
!
array sections. OMP_CLAUSE_SIZE for these is not the pointer size,
which is implicitly POINTER_SIZE / BITS_PER_UNIT, but the bias. */
OMP_CLAUSE_MAP_POINTER,
+ /* Also internal, behaves like OMP_CLAUS_MAP_TO, but additionally any
+ OMP_CLAUSE_MAP_POINTER records consecutive after it which have addresses
+ falling into that range will not be ignored if OMP_CLAUSE_MAP_TO_PSET
+ wasn't mapped already. */
+ OMP_CLAUSE_MAP_TO_PSET,
OMP_CLAUSE_MAP_LAST
};
case OMP_CLAUSE_LINEAR:
if (OMP_CLAUSE_LINEAR_GIMPLE_SEQ (clause))
need_stmts = true;
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op (&OMP_CLAUSE_LINEAR_STEP (clause),
+ &dummy, wi);
goto do_decl_clause;
case OMP_CLAUSE_PRIVATE:
case OMP_CLAUSE_FINAL:
case OMP_CLAUSE_IF:
case OMP_CLAUSE_NUM_THREADS:
+ case OMP_CLAUSE_DEPEND:
+ case OMP_CLAUSE_DEVICE:
+ case OMP_CLAUSE_NUM_TEAMS:
+ case OMP_CLAUSE_THREAD_LIMIT:
+ case OMP_CLAUSE_SAFELEN:
wi->val_only = true;
wi->is_lhs = false;
convert_nonlocal_reference_op (&OMP_CLAUSE_OPERAND (clause, 0),
- &dummy, wi);
+ &dummy, wi);
+ break;
+
+ case OMP_CLAUSE_DIST_SCHEDULE:
+ if (OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (clause) != NULL)
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op (&OMP_CLAUSE_OPERAND (clause, 0),
+ &dummy, wi);
+ }
+ break;
+
+ case OMP_CLAUSE_MAP:
+ case OMP_CLAUSE_TO:
+ case OMP_CLAUSE_FROM:
+ if (OMP_CLAUSE_SIZE (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op (&OMP_CLAUSE_SIZE (clause),
+ &dummy, wi);
+ }
+ if (DECL_P (OMP_CLAUSE_DECL (clause)))
+ goto do_decl_clause;
+ wi->val_only = true;
+ wi->is_lhs = false;
+ walk_tree (&OMP_CLAUSE_DECL (clause), convert_nonlocal_reference_op,
+ wi, NULL);
+ break;
+
+ case OMP_CLAUSE_ALIGNED:
+ if (OMP_CLAUSE_ALIGNED_ALIGNMENT (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_nonlocal_reference_op
+ (&OMP_CLAUSE_ALIGNED_ALIGNMENT (clause), &dummy, wi);
+ }
+ /* Like do_decl_clause, but don't add any suppression. */
+ decl = OMP_CLAUSE_DECL (clause);
+ if (TREE_CODE (decl) == VAR_DECL
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ break;
+ if (decl_function_context (decl) != info->context)
+ {
+ OMP_CLAUSE_DECL (clause) = get_nonlocal_debug_decl (info, decl);
+ if (OMP_CLAUSE_CODE (clause) != OMP_CLAUSE_PRIVATE)
+ need_chain = true;
+ }
break;
case OMP_CLAUSE_NOWAIT:
case OMP_CLAUSE_COLLAPSE:
case OMP_CLAUSE_UNTIED:
case OMP_CLAUSE_MERGEABLE:
+ case OMP_CLAUSE_PROC_BIND:
break;
default:
break;
case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ save_suppress = info->suppress_expansion;
+ convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt),
+ wi);
+ info->suppress_expansion = save_suppress;
+ walk_body (convert_nonlocal_reference_stmt,
+ convert_nonlocal_reference_op, info,
+ gimple_omp_body_ptr (stmt));
+ break;
+ }
save_suppress = info->suppress_expansion;
- convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi);
+ if (convert_nonlocal_omp_clauses (gimple_omp_target_clauses_ptr (stmt),
+ wi))
+ {
+ tree c, decl;
+ decl = get_chain_decl (info);
+ c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP);
+ OMP_CLAUSE_DECL (c) = decl;
+ OMP_CLAUSE_MAP_KIND (c) = OMP_CLAUSE_MAP_TO;
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
+ OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt);
+ gimple_omp_target_set_clauses (stmt, c);
+ }
+
+ save_local_var_chain = info->new_local_var_chain;
+ info->new_local_var_chain = NULL;
+
walk_body (convert_nonlocal_reference_stmt, convert_nonlocal_reference_op,
info, gimple_omp_body_ptr (stmt));
+
+ if (info->new_local_var_chain)
+ declare_vars (info->new_local_var_chain,
+ gimple_seq_first_stmt (gimple_omp_body (stmt)),
+ false);
+ info->new_local_var_chain = save_local_var_chain;
info->suppress_expansion = save_suppress;
break;
case OMP_CLAUSE_LINEAR:
if (OMP_CLAUSE_LINEAR_GIMPLE_SEQ (clause))
need_stmts = true;
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_local_reference_op (&OMP_CLAUSE_LINEAR_STEP (clause), &dummy,
+ wi);
goto do_decl_clause;
case OMP_CLAUSE_PRIVATE:
case OMP_CLAUSE_FINAL:
case OMP_CLAUSE_IF:
case OMP_CLAUSE_NUM_THREADS:
+ case OMP_CLAUSE_DEPEND:
+ case OMP_CLAUSE_DEVICE:
+ case OMP_CLAUSE_NUM_TEAMS:
+ case OMP_CLAUSE_THREAD_LIMIT:
+ case OMP_CLAUSE_SAFELEN:
wi->val_only = true;
wi->is_lhs = false;
convert_local_reference_op (&OMP_CLAUSE_OPERAND (clause, 0), &dummy,
wi);
break;
+ case OMP_CLAUSE_DIST_SCHEDULE:
+ if (OMP_CLAUSE_DIST_SCHEDULE_CHUNK_EXPR (clause) != NULL)
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_local_reference_op (&OMP_CLAUSE_OPERAND (clause, 0),
+ &dummy, wi);
+ }
+ break;
+
+ case OMP_CLAUSE_MAP:
+ case OMP_CLAUSE_TO:
+ case OMP_CLAUSE_FROM:
+ if (OMP_CLAUSE_SIZE (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_local_reference_op (&OMP_CLAUSE_SIZE (clause),
+ &dummy, wi);
+ }
+ if (DECL_P (OMP_CLAUSE_DECL (clause)))
+ goto do_decl_clause;
+ wi->val_only = true;
+ wi->is_lhs = false;
+ walk_tree (&OMP_CLAUSE_DECL (clause), convert_local_reference_op,
+ wi, NULL);
+ break;
+
+ case OMP_CLAUSE_ALIGNED:
+ if (OMP_CLAUSE_ALIGNED_ALIGNMENT (clause))
+ {
+ wi->val_only = true;
+ wi->is_lhs = false;
+ convert_local_reference_op
+ (&OMP_CLAUSE_ALIGNED_ALIGNMENT (clause), &dummy, wi);
+ }
+ /* Like do_decl_clause, but don't add any suppression. */
+ decl = OMP_CLAUSE_DECL (clause);
+ if (TREE_CODE (decl) == VAR_DECL
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ break;
+ if (decl_function_context (decl) == info->context
+ && !use_pointer_in_frame (decl))
+ {
+ tree field = lookup_field_for_decl (info, decl, NO_INSERT);
+ if (field)
+ {
+ OMP_CLAUSE_DECL (clause)
+ = get_local_debug_decl (info, decl, field);
+ need_frame = true;
+ }
+ }
+ break;
+
case OMP_CLAUSE_NOWAIT:
case OMP_CLAUSE_ORDERED:
case OMP_CLAUSE_DEFAULT:
case OMP_CLAUSE_COLLAPSE:
case OMP_CLAUSE_UNTIED:
case OMP_CLAUSE_MERGEABLE:
+ case OMP_CLAUSE_PROC_BIND:
break;
default:
break;
case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ save_suppress = info->suppress_expansion;
+ convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi);
+ info->suppress_expansion = save_suppress;
+ walk_body (convert_local_reference_stmt, convert_local_reference_op,
+ info, gimple_omp_body_ptr (stmt));
+ break;
+ }
save_suppress = info->suppress_expansion;
- convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi);
- walk_body (convert_local_reference_stmt, convert_local_reference_op,
- info, gimple_omp_body_ptr (stmt));
+ if (convert_local_omp_clauses (gimple_omp_target_clauses_ptr (stmt), wi))
+ {
+ tree c;
+ (void) get_frame_type (info);
+ c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP);
+ OMP_CLAUSE_DECL (c) = info->frame_decl;
+ OMP_CLAUSE_MAP_KIND (c) = OMP_CLAUSE_MAP_TOFROM;
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (info->frame_decl);
+ OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt);
+ gimple_omp_target_set_clauses (stmt, c);
+ }
+
+ save_local_var_chain = info->new_local_var_chain;
+ info->new_local_var_chain = NULL;
+
+ walk_body (convert_local_reference_stmt, convert_local_reference_op, info,
+ gimple_omp_body_ptr (stmt));
+
+ if (info->new_local_var_chain)
+ declare_vars (info->new_local_var_chain,
+ gimple_seq_first_stmt (gimple_omp_body (stmt)), false);
+ info->new_local_var_chain = save_local_var_chain;
info->suppress_expansion = save_suppress;
break;
break;
}
+ case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ *handled_ops_p = false;
+ return NULL_TREE;
+ }
+ /* FALLTHRU */
case GIMPLE_OMP_PARALLEL:
case GIMPLE_OMP_TASK:
{
default:
*handled_ops_p = false;
return NULL_TREE;
- break;
}
*handled_ops_p = true;
info->static_chain_added |= save_static_chain_added;
break;
+ case GIMPLE_OMP_TARGET:
+ if (gimple_omp_target_kind (stmt) != GF_OMP_TARGET_KIND_REGION)
+ {
+ walk_body (convert_gimple_call, NULL, info, gimple_omp_body_ptr (stmt));
+ break;
+ }
+ save_static_chain_added = info->static_chain_added;
+ info->static_chain_added = 0;
+ walk_body (convert_gimple_call, NULL, info, gimple_omp_body_ptr (stmt));
+ for (i = 0; i < 2; i++)
+ {
+ tree c, decl;
+ if ((info->static_chain_added & (1 << i)) == 0)
+ continue;
+ decl = i ? get_chain_decl (info) : info->frame_decl;
+ /* Don't add CHAIN.* or FRAME.* twice. */
+ for (c = gimple_omp_target_clauses (stmt);
+ c;
+ c = OMP_CLAUSE_CHAIN (c))
+ if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_MAP
+ && OMP_CLAUSE_DECL (c) == decl)
+ break;
+ if (c == NULL)
+ {
+ c = build_omp_clause (gimple_location (stmt), OMP_CLAUSE_MAP);
+ OMP_CLAUSE_DECL (c) = decl;
+ OMP_CLAUSE_MAP_KIND (c)
+ = i ? OMP_CLAUSE_MAP_TO : OMP_CLAUSE_MAP_TOFROM;
+ OMP_CLAUSE_SIZE (c) = DECL_SIZE_UNIT (decl);
+ OMP_CLAUSE_CHAIN (c) = gimple_omp_target_clauses (stmt);
+ gimple_omp_target_set_clauses (stmt, c);
+ }
+ }
+ info->static_chain_added |= save_static_chain_added;
+ break;
+
case GIMPLE_OMP_FOR:
walk_body (convert_gimple_call, NULL, info,
gimple_omp_for_pre_body_ptr (stmt));
case GIMPLE_OMP_SECTIONS:
case GIMPLE_OMP_SECTION:
case GIMPLE_OMP_SINGLE:
- case GIMPLE_OMP_TARGET:
case GIMPLE_OMP_TEAMS:
case GIMPLE_OMP_MASTER:
case GIMPLE_OMP_TASKGROUP:
pp_string (buffer, "alloc");
break;
case OMP_CLAUSE_MAP_TO:
+ case OMP_CLAUSE_MAP_TO_PSET:
pp_string (buffer, "to");
break;
case OMP_CLAUSE_MAP_FROM:
if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
&& OMP_CLAUSE_MAP_KIND (clause) == OMP_CLAUSE_MAP_POINTER)
pp_string (buffer, " [pointer assign, bias: ");
+ else if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
+ && OMP_CLAUSE_MAP_KIND (clause) == OMP_CLAUSE_MAP_TO_PSET)
+ pp_string (buffer, " [pointer set, len: ");
else
pp_string (buffer, " [len: ");
dump_generic_node (buffer, OMP_CLAUSE_SIZE (clause),
while (is_gimple_assign (stmt)
&& ((CONVERT_EXPR_CODE_P (gimple_assign_rhs_code (stmt))
&& (TYPE_PRECISION (TREE_TYPE (gimple_assign_lhs (stmt)))
- <= TYPE_PRECISION (TREE_TYPE (gimple_assign_rhs1 (stmt)))))
+ <= TYPE_PRECISION (TREE_TYPE (gimple_assign_rhs1 (stmt))))
+ && TREE_CODE (gimple_assign_rhs1 (stmt)) == SSA_NAME)
|| gimple_assign_ssa_name_copy_p (stmt)))
stmt = SSA_NAME_DEF_STMT (gimple_assign_rhs1 (stmt));
struct symbolic_number {
unsigned HOST_WIDEST_INT n;
- int size;
+ tree type;
};
/* Perform a SHIFT or ROTATE operation by COUNT bits on symbolic
struct symbolic_number *n,
int count)
{
+ int bitsize = TYPE_PRECISION (n->type);
+
if (count % 8 != 0)
return false;
/* Zero out the extra bits of N in order to avoid them being shifted
into the significant bits. */
- if (n->size < (int)sizeof (HOST_WIDEST_INT))
- n->n &= ((unsigned HOST_WIDEST_INT)1 << (n->size * BITS_PER_UNIT)) - 1;
+ if (bitsize < 8 * (int)sizeof (HOST_WIDEST_INT))
+ n->n &= ((unsigned HOST_WIDEST_INT)1 << bitsize) - 1;
switch (code)
{
n->n <<= count;
break;
case RSHIFT_EXPR:
+ /* Arithmetic shift of signed type: result is dependent on the value. */
+ if (!TYPE_UNSIGNED (n->type)
+ && (n->n & ((unsigned HOST_WIDEST_INT) 0xff << (bitsize - 8))))
+ return false;
n->n >>= count;
break;
case LROTATE_EXPR:
- n->n = (n->n << count) | (n->n >> ((n->size * BITS_PER_UNIT) - count));
+ n->n = (n->n << count) | (n->n >> (bitsize - count));
break;
case RROTATE_EXPR:
- n->n = (n->n >> count) | (n->n << ((n->size * BITS_PER_UNIT) - count));
+ n->n = (n->n >> count) | (n->n << (bitsize - count));
break;
default:
return false;
}
/* Zero unused bits for size. */
- if (n->size < (int)sizeof (HOST_WIDEST_INT))
- n->n &= ((unsigned HOST_WIDEST_INT)1 << (n->size * BITS_PER_UNIT)) - 1;
+ if (bitsize < 8 * (int)sizeof (HOST_WIDEST_INT))
+ n->n &= ((unsigned HOST_WIDEST_INT)1 << bitsize) - 1;
return true;
}
if (TREE_CODE (lhs_type) != INTEGER_TYPE)
return false;
- if (TYPE_PRECISION (lhs_type) != n->size * BITS_PER_UNIT)
+ if (TYPE_PRECISION (lhs_type) != TYPE_PRECISION (n->type))
return false;
return true;
to initialize the symbolic number. */
if (!source_expr1)
{
+ int size;
+
/* Set up the symbolic number N by setting each byte to a
value between 1 and the byte size of rhs1. The highest
order byte is set to n->size and the lowest order
byte to 1. */
- n->size = TYPE_PRECISION (TREE_TYPE (rhs1));
- if (n->size % BITS_PER_UNIT != 0)
+ n->type = TREE_TYPE (rhs1);
+ size = TYPE_PRECISION (n->type);
+ if (size % BITS_PER_UNIT != 0)
return NULL_TREE;
- n->size /= BITS_PER_UNIT;
+ size /= BITS_PER_UNIT;
n->n = (sizeof (HOST_WIDEST_INT) < 8 ? 0 :
(unsigned HOST_WIDEST_INT)0x08070605 << 32 | 0x04030201);
- if (n->size < (int)sizeof (HOST_WIDEST_INT))
+ if (size < (int)sizeof (HOST_WIDEST_INT))
n->n &= ((unsigned HOST_WIDEST_INT)1 <<
- (n->size * BITS_PER_UNIT)) - 1;
+ (size * BITS_PER_UNIT)) - 1;
source_expr1 = rhs1;
}
{
case BIT_AND_EXPR:
{
- int i;
+ int i, size = TYPE_PRECISION (n->type) / BITS_PER_UNIT;
unsigned HOST_WIDEST_INT val = widest_int_cst_value (rhs2);
unsigned HOST_WIDEST_INT tmp = val;
/* Only constants masking full bytes are allowed. */
- for (i = 0; i < n->size; i++, tmp >>= BITS_PER_UNIT)
+ for (i = 0; i < size; i++, tmp >>= BITS_PER_UNIT)
if ((tmp & 0xff) != 0 && (tmp & 0xff) != 0xff)
return NULL_TREE;
break;
CASE_CONVERT:
{
- int type_size;
+ int type_size, old_type_size;
+ tree type;
- type_size = TYPE_PRECISION (gimple_expr_type (stmt));
+ type = gimple_expr_type (stmt);
+ type_size = TYPE_PRECISION (type);
if (type_size % BITS_PER_UNIT != 0)
return NULL_TREE;
+ /* Sign extension: result is dependent on the value. */
+ old_type_size = TYPE_PRECISION (n->type);
+ if (!TYPE_UNSIGNED (n->type)
+ && type_size > old_type_size
+ && n->n &
+ ((unsigned HOST_WIDEST_INT) 0xff << (old_type_size - 8)))
+ return NULL_TREE;
+
if (type_size / BITS_PER_UNIT < (int)(sizeof (HOST_WIDEST_INT)))
{
/* If STMT casts to a smaller type mask out the bits not
belonging to the target type. */
n->n &= ((unsigned HOST_WIDEST_INT)1 << type_size) - 1;
}
- n->size = type_size / BITS_PER_UNIT;
+ n->type = type;
}
break;
default:
if (rhs_class == GIMPLE_BINARY_RHS)
{
- int i;
+ int i, size;
struct symbolic_number n1, n2;
unsigned HOST_WIDEST_INT mask;
tree source_expr2;
source_expr2 = find_bswap_1 (rhs2_stmt, &n2, limit - 1);
if (source_expr1 != source_expr2
- || n1.size != n2.size)
+ || TYPE_PRECISION (n1.type) != TYPE_PRECISION (n2.type))
return NULL_TREE;
- n->size = n1.size;
- for (i = 0, mask = 0xff; i < n->size; i++, mask <<= BITS_PER_UNIT)
+ n->type = n1.type;
+ size = TYPE_PRECISION (n->type) / BITS_PER_UNIT;
+ for (i = 0, mask = 0xff; i < size; i++, mask <<= BITS_PER_UNIT)
{
unsigned HOST_WIDEST_INT masked1, masked2;
struct symbolic_number n;
tree source_expr;
- int limit;
+ int limit, bitsize;
/* The last parameter determines the depth search limit. It usually
correlates directly to the number of bytes to be touched. We
return NULL_TREE;
/* Zero out the extra bits of N and CMP. */
- if (n.size < (int)sizeof (HOST_WIDEST_INT))
+ bitsize = TYPE_PRECISION (n.type);
+ if (bitsize < 8 * (int)sizeof (HOST_WIDEST_INT))
{
unsigned HOST_WIDEST_INT mask =
- ((unsigned HOST_WIDEST_INT)1 << (n.size * BITS_PER_UNIT)) - 1;
+ ((unsigned HOST_WIDEST_INT)1 << bitsize) - 1;
n.n &= mask;
- cmp >>= (sizeof (HOST_WIDEST_INT) - n.size) * BITS_PER_UNIT;
+ cmp >>= sizeof (HOST_WIDEST_INT) * BITS_PER_UNIT - bitsize;
}
/* A complete byte swap should make the symbolic number to start
pt->ipa_escaped = 1;
else
pt->escaped = 1;
+ /* Expand some special vars of ESCAPED in-place here. */
+ varinfo_t evi = get_varinfo (find (escaped_id));
+ if (bitmap_bit_p (evi->solution, nonlocal_id))
+ pt->nonlocal = 1;
}
else if (vi->id == nonlocal_id)
pt->nonlocal = 1;
.. = a[i+1];
where we will end up loading { a[i], a[i+1] } once, make
sure that inserting group loads before the first load and
- stores after the last store will do the right thing. */
- if ((STMT_VINFO_GROUPED_ACCESS (stmtinfo_a)
- && GROUP_SAME_DR_STMT (stmtinfo_a))
- || (STMT_VINFO_GROUPED_ACCESS (stmtinfo_b)
- && GROUP_SAME_DR_STMT (stmtinfo_b)))
+ stores after the last store will do the right thing.
+ Similar for groups like
+ a[i] = ...;
+ ... = a[i];
+ a[i+1] = ...;
+ where loads from the group interleave with the store. */
+ if (STMT_VINFO_GROUPED_ACCESS (stmtinfo_a)
+ || STMT_VINFO_GROUPED_ACCESS (stmtinfo_b))
{
gimple earlier_stmt;
earlier_stmt = get_earlier_stmt (DR_STMT (dra), DR_STMT (drb));
update_stmt (gsi_stmt (*gsi));
}
+/* Return type in which CODE operation with optab OP can be
+ computed. */
+
+static tree
+get_compute_type (enum tree_code code, optab op, tree type)
+{
+ /* For very wide vectors, try using a smaller vector mode. */
+ tree compute_type = type;
+ if (op
+ && (!VECTOR_MODE_P (TYPE_MODE (type))
+ || optab_handler (op, TYPE_MODE (type)) == CODE_FOR_nothing))
+ {
+ tree vector_compute_type
+ = type_for_widest_vector_mode (TREE_TYPE (type), op);
+ if (vector_compute_type != NULL_TREE
+ && (TYPE_VECTOR_SUBPARTS (vector_compute_type)
+ < TYPE_VECTOR_SUBPARTS (compute_type))
+ && (optab_handler (op, TYPE_MODE (vector_compute_type))
+ != CODE_FOR_nothing))
+ compute_type = vector_compute_type;
+ }
+
+ /* If we are breaking a BLKmode vector into smaller pieces,
+ type_for_widest_vector_mode has already looked into the optab,
+ so skip these checks. */
+ if (compute_type == type)
+ {
+ enum machine_mode compute_mode = TYPE_MODE (compute_type);
+ if (VECTOR_MODE_P (compute_mode))
+ {
+ if (op && optab_handler (op, compute_mode) != CODE_FOR_nothing)
+ return compute_type;
+ if (code == MULT_HIGHPART_EXPR
+ && can_mult_highpart_p (compute_mode,
+ TYPE_UNSIGNED (compute_type)))
+ return compute_type;
+ }
+ /* There is no operation in hardware, so fall back to scalars. */
+ compute_type = TREE_TYPE (type);
+ }
+
+ return compute_type;
+}
+
+/* Helper function of expand_vector_operations_1. Return number of
+ vector elements for vector types or 1 for other types. */
+
+static inline int
+count_type_subparts (tree type)
+{
+ return VECTOR_TYPE_P (type) ? TYPE_VECTOR_SUBPARTS (type) : 1;
+}
+
/* Process one statement. If we identify a vector operation, expand it. */
static void
expand_vector_operations_1 (gimple_stmt_iterator *gsi)
{
gimple stmt = gsi_stmt (*gsi);
- tree lhs, rhs1, rhs2 = NULL, type, compute_type;
+ tree lhs, rhs1, rhs2 = NULL, type, compute_type = NULL_TREE;
enum tree_code code;
- enum machine_mode compute_mode;
optab op = unknown_optab;
enum gimple_rhs_class rhs_class;
tree new_rhs;
{
op = optab_for_tree_code (code, type, optab_scalar);
+ compute_type = get_compute_type (code, op, type);
+ if (compute_type == type)
+ return;
/* The rtl expander will expand vector/scalar as vector/vector
- if necessary. Don't bother converting the stmt here. */
- if (optab_handler (op, TYPE_MODE (type)) == CODE_FOR_nothing
- && optab_handler (opv, TYPE_MODE (type)) != CODE_FOR_nothing)
+ if necessary. Pick one with wider vector type. */
+ tree compute_vtype = get_compute_type (code, opv, type);
+ if (count_type_subparts (compute_vtype)
+ > count_type_subparts (compute_type))
+ {
+ compute_type = compute_vtype;
+ op = opv;
+ }
+ }
+
+ if (code == LROTATE_EXPR || code == RROTATE_EXPR)
+ {
+ if (compute_type == NULL_TREE)
+ compute_type = get_compute_type (code, op, type);
+ if (compute_type == type)
return;
+ /* Before splitting vector rotates into scalar rotates,
+ see if we can't use vector shifts and BIT_IOR_EXPR
+ instead. For vector by vector rotates we'd also
+ need to check BIT_AND_EXPR and NEGATE_EXPR, punt there
+ for now, fold doesn't seem to create such rotates anyway. */
+ if (compute_type == TREE_TYPE (type)
+ && !VECTOR_INTEGER_TYPE_P (TREE_TYPE (rhs2)))
+ {
+ optab oplv = vashl_optab, opl = ashl_optab;
+ optab oprv = vlshr_optab, opr = lshr_optab, opo = ior_optab;
+ tree compute_lvtype = get_compute_type (LSHIFT_EXPR, oplv, type);
+ tree compute_rvtype = get_compute_type (RSHIFT_EXPR, oprv, type);
+ tree compute_otype = get_compute_type (BIT_IOR_EXPR, opo, type);
+ tree compute_ltype = get_compute_type (LSHIFT_EXPR, opl, type);
+ tree compute_rtype = get_compute_type (RSHIFT_EXPR, opr, type);
+ /* The rtl expander will expand vector/scalar as vector/vector
+ if necessary. Pick one with wider vector type. */
+ if (count_type_subparts (compute_lvtype)
+ > count_type_subparts (compute_ltype))
+ {
+ compute_ltype = compute_lvtype;
+ opl = oplv;
+ }
+ if (count_type_subparts (compute_rvtype)
+ > count_type_subparts (compute_rtype))
+ {
+ compute_rtype = compute_rvtype;
+ opr = oprv;
+ }
+ /* Pick the narrowest type from LSHIFT_EXPR, RSHIFT_EXPR and
+ BIT_IOR_EXPR. */
+ compute_type = compute_ltype;
+ if (count_type_subparts (compute_type)
+ > count_type_subparts (compute_rtype))
+ compute_type = compute_rtype;
+ if (count_type_subparts (compute_type)
+ > count_type_subparts (compute_otype))
+ compute_type = compute_otype;
+ /* Verify all 3 operations can be performed in that type. */
+ if (compute_type != TREE_TYPE (type))
+ {
+ if (optab_handler (opl, TYPE_MODE (compute_type))
+ == CODE_FOR_nothing
+ || optab_handler (opr, TYPE_MODE (compute_type))
+ == CODE_FOR_nothing
+ || optab_handler (opo, TYPE_MODE (compute_type))
+ == CODE_FOR_nothing)
+ compute_type = TREE_TYPE (type);
+ }
+ }
}
}
else
&& INTEGRAL_TYPE_P (TREE_TYPE (type)))
op = optab_for_tree_code (MINUS_EXPR, type, optab_default);
- /* For very wide vectors, try using a smaller vector mode. */
- compute_type = type;
- if (!VECTOR_MODE_P (TYPE_MODE (type)) && op)
- {
- tree vector_compute_type
- = type_for_widest_vector_mode (TREE_TYPE (type), op);
- if (vector_compute_type != NULL_TREE
- && (TYPE_VECTOR_SUBPARTS (vector_compute_type)
- < TYPE_VECTOR_SUBPARTS (compute_type))
- && (optab_handler (op, TYPE_MODE (vector_compute_type))
- != CODE_FOR_nothing))
- compute_type = vector_compute_type;
- }
-
- /* If we are breaking a BLKmode vector into smaller pieces,
- type_for_widest_vector_mode has already looked into the optab,
- so skip these checks. */
+ if (compute_type == NULL_TREE)
+ compute_type = get_compute_type (code, op, type);
if (compute_type == type)
- {
- compute_mode = TYPE_MODE (compute_type);
- if (VECTOR_MODE_P (compute_mode))
- {
- if (op && optab_handler (op, compute_mode) != CODE_FOR_nothing)
- return;
- if (code == MULT_HIGHPART_EXPR
- && can_mult_highpart_p (compute_mode,
- TYPE_UNSIGNED (compute_type)))
- return;
- }
- /* There is no operation in hardware, so fall back to scalars. */
- compute_type = TREE_TYPE (type);
- }
+ return;
gcc_assert (code != VEC_LSHIFT_EXPR && code != VEC_RSHIFT_EXPR);
new_rhs = expand_vector_operation (gsi, type, compute_type, stmt, code);
/* If arg is non-zero, then ffs or popcount
are non-zero. */
if (((vr0->type == VR_RANGE
- && integer_nonzerop (vr0->min))
+ && range_includes_zero_p (vr0->min, vr0->max) == 0)
|| (vr0->type == VR_ANTI_RANGE
- && integer_zerop (vr0->min)))
- && !is_overflow_infinity (vr0->min))
+ && range_includes_zero_p (vr0->min, vr0->max) == 1))
+ && !is_overflow_infinity (vr0->min)
+ && !is_overflow_infinity (vr0->max))
mini = 1;
/* If some high bits are known to be zero,
we can decrease the maximum. */
if (vr0->type == VR_RANGE
&& TREE_CODE (vr0->max) == INTEGER_CST
+ && !operand_less_p (vr0->min,
+ build_zero_cst (TREE_TYPE (vr0->min)))
&& !is_overflow_infinity (vr0->max))
maxi = tree_floor_log2 (vr0->max) + 1;
}
4, /* OMP_CLAUSE_REDUCTION */
1, /* OMP_CLAUSE_COPYIN */
1, /* OMP_CLAUSE_COPYPRIVATE */
- 2, /* OMP_CLAUSE_LINEAR */
+ 3, /* OMP_CLAUSE_LINEAR */
2, /* OMP_CLAUSE_ALIGNED */
1, /* OMP_CLAUSE_DEPEND */
1, /* OMP_CLAUSE_UNIFORM */
WALK_SUBTREE_TAIL (OMP_CLAUSE_CHAIN (*tp));
}
- case OMP_CLAUSE_ALIGNED:
case OMP_CLAUSE_LINEAR:
+ WALK_SUBTREE (OMP_CLAUSE_DECL (*tp));
+ WALK_SUBTREE (OMP_CLAUSE_LINEAR_STEP (*tp));
+ WALK_SUBTREE (OMP_CLAUSE_LINEAR_STMT (*tp));
+ WALK_SUBTREE_TAIL (OMP_CLAUSE_CHAIN (*tp));
+
+ case OMP_CLAUSE_ALIGNED:
case OMP_CLAUSE_FROM:
case OMP_CLAUSE_TO:
case OMP_CLAUSE_MAP:
#define OMP_CLAUSE_LINEAR_VARIABLE_STRIDE(NODE) \
TREE_PROTECTED (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LINEAR))
+/* True if a LINEAR clause is for an array or allocatable variable that
+ needs special handling by the frontend. */
+#define OMP_CLAUSE_LINEAR_ARRAY(NODE) \
+ (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LINEAR)->base.deprecated_flag)
+
#define OMP_CLAUSE_LINEAR_STEP(NODE) \
OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LINEAR), 1)
+#define OMP_CLAUSE_LINEAR_STMT(NODE) \
+ OMP_CLAUSE_OPERAND (OMP_CLAUSE_SUBCODE_CHECK (NODE, OMP_CLAUSE_LINEAR), 2)
+
#define OMP_CLAUSE_LINEAR_GIMPLE_SEQ(NODE) \
(OMP_CLAUSE_CHECK (NODE))->omp_clause.gimple_reduction_init
+2014-07-09 Edward Smith-Rowland <3dw4rd@verizon.net>
+
+ PR c++/58155 - -Wliteral-suffix warns about tokens which are skipped
+ by preprocessor
+ * lex.c (lex_raw_string ()): Do not warn about invalid suffix
+ if skipping. (lex_string ()): Ditto.
+
2014-04-22 Release Manager
* GCC 4.9.0 released.
if (is_macro (pfile, cur))
{
/* Raise a warning, but do not consume subsequent tokens. */
- if (CPP_OPTION (pfile, warn_literal_suffix))
+ if (CPP_OPTION (pfile, warn_literal_suffix) && !pfile->state.skipping)
cpp_warning_with_line (pfile, CPP_W_LITERAL_SUFFIX,
token->src_loc, 0,
"invalid suffix on literal; C++11 requires "
if (is_macro (pfile, cur))
{
/* Raise a warning, but do not consume subsequent tokens. */
- if (CPP_OPTION (pfile, warn_literal_suffix))
+ if (CPP_OPTION (pfile, warn_literal_suffix) && !pfile->state.skipping)
cpp_warning_with_line (pfile, CPP_W_LITERAL_SUFFIX,
token->src_loc, 0,
"invalid suffix on literal; C++11 requires "
+2014-07-06 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ Backport from trunk.
+ PR libgfortran/61640
+ * io/list_read.c (next_char_internal): Adjust the read length to
+ a single wide character. (eat_spaces): Add missing paren.
+ * io/unix.c (mem_read4): Use the correct mem_alloc function for
+ wide character internal reads.
+
+2014-06-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ Backport from trunk.
+ PR libgfortran/61499
+ * io/list_read.c (eat_spaces): Use a 'for' loop instead of
+ 'while' loop to skip the loop if there are no bytes left in the
+ string. Only seek if actual spaces can be skipped.
+
2014-06-07 Jerry DeLisle <jvdelisle@gcc.gnu>
Backport from trunk.
{
/* Check for kind=4 internal unit. */
if (dtp->common.unit)
- length = sread (dtp->u.p.current_unit->s, &c, sizeof (gfc_char4_t));
+ length = sread (dtp->u.p.current_unit->s, &c, 1);
else
{
char cc;
int c;
/* If internal character array IO, peak ahead and seek past spaces.
- This is an optimazation to eliminate numerous calls to
- next character unique to character arrays with large character
- lengths (PR38199). */
- if (is_array_io (dtp))
+ This is an optimization unique to character arrays with large
+ character lengths (PR38199). This code eliminates numerous calls
+ to next_character. */
+ if (is_array_io (dtp) && (dtp->u.p.last_char == EOF - 1))
{
gfc_offset offset = stell (dtp->u.p.current_unit->s);
- gfc_offset limit = offset + dtp->u.p.current_unit->bytes_left;
+ gfc_offset i;
if (dtp->common.unit) /* kind=4 */
{
- gfc_char4_t cc;
- limit *= (sizeof (gfc_char4_t));
- do
+ for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++)
{
- cc = dtp->internal_unit[offset];
- offset += (sizeof (gfc_char4_t));
- dtp->u.p.current_unit->bytes_left--;
+ if (dtp->internal_unit[(offset + i) * sizeof (gfc_char4_t)]
+ != (gfc_char4_t)' ')
+ break;
}
- while (offset < limit && cc == (gfc_char4_t)' ');
- /* Back up, seek ahead, and fall through to complete the
- process so that END conditions are handled correctly. */
- dtp->u.p.current_unit->bytes_left++;
-
- cc = dtp->internal_unit[offset];
- if (cc != (gfc_char4_t)' ')
- sseek (dtp->u.p.current_unit->s,
- offset-(sizeof (gfc_char4_t)), SEEK_SET);
}
else
{
- do
+ for (i = 0; i < dtp->u.p.current_unit->bytes_left; i++)
{
- c = dtp->internal_unit[offset++];
- dtp->u.p.current_unit->bytes_left--;
+ if (dtp->internal_unit[offset + i] != ' ')
+ break;
}
- while (offset < limit && c == ' ');
- /* Back up, seek ahead, and fall through to complete the
- process so that END conditions are handled correctly. */
- dtp->u.p.current_unit->bytes_left++;
+ }
- if (dtp->internal_unit[offset] != ' ')
- sseek (dtp->u.p.current_unit->s, offset - 1, SEEK_SET);
+ if (i != 0)
+ {
+ sseek (dtp->u.p.current_unit->s, offset + i, SEEK_SET);
+ dtp->u.p.current_unit->bytes_left -= i;
}
}
+
/* Now skip spaces, EOF and EOL are handled in next_char. */
do
c = next_char (dtp);
void *p;
int nb = nbytes;
- p = mem_alloc_r (s, &nb);
+ p = mem_alloc_r4 (s, &nb);
if (p)
{
- memcpy (buf, p, nb);
+ memcpy (buf, p, nb * 4);
return (ssize_t) nb;
}
else
+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.
+
2014-06-24 Jakub Jelinek <jakub@redhat.com>
* testsuite/libgomp.c/for-2.c: Define SC to static for
module omp_lib
use omp_lib_kinds
implicit none
- integer, parameter :: openmp_version = 201107
+ integer, parameter :: openmp_version = 201307
interface
subroutine omp_init_lock (svar)
parameter (omp_proc_bind_master = 2)
parameter (omp_proc_bind_close = 3)
parameter (omp_proc_bind_spread = 4)
- parameter (openmp_version = 201107)
+ parameter (openmp_version = 201307)
external omp_init_lock, omp_init_nest_lock
external omp_destroy_lock, omp_destroy_nest_lock
--- /dev/null
+/* { dg-do run } */
+/* { dg-options "-fopenmp" } */
+
+void
+foo (int *p)
+{
+ int i;
+ #pragma omp parallel
+ #pragma omp single
+ #pragma omp target teams distribute parallel for map(p[0:24])
+ for (i = 0; i < 24; i++)
+ p[i] = p[i] + 1;
+}
+
+int
+main ()
+{
+ int p[24], i;
+ for (i = 0; i < 24; i++)
+ p[i] = i;
+ foo (p);
+ for (i = 0; i < 24; i++)
+ if (p[i] != i + 1)
+ __builtin_abort ();
+ return 0;
+}
--- /dev/null
+! { dg-do run }
+! { dg-options "-fopenmp -fcray-pointer" }
+
+ use iso_c_binding, only : c_ptr, c_ptrdiff_t, c_loc
+ interface
+ subroutine foo (x, y, z, w)
+ use iso_c_binding, only : c_ptr
+ real, pointer :: x(:), y(:), w(:)
+ type(c_ptr) :: z
+ end subroutine
+ subroutine bar (x, y, z, w)
+ use iso_c_binding, only : c_ptr
+ real, pointer :: x(:), y(:), w(:)
+ type(c_ptr) :: z
+ end subroutine
+ subroutine baz (x, c)
+ real, pointer :: x(:)
+ real, allocatable :: c(:)
+ end subroutine
+ end interface
+ type dt
+ real, allocatable :: a(:)
+ end type
+ type (dt) :: b(64)
+ real, target :: a(4096+63)
+ real, pointer :: p(:), q(:), r(:), s(:)
+ real, allocatable :: c(:)
+ integer(c_ptrdiff_t) :: o
+ integer :: i
+ o = 64 - mod (loc (a), 64)
+ if (o == 64) o = 0
+ o = o / sizeof(0.0)
+ p => a(o + 1:o + 1024)
+ q => a(o + 1025:o + 2048)
+ r => a(o + 2049:o + 3072)
+ s => a(o + 3073:o + 4096)
+ do i = 1, 1024
+ p(i) = i
+ q(i) = i
+ r(i) = i
+ s(i) = i
+ end do
+ call foo (p, q, c_loc (r(1)), s)
+ do i = 1, 1024
+ if (p(i) /= i * i + 3 * i + 2) call abort
+ p(i) = i
+ end do
+ call bar (p, q, c_loc (r(1)), s)
+ do i = 1, 1024
+ if (p(i) /= i * i + 3 * i + 2) call abort
+ end do
+ ! Attempt to create 64-byte aligned allocatable
+ do i = 1, 64
+ allocate (c(1023 + i))
+ if (iand (loc (c(1)), 63) == 0) exit
+ deallocate (c)
+ allocate (b(i)%a(1023 + i))
+ allocate (c(1023 + i))
+ if (iand (loc (c(1)), 63) == 0) exit
+ deallocate (c)
+ end do
+ if (allocated (c)) then
+ do i = 1, 1024
+ c(i) = 2 * i
+ end do
+ call baz (p, c)
+ do i = 1, 1024
+ if (p(i) /= i * i + 5 * i + 2) call abort
+ end do
+ end if
+end
+subroutine foo (x, y, z, w)
+ use iso_c_binding, only : c_ptr, c_f_pointer
+ real, pointer :: x(:), y(:), w(:), p(:)
+ type(c_ptr) :: z
+ integer :: i
+ real :: pt(1024)
+ pointer (ip, pt)
+ ip = loc (w)
+!$omp simd aligned (x, y : 64)
+ do i = 1, 1024
+ x(i) = x(i) * y(i) + 2.0
+ end do
+!$omp simd aligned (x, z : 64) private (p)
+ do i = 1, 1024
+ call c_f_pointer (z, p, shape=[1024])
+ x(i) = x(i) + p(i)
+ end do
+!$omp simd aligned (x, ip : 64)
+ do i = 1, 1024
+ x(i) = x(i) + 2 * pt(i)
+ end do
+!$omp end simd
+end subroutine
+subroutine bar (x, y, z, w)
+ use iso_c_binding, only : c_ptr, c_f_pointer
+ real, pointer :: x(:), y(:), w(:), a(:), b(:)
+ type(c_ptr) :: z, c
+ integer :: i
+ real :: pt(1024)
+ pointer (ip, pt)
+ ip = loc (w)
+ a => x
+ b => y
+ c = z
+!$omp simd aligned (a, b : 64)
+ do i = 1, 1024
+ a(i) = a(i) * b(i) + 2.0
+ end do
+!$omp simd aligned (a, c : 64)
+ do i = 1, 1024
+ block
+ real, pointer :: p(:)
+ call c_f_pointer (c, p, shape=[1024])
+ a(i) = a(i) + p(i)
+ end block
+ end do
+!$omp simd aligned (a, ip : 64)
+ do i = 1, 1024
+ a(i) = a(i) + 2 * pt(i)
+ end do
+!$omp end simd
+end subroutine
+subroutine baz (x, c)
+ real, pointer :: x(:)
+ real, allocatable :: c(:)
+ integer :: i
+!$omp simd aligned (x, c : 64)
+ do i = 1, 1024
+ x(i) = x(i) + c(i)
+ end do
+!$omp end simd
+end subroutine baz
--- /dev/null
+! { dg-do run }
+! Don't cycle by default through all options, just test -O0 and -O2,
+! as this is quite large test.
+! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
+
+module m
+ type dl
+ integer :: a, b
+ integer, allocatable :: c(:,:)
+ integer :: d, e
+ integer, allocatable :: f
+ end type
+ type dt
+ integer :: g
+ type (dl), allocatable :: h(:)
+ integer :: i
+ type (dl) :: j(2, 2)
+ type (dl), allocatable :: k
+ end type
+contains
+ subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+ type (dl), intent (in) :: obj
+ integer, intent (in) :: val, cl1, cu1, cl2, cu2
+ logical, intent (in) :: c, f
+ if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
+ if (c) then
+ if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
+ if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
+ end if
+ if (val /= 0) then
+ if (obj%a /= val .or. obj%b /= val) call abort
+ if (obj%d /= val .or. obj%e /= val) call abort
+ if (c) then
+ if (any (obj%c /= val)) call abort
+ end if
+ if (f) then
+ if (obj%f /= val) call abort
+ end if
+ end if
+ end subroutine ver_dl
+ subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+ type (dt), intent (in) :: obj
+ integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+ logical, intent (in) :: h, k, c, f
+ integer :: i, j
+ if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
+ if (h) then
+ if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
+ do i = hl, hu
+ call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end if
+ do i = 1, 2
+ do j = 1, 2
+ call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end do
+ if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+ if (val /= 0) then
+ if (obj%g /= val .or. obj%i /= val) call abort
+ end if
+ end subroutine ver_dt
+ subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+ type (dl), intent (inout) :: obj
+ integer, intent (in) :: val, cl1, cu1, cl2, cu2
+ logical, intent (in) :: c, f
+ if (val /= 0) then
+ obj%a = val
+ obj%b = val
+ obj%d = val
+ obj%e = val
+ end if
+ if (allocated (obj%c)) deallocate (obj%c)
+ if (c) then
+ allocate (obj%c(cl1:cu1, cl2:cu2))
+ if (val /= 0) obj%c = val
+ end if
+ if (f) then
+ if (.not.allocated (obj%f)) allocate (obj%f)
+ if (val /= 0) obj%f = val
+ else
+ if (allocated (obj%f)) deallocate (obj%f)
+ end if
+ end subroutine alloc_dl
+ subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+ type (dt), intent (inout) :: obj
+ integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+ logical, intent (in) :: h, k, c, f
+ integer :: i, j
+ if (val /= 0) then
+ obj%g = val
+ obj%i = val
+ end if
+ if (allocated (obj%h)) deallocate (obj%h)
+ if (h) then
+ allocate (obj%h(hl:hu))
+ do i = hl, hu
+ call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end if
+ do i = 1, 2
+ do j = 1, 2
+ call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end do
+ if (k) then
+ if (.not.allocated (obj%k)) allocate (obj%k)
+ call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+ else
+ if (allocated (obj%k)) deallocate (obj%k)
+ end if
+ end subroutine alloc_dt
+end module m
+ use m
+ type (dt) :: y
+ call foo (y)
+contains
+ subroutine foo (y)
+ use m
+ type (dt) :: x, y, z(-3:-3,2:3)
+ logical, parameter :: F = .false.
+ logical, parameter :: T = .true.
+ logical :: l
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (x, y, z)
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp end parallel
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp parallel private (x, y, z)
+ call ver_dt (x, 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ deallocate (x%h, x%k)
+ deallocate (y%h)
+ allocate (y%k)
+ call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ deallocate (z(-3,2)%h, z(-3,2)%k)
+ deallocate (z(-3,3)%h)
+ allocate (z(-3,3)%k)
+!$omp end parallel
+ call alloc_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+!$omp parallel firstprivate (x, y, z)
+ call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+!$omp end parallel
+ call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel firstprivate (x, y, z)
+ call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+!$omp end parallel
+ call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+ if (l) then
+ call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ else
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ end if
+ l = T
+ call alloc_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call alloc_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+!$omp section
+ if (l) then
+ call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ else
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ end if
+ l = T
+ call alloc_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call alloc_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp section
+!$omp end parallel sections
+ call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+ if (l) then
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ else
+ call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ end if
+ l = T
+ call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp section
+ if (l) then
+ call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ else
+ call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ end if
+ l = T
+ call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp parallel private (x, y, z)
+ call ver_dt (x, 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp single
+ call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end single copyprivate (x, y, z)
+ call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end parallel
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ end subroutine foo
+end
--- /dev/null
+! { dg-do run }
+! Don't cycle by default through all options, just test -O0 and -O2,
+! as this is quite large test.
+! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
+
+module m
+ type dl
+ integer :: a, b
+ integer, allocatable :: c(:,:)
+ integer :: d, e
+ integer, allocatable :: f
+ end type
+ type dt
+ integer :: g
+ type (dl), allocatable :: h(:)
+ integer :: i
+ type (dl) :: j(2, 2)
+ type (dl), allocatable :: k
+ end type
+contains
+ subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+ type (dl), intent (in) :: obj
+ integer, intent (in) :: val, cl1, cu1, cl2, cu2
+ logical, intent (in) :: c, f
+ if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
+ if (c) then
+ if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
+ if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
+ end if
+ if (val /= 0) then
+ if (obj%a /= val .or. obj%b /= val) call abort
+ if (obj%d /= val .or. obj%e /= val) call abort
+ if (c) then
+ if (any (obj%c /= val)) call abort
+ end if
+ if (f) then
+ if (obj%f /= val) call abort
+ end if
+ end if
+ end subroutine ver_dl
+ subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+ type (dt), intent (in) :: obj
+ integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+ logical, intent (in) :: h, k, c, f
+ integer :: i, j
+ if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
+ if (h) then
+ if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
+ do i = hl, hu
+ call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end if
+ do i = 1, 2
+ do j = 1, 2
+ call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end do
+ if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+ if (val /= 0) then
+ if (obj%g /= val .or. obj%i /= val) call abort
+ end if
+ end subroutine ver_dt
+ subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+ type (dl), intent (inout) :: obj
+ integer, intent (in) :: val, cl1, cu1, cl2, cu2
+ logical, intent (in) :: c, f
+ if (val /= 0) then
+ obj%a = val
+ obj%b = val
+ obj%d = val
+ obj%e = val
+ end if
+ if (allocated (obj%c)) deallocate (obj%c)
+ if (c) then
+ allocate (obj%c(cl1:cu1, cl2:cu2))
+ if (val /= 0) obj%c = val
+ end if
+ if (f) then
+ if (.not.allocated (obj%f)) allocate (obj%f)
+ if (val /= 0) obj%f = val
+ else
+ if (allocated (obj%f)) deallocate (obj%f)
+ end if
+ end subroutine alloc_dl
+ subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+ type (dt), intent (inout) :: obj
+ integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+ logical, intent (in) :: h, k, c, f
+ integer :: i, j
+ if (val /= 0) then
+ obj%g = val
+ obj%i = val
+ end if
+ if (allocated (obj%h)) deallocate (obj%h)
+ if (h) then
+ allocate (obj%h(hl:hu))
+ do i = hl, hu
+ call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end if
+ do i = 1, 2
+ do j = 1, 2
+ call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end do
+ if (k) then
+ if (.not.allocated (obj%k)) allocate (obj%k)
+ call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+ else
+ if (allocated (obj%k)) deallocate (obj%k)
+ end if
+ end subroutine alloc_dt
+end module m
+ use m
+ type (dt), allocatable :: y
+ call foo (y)
+contains
+ subroutine foo (y)
+ use m
+ type (dt), allocatable :: x, y, z(:,:)
+ logical, parameter :: F = .false.
+ logical, parameter :: T = .true.
+ logical :: l
+!$omp parallel private (x, y, z)
+ if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+!$omp end parallel
+!$omp parallel firstprivate (x, y, z)
+ if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+!$omp end parallel
+ l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+ if (.not. l) then
+ if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+ end if
+!$omp section
+ if (.not. l) then
+ if (allocated (x) .or. allocated (y) .or. allocated (z)) call abort
+ end if
+ allocate (x, y, z(-3:-3,2:3))
+ call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+ if (.not.allocated (x) .or. .not.allocated (y)) call abort
+ if (.not.allocated (z)) call abort
+ if (lbound (z, 1) /= -3 .or. ubound (z, 1) /= -3) call abort
+ if (lbound (z, 2) /= 2 .or. ubound (z, 2) /= 3) call abort
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call alloc_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (x, y, z)
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp end parallel
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp parallel private (x, y, z)
+ call ver_dt (x, 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ deallocate (x%h, x%k)
+ deallocate (y%h)
+ allocate (y%k)
+ call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ deallocate (z(-3,2)%h, z(-3,2)%k)
+ deallocate (z(-3,3)%h)
+ allocate (z(-3,3)%k)
+!$omp end parallel
+ call alloc_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+!$omp parallel firstprivate (x, y, z)
+ call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (y, 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+!$omp end parallel
+ call ver_dt (x, 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel firstprivate (x, y, z)
+ call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x, 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (y, 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+!$omp end parallel
+ call ver_dt (x, 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y, 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+ if (l) then
+ call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ else
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ end if
+ l = T
+ call alloc_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call alloc_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+!$omp section
+ if (l) then
+ call ver_dt (x, 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (y, 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ else
+ call ver_dt (x, 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y, 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ end if
+ l = T
+ call alloc_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call alloc_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp section
+!$omp end parallel sections
+ call ver_dt (x, 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+ if (l) then
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ else
+ call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ end if
+ l = T
+ call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp section
+ if (l) then
+ call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ else
+ call ver_dt (x, 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y, 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ end if
+ l = T
+ call alloc_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp parallel private (x, y, z)
+ call ver_dt (x, 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp single
+ call alloc_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end single copyprivate (x, y, z)
+ call ver_dt (x, 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (y, 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end parallel
+ call ver_dt (x, 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y, 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ end subroutine foo
+end
--- /dev/null
+! { dg-do run }
+! Don't cycle by default through all options, just test -O0 and -O2,
+! as this is quite large test.
+! { dg-skip-if "" { ! run_expensive_tests } { "*" } { "-O0" "-O2" } }
+
+module m
+ type dl
+ integer :: a, b
+ integer, allocatable :: c(:,:)
+ integer :: d, e
+ integer, allocatable :: f
+ end type
+ type dt
+ integer :: g
+ type (dl), allocatable :: h(:)
+ integer :: i
+ type (dl) :: j(2, 2)
+ type (dl), allocatable :: k
+ end type
+contains
+ subroutine ver_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+ type (dl), intent (in) :: obj
+ integer, intent (in) :: val, cl1, cu1, cl2, cu2
+ logical, intent (in) :: c, f
+ if ((c .neqv. allocated (obj%c)) .or. (f .neqv. allocated (obj%f))) call abort
+ if (c) then
+ if (lbound (obj%c, 1) /= cl1 .or. ubound (obj%c, 1) /= cu1) call abort
+ if (lbound (obj%c, 2) /= cl2 .or. ubound (obj%c, 2) /= cu2) call abort
+ end if
+ if (val /= 0) then
+ if (obj%a /= val .or. obj%b /= val) call abort
+ if (obj%d /= val .or. obj%e /= val) call abort
+ if (c) then
+ if (any (obj%c /= val)) call abort
+ end if
+ if (f) then
+ if (obj%f /= val) call abort
+ end if
+ end if
+ end subroutine ver_dl
+ subroutine ver_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+ type (dt), intent (in) :: obj
+ integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+ logical, intent (in) :: h, k, c, f
+ integer :: i, j
+ if ((h .neqv. allocated (obj%h)) .or. (k .neqv. allocated (obj%k))) call abort
+ if (h) then
+ if (lbound (obj%h, 1) /= hl .or. ubound (obj%h, 1) /= hu) call abort
+ do i = hl, hu
+ call ver_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end if
+ do i = 1, 2
+ do j = 1, 2
+ call ver_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end do
+ if (k) call ver_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+ if (val /= 0) then
+ if (obj%g /= val .or. obj%i /= val) call abort
+ end if
+ end subroutine ver_dt
+ subroutine alloc_dl (obj, val, c, cl1, cu1, cl2, cu2, f)
+ type (dl), intent (inout) :: obj
+ integer, intent (in) :: val, cl1, cu1, cl2, cu2
+ logical, intent (in) :: c, f
+ if (val /= 0) then
+ obj%a = val
+ obj%b = val
+ obj%d = val
+ obj%e = val
+ end if
+ if (allocated (obj%c)) deallocate (obj%c)
+ if (c) then
+ allocate (obj%c(cl1:cu1, cl2:cu2))
+ if (val /= 0) obj%c = val
+ end if
+ if (f) then
+ if (.not.allocated (obj%f)) allocate (obj%f)
+ if (val /= 0) obj%f = val
+ else
+ if (allocated (obj%f)) deallocate (obj%f)
+ end if
+ end subroutine alloc_dl
+ subroutine alloc_dt (obj, val, h, hl, hu, k, c, cl1, cu1, cl2, cu2, f)
+ type (dt), intent (inout) :: obj
+ integer, intent (in) :: val, hl, hu, cl1, cu1, cl2, cu2
+ logical, intent (in) :: h, k, c, f
+ integer :: i, j
+ if (val /= 0) then
+ obj%g = val
+ obj%i = val
+ end if
+ if (allocated (obj%h)) deallocate (obj%h)
+ if (h) then
+ allocate (obj%h(hl:hu))
+ do i = hl, hu
+ call alloc_dl (obj%h(i), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end if
+ do i = 1, 2
+ do j = 1, 2
+ call alloc_dl (obj%j(i, j), val, c, cl1, cu1, cl2, cu2, f)
+ end do
+ end do
+ if (k) then
+ if (.not.allocated (obj%k)) allocate (obj%k)
+ call alloc_dl (obj%k, val, c, cl1, cu1, cl2, cu2, f)
+ else
+ if (allocated (obj%k)) deallocate (obj%k)
+ end if
+ end subroutine alloc_dt
+end module m
+ use m
+ type (dt), allocatable :: z(:,:)
+ type (dt) :: y(2:3)
+ call foo (y, z, 4)
+contains
+ subroutine foo (y, z, n)
+ use m
+ integer :: n
+ type (dt) :: x(2:n), y(3:)
+ type (dt), allocatable :: z(:,:)
+ logical, parameter :: F = .false.
+ logical, parameter :: T = .true.
+ logical :: l
+ if (lbound (x, 1) /= 2 .or. ubound (x, 1) /= 4) call abort
+ if (lbound (y, 1) /= 3 .or. ubound (y, 1) /= 4) call abort
+ call ver_dt (x(2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (x(n), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (z)
+ if (allocated (z)) call abort
+!$omp end parallel
+!$omp parallel firstprivate (z)
+ if (allocated (z)) call abort
+!$omp end parallel
+ l = F
+!$omp parallel sections lastprivate (z) firstprivate (l)
+!$omp section
+ if (.not. l) then
+ if (allocated (z)) call abort
+ end if
+!$omp section
+ if (.not. l) then
+ if (allocated (z)) call abort
+ end if
+ allocate (z(-3:-3,2:3))
+ call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+ if (.not.allocated (z)) call abort
+ if (lbound (z, 1) /= -3 .or. ubound (z, 1) /= -3) call abort
+ if (lbound (z, 2) /= 2 .or. ubound (z, 2) /= 3) call abort
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel private (x, y, z)
+ call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp end parallel
+ call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y(4), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y(4), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 14, T, 3, 4, F, T, 1, 1, 2, 4, T)
+!$omp parallel private (x, y, z)
+ call ver_dt (x(n - 1), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y(4), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ deallocate (x(n - 1)%h, x(n - 1)%k)
+ deallocate (y(4)%h)
+ allocate (y(4)%k)
+ call ver_dt (z(-3,2), 0, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 0, T, 3, 4, F, T, 1, 1, 2, 4, T)
+ deallocate (z(-3,2)%h, z(-3,2)%k)
+ deallocate (z(-3,3)%h)
+ allocate (z(-3,3)%k)
+!$omp end parallel
+ call alloc_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+!$omp parallel firstprivate (x, y, z)
+ if (lbound (x, 1) /= 2 .or. ubound (x, 1) /= 4) call abort
+ if (lbound (y, 1) /= 3 .or. ubound (y, 1) /= 4) call abort
+ call ver_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (y(4), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (y(4), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+ call ver_dt (z(-3,3), 4, T, 3, 4, T, T, 1, 1, 2, 4, T)
+!$omp end parallel
+ call ver_dt (x(n - 1), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(4), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,2), 5, T, 1, 2, F, T, 2, 3, -2, -2, F)
+ call alloc_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 15, F, 0, 0, T, T, 2, 2, 2, 2, T)
+ call alloc_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+!$omp parallel firstprivate (x, y, z)
+ call ver_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (x(n - 1), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y(4), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (y(4), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,2), 4, T, -3, -1, T, T, -1, -1, 2, 3, T)
+ call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+ call ver_dt (z(-3,3), 17, T, 1, 2, F, T, 2, 2, 3, 3, F)
+!$omp end parallel
+ call ver_dt (x(n - 1), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(4), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (y(4), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 4, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 16, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call alloc_dt (z(-3,3), 18, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ l = F
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+ if (l) then
+ call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ else
+ call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(4), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ end if
+ l = T
+ call alloc_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call alloc_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call alloc_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call alloc_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+!$omp section
+ if (l) then
+ call ver_dt (x(n - 1), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (y(4), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ call ver_dt (z(-3,2), 7, T, 1, 1, T, T, 1, 2, 3, 3, T)
+ call ver_dt (z(-3,3), 20, T, 0, 0, F, T, 2, 2, 3, 4, F)
+ else
+ call ver_dt (x(n - 1), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(4), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ call ver_dt (z(-3,2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 0, 1, 0, 1, T)
+ end if
+ l = T
+ call alloc_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call alloc_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call alloc_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call alloc_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp section
+!$omp end parallel sections
+ call ver_dt (x(n - 1), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y(4), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 9, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 21, F, 0, 0, T, T, 1, 2, 3, 4, T)
+!$omp parallel sections lastprivate (x, y, z) firstprivate (l)
+!$omp section
+ if (l) then
+ call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ else
+ call ver_dt (x(n - 1), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y(4), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ end if
+ l = T
+ call alloc_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp section
+ if (l) then
+ call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ else
+ call ver_dt (x(n - 1), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (y(4), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ call ver_dt (z(-3,2), 0, T, 1, 1, F, F, 0, 0, 0, 0, T)
+ call ver_dt (z(-3,3), 0, F, 0, 0, T, T, 1, 2, 3, 4, T)
+ end if
+ l = T
+ call alloc_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call alloc_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call alloc_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp section
+!$omp end parallel sections
+ call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp parallel private (x, y, z)
+ call ver_dt (x(n - 1), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y(4), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 0, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 0, T, 0, 1, T, T, 2, 2, 2, 2, F)
+!$omp single
+ call alloc_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call alloc_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call alloc_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end single copyprivate (x, y, z)
+ call ver_dt (x(n - 1), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (y(4), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+ call ver_dt (z(-3,2), 3, F, 0, 0, T, T, 0, 1, 0, 1, F)
+ call ver_dt (z(-3,3), 22, T, 5, 5, F, T, 2, 3, 2, 2, T)
+!$omp end parallel
+ call ver_dt (x(n - 1), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (y(4), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (z(-3,2), 5, F, 0, 0, T, T, -1, -1, -1, -1, T)
+ call ver_dt (z(-3,3), 23, T, 0, 1, T, T, 2, 2, 2, 2, F)
+ call ver_dt (x(2), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (x(n), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ call ver_dt (y(3), 0, F, 0, 0, F, F, 0, 0, 0, 0, F)
+ end subroutine foo
+end
--- /dev/null
+! { dg-do run }
+
+ integer, allocatable :: a, b(:), c(:,:)
+ integer :: i
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) &
+!$omp & initializer (omp_priv = 0)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+ allocate (a, b(6:9), c(3, 8:9))
+ a = 0
+ b = 0
+ c = 0
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+!$omp parallel do reduction (+:a, b, c)
+ do i = 1, 10
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ a = a + i
+ b = b + 2 * i
+ c = c + 3 * i
+ end do
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+ a = 0
+ b = 0
+ c = 0
+!$omp parallel do reduction (foo : a, b, c)
+ do i = 1, 10
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ a = a + i
+ b = b + 2 * i
+ c = c + 3 * i
+ end do
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+ a = 0
+ b = 0
+ c = 0
+!$omp simd reduction (+:a, b, c)
+ do i = 1, 10
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ a = a + i
+ b = b + 2 * i
+ c = c + 3 * i
+ end do
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+ a = 0
+ b = 0
+ c = 0
+!$omp simd reduction (foo : a, b, c)
+ do i = 1, 10
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ a = a + i
+ b = b + 2 * i
+ c = c + 3 * i
+ end do
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 55 .or. any (b /= 110) .or. any (c /= 165)) call abort
+end
--- /dev/null
+! { dg-do run }
+! { dg-require-effective-target tls_runtime }
+
+ use omp_lib
+ integer, allocatable, save :: a, b(:), c(:,:)
+ integer :: p
+!$omp threadprivate (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+ call omp_set_dynamic (.false.)
+ call omp_set_num_threads (4)
+
+!$omp parallel num_threads (4)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp end parallel
+
+ allocate (a, b(6:9), c(3, 8:9))
+ a = 4
+ b = 5
+ c = 6
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+
+!$omp parallel num_threads (4) copyin (a, b, c) private (p)
+ p = omp_get_thread_num ()
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 4 .or. any (b /= 5) .or. any (c /= 6)) call abort
+ deallocate (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+ allocate (a, b(p:9), c(3, p:7))
+ a = p
+ b = p
+ c = p
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= (10 - p)) call abort
+ if (lbound (b, 1) /= p .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= (3 * (8 - p))) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= (8 - p)) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= p .or. ubound (c, 2) /= 7) call abort
+ if (a /= p .or. any (b /= p) .or. any (c /= p)) call abort
+!$omp end parallel
+
+!$omp parallel num_threads (4) copyin (a, b, c)
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 10) call abort
+ if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 24) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 8) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 0 .or. ubound (c, 2) /= 7) call abort
+ if (a /= 0 .or. any (b /= 0) .or. any (c /= 0)) call abort
+!$omp end parallel
+
+ deallocate (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+!$omp parallel num_threads (4) copyin (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp end parallel
+end
--- /dev/null
+! { dg-do run }
+
+ integer, allocatable :: a, b(:), c(:,:)
+ logical :: l
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+!$omp parallel private (a, b, c, l)
+ l = .false.
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+
+!$omp single
+ allocate (a, b(6:9), c(3, 8:9))
+ a = 4
+ b = 5
+ c = 6
+!$omp end single copyprivate (a, b, c)
+
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 4 .or. any (b /= 5) .or. any (c /= 6)) call abort
+
+!$omp single
+ deallocate (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+ allocate (a, b(0:4), c(3, 2:7))
+ a = 1
+ b = 2
+ c = 3
+!$omp end single copyprivate (a, b, c)
+
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 5) call abort
+ if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 4) call abort
+ if (.not.allocated (c) .or. size (c) /= 18) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 6) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 2 .or. ubound (c, 2) /= 7) call abort
+ if (a /= 1 .or. any (b /= 2) .or. any (c /= 3)) call abort
+
+!$omp single
+ l = .true.
+ deallocate (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+ allocate (a, b(2:6), c(3:5, 3:8))
+ a = 7
+ b = 8
+ c = 9
+!$omp end single copyprivate (a, b, c)
+
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 5) call abort
+ if (l) then
+ if (lbound (b, 1) /= 2 .or. ubound (b, 1) /= 6) call abort
+ else
+ if (lbound (b, 1) /= 0 .or. ubound (b, 1) /= 4) call abort
+ end if
+ if (.not.allocated (c) .or. size (c) /= 18) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 6) call abort
+ if (l) then
+ if (lbound (c, 1) /= 3 .or. ubound (c, 1) /= 5) call abort
+ if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 8) call abort
+ else
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 2 .or. ubound (c, 2) /= 7) call abort
+ end if
+ if (a /= 7 .or. any (b /= 8) .or. any (c /= 9)) call abort
+
+!$omp end parallel
+end
--- /dev/null
+! { dg-do run }
+
+ integer, allocatable :: a, b(:), c(:,:)
+ logical :: l
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp parallel private (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+ allocate (a, b(-7:-1), c(2:3, 3:5))
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 7) call abort
+ if (lbound (b, 1) /= -7 .or. ubound (b, 1) /= -1) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 2 .or. size (c, 2) /= 3) call abort
+ if (lbound (c, 1) /= 2 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 5) call abort
+ a = 4
+ b = 3
+ c = 2
+!$omp end parallel
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+!$omp parallel firstprivate (a, b, c)
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+ allocate (a, b(-7:-1), c(2:3, 3:5))
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 7) call abort
+ if (lbound (b, 1) /= -7 .or. ubound (b, 1) /= -1) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 2 .or. size (c, 2) /= 3) call abort
+ if (lbound (c, 1) /= 2 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 3 .or. ubound (c, 2) /= 5) call abort
+ a = 4
+ b = 3
+ c = 2
+!$omp end parallel
+ if (allocated (a) .or. allocated (b) .or. allocated (c)) call abort
+ allocate (a, b(6:9), c(3, 8:9))
+ a = 2
+ b = 4
+ c = 5
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+!$omp parallel firstprivate (a, b, c)
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 2 .or. any (b .ne. 4) .or. any (c .ne. 5)) call abort
+ deallocate (a)
+ if (allocated (a)) call abort
+ allocate (a)
+ a = 8
+ b = (/ 1, 2, 3 /)
+ c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 2, 4 /))
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 3) call abort
+ if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
+ if (.not.allocated (c) .or. size (c) /= 8) call abort
+ if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
+ if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
+ if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
+!$omp end parallel
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ if (a /= 2 .or. any (b .ne. 4) .or. any (c .ne. 5)) call abort
+ l = .false.
+!$omp parallel sections lastprivate (a, b, c) firstprivate (l)
+!$omp section
+ if (.not.allocated (a)) call abort
+ if (l) then
+ if (.not.allocated (b) .or. size (b) /= 6) call abort
+ if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
+ if (.not.allocated (c) .or. size (c) /= 8) call abort
+ if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
+ if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
+ if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
+ else
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ end if
+ l = .true.
+ deallocate (a)
+ if (allocated (a)) call abort
+ allocate (a)
+ a = 8
+ b = (/ 1, 2, 3 /)
+ c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 2, 4 /))
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 3) call abort
+ if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
+ if (.not.allocated (c) .or. size (c) /= 8) call abort
+ if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
+ if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
+ if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
+!$omp section
+ if (.not.allocated (a)) call abort
+ if (l) then
+ if (.not.allocated (b) .or. size (b) /= 3) call abort
+ if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 3) call abort
+ if (.not.allocated (c) .or. size (c) /= 8) call abort
+ if (size (c, 1) /= 2 .or. size (c, 2) /= 4) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 2) call abort
+ if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 4) call abort
+ if (a /= 8 .or. b(2) /= 2 .or. c(1, 2) /= 3) call abort
+ else
+ if (.not.allocated (b) .or. size (b) /= 4) call abort
+ if (lbound (b, 1) /= 6 .or. ubound (b, 1) /= 9) call abort
+ if (.not.allocated (c) .or. size (c) /= 6) call abort
+ if (size (c, 1) /= 3 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 3) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 9) call abort
+ end if
+ l = .true.
+ deallocate (a)
+ if (allocated (a)) call abort
+ allocate (a)
+ a = 12
+ b = (/ 9, 8, 7, 6, 5, 4 /)
+ c = reshape ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), (/ 4, 2 /))
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 6) call abort
+ if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
+ if (.not.allocated (c) .or. size (c) /= 8) call abort
+ if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
+ if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
+ if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
+!$omp end parallel sections
+ if (.not.allocated (a)) call abort
+ if (.not.allocated (b) .or. size (b) /= 6) call abort
+ if (lbound (b, 1) /= 1 .or. ubound (b, 1) /= 6) call abort
+ if (.not.allocated (c) .or. size (c) /= 8) call abort
+ if (size (c, 1) /= 4 .or. size (c, 2) /= 2) call abort
+ if (lbound (c, 1) /= 1 .or. ubound (c, 1) /= 4) call abort
+ if (lbound (c, 2) /= 1 .or. ubound (c, 2) /= 2) call abort
+ if (a /= 12 .or. b(2) /= 8 .or. c(1, 2) /= 5) call abort
+end
--- /dev/null
+! { dg-do run }
+
+program associate1
+ integer :: v, i, j
+ real :: a(3, 3)
+ v = 15
+ a = 4.5
+ a(2,1) = 3.5
+ i = 2
+ j = 1
+ associate(u => v, b => a(i, j))
+!$omp parallel private(v, a) default(none)
+ v = -1
+ a = 2.5
+ if (v /= -1 .or. u /= 15) call abort
+ if (a(2,1) /= 2.5 .or. b /= 3.5) call abort
+ associate(u => v, b => a(2, 1))
+ if (u /= -1 .or. b /= 2.5) call abort
+ end associate
+ if (u /= 15 .or. b /= 3.5) call abort
+!$omp end parallel
+ end associate
+end program
--- /dev/null
+! { dg-do run }
+
+program associate2
+ type dl
+ integer :: i
+ end type
+ type dt
+ integer :: i
+ real :: a(3, 3)
+ type(dl) :: c(3, 3)
+ end type
+ integer :: v(4), i, j, k, l
+ type (dt) :: a(3, 3)
+ v = 15
+ forall (k = 1:3, l = 1:3) a(k, l)%a(:,:) = 4.5
+ a(2,1)%a(1,2) = 3.5
+ i = 2
+ j = 1
+ associate(u => v, b => a(i, j)%a)
+!$omp parallel private(v, a) default(none)
+ v = -1
+ forall (k = 1:3, l = 1:3) a(k, l)%a(:,:) = 2.5
+ if (v(3) /= -1 .or. u(3) /= 15) call abort
+ if (a(2,1)%a(1,2) /= 2.5 .or. b(1,2) /= 3.5) call abort
+ associate(u => v, b => a(2, 1)%a)
+ if (u(3) /= -1 .or. b(1,2) /= 2.5) call abort
+ end associate
+ if (u(3) /= 15 .or. b(1,2) /= 3.5) call abort
+!$omp end parallel
+ end associate
+ forall (k = 1:3, l = 1:3) a(k, l)%c(:,:)%i = 7
+ a(1,2)%c(2,1)%i = 9
+ i = 1
+ j = 2
+ associate(d => a(i, j)%c(2,:)%i)
+!$omp parallel private(a) default(none)
+ forall (k = 1:3, l = 1:3) a(k, l)%c(:,:)%i = 15
+ if (a(1,2)%c(2,1)%i /= 15 .or. d(1) /= 9) call abort
+ if (a(1,2)%c(2,2)%i /= 15 .or. d(2) /= 7) call abort
+ associate(d => a(2,1)%c(2,:)%i)
+ if (d(1) /= 15 .or. d(2) /= 15) call abort
+ end associate
+ if (d(1) /= 9 .or. d(2) /= 7) call abort
+!$omp end parallel
+ end associate
+end program
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: i
+
+ !$omp parallel num_threads(32)
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do
+ if (omp_get_cancellation ()) call abort
+ enddo
+ !$omp endparallel
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fno-inline -fno-ipa-sra -fno-ipa-cp -fno-ipa-cp-clone" }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: i
+ logical :: x(5)
+
+ x(:) = .false.
+ x(1) = .true.
+ x(3) = .true.
+ if (omp_get_cancellation ()) call foo (x)
+contains
+ subroutine foo (x)
+ use omp_lib
+ logical :: x(5)
+ integer :: v, w, i
+
+ v = 0
+ w = 0
+ !$omp parallel num_threads (32) shared (v, w)
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(1))
+ call abort
+ end do
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(2))
+ !$omp atomic
+ v = v + 1
+ !$omp endatomic
+ enddo
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(3))
+ !$omp atomic
+ w = w + 8
+ !$omp end atomic
+ end do
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(4))
+ !$omp atomic
+ v = v + 2
+ !$omp end atomic
+ end do
+ !$omp end do
+ !$omp end parallel
+ if (v.ne.3000.or.w.ne.0) call abort
+ !$omp parallel num_threads (32) shared (v, w)
+ ! None of these cancel directives should actually cancel anything,
+ ! but the compiler shouldn't know that and thus should use cancellable
+ ! barriers at the end of all the workshares.
+ !$omp cancel parallel if (omp_get_thread_num ().eq.1.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(1))
+ call abort
+ end do
+ !$omp cancel parallel if (omp_get_thread_num ().eq.2.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(2))
+ !$omp atomic
+ v = v + 1
+ !$omp endatomic
+ enddo
+ !$omp cancel parallel if (omp_get_thread_num ().eq.3.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(3))
+ !$omp atomic
+ w = w + 8
+ !$omp end atomic
+ end do
+ !$omp cancel parallel if (omp_get_thread_num ().eq.4.and.x(5))
+ !$omp do
+ do i = 0, 999
+ !$omp cancel do if (x(4))
+ !$omp atomic
+ v = v + 2
+ !$omp end atomic
+ end do
+ !$omp end do
+ !$omp cancel parallel if (omp_get_thread_num ().eq.5.and.x(5))
+ !$omp end parallel
+ if (v.ne.6000.or.w.ne.0) call abort
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+
+ !$omp parallel num_threads(32)
+ !$omp cancel parallel
+ if (omp_get_cancellation ()) call abort
+ !$omp end parallel
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fno-inline -fno-ipa-sra -fno-ipa-cp -fno-ipa-cp-clone" }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: x, i, j
+ common /x/ x
+
+ call omp_set_dynamic (.false.)
+ call omp_set_schedule (omp_sched_static, 1)
+ !$omp parallel num_threads(16) private (i, j)
+ call do_some_work
+ !$omp barrier
+ if (omp_get_thread_num ().eq.1) then
+ call sleep (2)
+ !$omp cancellation point parallel
+ end if
+ do j = 3, 16
+ !$omp do schedule(runtime)
+ do i = 0, j - 1
+ call do_some_work
+ end do
+ !$omp enddo nowait
+ end do
+ if (omp_get_thread_num ().eq.0) then
+ call sleep (1)
+ !$omp cancel parallel
+ end if
+ !$omp end parallel
+contains
+ subroutine do_some_work
+ integer :: x
+ common /x/ x
+ !$omp atomic
+ x = x + 1
+ !$omp end atomic
+ endsubroutine do_some_work
+end
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+
+ if (omp_get_cancellation ()) then
+ !$omp parallel num_threads(32)
+ !$omp sections
+ !$omp cancel sections
+ call abort
+ !$omp section
+ !$omp cancel sections
+ call abort
+ !$omp section
+ !$omp cancel sections
+ call abort
+ !$omp section
+ !$omp cancel sections
+ call abort
+ !$omp end sections
+ !$omp end parallel
+ end if
+end
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var OMP_CANCELLATION "true" }
+
+ use omp_lib
+ integer :: i
+
+ !$omp parallel
+ !$omp taskgroup
+ !$omp task
+ !$omp cancel taskgroup
+ call abort
+ !$omp endtask
+ !$omp endtaskgroup
+ !$omp endparallel
+ !$omp parallel private (i)
+ !$omp barrier
+ !$omp single
+ !$omp taskgroup
+ do i = 0, 49
+ !$omp task
+ !$omp cancellation point taskgroup
+ !$omp cancel taskgroup if (i.gt.5)
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ !$omp endsingle
+ !$omp end parallel
+end
--- /dev/null
+! { dg-do run { target vect_simd_clones } }
+! { dg-options "-fno-inline" }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+module declare_simd_1_mod
+ contains
+ real function foo (a, b, c)
+ !$omp declare simd (foo) simdlen (4) uniform (a) linear (b : 5) &
+ !$omp & notinbranch
+ double precision, value :: a
+ real, value :: c
+ !$omp declare simd (foo)
+ integer, value :: b
+ foo = a + b * c
+ end function foo
+end module declare_simd_1_mod
+ use declare_simd_1_mod
+ interface
+ function bar (a, b, c)
+ !$omp declare simd (bar)
+ integer, value :: b
+ real, value :: c
+ real :: bar
+ !$omp declare simd (bar) simdlen (4) linear (b : 2)
+ !$omp declare simd (bar) simdlen (16) inbranch
+ double precision, value :: a
+ end function bar
+ end interface
+ integer :: i
+ double precision :: a(128)
+ real :: b(128), d(128)
+ data d /171., 414., 745., 1164., 1671., 2266., 2949., 3720., 4579., &
+ & 5526., 6561., 7684., 8895., 10194., 11581., 13056., 14619., &
+ & 16270., 18009., 19836., 21751., 23754., 25845., 28024., &
+ & 30291., 32646., 35089., 37620., 40239., 42946., 45741., &
+ & 48624., 51595., 54654., 57801., 61036., 64359., 67770., &
+ & 71269., 74856., 78531., 82294., 86145., 90084., 94111., &
+ & 98226., 102429., 106720., 111099., 115566., 120121., 124764., &
+ & 129495., 134314., 139221., 144216., 149299., 154470., 159729., &
+ & 165076., 170511., 176034., 181645., 187344., 193131., 199006., &
+ & 204969., 211020., 217159., 223386., 229701., 236104., 242595., &
+ & 249174., 255841., 262596., 269439., 276370., 283389., 290496., &
+ & 297691., 304974., 312345., 319804., 327351., 334986., 342709., &
+ & 350520., 358419., 366406., 374481., 382644., 390895., 399234., &
+ & 407661., 416176., 424779., 433470., 442249., 451116., 460071., &
+ & 469114., 478245., 487464., 496771., 506166., 515649., 525220., &
+ & 534879., 544626., 554461., 564384., 574395., 584494., 594681., &
+ & 604956., 615319., 625770., 636309., 646936., 657651., 668454., &
+ & 679345., 690324., 701391., 712546., 723789., 735120./
+ !$omp simd
+ do i = 1, 128
+ a(i) = 7.0 * i + 16.0
+ b(i) = 5.0 * i + 12.0
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = foo (a(i), 3, b(i))
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = bar (a(i), 2 * i, b(i))
+ end do
+ if (any (b.ne.d)) call abort
+ !$omp simd
+ do i = 1, 128
+ b(i) = i * 2.0
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = baz (7.0_8, 2, b(i))
+ end do
+ do i = 1, 128
+ if (b(i).ne.(7.0 + 4.0 * i)) call abort
+ end do
+contains
+ function baz (x, y, z)
+ !$omp declare simd (baz) simdlen (8) uniform (x, y)
+ !$omp declare simd (baz)
+ integer, value :: y
+ real, value :: z
+ real :: baz
+ double precision, value :: x
+ baz = x + y * z
+ end function baz
+end
+function bar (a, b, c)
+ integer, value :: b
+ real, value :: c
+ real :: bar
+ double precision, value :: a
+ !$omp declare simd (bar)
+ !$omp declare simd (bar) simdlen (4) linear (b : 2)
+ bar = a + b * c
+end function bar
--- /dev/null
+! { dg-do run { target vect_simd_clones } }
+! { dg-options "-fno-inline" }
+! { dg-additional-sources declare-simd-3.f90 }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+module declare_simd_2_mod
+ contains
+ real function foo (a, b, c)
+ !$omp declare simd (foo) simdlen (4) uniform (a) linear (b : 5)
+ double precision, value :: a
+ real, value :: c
+ !$omp declare simd (foo)
+ integer, value :: b
+ foo = a + b * c
+ end function foo
+end module declare_simd_2_mod
+
+ interface
+ subroutine bar ()
+ end subroutine bar
+ end interface
+
+ call bar ()
+end
--- /dev/null
+! Don't compile this anywhere, it is just auxiliary
+! file compiled together with declare-simd-2.f90
+! to verify inter-CU module handling of omp declare simd.
+! { dg-do compile { target { lp64 && { ! lp64 } } } }
+
+subroutine bar
+ use declare_simd_2_mod
+ real :: b(128)
+ integer :: i
+
+ !$omp simd
+ do i = 1, 128
+ b(i) = i * 2.0
+ end do
+ !$omp simd
+ do i = 1, 128
+ b(i) = foo (7.0_8, 5 * i, b(i))
+ end do
+ do i = 1, 128
+ if (b(i).ne.(7.0 + 10.0 * i * i)) call abort
+ end do
+end subroutine bar
--- /dev/null
+! { dg-do run }
+
+ call dep ()
+ call dep2 ()
+ call dep3 ()
+ call firstpriv ()
+ call antidep ()
+ call antidep2 ()
+ call antidep3 ()
+ call outdep ()
+ call concurrent ()
+ call concurrent2 ()
+ call concurrent3 ()
+contains
+ subroutine dep
+ integer :: x
+ x = 1
+ !$omp parallel
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine dep
+
+ subroutine dep2
+ integer :: x
+ !$omp parallel
+ !$omp single private (x)
+ x = 1
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp taskwait
+ !$omp end single
+ !$omp end parallel
+ end subroutine dep2
+
+ subroutine dep3
+ integer :: x
+ !$omp parallel private (x)
+ x = 1
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp endtask
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp endtask
+ !$omp endsingle
+ !$omp endparallel
+ end subroutine dep3
+
+ subroutine firstpriv
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 1
+ !$omp task depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine firstpriv
+
+ subroutine antidep
+ integer :: x
+ x = 1
+ !$omp parallel
+ !$omp single
+ !$omp task shared(x) depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine antidep
+
+ subroutine antidep2
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 1
+ !$omp taskgroup
+ !$omp task shared(x) depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp end taskgroup
+ !$omp end single
+ !$omp end parallel
+ end subroutine antidep2
+
+ subroutine antidep3
+ integer :: x
+ !$omp parallel
+ x = 1
+ !$omp single
+ !$omp task shared(x) depend(in: x)
+ if (x.ne.1) call abort
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine antidep3
+
+ subroutine outdep
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 0
+ !$omp task shared(x) depend(out: x)
+ x = 1
+ !$omp end task
+ !$omp task shared(x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp taskwait
+ if (x.ne.2) call abort
+ !$omp end single
+ !$omp end parallel
+ end subroutine outdep
+
+ subroutine concurrent
+ integer :: x
+ x = 1
+ !$omp parallel
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine concurrent
+
+ subroutine concurrent2
+ integer :: x
+ !$omp parallel private (x)
+ !$omp single
+ x = 1
+ !$omp task shared (x) depend(out: x)
+ x = 2;
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp taskwait
+ !$omp end single
+ !$omp end parallel
+ end subroutine concurrent2
+
+ subroutine concurrent3
+ integer :: x
+ !$omp parallel private (x)
+ x = 1
+ !$omp single
+ !$omp task shared (x) depend(out: x)
+ x = 2
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp task shared (x) depend(in: x)
+ if (x.ne.2) call abort
+ !$omp end task
+ !$omp end single
+ !$omp end parallel
+ end subroutine concurrent3
+end
--- /dev/null
+! { dg-do run }
+
+ integer :: x(3:6, 7:12), y
+ y = 1
+ !$omp parallel shared (x, y)
+ !$omp single
+ !$omp taskgroup
+ !$omp task depend(in: x(:, :))
+ if (y.ne.1) call abort
+ !$omp end task
+ !$omp task depend(out: x(:, :))
+ y = 2
+ !$omp end task
+ !$omp end taskgroup
+ !$omp taskgroup
+ !$omp task depend(in: x(4, 7))
+ if (y.ne.2) call abort
+ !$omp end task
+ !$omp task depend(out: x(4:4, 7:7))
+ y = 3
+ !$omp end task
+ !$omp end taskgroup
+ !$omp taskgroup
+ !$omp task depend(in: x(4:, 8:))
+ if (y.ne.3) call abort
+ !$omp end task
+ !$omp task depend(out: x(4:6, 8:12))
+ y = 4
+ !$omp end task
+ !$omp end taskgroup
+ !$omp end single
+ !$omp end parallel
+ if (y.ne.4) call abort
+end
--- /dev/null
+! { dg-do run }
+
+ integer :: x(2, 3)
+ integer, allocatable :: z(:, :)
+ allocate (z(-2:3, 2:4))
+ call foo (x, z)
+contains
+ subroutine foo (x, z)
+ integer :: x(:, :), y
+ integer, allocatable :: z(:, :)
+ y = 1
+ !$omp parallel shared (x, y, z)
+ !$omp single
+ !$omp taskgroup
+ !$omp task depend(in: x)
+ if (y.ne.1) call abort
+ !$omp end task
+ !$omp task depend(out: x(1:2, 1:3))
+ y = 2
+ !$omp end task
+ !$omp end taskgroup
+ !$omp taskgroup
+ !$omp task depend(in: z)
+ if (y.ne.2) call abort
+ !$omp end task
+ !$omp task depend(out: z(-2:3, 2:4))
+ y = 3
+ !$omp end task
+ !$omp end taskgroup
+ !$omp taskgroup
+ !$omp task depend(in: x)
+ if (y.ne.3) call abort
+ !$omp end task
+ !$omp task depend(out: x(1:, 1:))
+ y = 4
+ !$omp end task
+ !$omp end taskgroup
+ !$omp end single
+ !$omp end parallel
+ if (y.ne.4) call abort
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+
+ interface
+ subroutine bar (q)
+ integer :: q(19:)
+ end subroutine
+ end interface
+ integer :: q(7:15)
+ q(:) = 5
+ call bar (q)
+end
+subroutine bar (q)
+ use iso_c_binding, only: c_ptr, c_loc, c_int
+ integer :: a, b, c, d(2:3,4:5), q(19:), h, k, m, n, o, p
+ integer(c_int), target :: e(64)
+ type (c_ptr) :: f, g(64)
+ logical :: l
+ a = 1
+ b = 2
+ c = 3
+ d = 4
+ l = .false.
+ f = c_loc (e)
+ call foo
+contains
+ subroutine foo
+ use iso_c_binding, only: c_sizeof
+!$omp simd linear(a:2) linear(b:1)
+ do a = 1, 20, 2
+ b = b + 1
+ end do
+!$omp end simd
+ if (a /= 21 .or. b /= 12) call abort
+!$omp simd aligned(f : c_sizeof (e(1)))
+ do b = 1, 64
+ g(b) = f
+ end do
+!$omp end simd
+!$omp parallel
+!$omp single
+!$omp taskgroup
+!$omp task depend(out : a, d(2:2,4:5))
+ a = a + 1
+ d(2:2,4:5) = d(2:2,4:5) + 1
+!$omp end task
+!$omp task depend(in : a, d(2:2,4:5))
+ if (a /= 22) call abort
+ if (any (d(2:2,4:5) /= 5)) call abort
+!$omp end task
+!$omp end taskgroup
+!$omp end single
+!$omp end parallel
+ b = 10
+!$omp target data map (tofrom: a, d(2:3,4:4), q) map (from: l)
+!$omp target map (tofrom: b, d(2:3,4:4))
+ l = .false.
+ if (a /= 22 .or. any (q /= 5)) l = .true.
+ if (lbound (q, 1) /= 19 .or. ubound (q, 1) /= 27) l = .true.
+ if (d(2,4) /= 5 .or. d(3,4) /= 4) l = .true.
+ l = l .or. (b /= 10)
+ a = 6
+ b = 11
+ q = 8
+ d(2:3,4:4) = 9
+!$omp end target
+!$omp target update from (a, q, d(2:3,4:4), l)
+ if (a /= 6 .or. l .or. b /= 11 .or. any (q /= 8)) call abort
+ if (any (d(2:3,4:4) /= 9) .or. d(2,5) /= 5 .or. d(3,5) /= 4) call abort
+ a = 12
+ b = 13
+ q = 14
+ d = 15
+!$omp target update to (a, q, d(2:3,4:4))
+!$omp target map (tofrom: b, d(2:3,4:4))
+ if (a /= 12 .or. b /= 13 .or. any (q /= 14)) l = .true.
+ l = l .or. any (d(2:3,4:4) /= 15)
+!$omp end target
+ a = 0
+ b = 1
+ c = 100
+ h = 8
+ m = 0
+ n = 64
+ o = 16
+ if (l) call abort
+!$omp target teams distribute parallel do simd if (.not.l) device(a) &
+!$omp & num_teams(b) dist_schedule(static, c) num_threads (h) &
+!$omp & reduction (+: m) safelen (n) schedule(static, o)
+ do p = 1, 64
+ m = m + 1
+ end do
+!$omp end target teams distribute parallel do simd
+ if (m /= 64) call abort
+!$omp end target data
+ end subroutine foo
+end subroutine bar
--- /dev/null
+! { dg-do run }
+ integer (kind = 4) :: a, a2
+ integer (kind = 2) :: b, b2
+ real :: c
+ double precision :: d, d2, c2
+ integer, dimension (10) :: e
+ e(:) = 5
+ e(7) = 9
+!$omp atomic write seq_cst
+ a = 1
+!$omp atomic seq_cst, write
+ b = 2
+!$omp atomic write, seq_cst
+ c = 3
+!$omp atomic seq_cst write
+ d = 4
+!$omp atomic capture seq_cst
+ a2 = a
+ a = a + 4
+!$omp end atomic
+!$omp atomic capture, seq_cst
+ b = b - 18
+ b2 = b
+!$omp end atomic
+!$omp atomic seq_cst, capture
+ c2 = c
+ c = 2.0 * c
+!$omp end atomic
+!$omp atomic seq_cst capture
+ d = d / 2.0
+ d2 = d
+!$omp end atomic
+ if (a2 .ne. 1 .or. b2 .ne. -16 .or. c2 .ne. 3 .or. d2 .ne. 2) call abort
+!$omp atomic read seq_cst
+ a2 = a
+!$omp atomic seq_cst, read
+ c2 = c
+ if (a2 .ne. 5 .or. b2 .ne. -16 .or. c2 .ne. 6 .or. d2 .ne. 2) call abort
+ a2 = 10
+ if (a2 .ne. 10) call abort
+!$omp atomic capture
+ a2 = a
+ a = e(1) + e(6) + e(7) * 2
+!$omp endatomic
+ if (a2 .ne. 5) call abort
+!$omp atomic read
+ a2 = a
+!$omp end atomic
+ if (a2 .ne. 28) call abort
+!$omp atomic capture seq_cst
+ b2 = b
+ b = e(1) + e(7) + e(5) * 2
+!$omp end atomic
+ if (b2 .ne. -16) call abort
+!$omp atomic seq_cst, read
+ b2 = b
+!$omp end atomic
+ if (b2 .ne. 24) call abort
+end
implicit none
include "omp_lib.h"
- if (openmp_version .ne. 201107) call abort;
+ if (openmp_version .ne. 201307) call abort;
end program main
use omp_lib
implicit none
- if (openmp_version .ne. 201107) call abort;
+ if (openmp_version .ne. 201307) call abort;
end program main
--- /dev/null
+! { dg-do run }
+ interface
+ integer function foo ()
+ end function
+ integer function bar ()
+ end function
+ integer function baz ()
+ end function
+ end interface
+ procedure(foo), pointer :: ptr
+ integer :: i
+ ptr => foo
+!$omp parallel shared (ptr)
+ if (ptr () /= 1) call abort
+!$omp end parallel
+ ptr => bar
+!$omp parallel firstprivate (ptr)
+ if (ptr () /= 2) call abort
+!$omp end parallel
+!$omp parallel sections lastprivate (ptr)
+!$omp section
+ ptr => foo
+ if (ptr () /= 1) call abort
+!$omp section
+ ptr => bar
+ if (ptr () /= 2) call abort
+!$omp section
+ ptr => baz
+ if (ptr () /= 3) call abort
+!$omp end parallel sections
+ if (ptr () /= 3) call abort
+ if (.not.associated (ptr, baz)) call abort
+end
+integer function foo ()
+ foo = 1
+end function
+integer function bar ()
+ bar = 2
+end function
+integer function baz ()
+ baz = 3
+end function
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ type dt
+ integer :: x = 0
+ end type
+ type (dt) :: t
+ integer :: i, j, k, l, r, s, a(30)
+ integer, target :: q(30)
+ integer, pointer :: p(:)
+ !$omp declare reduction (foo : integer : &
+ !$omp & omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+ !$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
+ !$omp & + omp_in%x)
+ a(:) = 1
+ q(:) = 1
+ p => q
+ r = 0
+ j = 10
+ k = 20
+ s = 0
+ !$omp simd safelen (8) reduction(+:r, t) linear(j, k : 2) &
+ !$omp& private (l) aligned(p : 4) reduction(foo:s)
+ do i = 1, 30
+ l = j + k + a(i) + p(i)
+ r = r + l
+ j = j + 2
+ k = k + 2
+ s = s + l
+ t%x = t%x + l
+ end do
+ if (r.ne.2700.or.j.ne.70.or.k.ne.80.or.s.ne.2700) call abort
+ if (t%x.ne.2700) call abort
+end
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: a(1024), b(1024), k, m, i, s, t
+ k = 4
+ m = 2
+ t = 1
+ do i = 1, 1024
+ a(i) = i - 513
+ b(i) = modulo (i - 52, 39)
+ if (i.lt.52.and.b(i).ne.0) b(i) = b(i) - 39
+ end do
+ s = foo (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = bar (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = baz (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+contains
+ function foo (p)
+ integer :: p(1024), u, v, i, s, foo
+ s = 0
+ !$omp simd linear(k : m + 1) reduction(+: s) lastprivate(u, v)
+ do i = 1, 1024
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end simd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ foo = s
+ end function foo
+ function bar (p)
+ integer :: p(1024), u, v, i, s, bar
+ s = 0
+ !$omp simd linear(k : m + 1) reduction(+: s) lastprivate(u, v)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end simd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ bar = s
+ end function bar
+ function baz (p)
+ integer :: p(1024), u, v, i, s, baz
+ s = 0
+ !$omp simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & linear(i : t)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ baz = s
+ end function baz
+end
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: a(1024), b(1024), k, m, i, s, t
+ k = 4
+ m = 2
+ t = 1
+ do i = 1, 1024
+ a(i) = i - 513
+ b(i) = modulo (i - 52, 39)
+ if (i.lt.52.and.b(i).ne.0) b(i) = b(i) - 39
+ end do
+ s = foo (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = bar (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = baz (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+contains
+ function foo (p)
+ integer :: p(1024), u, v, i, s, foo
+ s = 0
+ !$omp parallel
+ !$omp do simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & schedule (static, 32)
+ do i = 1, 1024
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end do simd
+ !$omp end parallel
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ foo = s
+ end function foo
+ function bar (p)
+ integer :: p(1024), u, v, i, s, bar
+ s = 0
+ !$omp parallel
+ !$omp do simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & schedule (dynamic, 32)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end do simd
+ !$omp endparallel
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ bar = s
+ end function bar
+ function baz (p)
+ integer :: p(1024), u, v, i, s, baz
+ s = 0
+ !$omp parallel
+ !$omp do simd linear(k : m + 1) reduction(+: s) lastprivate(u, v) &
+ !$omp & linear(i : t) schedule (static, 8)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end parallel
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ baz = s
+ end function baz
+end
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: a(1024), b(1024), k, m, i, s, t
+ k = 4
+ m = 2
+ t = 1
+ do i = 1, 1024
+ a(i) = i - 513
+ b(i) = modulo (i - 52, 39)
+ if (i.lt.52.and.b(i).ne.0) b(i) = b(i) - 39
+ end do
+ s = foo (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = bar (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ a(i) = i - 513
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+ k = 4
+ m = 2
+ t = 1
+ s = baz (b)
+ do i = 1, 1024
+ if (a(i).ne.((i - 513) * b(i))) call abort
+ if (i.lt.52.and.modulo (i - 52, 39).ne.0) then
+ if (b(i).ne.(modulo (i - 52, 39) - 39)) call abort
+ else
+ if (b(i).ne.(modulo (i - 52, 39))) call abort
+ end if
+ end do
+ if (k.ne.(4 + 3 * 1024).or.s.ne.1596127) call abort
+contains
+ function foo (p)
+ integer :: p(1024), u, v, i, s, foo
+ s = 0
+ !$omp parallel do simd linear(k : m + 1) reduction(+: s) &
+ !$omp & lastprivate(u, v) schedule (static, 32)
+ do i = 1, 1024
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp end parallel do simd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ foo = s
+ end function foo
+ function bar (p)
+ integer :: p(1024), u, v, i, s, bar
+ s = 0
+ !$omp parallel do simd linear(k : m + 1) reduction(+: s) &
+ !$omp & lastprivate(u, v) schedule (dynamic, 32)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ !$omp endparalleldosimd
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ bar = s
+ end function bar
+ function baz (p)
+ integer :: p(1024), u, v, i, s, baz
+ s = 0
+ !$omp parallel do simd linear(k : m + 1) reduction(+: s) &
+ !$omp & lastprivate(u, v) linear(i : t) schedule (static, 8)
+ do i = 1, 1024, t
+ a(i) = a(i) * p(i)
+ u = p(i) + k
+ k = k + m + 1
+ v = p(i) + k
+ s = s + p(i) + k
+ end do
+ if (i.ne.1025) call abort
+ if (u.ne.(36 + 4 + 3 * 1023).or.v.ne.(36 + 4 + 3 * 1024)) call abort
+ baz = s
+ end function baz
+end
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ integer :: i, j, b, c
+ c = 0
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ b = b + 2
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ b = b + 3
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(i) linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ b = b + 2
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(i:4) linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ b = b + 3
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd collapse(2) linear(b:2) reduction(+:c)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ b = b + 2
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd collapse(2) linear(b:2) reduction(+:c) lastprivate (i, j)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ b = b + 2
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ b = b + 2
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ b = b + 3
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(i) linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ b = b + 2
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(i:4) linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ b = b + 3
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) collapse(2) linear(b:2) reduction(+:c)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ b = b + 2
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) collapse(2) linear(b:2) &
+!$omp & reduction(+:c) lastprivate (i, j)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ b = b + 2
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+end
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+ interface
+ subroutine foo (b, i, j, x)
+ integer, intent (inout) :: b
+ integer, intent (in) :: i, j, x
+ end subroutine
+ end interface
+ integer :: i, j, b, c
+ c = 0
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ call foo (b, i, j, 2)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ call foo (b, i, j, 3)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(i) linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ call foo (b, i, j, 2)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd linear(i:4) linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ call foo (b, i, j, 3)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd collapse(2) linear(b:2) reduction(+:c)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ call foo (b, i, j, 2)
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp simd collapse(2) linear(b:2) reduction(+:c) lastprivate (i, j)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ call foo (b, i, j, 2)
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ call foo (b, i, j, 2)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ call foo (b, i, j, 3)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(i) linear(b:2) reduction(+:c)
+ do i = 0, 63
+ c = c + b - (7 + 2 * i)
+ call foo (b, i, j, 2)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) linear(i:4) linear(b:3) reduction(+:c)
+ do i = 0, 63, 4
+ c = c + b - (7 + i / 4 * 3)
+ call foo (b, i, j, 3)
+ end do
+ if (c /= 0 .or. i /= 64 .or. b /= 7 + 16 * 3) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) collapse(2) linear(b:2) reduction(+:c)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ call foo (b, i, j, 2)
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+ i = 4
+ j = 4
+ b = 7
+!$omp parallel do simd schedule (static, 4) collapse(2) linear(b:2) &
+!$omp & reduction(+:c) lastprivate (i, j)
+ do i = 0, 7
+ do j = 0, 7
+ c = c + b - (7 + 2 * j + 2 * 8 * i)
+ call foo (b, i, j, 2)
+ end do
+ end do
+ if (c /= 0 .or. i /= 8 .or. j /= 8 .or. b /= 7 + 64 * 2) call abort
+end
+subroutine foo (b, i, j, x)
+ integer, intent (inout) :: b
+ integer, intent (in) :: i, j, x
+ b = b + (i - i) + (j - j) + x
+end subroutine
--- /dev/null
+! { dg-do run }
+! { dg-additional-options "-msse2" { target sse2_runtime } }
+! { dg-additional-options "-mavx" { target avx_runtime } }
+
+subroutine foo (d, e, f, g, m, n)
+ integer :: i, j, b(2:9), c(3:n), d(:), e(2:n), f(2:,3:), n
+ integer, allocatable :: g(:), h(:), k, m
+ logical :: l
+ l = .false.
+ allocate (h(2:7))
+ i = 4; j = 4; b = 7; c = 8; d = 9; e = 10; f = 11; g = 12; h = 13; k = 14; m = 15
+!$omp simd linear(b)linear(c:2)linear(d:3)linear(e:4)linear(f:5)linear(g:6) &
+!$omp & linear(h:7)linear(k:8)linear(m:9) reduction(.or.:l)
+ do i = 0, 63
+ l = l .or. .not.allocated (g) .or. .not.allocated (h)
+ l = l .or. .not.allocated (k) .or. .not.allocated (m)
+ l = l .or. any (b /= 7 + i) .or. any (c /= 8 + 2 * i)
+ l = l .or. any (d /= 9 + 3 * i) .or. any (e /= 10 + 4 * i)
+ l = l .or. any (f /= 11 + 5 * i) .or. any (g /= 12 + 6 * i)
+ l = l .or. any (h /= 13 + 7 * i) .or. (k /= 14 + 8 * i)
+ l = l .or. (m /= 15 + 9 * i)
+ l = l .or. (lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)
+ l = l .or. (lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)
+ l = l .or. (lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)
+ l = l .or. (lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)
+ l = l .or. (lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)
+ l = l .or. (lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)
+ l = l .or. (lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)
+ l = l .or. (lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)
+ b = b + 1; c = c + 2; d = d + 3; e = e + 4; f = f + 5; g = g + 6
+ h = h + 7; k = k + 8; m = m + 9
+ end do
+ if (l .or. i /= 64) call abort
+ if (any (b /= 7 + 64) .or. any (c /= 8 + 2 * 64)) call abort
+ if (any (d /= 9 + 3 * 64) .or. any (e /= 10 + 4 * 64)) call abort
+ if (any (f /= 11 + 5 * 64) .or. any (g /= 12 + 6 * 64)) call abort
+ if (any (h /= 13 + 7 * 64) .or. (k /= 14 + 8 * 64)) call abort
+ if (m /= 15 + 9 * 64) call abort
+ if ((lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)) call abort
+ if ((lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)) call abort
+ if ((lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)) call abort
+ if ((lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)) call abort
+ if ((lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)) call abort
+ if ((lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)) call abort
+ if ((lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)) call abort
+ if ((lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)) call abort
+ i = 4; j = 4; b = 7; c = 8; d = 9; e = 10; f = 11; g = 12; h = 13; k = 14; m = 15
+!$omp simd linear(b)linear(c:2)linear(d:3)linear(e:4)linear(f:5)linear(g:6) &
+!$omp & linear(h:7)linear(k:8)linear(m:9) reduction(.or.:l) collapse(2)
+ do i = 0, 7
+ do j = 0, 7
+ l = l .or. .not.allocated (g) .or. .not.allocated (h)
+ l = l .or. .not.allocated (k) .or. .not.allocated (m)
+ l = l .or. any (b /= 7 + (8 * i + j)) .or. any (c /= 8 + 2 * (8 * i + j))
+ l = l .or. any (d /= 9 + 3 * (8 * i + j)) .or. any (e /= 10 + 4 * (8 * i + j))
+ l = l .or. any (f /= 11 + 5 * (8 * i + j)) .or. any (g /= 12 + 6 * (8 * i + j))
+ l = l .or. any (h /= 13 + 7 * (8 * i + j)) .or. (k /= 14 + 8 * (8 * i + j))
+ l = l .or. (m /= 15 + 9 * (8 * i + j))
+ l = l .or. (lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)
+ l = l .or. (lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)
+ l = l .or. (lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)
+ l = l .or. (lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)
+ l = l .or. (lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)
+ l = l .or. (lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)
+ l = l .or. (lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)
+ l = l .or. (lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)
+ b = b + 1; c = c + 2; d = d + 3; e = e + 4; f = f + 5; g = g + 6
+ h = h + 7; k = k + 8; m = m + 9
+ end do
+ end do
+ if (l .or. i /= 8 .or. j /= 8) call abort
+ if (any (b /= 7 + 64) .or. any (c /= 8 + 2 * 64)) call abort
+ if (any (d /= 9 + 3 * 64) .or. any (e /= 10 + 4 * 64)) call abort
+ if (any (f /= 11 + 5 * 64) .or. any (g /= 12 + 6 * 64)) call abort
+ if (any (h /= 13 + 7 * 64) .or. (k /= 14 + 8 * 64)) call abort
+ if (m /= 15 + 9 * 64) call abort
+ if ((lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)) call abort
+ if ((lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)) call abort
+ if ((lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)) call abort
+ if ((lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)) call abort
+ if ((lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)) call abort
+ if ((lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)) call abort
+ if ((lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)) call abort
+ if ((lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)) call abort
+ i = 4; j = 4; b = 7; c = 8; d = 9; e = 10; f = 11; g = 12; h = 13; k = 14; m = 15
+!$omp parallel do simd linear(b)linear(c:2)linear(d:3)linear(e:4)linear(f:5) &
+!$omp & linear(g:6)linear(h:7)linear(k:8)linear(m:9) reduction(.or.:l)
+ do i = 0, 63
+ l = l .or. .not.allocated (g) .or. .not.allocated (h)
+ l = l .or. .not.allocated (k) .or. .not.allocated (m)
+ l = l .or. any (b /= 7 + i) .or. any (c /= 8 + 2 * i)
+ l = l .or. any (d /= 9 + 3 * i) .or. any (e /= 10 + 4 * i)
+ l = l .or. any (f /= 11 + 5 * i) .or. any (g /= 12 + 6 * i)
+ l = l .or. any (h /= 13 + 7 * i) .or. (k /= 14 + 8 * i)
+ l = l .or. (m /= 15 + 9 * i)
+ l = l .or. (lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)
+ l = l .or. (lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)
+ l = l .or. (lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)
+ l = l .or. (lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)
+ l = l .or. (lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)
+ l = l .or. (lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)
+ l = l .or. (lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)
+ l = l .or. (lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)
+ b = b + 1; c = c + 2; d = d + 3; e = e + 4; f = f + 5; g = g + 6
+ h = h + 7; k = k + 8; m = m + 9
+ end do
+ if (l .or. i /= 64) call abort
+ if (any (b /= 7 + 64) .or. any (c /= 8 + 2 * 64)) call abort
+ if (any (d /= 9 + 3 * 64) .or. any (e /= 10 + 4 * 64)) call abort
+ if (any (f /= 11 + 5 * 64) .or. any (g /= 12 + 6 * 64)) call abort
+ if (any (h /= 13 + 7 * 64) .or. (k /= 14 + 8 * 64)) call abort
+ if (m /= 15 + 9 * 64) call abort
+ if ((lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)) call abort
+ if ((lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)) call abort
+ if ((lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)) call abort
+ if ((lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)) call abort
+ if ((lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)) call abort
+ if ((lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)) call abort
+ if ((lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)) call abort
+ if ((lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)) call abort
+ i = 4; j = 4; b = 7; c = 8; d = 9; e = 10; f = 11; g = 12; h = 13; k = 14; m = 15
+!$omp parallel do simd linear(b)linear(c:2)linear(d:3)linear(e:4)linear(f:5) &
+!$omp & linear(g:6)linear(h:7)linear(k:8)linear(m:9) reduction(.or.:l) collapse(2)
+ do i = 0, 7
+ do j = 0, 7
+ l = l .or. .not.allocated (g) .or. .not.allocated (h)
+ l = l .or. .not.allocated (k) .or. .not.allocated (m)
+ l = l .or. any (b /= 7 + (8 * i + j)) .or. any (c /= 8 + 2 * (8 * i + j))
+ l = l .or. any (d /= 9 + 3 * (8 * i + j)) .or. any (e /= 10 + 4 * (8 * i + j))
+ l = l .or. any (f /= 11 + 5 * (8 * i + j)) .or. any (g /= 12 + 6 * (8 * i + j))
+ l = l .or. any (h /= 13 + 7 * (8 * i + j)) .or. (k /= 14 + 8 * (8 * i + j))
+ l = l .or. (m /= 15 + 9 * (8 * i + j))
+ l = l .or. (lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)
+ l = l .or. (lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)
+ l = l .or. (lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)
+ l = l .or. (lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)
+ l = l .or. (lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)
+ l = l .or. (lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)
+ l = l .or. (lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)
+ l = l .or. (lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)
+ b = b + 1; c = c + 2; d = d + 3; e = e + 4; f = f + 5; g = g + 6
+ h = h + 7; k = k + 8; m = m + 9
+ end do
+ end do
+ if (l .or. i /= 8 .or. j /= 8) call abort
+ if (any (b /= 7 + 64) .or. any (c /= 8 + 2 * 64)) call abort
+ if (any (d /= 9 + 3 * 64) .or. any (e /= 10 + 4 * 64)) call abort
+ if (any (f /= 11 + 5 * 64) .or. any (g /= 12 + 6 * 64)) call abort
+ if (any (h /= 13 + 7 * 64) .or. (k /= 14 + 8 * 64)) call abort
+ if (m /= 15 + 9 * 64) call abort
+ if ((lbound (b, 1) /= 2) .or. (ubound (b, 1) /= 9)) call abort
+ if ((lbound (c, 1) /= 3) .or. (ubound (c, 1) /= n)) call abort
+ if ((lbound (d, 1) /= 1) .or. (ubound (d, 1) /= 17)) call abort
+ if ((lbound (e, 1) /= 2) .or. (ubound (e, 1) /= n)) call abort
+ if ((lbound (f, 1) /= 2) .or. (ubound (f, 1) /= 3)) call abort
+ if ((lbound (f, 2) /= 3) .or. (ubound (f, 2) /= 5)) call abort
+ if ((lbound (g, 1) /= 7) .or. (ubound (g, 1) /= 10)) call abort
+ if ((lbound (h, 1) /= 2) .or. (ubound (h, 1) /= 7)) call abort
+end subroutine
+
+ interface
+ subroutine foo (d, e, f, g, m, n)
+ integer :: d(:), e(2:n), f(2:,3:), n
+ integer, allocatable :: g(:), m
+ end subroutine
+ end interface
+ integer, parameter :: n = 8
+ integer :: d(2:18), e(3:n+1), f(5:6,7:9)
+ integer, allocatable :: g(:), m
+ allocate (g(7:10))
+ call foo (d, e, f, g, m, n)
+end
--- /dev/null
+! { dg-do run }
+
+module target1
+contains
+ subroutine foo (p, v, w, n)
+ double precision, pointer :: p(:), v(:), w(:)
+ double precision :: q(n)
+ integer :: i, n
+ !$omp target if (n > 256) map (to: v(1:n), w(:n)) map (from: p(1:n), q)
+ !$omp parallel do simd
+ do i = 1, n
+ p(i) = v(i) * w(i)
+ q(i) = p(i)
+ end do
+ !$omp end target
+ if (any (p /= q)) call abort
+ do i = 1, n
+ if (p(i) /= i * iand (i, 63)) call abort
+ end do
+ !$omp target data if (n > 256) map (to: v(1:n), w) map (from: p, q)
+ !$omp target if (n > 256)
+ do i = 1, n
+ p(i) = 1.0
+ q(i) = 2.0
+ end do
+ !$omp end target
+ !$omp target if (n > 256)
+ do i = 1, n
+ p(i) = p(i) + v(i) * w(i)
+ q(i) = q(i) + v(i) * w(i)
+ end do
+ !$omp end target
+ !$omp target if (n > 256)
+ !$omp teams distribute parallel do simd linear(i:1)
+ do i = 1, n
+ p(i) = p(i) + 2.0
+ q(i) = q(i) + 3.0
+ end do
+ !$omp end target
+ !$omp end target data
+ if (any (p + 2.0 /= q)) call abort
+ end subroutine
+end module target1
+ use target1, only : foo
+ integer :: n, i
+ double precision, pointer :: p(:), v(:), w(:)
+ n = 10000
+ allocate (p(n), v(n), w(n))
+ do i = 1, n
+ v(i) = i
+ w(i) = iand (i, 63)
+ end do
+ call foo (p, v, w, n)
+ do i = 1, n
+ if (p(i) /= i * iand (i, 63) + 3) call abort
+ end do
+ deallocate (p, v, w)
+end
--- /dev/null
+! { dg-do run }
+! { dg-options "-fopenmp -ffree-line-length-160" }
+
+module target2
+contains
+ subroutine foo (a, b, c, d, e, f, g, n, q)
+ integer :: n, q
+ integer :: a, b(3:n), c(5:), d(2:*), e(:,:)
+ integer, pointer :: f, g(:)
+ integer :: h, i(3:n)
+ integer, pointer :: j, k(:)
+ logical :: r
+ allocate (j, k(4:n))
+ h = 14
+ i = 15
+ j = 16
+ k = 17
+ !$omp target map (to: a, b, c, d(2:n+1), e, f, g, h, i, j, k, n) map (from: r)
+ r = a /= 7
+ r = r .or. (any (b /= 8)) .or. (lbound (b, 1) /= 3) .or. (ubound (b, 1) /= n)
+ r = r .or. (any (c /= 9)) .or. (lbound (c, 1) /= 5) .or. (ubound (c, 1) /= n + 4)
+ r = r .or. (any (d(2:n+1) /= 10)) .or. (lbound (d, 1) /= 2)
+ r = r .or. (any (e /= 11)) .or. (lbound (e, 1) /= 1) .or. (ubound (e, 1) /= 2)
+ r = r .or. (lbound (e, 2) /= 1) .or. (ubound (e, 2) /= 2)
+ r = r .or. (f /= 12)
+ r = r .or. (any (g /= 13)) .or. (lbound (g, 1) /= 3) .or. (ubound (g, 1) /= n)
+ r = r .or. (h /= 14)
+ r = r .or. (any (i /= 15)) .or. (lbound (i, 1) /= 3) .or. (ubound (i, 1) /= n)
+ r = r .or. (j /= 16)
+ r = r .or. (any (k /= 17)) .or. (lbound (k, 1) /= 4) .or. (ubound (k, 1) /= n)
+ !$omp end target
+ if (r) call abort
+ !$omp target map (to: b(3:n), c(5:n+4), d(2:n+1), e(1:,:2), g(3:n), i(3:n), k(4:n), n) map (from: r)
+ r = (any (b /= 8)) .or. (lbound (b, 1) /= 3) .or. (ubound (b, 1) /= n)
+ r = r .or. (any (c /= 9)) .or. (lbound (c, 1) /= 5) .or. (ubound (c, 1) /= n + 4)
+ r = r .or. (any (d(2:n+1) /= 10)) .or. (lbound (d, 1) /= 2)
+ r = r .or. (any (e /= 11)) .or. (lbound (e, 1) /= 1) .or. (ubound (e, 1) /= 2)
+ r = r .or. (lbound (e, 2) /= 1) .or. (ubound (e, 2) /= 2)
+ r = r .or. (any (g /= 13)) .or. (lbound (g, 1) /= 3) .or. (ubound (g, 1) /= n)
+ r = r .or. (any (i /= 15)) .or. (lbound (i, 1) /= 3) .or. (ubound (i, 1) /= n)
+ r = r .or. (any (k /= 17)) .or. (lbound (k, 1) /= 4) .or. (ubound (k, 1) /= n)
+ !$omp end target
+ if (r) call abort
+ !$omp target map (to: b(5:n-2), c(7:n), d(4:n-2), e(1:,2:), g(5:n-3), i(6:n-4), k(5:n-5), n) map (from: r)
+ r = (any (b(5:n-2) /= 8)) .or. (lbound (b, 1) /= 3) .or. (ubound (b, 1) /= n)
+ r = r .or. (any (c(7:n) /= 9)) .or. (lbound (c, 1) /= 5) .or. (ubound (c, 1) /= n + 4)
+ r = r .or. (any (d(4:n-2) /= 10)) .or. (lbound (d, 1) /= 2)
+ r = r .or. (any (e(1:,2:) /= 11)) .or. (lbound (e, 1) /= 1) .or. (ubound (e, 1) /= 2)
+ r = r .or. (lbound (e, 2) /= 1) .or. (ubound (e, 2) /= 2)
+ r = r .or. (any (g(5:n-3) /= 13)) .or. (lbound (g, 1) /= 3) .or. (ubound (g, 1) /= n)
+ r = r .or. (any (i(6:n-4) /= 15)) .or. (lbound (i, 1) /= 3) .or. (ubound (i, 1) /= n)
+ r = r .or. (any (k(5:n-5) /= 17)) .or. (lbound (k, 1) /= 4) .or. (ubound (k, 1) /= n)
+ !$omp end target
+ !$omp target map (to: b(q+5:n-2+q), c(q+7:q+n), d(q+4:q+n-2), e(1:q+2,2:q+2), g(5+q:n-3+q), &
+ !$omp & i(6+q:n-4+q), k(5+q:n-5+q), n) map (from: r)
+ r = (any (b(5:n-2) /= 8)) .or. (lbound (b, 1) /= 3) .or. (ubound (b, 1) /= n)
+ r = r .or. (any (c(7:n) /= 9)) .or. (lbound (c, 1) /= 5) .or. (ubound (c, 1) /= n + 4)
+ r = r .or. (any (d(4:n-2) /= 10)) .or. (lbound (d, 1) /= 2)
+ r = r .or. (any (e(1:,2:) /= 11)) .or. (lbound (e, 1) /= 1) .or. (ubound (e, 1) /= 2)
+ r = r .or. (lbound (e, 2) /= 1) .or. (ubound (e, 2) /= 2)
+ r = r .or. (any (g(5:n-3) /= 13)) .or. (lbound (g, 1) /= 3) .or. (ubound (g, 1) /= n)
+ r = r .or. (any (i(6:n-4) /= 15)) .or. (lbound (i, 1) /= 3) .or. (ubound (i, 1) /= n)
+ r = r .or. (any (k(5:n-5) /= 17)) .or. (lbound (k, 1) /= 4) .or. (ubound (k, 1) /= n)
+ !$omp end target
+ if (r) call abort
+ !$omp target map (to: d(2:n+1), n)
+ r = a /= 7
+ r = r .or. (any (b /= 8)) .or. (lbound (b, 1) /= 3) .or. (ubound (b, 1) /= n)
+ r = r .or. (any (c /= 9)) .or. (lbound (c, 1) /= 5) .or. (ubound (c, 1) /= n + 4)
+ r = r .or. (any (d(2:n+1) /= 10)) .or. (lbound (d, 1) /= 2)
+ r = r .or. (any (e /= 11)) .or. (lbound (e, 1) /= 1) .or. (ubound (e, 1) /= 2)
+ r = r .or. (lbound (e, 2) /= 1) .or. (ubound (e, 2) /= 2)
+ r = r .or. (f /= 12)
+ r = r .or. (any (g /= 13)) .or. (lbound (g, 1) /= 3) .or. (ubound (g, 1) /= n)
+ r = r .or. (h /= 14)
+ r = r .or. (any (i /= 15)) .or. (lbound (i, 1) /= 3) .or. (ubound (i, 1) /= n)
+ r = r .or. (j /= 16)
+ r = r .or. (any (k /= 17)) .or. (lbound (k, 1) /= 4) .or. (ubound (k, 1) /= n)
+ !$omp end target
+ if (r) call abort
+ end subroutine foo
+end module target2
+ use target2, only : foo
+ integer, parameter :: n = 15, q = 0
+ integer :: a, b(2:n-1), c(n), d(n), e(3:4, 3:4)
+ integer, pointer :: f, g(:)
+ allocate (f, g(3:n))
+ a = 7
+ b = 8
+ c = 9
+ d = 10
+ e = 11
+ f = 12
+ g = 13
+ call foo (a, b, c, d, e, f, g, n, q)
+end
--- /dev/null
+! { dg-do run }
+
+module target3
+contains
+ subroutine foo (f, g)
+ integer :: n
+ integer, pointer :: f, g(:)
+ integer, pointer :: j, k(:)
+ logical :: r
+ nullify (j)
+ k => null ()
+ !$omp target map (tofrom: f, g, j, k) map (from: r)
+ r = associated (f) .or. associated (g)
+ r = r .or. associated (j) .or. associated (k)
+ !$omp end target
+ if (r) call abort
+ !$omp target
+ r = associated (f) .or. associated (g)
+ r = r .or. associated (j) .or. associated (k)
+ !$omp end target
+ if (r) call abort
+ end subroutine foo
+end module target3
+ use target3, only : foo
+ integer, pointer :: f, g(:)
+ f => null ()
+ nullify (g)
+ call foo (f, g)
+end
--- /dev/null
+! { dg-do run }
+
+module target4
+contains
+ subroutine foo (a,m,n)
+ integer :: m,n,i,j
+ double precision :: a(m, n), t
+ !$omp target data map(a) map(to: m, n)
+ do i=1,n
+ t = 0.0d0
+ !$omp target
+ !$omp parallel do reduction(+:t)
+ do j=1,m
+ t = t + a(j,i) * a(j,i)
+ end do
+ !$omp end target
+ t = 2.0d0 * t
+ !$omp target
+ !$omp parallel do
+ do j=1,m
+ a(j,i) = a(j,i) * t
+ end do
+ !$omp end target
+ end do
+ !$omp end target data
+ end subroutine foo
+end module target4
+ use target4, only : foo
+ integer :: i, j
+ double precision :: a(8, 9), res(8, 9)
+ do i = 1, 8
+ do j = 1, 9
+ a(i, j) = i + j
+ end do
+ end do
+ call foo (a, 8, 9)
+ res = reshape ((/ 1136.0d0, 1704.0d0, 2272.0d0, 2840.0d0, 3408.0d0, 3976.0d0, &
+& 4544.0d0, 5112.0d0, 2280.0d0, 3040.0d0, 3800.0d0, 4560.0d0, 5320.0d0, 6080.0d0, &
+& 6840.0d0, 7600.0d0, 3936.0d0, 4920.0d0, 5904.0d0, 6888.0d0, 7872.0d0, 8856.0d0, &
+& 9840.0d0, 10824.0d0, 6200.0d0, 7440.0d0, 8680.0d0, 9920.0d0, 11160.0d0, 12400.0d0, &
+& 13640.0d0, 14880.0d0, 9168.0d0, 10696.0d0, 12224.0d0, 13752.0d0, 15280.0d0, 16808.0d0, &
+& 18336.0d0, 19864.0d0, 12936.0d0, 14784.0d0, 16632.0d0, 18480.0d0, 20328.0d0, 22176.0d0, &
+& 24024.0d0, 25872.0d0, 17600.0d0, 19800.0d0, 22000.0d0, 24200.0d0, 26400.0d0, 28600.0d0, &
+& 30800.0d0, 33000.0d0, 23256.0d0, 25840.0d0, 28424.0d0, 31008.0d0, 33592.0d0, 36176.0d0, &
+& 38760.0d0, 41344.0d0, 30000.0d0, 33000.0d0, 36000.0d0, 39000.0d0, 42000.0d0, 45000.0d0, &
+& 48000.0d0, 51000.0d0 /), (/ 8, 9 /))
+ if (any (a /= res)) call abort
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fopenmp" }
+
+ integer :: r
+ r = 0
+ call foo (r)
+ if (r /= 11) call abort
+contains
+ subroutine foo (r)
+ integer :: i, r
+ !$omp parallel
+ !$omp single
+ !$omp target teams distribute parallel do reduction (+: r)
+ do i = 1, 10
+ r = r + 1
+ end do
+ r = r + 1
+ !$omp end single
+ !$omp end parallel
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+
+module target6
+contains
+ subroutine foo (p, v, w, n)
+ double precision, pointer :: p(:), v(:), w(:)
+ double precision :: q(n)
+ integer :: i, n
+ !$omp target data if (n > 256) map (to: v(1:n), w(:n)) map (from: p(1:n), q)
+ !$omp target if (n > 256)
+ !$omp parallel do simd
+ do i = 1, n
+ p(i) = v(i) * w(i)
+ q(i) = p(i)
+ end do
+ !$omp end target
+ !$omp target update if (n > 256) from (p)
+ do i = 1, n
+ if (p(i) /= i * iand (i, 63)) call abort
+ v(i) = v(i) + 1
+ end do
+ !$omp target update if (n > 256) to (v(1:n))
+ !$omp target if (n > 256)
+ !$omp parallel do simd
+ do i = 1, n
+ p(i) = v(i) * w(i)
+ end do
+ !$omp end target
+ !$omp end target data
+ do i = 1, n
+ if (q(i) /= (v(i) - 1) * w(i)) call abort
+ if (p(i) /= q(i) + w(i)) call abort
+ end do
+ end subroutine
+end module target6
+ use target6, only : foo
+ integer :: n, i
+ double precision, pointer :: p(:), v(:), w(:)
+ n = 10000
+ allocate (p(n), v(n), w(n))
+ do i = 1, n
+ v(i) = i
+ w(i) = iand (i, 63)
+ end do
+ call foo (p, v, w, n)
+ do i = 1, n
+ if (p(i) /= (i + 1) * iand (i, 63)) call abort
+ end do
+ deallocate (p, v, w)
+end
--- /dev/null
+! { dg-do run }
+
+ interface
+ real function foo (x)
+ !$omp declare target
+ real, intent(in) :: x
+ end function foo
+ end interface
+ integer, parameter :: n = 1000
+ integer, parameter :: c = 100
+ integer :: i, j
+ real :: a(n)
+ do i = 1, n
+ a(i) = i
+ end do
+ !$omp parallel
+ !$omp single
+ do i = 1, n, c
+ !$omp task shared(a)
+ !$omp target map(a(i:i+c-1))
+ !$omp parallel do
+ do j = i, i + c - 1
+ a(j) = foo (a(j))
+ end do
+ !$omp end target
+ !$omp end task
+ end do
+ !$omp end single
+ !$omp end parallel
+ do i = 1, n
+ if (a(i) /= i + 1) call abort
+ end do
+end
+real function foo (x)
+ !$omp declare target
+ real, intent(in) :: x
+ foo = x + 1
+end function foo
--- /dev/null
+! { dg-do run }
+
+ integer, parameter :: n = 1000
+ integer, parameter :: c = 100
+ integer :: i, j
+ real :: a(n)
+ do i = 1, n
+ a(i) = i
+ end do
+ !$omp parallel
+ !$omp single
+ do i = 1, n, c
+ !$omp task shared(a)
+ !$omp target map(a(i:i+c-1))
+ !$omp parallel do
+ do j = i, i + c - 1
+ a(j) = foo (a(j))
+ end do
+ !$omp end target
+ !$omp end task
+ end do
+ !$omp end single
+ !$omp end parallel
+ do i = 1, n
+ if (a(i) /= i + 1) call abort
+ end do
+contains
+ real function foo (x)
+ !$omp declare target
+ real, intent(in) :: x
+ foo = x + 1
+ end function foo
+end
--- /dev/null
+ integer :: v(16), i
+ do i = 1, 16
+ v(i) = i
+ end do
+
+ !$omp parallel num_threads (4)
+ !$omp single
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp task
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ do i = 1, 16
+ if (v(i).ne.(i + 1)) call abort
+ end do
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp task
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp endtask
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp endtask
+ !$omp taskwait
+ !$omp endtask
+ end do
+ !$omp endtaskgroup
+ do i = 1, 16
+ if (v(i).ne.(i + 2)) call abort
+ end do
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp task
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ end do
+ !$omp taskwait
+ do i = 1, 16, 2
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ do i = 1, 16, 2
+ if (v(i).ne.(i + 3)) call abort
+ if (v(i + 1).ne.(i + 5)) call abort
+ end do
+ !$omp taskgroup
+ do i = 1, 16, 2
+ !$omp taskgroup
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ !$omp task
+ v(i + 1) = v(i + 1) + 1
+ !$omp end task
+ !$omp end taskgroup
+ if (v(i).ne.(i + 4).or.v(i + 1).ne.(i + 6)) call abort
+ !$omp task
+ v(i) = v(i) + 1
+ !$omp end task
+ end do
+ !$omp end taskgroup
+ do i = 1, 16
+ if (v(i).ne.(i + 5)) call abort
+ end do
+ !$omp end single
+ !$omp end parallel
+end
--- /dev/null
+! { dg-do run }
+
+module udr1
+ type dt
+ integer :: x = 7
+ integer :: y = 9
+ end type
+end module udr1
+ use udr1, only : dt
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+ integer :: i, j
+!$omp declare reduction (bar : integer : &
+!$omp & omp_out = omp_out + iand (omp_in, -4)) initializer (omp_priv = 3)
+ type (dt) :: d
+!$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
+!$omp & + iand (omp_in%x, -8))
+!$omp declare reduction (foo : dt : omp_out%x = iand (omp_in%x, -8) &
+!$omp & + omp_out%x) initializer (omp_priv = dt (5, 21))
+ interface operator (+)
+ function notdefined(x, y)
+ use udr1, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: notdefined
+ end function
+ end interface
+ j = 0
+!$omp parallel do reduction (foo : j)
+ do i = 1, 100
+ j = j + i
+ end do
+ if (j .ne. 5050) call abort
+ j = 3
+!$omp parallel do reduction (bar : j)
+ do i = 1, 100
+ j = j + 4 * i
+ end do
+ if (j .ne. (5050 * 4 + 3)) call abort
+!$omp parallel do reduction (+ : d)
+ do i = 1, 100
+ if (d%y .ne. 9) call abort
+ d%x = d%x + 8 * i
+ end do
+ if (d%x .ne. (5050 * 8 + 7) .or. d%y .ne. 9) call abort
+ d = dt (5, 21)
+!$omp parallel do reduction (foo : d)
+ do i = 1, 100
+ if (d%y .ne. 21) call abort
+ d%x = d%x + 8 * i
+ end do
+ if (d%x .ne. (5050 * 8 + 5) .or. d%y .ne. 21) call abort
+end
--- /dev/null
+! { dg-do run }
+
+module udr10m
+ type dt
+ integer :: x = 0
+ end type
+!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
+!$omp declare reduction(+:dt:omp_out=omp_out+omp_in)
+ interface operator(+)
+ module procedure addme
+ end interface
+ interface operator(.add.)
+ module procedure addme
+ end interface
+contains
+ type(dt) function addme (x, y)
+ type (dt), intent (in) :: x, y
+ addme%x = x%x + y%x
+ end function addme
+end module udr10m
+program udr10
+ use udr10m, only : operator(.localadd.) => operator(.add.), &
+& operator(+), dl => dt
+ type(dl) :: j, k
+ integer :: i
+!$omp parallel do reduction(+:j) reduction(.localadd.:k)
+ do i = 1, 100
+ j = j .localadd. dl(i)
+ k = k + dl(i * 2)
+ end do
+ if (j%x /= 5050 .or. k%x /= 10100) call abort
+end
--- /dev/null
+! { dg-do run }
+
+module udr11
+ type dt
+ integer :: x = 0
+ end type
+end module udr11
+ use udr11, only : dt
+!$omp declare reduction(+:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(-:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(*:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(.and.:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(.or.:dt:omp_out%x=omp_out%x+3*omp_in%x)
+!$omp declare reduction(.eqv.:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(.neqv.:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(min:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(max:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(iand:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(ior:dt:omp_out%x=omp_out%x+omp_in%x)
+!$omp declare reduction(ieor:dt:omp_out%x=omp_out%x+omp_in%x)
+ interface operator(.and.)
+ function addme1 (x, y)
+ use udr11, only : dt
+ type (dt), intent (in) :: x, y
+ type(dt) :: addme1
+ end function addme1
+ end interface
+ interface operator(.or.)
+ function addme2 (x, y)
+ use udr11, only : dt
+ type (dt), intent (in) :: x, y
+ type(dt) :: addme2
+ end function addme2
+ end interface
+ interface operator(.eqv.)
+ function addme3 (x, y)
+ use udr11, only : dt
+ type (dt), intent (in) :: x, y
+ type(dt) :: addme3
+ end function addme3
+ end interface
+ interface operator(.neqv.)
+ function addme4 (x, y)
+ use udr11, only : dt
+ type (dt), intent (in) :: x, y
+ type(dt) :: addme4
+ end function addme4
+ end interface
+ interface operator(+)
+ function addme5 (x, y)
+ use udr11, only : dt
+ type (dt), intent (in) :: x, y
+ type(dt) :: addme5
+ end function addme5
+ end interface
+ interface operator(-)
+ function addme6 (x, y)
+ use udr11, only : dt
+ type (dt), intent (in) :: x, y
+ type(dt) :: addme6
+ end function addme6
+ end interface
+ interface operator(*)
+ function addme7 (x, y)
+ use udr11, only : dt
+ type (dt), intent (in) :: x, y
+ type(dt) :: addme7
+ end function addme7
+ end interface
+ type(dt) :: j, k, l, m, n, o, p, q, r, s, t, u
+ integer :: i
+!$omp parallel do reduction(.and.:j) reduction(.or.:k) &
+!$omp & reduction(.eqv.:l) reduction(.neqv.:m) &
+!$omp & reduction(min:n) reduction(max:o) &
+!$omp & reduction(iand:p) reduction(ior:q) reduction (ieor:r) &
+!$omp & reduction(+:s) reduction(-:t) reduction(*:u)
+ do i = 1, 100
+ j%x = j%x + i
+ k%x = k%x + 2 * i
+ l%x = l%x + 3 * i
+ m%x = m%x + i
+ n%x = n%x + 2 * i
+ o%x = o%x + 3 * i
+ p%x = p%x + i
+ q%x = q%x + 2 * i
+ r%x = r%x + 3 * i
+ s%x = s%x + i
+ t%x = t%x + 2 * i
+ u%x = u%x + 3 * i
+ end do
+ if (j%x /= 5050 .or. k%x /= 30300 .or. l%x /= 15150) call abort
+ if (m%x /= 5050 .or. n%x /= 10100 .or. o%x /= 15150) call abort
+ if (p%x /= 5050 .or. q%x /= 10100 .or. r%x /= 15150) call abort
+ if (s%x /= 5050 .or. t%x /= 10100 .or. u%x /= 15150) call abort
+end
--- /dev/null
+! { dg-do run }
+
+ interface
+ elemental subroutine sub1 (x, y)
+ integer, intent(in) :: y
+ integer, intent(out) :: x
+ end subroutine
+ elemental function fn2 (x)
+ integer, intent(in) :: x
+ integer :: fn2
+ end function
+ end interface
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) &
+!$omp & initializer (sub1 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn2 (omp_orig))
+ interface
+ elemental function fn1 (x, y)
+ integer, intent(in) :: x, y
+ integer :: fn1
+ end function
+ elemental subroutine sub2 (x, y)
+ integer, intent(in) :: y
+ integer, intent(inout) :: x
+ end subroutine
+ end interface
+ integer :: a(10), b, r
+ a(:) = 0
+ b = 0
+ r = 0
+!$omp parallel reduction (foo : a, b) reduction (+: r)
+ a = a + 2
+ b = b + 3
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 2 * r) .or. b /= 3 * r) call abort
+ a(:) = 0
+ b = 0
+ r = 0
+!$omp parallel reduction (bar : a, b) reduction (+: r)
+ a = a + 2
+ b = b + 3
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 4 * r) .or. b /= 6 * r) call abort
+ a(:) = 0
+ b = 0
+ r = 0
+!$omp parallel reduction (baz : a, b) reduction (+: r)
+ a = a + 2
+ b = b + 3
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 2 * r) .or. b /= 3 * r) call abort
+end
+elemental function fn1 (x, y)
+ integer, intent(in) :: x, y
+ integer :: fn1
+ fn1 = x + 2 * y
+end function
+elemental subroutine sub1 (x, y)
+ integer, intent(in) :: y
+ integer, intent(out) :: x
+ x = 0
+end subroutine
+elemental function fn2 (x)
+ integer, intent(in) :: x
+ integer :: fn2
+ fn2 = x
+end function
+elemental subroutine sub2 (x, y)
+ integer, intent(inout) :: x
+ integer, intent(in) :: y
+ x = x + y
+end subroutine
--- /dev/null
+! { dg-do run }
+
+ interface
+ subroutine sub1 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(out) :: x(:)
+ end subroutine
+ function fn2 (x, m1, m2, n1, n2)
+ integer, intent(in) :: x(:,:), m1, m2, n1, n2
+ integer :: fn2(m1:m2,n1:n2)
+ end function
+ subroutine sub3 (x, y)
+ integer, allocatable, intent(in) :: y(:,:)
+ integer, allocatable, intent(inout) :: x(:,:)
+ end subroutine
+ end interface
+!$omp declare reduction (foo : integer : sub3 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn3 (omp_orig))
+!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in, &
+!$omp & lbound (omp_out, 1), ubound (omp_out, 1))) &
+!$omp & initializer (sub1 (omp_priv, omp_orig))
+!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) &
+!$omp initializer (omp_priv = fn2 (omp_orig, lbound (omp_priv, 1), &
+!$omp ubound (omp_priv, 1), lbound (omp_priv, 2), ubound (omp_priv, 2)))
+ interface
+ function fn1 (x, y, m1, m2)
+ integer, intent(in) :: x(:), y(:), m1, m2
+ integer :: fn1(m1:m2)
+ end function
+ subroutine sub2 (x, y)
+ integer, intent(in) :: y(:,:)
+ integer, intent(inout) :: x(:,:)
+ end subroutine
+ function fn3 (x)
+ integer, allocatable, intent(in) :: x(:,:)
+ integer, allocatable :: fn3(:,:)
+ end function
+ end interface
+ integer :: a(10), b(3:5,7:9), r
+ integer, allocatable :: c(:,:)
+ a(:) = 0
+ r = 0
+!$omp parallel reduction (bar : a) reduction (+: r)
+ if (lbound (a, 1) /= 1 .or. ubound (a, 1) /= 10) call abort
+ a = a + 2
+ r = r + 1
+!$omp end parallel
+ if (any (a /= 4 * r) ) call abort
+ b(:,:) = 0
+ allocate (c (4:6,8:10))
+ c(:,:) = 0
+ r = 0
+!$omp parallel reduction (baz : b, c) reduction (+: r)
+ if (lbound (b, 1) /= 3 .or. ubound (b, 1) /= 5) call abort
+ if (lbound (b, 2) /= 7 .or. ubound (b, 2) /= 9) call abort
+ if (.not. allocated (c)) call abort
+ if (lbound (c, 1) /= 4 .or. ubound (c, 1) /= 6) call abort
+ if (lbound (c, 2) /= 8 .or. ubound (c, 2) /= 10) call abort
+ b = b + 3
+ c = c + 4
+ r = r + 1
+!$omp end parallel
+ if (any (b /= 3 * r) .or. any (c /= 4 * r)) call abort
+ deallocate (c)
+ allocate (c (0:1,7:11))
+ c(:,:) = 0
+ r = 0
+!$omp parallel reduction (foo : c) reduction (+: r)
+ if (.not. allocated (c)) call abort
+ if (lbound (c, 1) /= 0 .or. ubound (c, 1) /= 1) call abort
+ if (lbound (c, 2) /= 7 .or. ubound (c, 2) /= 11) call abort
+ c = c + 5
+ r = r + 1
+!$omp end parallel
+ if (any (c /= 10 * r)) call abort
+end
+function fn1 (x, y, m1, m2)
+ integer, intent(in) :: x(:), y(:), m1, m2
+ integer :: fn1(m1:m2)
+ fn1 = x + 2 * y
+end function
+subroutine sub1 (x, y)
+ integer, intent(in) :: y(:)
+ integer, intent(out) :: x(:)
+ x = 0
+end subroutine
+function fn2 (x, m1, m2, n1, n2)
+ integer, intent(in) :: x(:,:), m1, m2, n1, n2
+ integer :: fn2(m1:m2,n1:n2)
+ fn2 = x
+end function
+subroutine sub2 (x, y)
+ integer, intent(inout) :: x(:,:)
+ integer, intent(in) :: y(:,:)
+ x = x + y
+end subroutine
+function fn3 (x)
+ integer, allocatable, intent(in) :: x(:,:)
+ integer, allocatable :: fn3(:,:)
+ fn3 = x
+end function
+subroutine sub3 (x, y)
+ integer, allocatable, intent(inout) :: x(:,:)
+ integer, allocatable, intent(in) :: y(:,:)
+ x = x + 2 * y
+end subroutine
--- /dev/null
+! { dg-do run }
+
+ type dt
+ integer :: g
+ integer, allocatable :: h(:)
+ end type
+!$omp declare reduction (baz : dt : bar (omp_out, omp_in)) &
+!$omp & initializer (foo (omp_priv, omp_orig))
+ integer :: r
+ type (dt), allocatable :: a(:)
+ allocate (a(7:8))
+ a(:)%g = 0
+ a(7)%h = (/ 0, 0, 0 /)
+ r = 0
+!$omp parallel reduction(+:r) reduction (baz:a)
+ if (.not.allocated (a)) call abort
+ if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort
+ if (.not.allocated (a(7)%h)) call abort
+ if (allocated (a(8)%h)) call abort
+ if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort
+ a(:)%g = a(:)%g + 2
+ a(7)%h = a(7)%h + 3
+ r = r + 1
+!$omp end parallel
+ if (.not.allocated (a)) call abort
+ if (lbound (a, 1) /= 7 .or. ubound (a, 1) /= 8) call abort
+ if (.not.allocated (a(7)%h)) call abort
+ if (allocated (a(8)%h)) call abort
+ if (lbound (a(7)%h, 1) /= 1 .or. ubound (a(7)%h, 1) /= 3) call abort
+ if (any (a(:)%g /= 2 * r) .or. any (a(7)%h(:) /= 3 * r)) call abort
+contains
+ subroutine foo (x, y)
+ type (dt), allocatable :: x(:), y(:)
+ if (allocated (x) .neqv. allocated (y)) call abort
+ if (lbound (x, 1) /= lbound (y, 1)) call abort
+ if (ubound (x, 1) /= ubound (y, 1)) call abort
+ if (allocated (x(7)%h) .neqv. allocated (y(7)%h)) call abort
+ if (allocated (x(8)%h) .neqv. allocated (y(8)%h)) call abort
+ if (lbound (x(7)%h, 1) /= lbound (y(7)%h, 1)) call abort
+ if (ubound (x(7)%h, 1) /= ubound (y(7)%h, 1)) call abort
+ x(7)%g = 0
+ x(7)%h = 0
+ x(8)%g = 0
+ end subroutine
+ subroutine bar (x, y)
+ type (dt), allocatable :: x(:), y(:)
+ x(:)%g = x(:)%g + y(:)%g
+ x(7)%h(:) = x(7)%h(:) + y(7)%h(:)
+ end subroutine
+end
--- /dev/null
+! { dg-do run }
+
+module udr15m1
+ integer, parameter :: a = 6
+ integer :: b
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+!$omp declare reduction (.add. : integer : &
+!$omp & omp_out = omp_out .add. f3 (omp_in, -4)) &
+!$omp & initializer (s1 (omp_priv, omp_orig))
+ interface operator (.add.)
+ module procedure f1
+ end interface
+contains
+ integer function f1 (x, y)
+ integer, intent (in) :: x, y
+ f1 = x + y
+ end function f1
+ integer function f3 (x, y)
+ integer, intent (in) :: x, y
+ f3 = iand (x, y)
+ end function f3
+ subroutine s1 (x, y)
+ integer, intent (in) :: y
+ integer, intent (out) :: x
+ x = 3
+ end subroutine s1
+end module udr15m1
+module udr15m2
+ use udr15m1, f4 => f1, f5 => f3, s2 => s1, operator (.addtwo.) => operator (.add.)
+ type dt
+ integer :: x
+ end type
+!$omp declare reduction (+ : dt : omp_out = f6 (omp_out + omp_in)) &
+!$omp & initializer (s3 (omp_priv))
+ interface operator (+)
+ module procedure f2
+ end interface
+contains
+ type(dt) function f2 (x, y)
+ type(dt), intent (in) :: x, y
+ f2%x = x%x + y%x
+ end function f2
+ type(dt) function f6 (x)
+ type(dt), intent (in) :: x
+ f6%x = x%x
+ end function f6
+ subroutine s3 (x)
+ type(dt), intent (out) :: x
+ x = dt(0)
+ end subroutine
+end module udr15m2
+ use udr15m2, operator (.addthree.) => operator (.addtwo.), &
+ f7 => f4, f8 => f6, s4 => s3
+ integer :: i, j
+ type(dt) :: d
+ j = 3
+ d%x = 0
+!$omp parallel do reduction (.addthree.: j) reduction (+ : d)
+ do i = 1, 100
+ j = j.addthree.iand (i, -4)
+ d = d + dt(i)
+ end do
+ if (d%x /= 5050 .or. j /= 4903) call abort
+end
--- /dev/null
+! { dg-do run }
+
+module udr2
+ type dt
+ integer :: x = 7
+ integer :: y = 9
+ end type
+end module udr2
+ use udr2, only : dt
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+ integer :: i, j(2:4,3:5)
+!$omp declare reduction (bar : integer : &
+!$omp & omp_out = omp_out + iand (omp_in, -4)) initializer (omp_priv = 3)
+ interface operator (+)
+ function notdefined(x, y)
+ use udr2, only : dt
+ type(dt), intent (in) :: x, y
+ type(dt) :: notdefined
+ end function
+ end interface
+ type (dt) :: d(2:4,3:5)
+!$omp declare reduction (+ : dt : omp_out%x = omp_out%x &
+!$omp & + iand (omp_in%x, -8))
+!$omp declare reduction (foo : dt : omp_out%x = iand (omp_in%x, -8) &
+!$omp & + omp_out%x) initializer (omp_priv = dt (5, 21))
+ j = 0
+!$omp parallel do reduction (foo : j)
+ do i = 1, 100
+ j = j + i
+ end do
+ if (any(j .ne. 5050)) call abort
+ j = 3
+!$omp parallel do reduction (bar : j)
+ do i = 1, 100
+ j = j + 4 * i
+ end do
+ if (any(j .ne. (5050 * 4 + 3))) call abort
+!$omp parallel do reduction (+ : d)
+ do i = 1, 100
+ if (any(d%y .ne. 9)) call abort
+ d%x = d%x + 8 * i
+ end do
+ if (any(d%x .ne. (5050 * 8 + 7)) .or. any(d%y .ne. 9)) call abort
+ d = dt (5, 21)
+!$omp parallel do reduction (foo : d)
+ do i = 1, 100
+ if (any(d%y .ne. 21)) call abort
+ d%x = d%x + 8 * i
+ end do
+ if (any(d%x .ne. (5050 * 8 + 5)) .or. any(d%y .ne. 21)) call abort
+end
--- /dev/null
+! { dg-do run }
+
+!$omp declare reduction (foo : character(kind=1, len=*) &
+!$omp & : omp_out = trim(omp_out) // omp_in) initializer (omp_priv = '')
+!$omp declare reduction (bar : character(kind=1, len=:) &
+!$omp & : omp_out = trim(omp_in) // omp_out) initializer (omp_priv = '')
+!$omp declare reduction (baz : character(kind=1, len=1) &
+!$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) &
+!$omp & - ichar ('0'))) initializer (omp_priv = '0')
+!$omp declare reduction (baz : character(kind=1, len=2) &
+!$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) &
+!$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + &
+!$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00')
+ character(kind=1, len=64) :: c, d
+ character(kind = 1, len=1) :: e
+ character(kind = 1, len=1+1) :: f
+ integer :: i
+ c = ''
+ d = ''
+ e = '0'
+ f = '00'
+!$omp parallel do reduction (foo : c) reduction (bar : d) &
+!$omp & reduction (baz : e, f)
+ do i = 1, 64
+ c = trim(c) // char (ichar ('0') + i)
+ d = char (ichar ('0') + i) // d
+ e = char (ichar (e) + mod (i, 3))
+ f = char (ichar (f(1:1)) + mod (i, 2)) &
+& // char (ichar (f(2:2)) + mod (i, 3))
+ end do
+ do i = 1, 64
+ if (index (c, char (ichar ('0') + i)) .eq. 0) call abort
+ if (index (d, char (ichar ('0') + i)) .eq. 0) call abort
+ end do
+ if (e.ne.char (ichar ('0') + 64)) call abort
+ if (f(1:1).ne.char (ichar ('0') + 32)) call abort
+ if (f(2:2).ne.char (ichar ('0') + 64)) call abort
+end
--- /dev/null
+! { dg-do run }
+
+!$omp declare reduction (foo : character(kind=1, len=*) &
+!$omp & : omp_out = fn (omp_out, omp_in)) initializer (omp_priv = '')
+!$omp declare reduction (bar : character(kind=1, len=:) &
+!$omp & : omp_out = fn (omp_in, omp_out)) initializer (omp_priv = '')
+!$omp declare reduction (baz : character(kind=1, len=1) &
+!$omp & : omp_out = char (ichar (omp_out) + ichar (omp_in) &
+!$omp & - ichar ('0'))) initializer (omp_priv = '0')
+!$omp declare reduction (baz : character(kind=1, len=2) &
+!$omp & : omp_out = char (ichar (omp_out(1:1)) + ichar (omp_in(1:1)) &
+!$omp & - ichar ('0')) // char (ichar (omp_out(2:2)) + &
+!$omp & ichar (omp_in(2:2)) - ichar ('0'))) initializer (omp_priv = '00')
+ interface
+ elemental function fn (x, y)
+ character (len=64), intent (in) :: x, y
+ character (len=64) :: fn
+ end function
+ end interface
+ character(kind=1, len=64) :: c(-3:-2,1:1,7:8), d(2:3,-7:-5)
+ character(kind = 1, len=1) :: e(2:4)
+ character(kind = 1, len=1+1) :: f(8:10,9:10)
+ integer :: i, j, k
+ c = ''
+ d = ''
+ e = '0'
+ f = '00'
+!$omp parallel do reduction (foo : c) reduction (bar : d) &
+!$omp & reduction (baz : e, f) private (j, k)
+ do i = 1, 64
+ forall (j = -3:-2, k = 7:8) &
+ c(j,1,k) = trim(c(j,1,k)) // char (ichar ('0') + i)
+ d = char (ichar ('0') + i) // d
+ e = char (ichar (e) + mod (i, 3))
+ f = char (ichar (f(:,:)(1:1)) + mod (i, 2)) &
+& // char (ichar (f(:,:)(2:2)) + mod (i, 3))
+ end do
+ do i = 1, 64
+ if (any (index (c, char (ichar ('0') + i)) .eq. 0)) call abort
+ if (any (index (d, char (ichar ('0') + i)) .eq. 0)) call abort
+ end do
+ if (any (e.ne.char (ichar ('0') + 64))) call abort
+ if (any (f(:,:)(1:1).ne.char (ichar ('0') + 32))) call abort
+ if (any (f(:,:)(2:2).ne.char (ichar ('0') + 64))) call abort
+end
+elemental function fn (x, y)
+ character (len=64), intent (in) :: x, y
+ character (len=64) :: fn
+ fn = trim(x) // y
+end function
--- /dev/null
+! { dg-do run }
+
+module m
+ interface operator(.add.)
+ module procedure do_add
+ end interface
+ type dt
+ real :: r = 0.0
+ end type
+contains
+ function do_add(x, y)
+ type (dt), intent (in) :: x, y
+ type (dt) :: do_add
+ do_add%r = x%r + y%r
+ end function
+ subroutine dp_add(x, y)
+ double precision :: x, y
+ x = x + y
+ end subroutine
+ subroutine dp_init(x)
+ double precision :: x
+ x = 0.0
+ end subroutine
+end module
+
+program udr5
+ use m, only : operator(.add.), dt, dp_add, dp_init
+ type(dt) :: xdt, one
+ real :: r
+ integer (kind = 4) :: i4
+ integer (kind = 8) :: i8
+ real (kind = 4) :: r4
+ double precision :: dp
+!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
+!$omp declare reduction(foo:integer(4),integer(kind=8),real (kind = 4) &
+!$omp & :omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction(foo:double precision:dp_add (omp_out, omp_in)) &
+!$omp & initializer (dp_init (omp_priv))
+
+ one%r = 1.0
+ r = 0.0
+ i4 = 0
+ i8 = 0
+ r4 = 0.0
+ call dp_init (dp)
+!$omp parallel reduction(.add.: xdt) reduction(+: r) &
+!$omp & reduction(foo: i4, i8, r4, dp)
+ xdt = xdt.add.one
+ r = r + 1.0
+ i4 = i4 + 1
+ i8 = i8 + 1
+ r4 = r4 + 1.0
+ call dp_add (dp, 1.0d0)
+!$omp end parallel
+ if (xdt%r .ne. r) call abort
+ if (i4.ne.r.or.i8.ne.r.or.r4.ne.r.or.dp.ne.r) call abort
+end program udr5
--- /dev/null
+! { dg-do run }
+
+module m
+ interface operator(.add.)
+ module procedure do_add
+ end interface
+ type dt
+ real :: r = 0.0
+ end type
+contains
+ elemental function do_add(x, y)
+ type (dt), intent (in) :: x, y
+ type (dt) :: do_add
+ do_add%r = x%r + y%r
+ end function
+ elemental subroutine dp_add(x, y)
+ double precision, intent (inout) :: x
+ double precision, intent (in) :: y
+ x = x + y
+ end subroutine
+ elemental subroutine dp_init(x)
+ double precision, intent (out) :: x
+ x = 0.0
+ end subroutine
+end module
+
+program udr6
+ use m, only : operator(.add.), dt, dp_add, dp_init
+ type(dt), allocatable :: xdt(:)
+ type(dt) :: one
+ real :: r
+ integer (kind = 4), allocatable, dimension(:) :: i4
+ integer (kind = 8), allocatable, dimension(:,:) :: i8
+ integer :: i
+ real (kind = 4), allocatable :: r4(:,:)
+ double precision, allocatable :: dp(:)
+!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
+!$omp declare reduction(foo:integer(4),integer(kind=8),real (kind = 4) &
+!$omp & :omp_out = omp_out + omp_in) initializer (omp_priv = 0)
+!$omp declare reduction(foo:double precision:dp_add (omp_out, omp_in)) &
+!$omp & initializer (dp_init (omp_priv))
+
+ one%r = 1.0
+ allocate (xdt(4), i4 (3), i8(-5:-2,2:3), r4(2:5,1:1), dp(7))
+ r = 0.0
+ i4 = 0
+ i8 = 0
+ r4 = 0.0
+ do i = 1, 7
+ call dp_init (dp(i))
+ end do
+!$omp parallel reduction(.add.: xdt) reduction(+: r) &
+!$omp & reduction(foo: i4, i8, r4, dp) private(i)
+ do i = 1, 4
+ xdt(i) = xdt(i).add.one
+ end do
+ r = r + 1.0
+ i4 = i4 + 1
+ i8 = i8 + 1
+ r4 = r4 + 1.0
+ do i = 1, 7
+ call dp_add (dp(i), 1.0d0)
+ end do
+!$omp end parallel
+ if (any (xdt%r .ne. r)) call abort
+ if (any (i4.ne.r).or.any(i8.ne.r)) call abort
+ if (any(r4.ne.r).or.any(dp.ne.r)) call abort
+ deallocate (xdt, i4, i8, r4, dp)
+end program udr6
--- /dev/null
+! { dg-do run }
+
+program udr7
+ implicit none
+ interface
+ elemental subroutine omp_priv (x, y, z)
+ real, intent (in) :: x
+ real, intent (inout) :: y
+ real, intent (in) :: z
+ end subroutine omp_priv
+ elemental real function omp_orig (x)
+ real, intent (in) :: x
+ end function omp_orig
+ end interface
+!$omp declare reduction (omp_priv : real : &
+!$omp & omp_priv (omp_orig (omp_in), omp_out, 1.0)) &
+!$omp & initializer (omp_out (omp_priv, omp_in (omp_orig)))
+ real :: x (2:4, 1:1, -2:0)
+ integer :: i
+ x = 0
+!$omp parallel do reduction (omp_priv : x)
+ do i = 1, 64
+ x = x + i
+ end do
+ if (any (x /= 2080.0)) call abort
+contains
+ elemental subroutine omp_out (x, y)
+ real, intent (out) :: x
+ real, intent (in) :: y
+ x = y - 4.0
+ end subroutine omp_out
+ elemental real function omp_in (x)
+ real, intent (in) :: x
+ omp_in = x + 4.0
+ end function omp_in
+end program udr7
+elemental subroutine omp_priv (x, y, z)
+ real, intent (in) :: x
+ real, intent (inout) :: y
+ real, intent (in) :: z
+ y = y + (x - 4.0) + (z - 1.0)
+end subroutine omp_priv
+elemental real function omp_orig (x)
+ real, intent (in) :: x
+ omp_orig = x + 4.0
+end function omp_orig
--- /dev/null
+! { dg-do run }
+
+module udr8m1
+ integer, parameter :: a = 6
+ integer :: b
+!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in)
+!$omp declare reduction (.add. : integer : &
+!$omp & omp_out = omp_out .add. iand (omp_in, -4)) &
+!$omp & initializer (omp_priv = 3)
+ interface operator (.add.)
+ module procedure f1
+ end interface
+contains
+ integer function f1 (x, y)
+ integer, intent (in) :: x, y
+ f1 = x + y
+ end function f1
+end module udr8m1
+module udr8m2
+ use udr8m1
+ type dt
+ integer :: x
+ end type
+!$omp declare reduction (+ : dt : omp_out = omp_out + omp_in) &
+!$omp & initializer (omp_priv = dt (0))
+ interface operator (+)
+ module procedure f2
+ end interface
+contains
+ type(dt) function f2 (x, y)
+ type(dt), intent (in) :: x, y
+ f2%x = x%x + y%x
+ end function f2
+end module udr8m2
+ use udr8m2
+ integer :: i, j
+ type(dt) :: d
+ j = 3
+ d%x = 0
+!$omp parallel do reduction (.add.: j) reduction (+ : d)
+ do i = 1, 100
+ j = j.add.iand (i, -4)
+ d = d + dt(i)
+ end do
+ if (d%x /= 5050 .or. j /= 4903) call abort
+end
--- /dev/null
+! { dg-do run }
+
+module udr9m1
+ integer, parameter :: a = 6
+ integer :: b
+!$omp declare reduction (foo : integer : combiner1 (omp_out, omp_in)) &
+!$omp & initializer (initializer1 (omp_priv, omp_orig))
+!$omp declare reduction (.add. : integer : &
+!$omp & combiner1 (omp_out, omp_in)) &
+!$omp & initializer (initializer1 (omp_priv, omp_orig))
+ interface operator (.add.)
+ module procedure f1
+ end interface
+contains
+ integer function f1 (x, y)
+ integer, intent (in) :: x, y
+ f1 = x + y
+ end function f1
+ elemental subroutine combiner1 (x, y)
+ integer, intent (inout) :: x
+ integer, intent (in) :: y
+ x = x + iand (y, -4)
+ end subroutine
+ subroutine initializer1 (x, y)
+ integer :: x, y
+ if (y .ne. 3) call abort
+ x = y
+ end subroutine
+end module udr9m1
+module udr9m2
+ use udr9m1
+ type dt
+ integer :: x
+ end type
+!$omp declare reduction (+ : dt : combiner2 (omp_in, omp_out)) &
+!$omp & initializer (initializer2 (omp_priv))
+ interface operator (+)
+ module procedure f2
+ end interface
+contains
+ type(dt) function f2 (x, y)
+ type(dt), intent (in) :: x, y
+ f2%x = x%x + y%x
+ end function f2
+ subroutine combiner2 (x, y)
+ type(dt) :: x, y
+ y = y + x
+ end subroutine combiner2
+ subroutine initializer2 (x)
+ type(dt), intent(out) :: x
+ x%x = 0
+ end subroutine initializer2
+end module udr9m2
+ use udr9m2
+ integer :: i, j
+ type(dt) :: d
+ j = 3
+ d%x = 0
+!$omp parallel do reduction (.add.: j) reduction (+ : d)
+ do i = 1, 100
+ j = j.add.iand (i, -4)
+ d = d + dt(i)
+ end do
+ if (d%x /= 5050 .or. j /= 4903) call abort
+end
projects / platform / upstream / gcc49.git / commitdiff