diff options
Diffstat (limited to 'gcc')
133 files changed, 4667 insertions, 867 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index b16db67..5b54c5a 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,148 @@ +2025-04-21 Jan Hubicka <hubicka@ucw.cz> + + PR target/119879 + * config/i386/i386.cc (fp_conversion_stmt_cost): Inline to ... + (ix86_vector_costs::add_stmt_cost): ... here; fix handling of NOP_EXPR. + +2025-04-21 Matthew Fortune <matthew.fortune@imgtec.com> + + * config/mips/mips.cc (mips_option_override): Error out for + -mmicromips -mmsa. + +2025-04-21 Andrew Pinski <quic_apinski@quicinc.com> + + PR middle-end/119507 + * except.cc (switch_to_exception_section): Don't use the cached section if + the current function is in comdat. + +2025-04-21 Andrew Pinski <quic_apinski@quicinc.com> + + * vec.h (array_slice::begin): Assert that the + slice is valid. + (array_slice::end): Likewise. + +2025-04-21 hongtao.liu <hongtao.liu@intel.com> + + * config/i386/i386-expand.cc (ix86_emit_swdivsf): Generate 2 + FMA instructions when TARGET_FMA. + +2025-04-19 Jeff Law <jlaw@ventanamicro.com> + + PR target/119865 + * config/riscv/riscv.cc (parse_features_for_version): Do not + explicitly free the architecture string. + +2025-04-19 Jeff Law <jlaw@ventanamicro.com> + + PR target/118410 + * config/riscv/bitmanip.md (logical with constant argument): New + splitter for cases where synthesizing ~C is cheaper than synthesizing + the original constant C. + +2025-04-19 Jan Hubicka <hubicka@ucw.cz> + + * config/i386/i386.cc (vec_fp_conversion_cost): New function. + (ix86_rtx_costs): Use it for SSE/AVX FP conversoins. + (ix86_builtin_vectorization_cost): Fix indentation; + and use vec_fp_conversion_cost in vec_promote_demote. + (fp_conversion_stmt_cost): New function. + (ix86_vector_costs::add_stmt_cost): Use it to cost NOP_EXPR + and vec_promote_demote. + * config/i386/i386.h (struct processor_costs): + * config/i386/x86-tune-costs.h (struct processor_costs): + +2025-04-19 Andrew Pinski <quic_apinski@quicinc.com> + + PR rtl-optimization/111949 + * combine.cc (find_split_point): Add a split point + for `(and (not X) Y)` if not in the outer set already. + +2025-04-19 Jiaxun Yang <jiaxun.yang@flygoat.com> + + PR target/111814 + * config/sh/sh-modes.def (RESET_FLOAT_FORMAT): Use mips format. + (FLOAT_MODE): Use mips mode. + +2025-04-19 Maciej W. Rozycki <macro@orcam.me.uk> + + * config/alpha/alpha.cc + (alpha_get_mem_rtx_alignment_and_offset): Recurse into + COMPONENT_REF nodes. + +2025-04-18 Jeff Law <jlaw@ventanamicro.com> + + * config/riscv/bitmanip.md (*bext<mode>_mask_pos): New pattern + for extracting a single bit at masked bit position. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/87901 + * tree-ssa-dse.cc (maybe_trim_constructor_store): Add was_integer_cst argument. + Check for was_integer_cst instead of `{}` when was_integer_cst is true. + (maybe_trim_partially_dead_store): Handle INTEGER_CST stores of 0 as stores of `{}`. + Udpate call to maybe_trim_constructor_store for CONSTRUCTOR. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/87901 + * tree-ssa-dse.cc (maybe_trim_constructor_store): Strip over useless type + conversions after taking the address of the MEM_REF. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/118902 + * fold-const.cc (tree_swap_operands_p): Place invariants in the first operand + if not used with constants. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/118947 + * gimple-fold.cc (optimize_memcpy_to_memset): Walk back until we get a + statement that may clobber the read. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/78408 + PR tree-optimization/118947 + * gimple-fold.cc (optimize_memcpy_to_memset): Handle STRING_CST case too. + +2025-04-18 Richard Braun <rbraun@sceen.net> + + * config/c6x/c6x.h (ASM_PREFERRED_EH_DATA_FORMAT): Remove the + DW_EH_PE_indirect flag. + +2025-04-18 Richard Biener <rguenther@suse.de> + + PR tree-optimization/119858 + * tree-vect-loop.cc (vectorizable_live_operation): Convert + pointer offset to sizetype. + +2025-04-18 Hakan Candar <hakancandar@protonmail.com> + + * config.gcc: Recognize riscv*-*-gnu* targets. + * config/riscv/gnu.h: New file. + +2025-04-18 Alexey Merzlyakov <alexey.merzlyakov@samsung.com> + + PR middle-end/108016 + PR middle-end/108016 + * config/riscv/riscv.md (addv<mode>4, uaddv<mode>4, subv<mode>4, + usubv<mode>4): Tunes for unnecessary sext.w elimination. + +2025-04-18 kelefth <konstantinos.eleftheriou@vrull.eu> + + PR rtl-optimization/119160 + * avoid-store-forwarding.cc (process_store_forwarding): + Zero-extend the value stored in the base register, in case + of load-elimination, only when the mode of the destination + is wider. + +2025-04-18 kelefth <konstantinos.eleftheriou@vrull.eu> + + * doc/cfg.texi: Update the exception handling section for the + REG_EH_REGION notes to make it clear that the note is attached + to the instruction throwing the exception. + 2025-04-17 翁愷邑 <kaiweng9487@gmail.com> * config/riscv/riscv-target-attr.cc diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 18aa6a5..fa0255d 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20250418 +20250422 diff --git a/gcc/combine.cc b/gcc/combine.cc index e118608..873c2bd 100644 --- a/gcc/combine.cc +++ b/gcc/combine.cc @@ -5280,6 +5280,12 @@ find_split_point (rtx *loc, rtx_insn *insn, bool set_src) SUBST (XEXP (x, 0), XEXP (x, 1)); SUBST (XEXP (x, 1), tem); } + /* Many targets have a `(and (not X) Y)` and/or `(ior (not X) Y)` instructions. + Split at that insns. However if this is + the SET_SRC, we likely do not have such an instruction and it's + worthless to try this split. */ + if (!set_src && GET_CODE (XEXP (x, 0)) == NOT) + return loc; break; case PLUS: diff --git a/gcc/config/aarch64/aarch64-c.cc b/gcc/config/aarch64/aarch64-c.cc index d1e2ab9..98337b7 100644 --- a/gcc/config/aarch64/aarch64-c.cc +++ b/gcc/config/aarch64/aarch64-c.cc @@ -293,6 +293,7 @@ aarch64_update_cpp_builtins (cpp_reader *pfile) aarch64_def_or_undef (TARGET_SME2, "__ARM_FEATURE_SME2", pfile); aarch64_def_or_undef (AARCH64_HAVE_ISA (SME2p1), "__ARM_FEATURE_SME2p1", pfile); + aarch64_def_or_undef (TARGET_FAMINMAX, "__ARM_FEATURE_FAMINMAX", pfile); /* Not for ACLE, but required to keep "float.h" correct if we switch target between implementations that do or do not support ARMv8.2-A diff --git a/gcc/config/aarch64/aarch64-cores.def b/gcc/config/aarch64/aarch64-cores.def index 7f204fd..1209630 100644 --- a/gcc/config/aarch64/aarch64-cores.def +++ b/gcc/config/aarch64/aarch64-cores.def @@ -224,7 +224,7 @@ AARCH64_CORE("neoverse-v3ae", neoversev3ae, cortexa57, V9_2A, (SVE2_BITPERM, RNG AARCH64_CORE("demeter", demeter, cortexa57, V9A, (I8MM, BF16, SVE2_BITPERM, RNG, MEMTAG, PROFILE), neoversev2, 0x41, 0xd4f, -1) /* NVIDIA ('N') cores. */ -AARCH64_CORE("olympus", olympus, cortexa57, V9_2A, (SVE2_BITPERM, RNG, LS64, MEMTAG, PROFILE, FAMINMAX, FP8DOT2, LUT, SVE2_AES, SVE2_SHA3, SVE2_SM4), neoversev3, 0x4e, 0x10, -1) +AARCH64_CORE("olympus", olympus, cortexa57, V9_2A, (SVE2_BITPERM, RNG, LS64, MEMTAG, PROFILE, FAMINMAX, FP8FMA, FP8DOT2, FP8DOT4, LUT, SVE2_AES, SVE2_SHA3, SVE2_SM4), neoversev3, 0x4e, 0x10, -1) /* Generic Architecture Processors. */ AARCH64_CORE("generic", generic, cortexa53, V8A, (), generic, 0x0, 0x0, -1) diff --git a/gcc/config/aarch64/aarch64-protos.h b/gcc/config/aarch64/aarch64-protos.h index 8f44aea..1ca86c9 100644 --- a/gcc/config/aarch64/aarch64-protos.h +++ b/gcc/config/aarch64/aarch64-protos.h @@ -1260,6 +1260,7 @@ void aarch64_restore_za (rtx); void aarch64_expand_crc_using_pmull (scalar_mode, scalar_mode, rtx *); void aarch64_expand_reversed_crc_using_pmull (scalar_mode, scalar_mode, rtx *); +void aarch64_expand_fp_spaceship (rtx, rtx, rtx, rtx); extern bool aarch64_gcs_enabled (); diff --git a/gcc/config/aarch64/aarch64.cc b/gcc/config/aarch64/aarch64.cc index 433ec97..38c112c 100644 --- a/gcc/config/aarch64/aarch64.cc +++ b/gcc/config/aarch64/aarch64.cc @@ -31294,6 +31294,79 @@ aarch64_expand_reversed_crc_using_pmull (scalar_mode crc_mode, } } +/* Expand the spaceship optab for floating-point operands. + + If the result is compared against (-1, 0, 1 , 2), expand into + fcmpe + conditional branch insns. + + Otherwise (the result is just stored as an integer), expand into + fcmpe + a sequence of conditional select/increment/invert insns. */ +void +aarch64_expand_fp_spaceship (rtx dest, rtx op0, rtx op1, rtx hint) +{ + rtx cc_reg = gen_rtx_REG (CCFPEmode, CC_REGNUM); + emit_set_insn (cc_reg, gen_rtx_COMPARE (CCFPEmode, op0, op1)); + + rtx cc_gt = gen_rtx_GT (VOIDmode, cc_reg, const0_rtx); + rtx cc_lt = gen_rtx_LT (VOIDmode, cc_reg, const0_rtx); + rtx cc_un = gen_rtx_UNORDERED (VOIDmode, cc_reg, const0_rtx); + + if (hint == const0_rtx) + { + rtx un_label = gen_label_rtx (); + rtx lt_label = gen_label_rtx (); + rtx gt_label = gen_label_rtx (); + rtx end_label = gen_label_rtx (); + + rtx temp = gen_rtx_IF_THEN_ELSE (VOIDmode, cc_un, + gen_rtx_LABEL_REF (Pmode, un_label), pc_rtx); + aarch64_emit_unlikely_jump (gen_rtx_SET (pc_rtx, temp)); + + temp = gen_rtx_IF_THEN_ELSE (VOIDmode, cc_lt, + gen_rtx_LABEL_REF (Pmode, lt_label), pc_rtx); + emit_jump_insn (gen_rtx_SET (pc_rtx, temp)); + + temp = gen_rtx_IF_THEN_ELSE (VOIDmode, cc_gt, + gen_rtx_LABEL_REF (Pmode, gt_label), pc_rtx); + emit_jump_insn (gen_rtx_SET (pc_rtx, temp)); + + /* Equality. */ + emit_move_insn (dest, const0_rtx); + emit_jump (end_label); + + emit_label (un_label); + emit_move_insn (dest, const2_rtx); + emit_jump (end_label); + + emit_label (gt_label); + emit_move_insn (dest, const1_rtx); + emit_jump (end_label); + + emit_label (lt_label); + emit_move_insn (dest, constm1_rtx); + + emit_label (end_label); + } + else + { + rtx temp0 = gen_reg_rtx (SImode); + rtx temp1 = gen_reg_rtx (SImode); + rtx cc_ungt = gen_rtx_UNGT (VOIDmode, cc_reg, const0_rtx); + + /* The value of hint is stored if the operands are unordered. */ + rtx temp_un = gen_int_mode (UINTVAL (hint) - 1, SImode); + if (!aarch64_reg_zero_or_m1_or_1 (temp_un, SImode)) + temp_un = force_reg (SImode, temp_un); + + emit_set_insn (temp0, gen_rtx_IF_THEN_ELSE (SImode, cc_lt, + constm1_rtx, const0_rtx)); + emit_set_insn (temp1, gen_rtx_IF_THEN_ELSE (SImode, cc_un, + temp_un, const0_rtx)); + emit_set_insn (dest, gen_rtx_IF_THEN_ELSE (SImode, cc_ungt, + gen_rtx_PLUS (SImode, temp1, const1_rtx), temp0)); + } +} + /* Target-specific selftests. */ #if CHECKING_P diff --git a/gcc/config/aarch64/aarch64.md b/gcc/config/aarch64/aarch64.md index 031e621..c678f7a 100644 --- a/gcc/config/aarch64/aarch64.md +++ b/gcc/config/aarch64/aarch64.md @@ -707,11 +707,12 @@ ) (define_expand "cbranch<mode>4" - [(set (pc) (if_then_else (match_operator 0 "aarch64_comparison_operator" - [(match_operand:GPF 1 "register_operand") - (match_operand:GPF 2 "aarch64_fp_compare_operand")]) - (label_ref (match_operand 3 "" "")) - (pc)))] + [(set (pc) (if_then_else + (match_operator 0 "aarch64_comparison_operator" + [(match_operand:GPF_F16 1 "register_operand") + (match_operand:GPF_F16 2 "aarch64_fp_compare_operand")]) + (label_ref (match_operand 3 "" "")) + (pc)))] "" " operands[1] = aarch64_gen_compare_reg (GET_CODE (operands[0]), operands[1], @@ -4337,26 +4338,28 @@ (define_insn "fcmp<mode>" [(set (reg:CCFP CC_REGNUM) - (compare:CCFP (match_operand:GPF 0 "register_operand") - (match_operand:GPF 1 "aarch64_fp_compare_operand")))] + (compare:CCFP + (match_operand:GPF_F16 0 "register_operand") + (match_operand:GPF_F16 1 "aarch64_fp_compare_operand")))] "TARGET_FLOAT" {@ [ cons: 0 , 1 ] [ w , Y ] fcmp\t%<s>0, #0.0 [ w , w ] fcmp\t%<s>0, %<s>1 } - [(set_attr "type" "fcmp<s>")] + [(set_attr "type" "fcmp<stype>")] ) (define_insn "fcmpe<mode>" [(set (reg:CCFPE CC_REGNUM) - (compare:CCFPE (match_operand:GPF 0 "register_operand") - (match_operand:GPF 1 "aarch64_fp_compare_operand")))] + (compare:CCFPE + (match_operand:GPF_F16 0 "register_operand") + (match_operand:GPF_F16 1 "aarch64_fp_compare_operand")))] "TARGET_FLOAT" {@ [ cons: 0 , 1 ] [ w , Y ] fcmpe\t%<s>0, #0.0 [ w , w ] fcmpe\t%<s>0, %<s>1 } - [(set_attr "type" "fcmp<s>")] + [(set_attr "type" "fcmp<stype>")] ) (define_insn "*cmp_swp_<shift>_reg<mode>" @@ -4392,6 +4395,49 @@ [(set_attr "type" "alus_ext")] ) +;; <=> operator pattern (integer) +;; (a == b) ? 0 : (a < b) ? -1 : 1. +(define_expand "spaceship<mode>4" + [(match_operand:SI 0 "register_operand") + (match_operand:GPI 1 "register_operand") + (match_operand:GPI 2 "register_operand") + (match_operand:SI 3 "const_int_operand")] + "" + { + // 1 indicates unsigned comparison, -1 indicates signed. + gcc_assert (operands[3] == constm1_rtx || operands[3] == const1_rtx); + + rtx cc_reg = aarch64_gen_compare_reg (EQ, operands[1], operands[2]); + RTX_CODE code_gt = operands[3] == const1_rtx ? GTU : GT; + RTX_CODE code_lt = operands[3] == const1_rtx ? LTU : LT; + + rtx cc_gt = gen_rtx_fmt_ee (code_gt, VOIDmode, cc_reg, const0_rtx); + rtx cc_lt = gen_rtx_fmt_ee (code_lt, VOIDmode, cc_reg, const0_rtx); + + rtx temp = gen_reg_rtx (SImode); + emit_insn (gen_rtx_SET (temp, gen_rtx_IF_THEN_ELSE (SImode, cc_gt, + const1_rtx, const0_rtx))); + emit_insn (gen_rtx_SET (operands[0], gen_rtx_IF_THEN_ELSE (SImode, cc_lt, + constm1_rtx, temp))); + DONE; + } +) + +;; <=> operator pattern (floating-point) +;; (a == b) ? 0 : (a < b) ? -1 : (a > b) ? 1 : UNORDERED. +(define_expand "spaceship<mode>4" + [(match_operand:SI 0 "register_operand") + (match_operand:GPF 1 "register_operand") + (match_operand:GPF 2 "register_operand") + (match_operand:SI 3 "const_int_operand")] + "TARGET_FLOAT" + { + aarch64_expand_fp_spaceship (operands[0], operands[1], operands[2], + operands[3]); + DONE; + } +) + ;; ------------------------------------------------------------------- ;; Store-flag and conditional select insns ;; ------------------------------------------------------------------- @@ -4424,8 +4470,8 @@ (define_expand "cstore<mode>4" [(set (match_operand:SI 0 "register_operand") (match_operator:SI 1 "aarch64_comparison_operator_mode" - [(match_operand:GPF 2 "register_operand") - (match_operand:GPF 3 "aarch64_fp_compare_operand")]))] + [(match_operand:GPF_F16 2 "register_operand") + (match_operand:GPF_F16 3 "aarch64_fp_compare_operand")]))] "" " operands[2] = aarch64_gen_compare_reg (GET_CODE (operands[1]), operands[2], diff --git a/gcc/config/alpha/alpha.cc b/gcc/config/alpha/alpha.cc index ba470d9..14e7da5 100644 --- a/gcc/config/alpha/alpha.cc +++ b/gcc/config/alpha/alpha.cc @@ -4291,14 +4291,10 @@ alpha_get_mem_rtx_alignment_and_offset (rtx expr, int &a, HOST_WIDE_INT &o) tree mem = MEM_EXPR (expr); if (mem != NULL_TREE) - switch (TREE_CODE (mem)) - { - case MEM_REF: - tree_offset = mem_ref_offset (mem).force_shwi (); - tree_align = get_object_alignment (get_base_address (mem)); - break; + { + HOST_WIDE_INT comp_offset = 0; - case COMPONENT_REF: + for (; TREE_CODE (mem) == COMPONENT_REF; mem = TREE_OPERAND (mem, 0)) { tree byte_offset = component_ref_field_offset (mem); tree bit_offset = DECL_FIELD_BIT_OFFSET (TREE_OPERAND (mem, 1)); @@ -4307,14 +4303,15 @@ alpha_get_mem_rtx_alignment_and_offset (rtx expr, int &a, HOST_WIDE_INT &o) || !poly_int_tree_p (byte_offset, &offset) || !tree_fits_shwi_p (bit_offset)) break; - tree_offset = offset + tree_to_shwi (bit_offset) / BITS_PER_UNIT; + comp_offset += offset + tree_to_shwi (bit_offset) / BITS_PER_UNIT; } - tree_align = get_object_alignment (get_base_address (mem)); - break; - default: - break; - } + if (TREE_CODE (mem) == MEM_REF) + { + tree_offset = comp_offset + mem_ref_offset (mem).force_shwi (); + tree_align = get_object_alignment (get_base_address (mem)); + } + } if (reg_align > mem_align) { diff --git a/gcc/config/i386/i386-expand.cc b/gcc/config/i386/i386-expand.cc index cdfd94d..36f71eb 100644 --- a/gcc/config/i386/i386-expand.cc +++ b/gcc/config/i386/i386-expand.cc @@ -19256,8 +19256,6 @@ ix86_emit_swdivsf (rtx res, rtx a, rtx b, machine_mode mode) e1 = gen_reg_rtx (mode); x1 = gen_reg_rtx (mode); - /* a / b = a * ((rcp(b) + rcp(b)) - (b * rcp(b) * rcp (b))) */ - b = force_reg (mode, b); /* x0 = rcp(b) estimate */ @@ -19270,20 +19268,42 @@ ix86_emit_swdivsf (rtx res, rtx a, rtx b, machine_mode mode) emit_insn (gen_rtx_SET (x0, gen_rtx_UNSPEC (mode, gen_rtvec (1, b), UNSPEC_RCP))); - /* e0 = x0 * b */ - emit_insn (gen_rtx_SET (e0, gen_rtx_MULT (mode, x0, b))); + unsigned vector_size = GET_MODE_SIZE (mode); + + /* (a - (rcp(b) * a * b)) * rcp(b) + rcp(b) * a + N-R step with 2 fma implementation. */ + if (TARGET_FMA + || (TARGET_AVX512F && vector_size == 64) + || (TARGET_AVX512VL && (vector_size == 32 || vector_size == 16))) + { + /* e0 = x0 * a */ + emit_insn (gen_rtx_SET (e0, gen_rtx_MULT (mode, x0, a))); + /* e1 = e0 * b - a */ + emit_insn (gen_rtx_SET (e1, gen_rtx_FMA (mode, e0, b, + gen_rtx_NEG (mode, a)))); + /* res = - e1 * x0 + e0 */ + emit_insn (gen_rtx_SET (res, gen_rtx_FMA (mode, + gen_rtx_NEG (mode, e1), + x0, e0))); + } + else + /* a / b = a * ((rcp(b) + rcp(b)) - (b * rcp(b) * rcp (b))) */ + { + /* e0 = x0 * b */ + emit_insn (gen_rtx_SET (e0, gen_rtx_MULT (mode, x0, b))); - /* e0 = x0 * e0 */ - emit_insn (gen_rtx_SET (e0, gen_rtx_MULT (mode, x0, e0))); + /* e1 = x0 + x0 */ + emit_insn (gen_rtx_SET (e1, gen_rtx_PLUS (mode, x0, x0))); - /* e1 = x0 + x0 */ - emit_insn (gen_rtx_SET (e1, gen_rtx_PLUS (mode, x0, x0))); + /* e0 = x0 * e0 */ + emit_insn (gen_rtx_SET (e0, gen_rtx_MULT (mode, x0, e0))); - /* x1 = e1 - e0 */ - emit_insn (gen_rtx_SET (x1, gen_rtx_MINUS (mode, e1, e0))); + /* x1 = e1 - e0 */ + emit_insn (gen_rtx_SET (x1, gen_rtx_MINUS (mode, e1, e0))); - /* res = a * x1 */ - emit_insn (gen_rtx_SET (res, gen_rtx_MULT (mode, a, x1))); + /* res = a * x1 */ + emit_insn (gen_rtx_SET (res, gen_rtx_MULT (mode, a, x1))); + } } /* Output code to perform a Newton-Rhapson approximation of a diff --git a/gcc/config/i386/i386.cc b/gcc/config/i386/i386.cc index 38df84f..d15f91d 100644 --- a/gcc/config/i386/i386.cc +++ b/gcc/config/i386/i386.cc @@ -100,6 +100,7 @@ along with GCC; see the file COPYING3. If not see #include "i386-features.h" #include "function-abi.h" #include "rtl-error.h" +#include "gimple-pretty-print.h" /* This file should be included last. */ #include "target-def.h" @@ -21816,6 +21817,25 @@ ix86_insn_cost (rtx_insn *insn, bool speed) return insn_cost + pattern_cost (PATTERN (insn), speed); } +/* Return cost of SSE/AVX FP->FP conversion (extensions and truncates). */ + +static int +vec_fp_conversion_cost (const struct processor_costs *cost, int size) +{ + if (size < 128) + return cost->cvtss2sd; + else if (size < 256) + { + if (TARGET_SSE_SPLIT_REGS) + return cost->cvtss2sd * size / 64; + return cost->cvtss2sd; + } + if (size < 512) + return cost->vcvtps2pd256; + else + return cost->vcvtps2pd512; +} + /* Compute a (partial) cost for rtx X. Return true if the complete cost has been computed, and false if subexpressions should be scanned. In either case, *TOTAL contains the cost result. */ @@ -22479,17 +22499,18 @@ ix86_rtx_costs (rtx x, machine_mode mode, int outer_code_i, int opno, return false; case FLOAT_EXTEND: + /* x87 represents all values extended to 80bit. */ if (!SSE_FLOAT_MODE_SSEMATH_OR_HFBF_P (mode)) *total = 0; else - *total = ix86_vec_cost (mode, cost->addss); + *total = vec_fp_conversion_cost (cost, GET_MODE_BITSIZE (mode)); return false; case FLOAT_TRUNCATE: if (!SSE_FLOAT_MODE_SSEMATH_OR_HFBF_P (mode)) *total = cost->fadd; else - *total = ix86_vec_cost (mode, cost->addss); + *total = vec_fp_conversion_cost (cost, GET_MODE_BITSIZE (mode)); return false; case ABS: @@ -24683,7 +24704,7 @@ ix86_builtin_vectorization_cost (enum vect_cost_for_stmt type_of_cost, switch (type_of_cost) { case scalar_stmt: - return fp ? ix86_cost->addss : COSTS_N_INSNS (1); + return fp ? ix86_cost->addss : COSTS_N_INSNS (1); case scalar_load: /* load/store costs are relative to register move which is 2. Recompute @@ -24754,7 +24775,11 @@ ix86_builtin_vectorization_cost (enum vect_cost_for_stmt type_of_cost, return ix86_cost->cond_not_taken_branch_cost; case vec_perm: + return ix86_vec_cost (mode, ix86_cost->sse_op); + case vec_promote_demote: + if (fp) + return vec_fp_conversion_cost (ix86_tune_cost, mode); return ix86_vec_cost (mode, ix86_cost->sse_op); case vec_construct: @@ -25342,6 +25367,9 @@ ix86_vector_costs::add_stmt_cost (int count, vect_cost_for_stmt kind, (TREE_TYPE (gimple_assign_lhs (stmt_info->stmt)), TREE_TYPE (gimple_assign_rhs1 (stmt_info->stmt)))) stmt_cost = 0; + else if (fp) + stmt_cost = vec_fp_conversion_cost + (ix86_tune_cost, GET_MODE_BITSIZE (mode)); break; case BIT_IOR_EXPR: @@ -25383,6 +25411,29 @@ ix86_vector_costs::add_stmt_cost (int count, vect_cost_for_stmt kind, break; } + if (kind == vec_promote_demote + && fp && FLOAT_TYPE_P (TREE_TYPE (gimple_assign_rhs1 (stmt_info->stmt)))) + { + int outer_size + = tree_to_uhwi + (TYPE_SIZE + (TREE_TYPE (gimple_assign_lhs (stmt_info->stmt)))); + int inner_size + = tree_to_uhwi + (TYPE_SIZE + (TREE_TYPE (gimple_assign_rhs1 (stmt_info->stmt)))); + int stmt_cost = vec_fp_conversion_cost + (ix86_tune_cost, GET_MODE_BITSIZE (mode)); + /* VEC_PACK_TRUNC_EXPR: If inner size is greater than outer size we will end + up doing two conversions and packing them. */ + if (inner_size > outer_size) + { + int n = inner_size / outer_size; + stmt_cost = stmt_cost * n + + (n - 1) * ix86_vec_cost (mode, ix86_cost->sse_op); + } + } + /* If we do elementwise loads into a vector then we are bound by latency and execution resources for the many scalar loads (AGU and load ports). Try to account for this by scaling the diff --git a/gcc/config/i386/i386.h b/gcc/config/i386/i386.h index 8507243..18aa42d 100644 --- a/gcc/config/i386/i386.h +++ b/gcc/config/i386/i386.h @@ -207,6 +207,12 @@ struct processor_costs { const int divsd; /* cost of DIVSD instructions. */ const int sqrtss; /* cost of SQRTSS instructions. */ const int sqrtsd; /* cost of SQRTSD instructions. */ + const int cvtss2sd; /* cost SSE FP conversions, + such as CVTSS2SD. */ + const int vcvtps2pd256; /* cost 256bit packed FP conversions, + such as VCVTPD2PS with larger reg in ymm. */ + const int vcvtps2pd512; /* cost 512bit packed FP conversions, + such as VCVTPD2PS with larger reg in zmm. */ const int reassoc_int, reassoc_fp, reassoc_vec_int, reassoc_vec_fp; /* Specify reassociation width for integer, fp, vector integer and vector fp diff --git a/gcc/config/i386/x86-tune-costs.h b/gcc/config/i386/x86-tune-costs.h index 9477345..cddcf61 100644 --- a/gcc/config/i386/x86-tune-costs.h +++ b/gcc/config/i386/x86-tune-costs.h @@ -121,16 +121,19 @@ struct processor_costs ix86_size_cost = {/* costs for tuning for size */ COSTS_N_BYTES (2), /* cost of FCHS instruction. */ COSTS_N_BYTES (2), /* cost of FSQRT instruction. */ - COSTS_N_BYTES (2), /* cost of cheap SSE instruction. */ - COSTS_N_BYTES (2), /* cost of ADDSS/SD SUBSS/SD insns. */ - COSTS_N_BYTES (2), /* cost of MULSS instruction. */ - COSTS_N_BYTES (2), /* cost of MULSD instruction. */ - COSTS_N_BYTES (2), /* cost of FMA SS instruction. */ - COSTS_N_BYTES (2), /* cost of FMA SD instruction. */ - COSTS_N_BYTES (2), /* cost of DIVSS instruction. */ - COSTS_N_BYTES (2), /* cost of DIVSD instruction. */ - COSTS_N_BYTES (2), /* cost of SQRTSS instruction. */ - COSTS_N_BYTES (2), /* cost of SQRTSD instruction. */ + COSTS_N_BYTES (4), /* cost of cheap SSE instruction. */ + COSTS_N_BYTES (4), /* cost of ADDSS/SD SUBSS/SD insns. */ + COSTS_N_BYTES (4), /* cost of MULSS instruction. */ + COSTS_N_BYTES (4), /* cost of MULSD instruction. */ + COSTS_N_BYTES (4), /* cost of FMA SS instruction. */ + COSTS_N_BYTES (4), /* cost of FMA SD instruction. */ + COSTS_N_BYTES (4), /* cost of DIVSS instruction. */ + COSTS_N_BYTES (4), /* cost of DIVSD instruction. */ + COSTS_N_BYTES (4), /* cost of SQRTSS instruction. */ + COSTS_N_BYTES (4), /* cost of SQRTSD instruction. */ + COSTS_N_BYTES (4), /* cost of CVTSS2SD etc. */ + COSTS_N_BYTES (4), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_BYTES (6), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ ix86_size_memcpy, ix86_size_memset, @@ -243,6 +246,9 @@ struct processor_costs i386_cost = { /* 386 specific costs */ COSTS_N_INSNS (88), /* cost of DIVSD instruction. */ COSTS_N_INSNS (122), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (122), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (27), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (54), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (108), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ i386_memcpy, i386_memset, @@ -356,6 +362,9 @@ struct processor_costs i486_cost = { /* 486 specific costs */ COSTS_N_INSNS (74), /* cost of DIVSD instruction. */ COSTS_N_INSNS (83), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (83), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (8), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (16), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (32), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ i486_memcpy, i486_memset, @@ -467,6 +476,9 @@ struct processor_costs pentium_cost = { COSTS_N_INSNS (39), /* cost of DIVSD instruction. */ COSTS_N_INSNS (70), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (70), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ pentium_memcpy, pentium_memset, @@ -571,6 +583,9 @@ struct processor_costs lakemont_cost = { COSTS_N_INSNS (60), /* cost of DIVSD instruction. */ COSTS_N_INSNS (31), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (63), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (5), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (10), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (20), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ pentium_memcpy, pentium_memset, @@ -690,6 +705,9 @@ struct processor_costs pentiumpro_cost = { COSTS_N_INSNS (18), /* cost of DIVSD instruction. */ COSTS_N_INSNS (31), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (31), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ pentiumpro_memcpy, pentiumpro_memset, @@ -800,6 +818,9 @@ struct processor_costs geode_cost = { COSTS_N_INSNS (47), /* cost of DIVSD instruction. */ COSTS_N_INSNS (54), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (54), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (6), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (12), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (24), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ geode_memcpy, geode_memset, @@ -913,6 +934,9 @@ struct processor_costs k6_cost = { COSTS_N_INSNS (56), /* cost of DIVSD instruction. */ COSTS_N_INSNS (56), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (56), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (2), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (4), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (8), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ k6_memcpy, k6_memset, @@ -1027,6 +1051,9 @@ struct processor_costs athlon_cost = { COSTS_N_INSNS (24), /* cost of DIVSD instruction. */ COSTS_N_INSNS (19), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (19), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (4), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (8), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (16), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ athlon_memcpy, athlon_memset, @@ -1150,6 +1177,9 @@ struct processor_costs k8_cost = { COSTS_N_INSNS (20), /* cost of DIVSD instruction. */ COSTS_N_INSNS (19), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (27), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (4), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (8), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (16), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ k8_memcpy, k8_memset, @@ -1281,6 +1311,9 @@ struct processor_costs amdfam10_cost = { COSTS_N_INSNS (20), /* cost of DIVSD instruction. */ COSTS_N_INSNS (19), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (27), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (4), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (8), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (16), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ amdfam10_memcpy, amdfam10_memset, @@ -1405,6 +1438,9 @@ const struct processor_costs bdver_cost = { COSTS_N_INSNS (27), /* cost of DIVSD instruction. */ COSTS_N_INSNS (15), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (26), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (4), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (7), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (14), /* cost of 512bit VCVTPS2PD etc. */ 1, 2, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ bdver_memcpy, bdver_memset, @@ -1553,6 +1589,10 @@ struct processor_costs znver1_cost = { COSTS_N_INSNS (13), /* cost of DIVSD instruction. */ COSTS_N_INSNS (10), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (15), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + /* Real latency is 4, but for split regs multiply cost of half op by 2. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ /* Zen can execute 4 integer operations per cycle. FP operations take 3 cycles and it can execute 2 integer additions and 2 multiplications thus reassociation may make sense up to with of 6. SPEC2k6 bencharks suggests @@ -1712,6 +1752,9 @@ struct processor_costs znver2_cost = { COSTS_N_INSNS (13), /* cost of DIVSD instruction. */ COSTS_N_INSNS (10), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (15), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (5), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (10), /* cost of 512bit VCVTPS2PD etc. */ /* Zen can execute 4 integer operations per cycle. FP operations take 3 cycles and it can execute 2 integer additions and 2 multiplications thus reassociation may make sense up to with of 6. @@ -1847,6 +1890,9 @@ struct processor_costs znver3_cost = { COSTS_N_INSNS (13), /* cost of DIVSD instruction. */ COSTS_N_INSNS (10), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (15), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (5), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (10), /* cost of 512bit VCVTPS2PD etc. */ /* Zen can execute 4 integer operations per cycle. FP operations take 3 cycles and it can execute 2 integer additions and 2 multiplications thus reassociation may make sense up to with of 6. @@ -1984,6 +2030,10 @@ struct processor_costs znver4_cost = { COSTS_N_INSNS (13), /* cost of DIVSD instruction. */ COSTS_N_INSNS (15), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (21), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (5), /* cost of 256bit VCVTPS2PD etc. */ + /* Real latency is 6, but for split regs multiply cost of half op by 2. */ + COSTS_N_INSNS (10), /* cost of 512bit VCVTPS2PD etc. */ /* Zen can execute 4 integer operations per cycle. FP operations take 3 cycles and it can execute 2 integer additions and 2 multiplications thus reassociation may make sense up to with of 6. @@ -2135,6 +2185,9 @@ struct processor_costs znver5_cost = { COSTS_N_INSNS (14), /* cost of SQRTSS instruction. */ /* DIVSD has throughtput 0.13 and latency 20. */ COSTS_N_INSNS (20), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (5), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (5), /* cost of 512bit VCVTPS2PD etc. */ /* Zen5 can execute: - integer ops: 6 per cycle, at most 3 multiplications. latency 1 for additions, 3 for multiplications (pipelined) @@ -2274,6 +2327,9 @@ struct processor_costs skylake_cost = { COSTS_N_INSNS (14), /* cost of DIVSD instruction. */ COSTS_N_INSNS (12), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (18), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (2), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (2), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (4), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 2, 2, /* reassoc int, fp, vec_int, vec_fp. */ skylake_memcpy, skylake_memset, @@ -2403,6 +2459,9 @@ struct processor_costs icelake_cost = { COSTS_N_INSNS (14), /* cost of DIVSD instruction. */ COSTS_N_INSNS (12), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (18), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (2), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (2), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (2), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 2, 2, /* reassoc int, fp, vec_int, vec_fp. */ icelake_memcpy, icelake_memset, @@ -2526,6 +2585,9 @@ struct processor_costs alderlake_cost = { COSTS_N_INSNS (17), /* cost of DIVSD instruction. */ COSTS_N_INSNS (14), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (18), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (2), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (2), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (2), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 3, 3, /* reassoc int, fp, vec_int, vec_fp. */ alderlake_memcpy, alderlake_memset, @@ -2642,6 +2704,9 @@ const struct processor_costs btver1_cost = { COSTS_N_INSNS (17), /* cost of DIVSD instruction. */ COSTS_N_INSNS (14), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (48), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (4), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (7), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (14), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ btver1_memcpy, btver1_memset, @@ -2755,6 +2820,9 @@ const struct processor_costs btver2_cost = { COSTS_N_INSNS (19), /* cost of DIVSD instruction. */ COSTS_N_INSNS (16), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (21), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (4), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (7), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (14), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ btver2_memcpy, btver2_memset, @@ -2867,6 +2935,9 @@ struct processor_costs pentium4_cost = { COSTS_N_INSNS (38), /* cost of DIVSD instruction. */ COSTS_N_INSNS (23), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (38), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (10), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (20), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (40), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ pentium4_memcpy, pentium4_memset, @@ -2982,6 +3053,9 @@ struct processor_costs nocona_cost = { COSTS_N_INSNS (40), /* cost of DIVSD instruction. */ COSTS_N_INSNS (32), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (41), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (10), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (20), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (40), /* cost of 512bit VCVTPS2PD etc. */ 1, 1, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ nocona_memcpy, nocona_memset, @@ -3095,6 +3169,9 @@ struct processor_costs atom_cost = { COSTS_N_INSNS (60), /* cost of DIVSD instruction. */ COSTS_N_INSNS (31), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (63), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (6), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (12), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (24), /* cost of 512bit VCVTPS2PD etc. */ 2, 2, 2, 2, /* reassoc int, fp, vec_int, vec_fp. */ atom_memcpy, atom_memset, @@ -3208,6 +3285,9 @@ struct processor_costs slm_cost = { COSTS_N_INSNS (69), /* cost of DIVSD instruction. */ COSTS_N_INSNS (20), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (35), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ 1, 2, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ slm_memcpy, slm_memset, @@ -3335,6 +3415,9 @@ struct processor_costs tremont_cost = { COSTS_N_INSNS (17), /* cost of DIVSD instruction. */ COSTS_N_INSNS (14), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (18), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 3, 3, /* reassoc int, fp, vec_int, vec_fp. */ tremont_memcpy, tremont_memset, @@ -3448,6 +3531,9 @@ struct processor_costs intel_cost = { COSTS_N_INSNS (20), /* cost of DIVSD instruction. */ COSTS_N_INSNS (40), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (40), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (8), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (16), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (32), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 1, 1, /* reassoc int, fp, vec_int, vec_fp. */ intel_memcpy, intel_memset, @@ -3566,6 +3652,9 @@ struct processor_costs lujiazui_cost = { COSTS_N_INSNS (17), /* cost of DIVSD instruction. */ COSTS_N_INSNS (32), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (60), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 3, 3, /* reassoc int, fp, vec_int, vec_fp. */ lujiazui_memcpy, lujiazui_memset, @@ -3682,6 +3771,9 @@ struct processor_costs yongfeng_cost = { COSTS_N_INSNS (14), /* cost of DIVSD instruction. */ COSTS_N_INSNS (20), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (35), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ 4, 4, 4, 4, /* reassoc int, fp, vec_int, vec_fp. */ yongfeng_memcpy, yongfeng_memset, @@ -3798,6 +3890,9 @@ struct processor_costs shijidadao_cost = { COSTS_N_INSNS (14), /* cost of DIVSD instruction. */ COSTS_N_INSNS (11), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (18), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (6), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (12), /* cost of 512bit VCVTPS2PD etc. */ 4, 4, 4, 4, /* reassoc int, fp, vec_int, vec_fp. */ shijidadao_memcpy, shijidadao_memset, @@ -3922,6 +4017,9 @@ struct processor_costs generic_cost = { COSTS_N_INSNS (17), /* cost of DIVSD instruction. */ COSTS_N_INSNS (14), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (18), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (3), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (4), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (5), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 3, 3, /* reassoc int, fp, vec_int, vec_fp. */ generic_memcpy, generic_memset, @@ -4051,6 +4149,9 @@ struct processor_costs core_cost = { COSTS_N_INSNS (32), /* cost of DIVSD instruction. */ COSTS_N_INSNS (30), /* cost of SQRTSS instruction. */ COSTS_N_INSNS (58), /* cost of SQRTSD instruction. */ + COSTS_N_INSNS (2), /* cost of CVTSS2SD etc. */ + COSTS_N_INSNS (2), /* cost of 256bit VCVTPS2PD etc. */ + COSTS_N_INSNS (2), /* cost of 512bit VCVTPS2PD etc. */ 1, 4, 2, 2, /* reassoc int, fp, vec_int, vec_fp. */ core_memcpy, core_memset, diff --git a/gcc/config/mips/mips.cc b/gcc/config/mips/mips.cc index 24a28dc..0d3d026 100644 --- a/gcc/config/mips/mips.cc +++ b/gcc/config/mips/mips.cc @@ -20678,6 +20678,9 @@ mips_option_override (void) "-mcompact-branches=never"); } + if (is_micromips && TARGET_MSA) + error ("unsupported combination: %s", "-mmicromips -mmsa"); + /* Require explicit relocs for MIPS R6 onwards. This enables simplification of the compact branch and jump support through the backend. */ if (!TARGET_EXPLICIT_RELOCS && mips_isa_rev >= 6) diff --git a/gcc/config/riscv/bitmanip.md b/gcc/config/riscv/bitmanip.md index 5ed5e18..d0919ec 100644 --- a/gcc/config/riscv/bitmanip.md +++ b/gcc/config/riscv/bitmanip.md @@ -908,6 +908,24 @@ "bext\t%0,%1,%2" [(set_attr "type" "bitmanip")]) +;; We do not define SHIFT_COUNT_TRUNCATED, so we have to have variants +;; that mask/extend the count if we want to eliminate those ops +;; +;; We could (in theory) use GPR for the various modes, but I haven't +;; seen those cases appear in practice. Without a testcase I've +;; elected to keep the modes X which is easy to reason about. +(define_insn "*bext<mode>_mask_pos" + [(set (match_operand:X 0 "register_operand" "=r") + (zero_extract:X (match_operand:X 1 "register_operand" "r") + (const_int 1) + (and:X + (match_operand:X 2 "register_operand" "r") + (match_operand 3 "const_int_operand"))))] + "(TARGET_ZBS + && INTVAL (operands[3]) + 1 == GET_MODE_BITSIZE (<MODE>mode))" + "bext\t%0,%1,%2" + [(set_attr "type" "bitmanip")]) + ;; This is a bext followed by a seqz. Normally this would be a 3->2 split ;; But the and-not pattern with a constant operand is a define_insn_and_split, ;; so this looks like a 2->2 split, which combine rejects. So implement it @@ -1245,3 +1263,41 @@ expand_crc_using_clmul (<SUBX:MODE>mode, <SUBX1:MODE>mode, operands); DONE; }) + +;; If we have an XOR/IOR with a constant operand (C) and the we can +;; synthesize ~C more efficiently than C, then synthesize ~C and use +;; xnor/orn instead. +;; +;; The same can be done for AND, but mvconst_internal's issues get in +;; the way. That's future work. +(define_split + [(set (match_operand:X 0 "register_operand") + (any_or:X (match_operand:X 1 "register_operand") + (match_operand:X 2 "const_int_operand"))) + (clobber (match_operand:X 3 "register_operand"))] + "TARGET_ZBB + && (riscv_const_insns (operands[2], true) + > riscv_const_insns (GEN_INT (~INTVAL (operands[2])), true))" + [(const_int 0)] +{ + /* Get the inverted constant into the temporary register. */ + riscv_emit_move (operands[3], GEN_INT (~INTVAL (operands[2]))); + + /* For xnor, the NOT operation is in a different position. So + we have to customize the split code we generate a bit. + + It is expected that AND will be handled like IOR in the future. */ + if (<CODE> == XOR) + { + rtx x = gen_rtx_XOR (<X:MODE>mode, operands[1], operands[3]); + x = gen_rtx_NOT (<X:MODE>mode, x); + emit_insn (gen_rtx_SET (operands[0], x)); + } + else + { + rtx x = gen_rtx_NOT (<X:MODE>mode, operands[3]); + x = gen_rtx_IOR (<X:MODE>mode, x, operands[1]); + emit_insn (gen_rtx_SET (operands[0], x)); + } + DONE; +}) diff --git a/gcc/config/riscv/riscv-cores.def b/gcc/config/riscv/riscv-cores.def index 2918496..e31afc3 100644 --- a/gcc/config/riscv/riscv-cores.def +++ b/gcc/config/riscv/riscv-cores.def @@ -41,6 +41,12 @@ RISCV_TUNE("sifive-p400-series", sifive_p400, sifive_p400_tune_info) RISCV_TUNE("sifive-p600-series", sifive_p600, sifive_p600_tune_info) RISCV_TUNE("tt-ascalon-d8", generic_ooo, tt_ascalon_d8_tune_info) RISCV_TUNE("thead-c906", generic, thead_c906_tune_info) +RISCV_TUNE("xt-c908", generic, generic_ooo_tune_info) +RISCV_TUNE("xt-c908v", generic, generic_ooo_tune_info) +RISCV_TUNE("xt-c910", generic, generic_ooo_tune_info) +RISCV_TUNE("xt-c910v2", generic, generic_ooo_tune_info) +RISCV_TUNE("xt-c920", generic, generic_ooo_tune_info) +RISCV_TUNE("xt-c920v2", generic, generic_ooo_tune_info) RISCV_TUNE("xiangshan-nanhu", xiangshan, xiangshan_nanhu_tune_info) RISCV_TUNE("generic-ooo", generic_ooo, generic_ooo_tune_info) RISCV_TUNE("size", generic, optimize_size_tune_info) @@ -93,6 +99,48 @@ RISCV_CORE("thead-c906", "rv64imafdc_xtheadba_xtheadbb_xtheadbs_xtheadcmo_" "xtheadmemidx_xtheadmempair_xtheadsync", "thead-c906") +RISCV_CORE("xt-c908", "rv64imafdc_zicbom_zicbop_zicboz_zicntr_zicsr_" + "zifencei_zihintpause_zihpm_zfh_zba_zbb_zbc_zbs_" + "sstc_svinval_svnapot_svpbmt_xtheadba_xtheadbb_" + "xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_" + "xtheadmac_xtheadmemidx_xtheadmempair_xtheadsync", + "xt-c908") +RISCV_CORE("xt-c908v", "rv64imafdcv_zicbom_zicbop_zicboz_zicntr_zicsr_" + "zifencei_zihintpause_zihpm_zfh_zba_zbb_zbc_zbs_" + "zvfh_sstc_svinval_svnapot_svpbmt__xtheadba_" + "xtheadbb_xtheadbs_xtheadcmo_xtheadcondmov_" + "xtheadfmemidx_xtheadmac_xtheadmemidx_" + "xtheadmempair_xtheadsync_xtheadvdot", + "xt-c908") +RISCV_CORE("xt-c910", "rv64imafdc_zicntr_zicsr_zifencei_zihpm_zfh_" + "xtheadba_xtheadbb_xtheadbs_xtheadcmo_" + "xtheadcondmov_xtheadfmemidx_xtheadmac_" + "xtheadmemidx_xtheadmempair_xtheadsync", + "xt-c910") +RISCV_CORE("xt-c910v2", "rv64imafdc_zicbom_zicbop_zicboz_zicntr_zicond_" + "zicsr_zifencei _zihintntl_zihintpause_zihpm_" + "zawrs_zfa_zfbfmin_zfh_zca_zcb_zcd_zba_zbb_zbc_" + "zbs_sscofpmf_sstc_svinval_svnapot_svpbmt_" + "xtheadba_xtheadbb_xtheadbs_xtheadcmo_" + "xtheadcondmov_xtheadfmemidx_xtheadmac_" + "xtheadmemidx_xtheadmempair_xtheadsync", + "xt-c910v2") +RISCV_CORE("xt-c920", "rv64imafdc_zicntr_zicsr_zifencei_zihpm_zfh_" + "xtheadba_xtheadbb_xtheadbs_xtheadcmo_" + "xtheadcondmov_xtheadfmemidx_xtheadmac_" + "xtheadmemidx_xtheadmempair_xtheadsync_" + "xtheadvector", + "xt-c910") +RISCV_CORE("xt-c920v2", "rv64imafdcv_zicbom_zicbop_zicboz_zicntr_zicond_" + "zicsr_zifencei _zihintntl_zihintpause_zihpm_" + "zawrs_zfa_zfbfmin_zfh_zca_zcb_zcd_zba_zbb_zbc_" + "zbs_zvfbfmin_zvfbfwma_zvfh_sscofpmf_sstc_" + "svinval_svnapot_svpbmt_xtheadba_xtheadbb_" + "xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_" + "xtheadmac_xtheadmemidx_xtheadmempair_" + "xtheadsync_xtheadvdot", + "xt-c920v2") + RISCV_CORE("tt-ascalon-d8", "rv64imafdcv_zic64b_zicbom_zicbop_zicboz_" "ziccamoa_ziccif_zicclsm_ziccrse_zicond_zicsr_" "zifencei_zihintntl_zihintpause_zimop_za64rs_" diff --git a/gcc/config/riscv/riscv.cc b/gcc/config/riscv/riscv.cc index d3656a7..bad59e2 100644 --- a/gcc/config/riscv/riscv.cc +++ b/gcc/config/riscv/riscv.cc @@ -13136,9 +13136,6 @@ parse_features_for_version (tree decl, DECL_SOURCE_LOCATION (decl)); gcc_assert (parse_res); - if (arch_string != default_opts->x_riscv_arch_string) - free (CONST_CAST (void *, (const void *) arch_string)); - cl_target_option_restore (&global_options, &global_options_set, &cur_target); } diff --git a/gcc/config/riscv/vector.md b/gcc/config/riscv/vector.md index 51eb64f..3ab4d76 100644 --- a/gcc/config/riscv/vector.md +++ b/gcc/config/riscv/vector.md @@ -2136,18 +2136,34 @@ (match_operand 7 "const_int_operand") (reg:SI VL_REGNUM) (reg:SI VTYPE_REGNUM)] UNSPEC_VPREDICATE) - (vec_duplicate:V_VLS - (match_operand:<VEL> 3 "direct_broadcast_operand")) + ;; (vec_duplicate:V_VLS ;; wrapper activated by wrap_vec_dup below. + (match_operand:<VEL> 3 "direct_broadcast_operand") ;; ) (match_operand:V_VLS 2 "vector_merge_operand")))] "TARGET_VECTOR" { /* Transform vmv.v.x/vfmv.v.f (avl = 1) into vmv.s.x since vmv.s.x/vfmv.s.f has better chances to do vsetvl fusion in vsetvl pass. */ + bool wrap_vec_dup = true; + rtx vec_cst = NULL_RTX; if (riscv_vector::splat_to_scalar_move_p (operands)) { operands[1] = riscv_vector::gen_scalar_move_mask (<VM>mode); operands[3] = force_reg (<VEL>mode, operands[3]); } + else if (immediate_operand (operands[3], <VEL>mode) + && (vec_cst = gen_const_vec_duplicate (<MODE>mode, operands[3])) + && (/* -> pred_broadcast<mode>_zero */ + (vector_least_significant_set_mask_operand (operands[1], + <VM>mode) + && vector_const_0_operand (vec_cst, <MODE>mode)) + || (/* pred_broadcast<mode>_imm */ + vector_all_trues_mask_operand (operands[1], <VM>mode) + && vector_const_int_or_double_0_operand (vec_cst, + <MODE>mode)))) + { + operands[3] = vec_cst; + wrap_vec_dup = false; + } /* Handle vmv.s.x instruction (Wb1 mask) which has memory scalar. */ else if (satisfies_constraint_Wdm (operands[3])) { @@ -2191,6 +2207,8 @@ ; else operands[3] = force_reg (<VEL>mode, operands[3]); + if (wrap_vec_dup) + operands[3] = gen_rtx_VEC_DUPLICATE (<MODE>mode, operands[3]); }) (define_insn_and_split "*pred_broadcast<mode>" diff --git a/gcc/config/sh/sh-modes.def b/gcc/config/sh/sh-modes.def index 80650b4..e31ae69 100644 --- a/gcc/config/sh/sh-modes.def +++ b/gcc/config/sh/sh-modes.def @@ -17,6 +17,12 @@ 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/>. */ +/* SH has the same reversed quiet bit as MIPS. */ +RESET_FLOAT_FORMAT (SF, mips_single_format); +RESET_FLOAT_FORMAT (DF, mips_double_format); +/* TFmode: IEEE quad floating point (software). */ +FLOAT_MODE (TF, 16, mips_quad_format); + /* Vector modes. */ VECTOR_MODE (INT, QI, 2); /* V2QI */ VECTOR_MODES (INT, 4); /* V4QI V2HI */ diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 644b36a..e85a710 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,31 @@ +2025-04-21 Jason Merrill <jason@redhat.com> + + * constexpr.cc (cxx_eval_outermost_constant_expr): Move + verify_constant later. + +2025-04-21 Jason Merrill <jason@redhat.com> + + PR c++/118775 + * constexpr.cc (cxx_eval_call_expression): Add assert. + (fold_to_constant): Handle processing_template_decl. + * init.cc (build_new_1): Use fold_to_constant. + +2025-04-21 Jason Merrill <jason@redhat.com> + + PR c++/99456 + * constexpr.cc (cxx_eval_constant_expression): Check strict + instead of manifestly_const_eval. + (maybe_constant_init_1): Be strict for static constexpr vars. + +2025-04-19 Jason Merrill <jason@redhat.com> + + * coroutines.cc (coro_build_expr_stmt) + (coro_build_cvt_void_expr_stmt): Remove. + (build_actor_fn): Use finish_expr_stmt. + * semantics.cc (finish_expr_stmt): Avoid wrapping statement in + EXPR_STMT. + (finish_stmt_expr_expr): Add comment. + 2025-04-17 Jason Merrill <jason@redhat.com> * constexpr.cc (is_valid_constexpr_fn): Improve diagnostic. diff --git a/gcc/cp/constexpr.cc b/gcc/cp/constexpr.cc index f56c5c4..8a11e62 100644 --- a/gcc/cp/constexpr.cc +++ b/gcc/cp/constexpr.cc @@ -2956,12 +2956,11 @@ cxx_eval_call_expression (const constexpr_ctx *ctx, tree t, gcc_assert (arg0); if (new_op_p) { - /* FIXME: We should not get here; the VERIFY_CONSTANT above - should have already caught it. But currently a conversion - from pointer type to arithmetic type is only considered - non-constant for CONVERT_EXPRs, not NOP_EXPRs. */ if (!tree_fits_uhwi_p (arg0)) { + /* We should not get here; the VERIFY_CONSTANT above + should have already caught it. */ + gcc_checking_assert (false); if (!ctx->quiet) error_at (loc, "cannot allocate array: size not constant"); *non_constant_p = true; @@ -8479,7 +8478,7 @@ cxx_eval_constant_expression (const constexpr_ctx *ctx, tree t, if (TREE_CODE (t) == CONVERT_EXPR && ARITHMETIC_TYPE_P (type) && INDIRECT_TYPE_P (TREE_TYPE (op)) - && ctx->manifestly_const_eval == mce_true) + && ctx->strict) { if (!ctx->quiet) error_at (loc, @@ -9228,11 +9227,6 @@ cxx_eval_outermost_constant_expr (tree t, bool allow_non_constant, if (r == void_node && !constexpr_dtor && ctx.ctor) r = ctx.ctor; - if (!constexpr_dtor) - verify_constant (r, allow_non_constant, &non_constant_p, &overflow_p); - else - DECL_INITIALIZED_BY_CONSTANT_EXPRESSION_P (object) = true; - unsigned int i; tree cleanup; /* Evaluate the cleanups. */ @@ -9251,15 +9245,6 @@ cxx_eval_outermost_constant_expr (tree t, bool allow_non_constant, non_constant_p = true; } - if (TREE_CODE (r) == CONSTRUCTOR && CONSTRUCTOR_NO_CLEARING (r)) - { - if (!allow_non_constant) - error ("%qE is not a constant expression because it refers to " - "an incompletely initialized variable", t); - TREE_CONSTANT (r) = false; - non_constant_p = true; - } - if (!non_constant_p && cxx_dialect >= cxx20 && !global_ctx.heap_vars.is_empty ()) { @@ -9316,6 +9301,21 @@ cxx_eval_outermost_constant_expr (tree t, bool allow_non_constant, non_constant_p = true; } + if (!non_constant_p && !constexpr_dtor) + verify_constant (r, allow_non_constant, &non_constant_p, &overflow_p); + + /* After verify_constant because reduced_constant_expression_p can unset + CONSTRUCTOR_NO_CLEARING. */ + if (!non_constant_p + && TREE_CODE (r) == CONSTRUCTOR && CONSTRUCTOR_NO_CLEARING (r)) + { + if (!allow_non_constant) + error ("%qE is not a constant expression because it refers to " + "an incompletely initialized variable", t); + TREE_CONSTANT (r) = false; + non_constant_p = true; + } + if (non_constant_p) /* If we saw something bad, go back to our argument. The wrapping below is only for the cases of TREE_CONSTANT argument or overflow. */ @@ -9332,13 +9332,17 @@ cxx_eval_outermost_constant_expr (tree t, bool allow_non_constant, if (non_constant_p && !allow_non_constant) return error_mark_node; - else if (constexpr_dtor) - return r; else if (non_constant_p && TREE_CONSTANT (r)) r = mark_non_constant (r); else if (non_constant_p) return t; + if (constexpr_dtor) + { + DECL_INITIALIZED_BY_CONSTANT_EXPRESSION_P (object) = true; + return r; + } + /* Check we are not trying to return the wrong type. */ if (!same_type_ignoring_top_level_qualifiers_p (type, TREE_TYPE (r))) { @@ -9490,6 +9494,9 @@ fold_simple (tree t) tree fold_to_constant (tree t) { + if (processing_template_decl) + return t; + tree r = fold (t); if (CONSTANT_CLASS_P (r) && !TREE_OVERFLOW (r)) return r; @@ -9747,16 +9754,26 @@ maybe_constant_init_1 (tree t, tree decl, bool allow_non_constant, { /* [basic.start.static] allows constant-initialization of variables with static or thread storage duration even if it isn't required, but we - shouldn't bend the rules the same way for automatic variables. */ + shouldn't bend the rules the same way for automatic variables. + + But still enforce the requirements of constexpr/constinit. + [dcl.constinit] "If a variable declared with the constinit specifier + has dynamic initialization, the program is ill-formed, even if the + implementation would perform that initialization as a static + initialization." */ bool is_static = (decl && DECL_P (decl) && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))); + bool strict = (!is_static + || (decl && DECL_P (decl) + && (DECL_DECLARED_CONSTEXPR_P (decl) + || DECL_DECLARED_CONSTINIT_P (decl)))); if (is_static) manifestly_const_eval = mce_true; if (cp_unevaluated_operand && manifestly_const_eval != mce_true) return fold_to_constant (t); - t = cxx_eval_outermost_constant_expr (t, allow_non_constant, !is_static, + t = cxx_eval_outermost_constant_expr (t, allow_non_constant, strict, manifestly_const_eval, false, decl); } diff --git a/gcc/cp/coroutines.cc b/gcc/cp/coroutines.cc index b92d09f..743da06 100644 --- a/gcc/cp/coroutines.cc +++ b/gcc/cp/coroutines.cc @@ -1852,21 +1852,6 @@ coro_build_frame_access_expr (tree coro_ref, tree member_id, bool preserve_ref, return expr; } -/* Helpers to build EXPR_STMT and void-cast EXPR_STMT, common ops. */ - -static tree -coro_build_expr_stmt (tree expr, location_t loc) -{ - return maybe_cleanup_point_expr_void (build_stmt (loc, EXPR_STMT, expr)); -} - -static tree -coro_build_cvt_void_expr_stmt (tree expr, location_t loc) -{ - tree t = build1 (CONVERT_EXPR, void_type_node, expr); - return coro_build_expr_stmt (t, loc); -} - /* Helpers to build an artificial var, with location LOC, NAME and TYPE, in CTX, and with initializer INIT. */ @@ -2582,8 +2567,7 @@ build_actor_fn (location_t loc, tree coro_frame_type, tree actor, tree fnbody, tree hfa = build_new_method_call (ash, hfa_m, &args, NULL_TREE, LOOKUP_NORMAL, NULL, tf_warning_or_error); r = cp_build_init_expr (ash, hfa); - r = coro_build_cvt_void_expr_stmt (r, loc); - add_stmt (r); + finish_expr_stmt (r); release_tree_vector (args); /* Now we know the real promise, and enough about the frame layout to @@ -2678,8 +2662,7 @@ build_actor_fn (location_t loc, tree coro_frame_type, tree actor, tree fnbody, we must tail call them. However, some targets do not support indirect tail calls to arbitrary callees. See PR94359. */ CALL_EXPR_TAILCALL (resume) = true; - resume = coro_build_cvt_void_expr_stmt (resume, loc); - add_stmt (resume); + finish_expr_stmt (resume); r = build_stmt (loc, RETURN_EXPR, NULL); gcc_checking_assert (maybe_cleanup_point_expr_void (r) == r); diff --git a/gcc/cp/init.cc b/gcc/cp/init.cc index e589e45..062a493 100644 --- a/gcc/cp/init.cc +++ b/gcc/cp/init.cc @@ -3405,7 +3405,7 @@ build_new_1 (vec<tree, va_gc> **placement, tree type, tree nelts, errval = throw_bad_array_new_length (); if (outer_nelts_check != NULL_TREE) size = build3 (COND_EXPR, sizetype, outer_nelts_check, size, errval); - size = cp_fully_fold (size); + size = fold_to_constant (size); /* Create the argument list. */ vec_safe_insert (*placement, 0, size); /* Do name-lookup to find the appropriate operator. */ @@ -3462,7 +3462,7 @@ build_new_1 (vec<tree, va_gc> **placement, tree type, tree nelts, outer_nelts_check = NULL_TREE; } - size = cp_fully_fold (size); + size = fold_to_constant (size); /* If size is zero e.g. due to type having zero size, try to preserve outer_nelts for constant expression evaluation purposes. */ diff --git a/gcc/cp/name-lookup.cc b/gcc/cp/name-lookup.cc index 498126a..aa2dc0e 100644 --- a/gcc/cp/name-lookup.cc +++ b/gcc/cp/name-lookup.cc @@ -4178,22 +4178,6 @@ mergeable_namespace_slots (tree ns, tree name, bool is_attached, tree *vec) return vslot; } -/* Retrieve the bindings for an existing mergeable entity in namespace - NS slot NAME. Returns NULL if no such bindings exists. */ - -static tree -get_mergeable_namespace_binding (tree ns, tree name, bool is_attached) -{ - tree *mslot = find_namespace_slot (ns, name, false); - if (!mslot || !*mslot || TREE_CODE (*mslot) != BINDING_VECTOR) - return NULL_TREE; - - tree *vslot = get_fixed_binding_slot - (mslot, name, is_attached ? BINDING_SLOT_PARTITION : BINDING_SLOT_GLOBAL, - false); - return vslot ? *vslot : NULL_TREE; -} - /* DECL is a new mergeable namespace-scope decl. Add it to the mergeable entities on GSLOT. */ @@ -4572,11 +4556,9 @@ lookup_imported_hidden_friend (tree friend_tmpl) || !DECL_MODULE_ENTITY_P (inner)) return NULL_TREE; - lazy_load_pendings (friend_tmpl); - - tree bind = get_mergeable_namespace_binding - (current_namespace, DECL_NAME (inner), DECL_MODULE_ATTACH_P (inner)); - if (!bind) + tree name = DECL_NAME (inner); + tree *slot = find_namespace_slot (current_namespace, name, false); + if (!slot || !*slot || TREE_CODE (*slot) != BINDING_VECTOR) return NULL_TREE; /* We're only interested in declarations attached to the same module @@ -4584,9 +4566,28 @@ lookup_imported_hidden_friend (tree friend_tmpl) int m = get_originating_module (friend_tmpl, /*global=-1*/true); gcc_assert (m != 0); + /* First check whether there's a reachable declaration attached to the module + we're looking for. */ + if (m > 0) + if (binding_slot *mslot = search_imported_binding_slot (slot, m)) + { + if (mslot->is_lazy ()) + lazy_load_binding (m, current_namespace, name, mslot); + for (ovl_iterator iter (*mslot); iter; ++iter) + if (DECL_CLASS_TEMPLATE_P (*iter)) + return *iter; + } + + /* Otherwise, look in the mergeable slots for this name, in case an importer + has already instantiated this declaration. */ + tree *vslot = get_fixed_binding_slot + (slot, name, m > 0 ? BINDING_SLOT_PARTITION : BINDING_SLOT_GLOBAL, false); + if (!vslot || !*vslot) + return NULL_TREE; + /* There should be at most one class template from the module we're looking for, return it. */ - for (ovl_iterator iter (bind); iter; ++iter) + for (ovl_iterator iter (*vslot); iter; ++iter) if (DECL_CLASS_TEMPLATE_P (*iter) && get_originating_module (*iter, true) == m) return *iter; diff --git a/gcc/cp/semantics.cc b/gcc/cp/semantics.cc index 7f23efd..1aa35d3 100644 --- a/gcc/cp/semantics.cc +++ b/gcc/cp/semantics.cc @@ -1180,10 +1180,13 @@ finish_expr_stmt (tree expr) expr = error_mark_node; /* Simplification of inner statement expressions, compound exprs, - etc can result in us already having an EXPR_STMT. */ + etc can result in us already having an EXPR_STMT or other statement + tree. Don't wrap them in EXPR_STMT. */ if (TREE_CODE (expr) != CLEANUP_POINT_EXPR) { - if (TREE_CODE (expr) != EXPR_STMT) + if (TREE_CODE (expr) != EXPR_STMT + && !STATEMENT_CLASS_P (expr) + && TREE_CODE (expr) != STATEMENT_LIST) expr = build_stmt (loc, EXPR_STMT, expr); expr = maybe_cleanup_point_expr_void (expr); } @@ -3082,6 +3085,7 @@ finish_stmt_expr_expr (tree expr, tree stmt_expr) } else if (processing_template_decl) { + /* Not finish_expr_stmt because we don't want convert_to_void. */ expr = build_stmt (input_location, EXPR_STMT, expr); expr = add_stmt (expr); /* Mark the last statement so that we can recognize it as such at diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index 020442a..88fb9bd 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -16963,6 +16963,19 @@ Size of max partition for WHOPR (in estimated instructions). to provide an upper bound for individual size of partition. Meant to be used only with balanced partitioning. +@item lto-partition-locality-frequency-cutoff +The denominator n of fraction 1/n of the execution frequency of callee to be +cloned for a particular caller. Special value of 0 dictates to always clone +without a cut-off. + +@item lto-partition-locality-size-cutoff +Size cut-off for callee including inlined calls to be cloned for a particular +caller. + +@item lto-max-locality-partition +Maximal size of a locality partition for LTO (in estimated instructions). +Value of 0 results in default value being used. + @item lto-max-streaming-parallelism Maximal number of parallel processes used for LTO streaming. @@ -31504,8 +31517,9 @@ Permissible values for this option are: @samp{sifive-e20}, @samp{sifive-e21}, @samp{sifive-e24}, @samp{sifive-e31}, @samp{sifive-e34}, @samp{sifive-e76}, @samp{sifive-s21}, @samp{sifive-s51}, @samp{sifive-s54}, @samp{sifive-s76}, @samp{sifive-u54}, @samp{sifive-u74}, @samp{sifive-x280}, @samp{sifive-xp450}, -@samp{sifive-x670}, @samp{thead-c906}, @samp{tt-ascalon-d8}, -@samp{xiangshan-nanhu}. +@samp{sifive-x670}, @samp{thead-c906}, @samp{tt-ascalon-d8}, @samp{xiangshan-nanhu}, +@samp{xt-c908}, @samp{xt-c908v}, @samp{xt-c910}, @samp{xt-c910v2}, +@samp{xt-c920}, @samp{xt-c920v2}. Note that @option{-mcpu} does not override @option{-march} or @option{-mtune}. diff --git a/gcc/except.cc b/gcc/except.cc index 205811c..0fe1e09 100644 --- a/gcc/except.cc +++ b/gcc/except.cc @@ -2949,7 +2949,14 @@ switch_to_exception_section (const char * ARG_UNUSED (fnname)) { section *s; - if (exception_section) + if (exception_section + /* Don't use the cached section for comdat if it will be different. */ +#ifdef HAVE_LD_EH_GC_SECTIONS + && !(targetm_common.have_named_sections + && DECL_COMDAT_GROUP (current_function_decl) + && HAVE_COMDAT_GROUP) +#endif + ) s = exception_section; else { diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1c45bdb..56325a9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2025-04-19 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/119836 + * resolve.cc (check_pure_function): Fix checking for + an impure subprogram within a DO CONCURRENT construct. + (pure_subroutine): Ditto. + 2025-04-16 Harald Anlauf <anlauf@gmx.de> PR fortran/106948 diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 9c66c25..356e0d7 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -1809,6 +1809,23 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat) return gfc_check_atomic (atom, 1, value, 0, stat, 2); } +bool +team_type_check (gfc_expr *e, int n) +{ + if (e->ts.type != BT_DERIVED || !e->ts.u.derived + || e->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || e->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall be of type " + "%<team_type%> from the intrinsic module " + "%<ISO_FORTRAN_ENV%>", + gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic, + &e->where); + return false; + } + + return true; +} bool gfc_check_image_status (gfc_expr *image, gfc_expr *team) @@ -1818,14 +1835,7 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team) || !positive_check (0, image)) return false; - if (team) - { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic, - &team->where); - return false; - } - return true; + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } @@ -1905,10 +1915,25 @@ gfc_check_get_team (gfc_expr *level) { if (level) { - gfc_error ("%qs argument of %qs intrinsic at %L not yet supported", - gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, - &level->where); - return false; + int l; + + if (!type_check (level, 0, BT_INTEGER) || !scalar_check (level, 0)) + return false; + + /* When level is a constant, try to extract it. If not, the runtime has + to check. */ + if (gfc_extract_int (level, &l, 0)) + return true; + + if (l < GFC_CAF_INITIAL_TEAM || l > GFC_CAF_CURRENT_TEAM) + { + gfc_error ("%qs argument of %qs intrinsic at %L shall specify one of " + "the INITIAL_TEAM, PARENT_TEAM or CURRENT_TEAM constants " + "from the intrinsic module ISO_FORTRAN_ENV", + gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, + &level->where); + return false; + } } return true; } @@ -4683,8 +4708,18 @@ gfc_check_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask) bool -gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) +gfc_check_move_alloc (gfc_expr *from, gfc_expr *to, gfc_expr *stat, + gfc_expr *errmsg) { + struct sync_stat sync_stat = {stat, errmsg}; + + if ((stat || errmsg) + && !gfc_notify_std (GFC_STD_F2008, "STAT= or ERRMSG= at %L not supported", + &to->where)) + return false; + + gfc_resolve_sync_stat (&sync_stat); + if (!variable_check (from, 0, false)) return false; if (!allocatable_check (from, 0)) @@ -6530,7 +6565,8 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) bool -gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) +gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub, + gfc_expr *team_or_team_number) { mpz_t nelems; @@ -6550,12 +6586,8 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) return false; } - if (sub->ts.type != BT_INTEGER) - { - gfc_error ("Type of %s argument of IMAGE_INDEX at %L shall be INTEGER", - gfc_current_intrinsic_arg[1]->name, &sub->where); - return false; - } + if (!type_check (sub, 1, BT_INTEGER)) + return false; if (gfc_array_size (sub, &nelems)) { @@ -6570,12 +6602,23 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) mpz_clear (nelems); } + if (team_or_team_number) + { + if (!type_check2 (team_or_team_number, 2, BT_DERIVED, BT_INTEGER) + || !scalar_check (team_or_team_number, 2)) + return false; + + /* Check team is of team_type. */ + if (team_or_team_number->ts.type == BT_DERIVED + && !team_type_check (team_or_team_number, 2)) + return false; + } + return true; } - bool -gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) +gfc_check_num_images (gfc_expr *team_or_team_number) { if (flag_coarray == GFC_FCOARRAY_NONE) { @@ -6583,34 +6626,21 @@ gfc_check_num_images (gfc_expr *distance, gfc_expr *failed) return false; } - if (distance) - { - if (!type_check (distance, 0, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 0)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "NUM_IMAGES at %L", &distance->where)) - return false; - } + if (!team_or_team_number) + return true; - if (failed) - { - if (!type_check (failed, 1, BT_LOGICAL)) - return false; + if (!gfc_notify_std (GFC_STD_F2008, + "%<team%> or %<team_number%> argument to %qs at %L", + gfc_current_intrinsic, &team_or_team_number->where)) + return false; - if (!scalar_check (failed, 1)) - return false; + if (!type_check2 (team_or_team_number, 0, BT_DERIVED, BT_INTEGER) + || !scalar_check (team_or_team_number, 0)) + return false; - if (!gfc_notify_std (GFC_STD_F2018, "FAILED= argument to " - "NUM_IMAGES at %L", &failed->where)) - return false; - } + if (team_or_team_number->ts.type == BT_DERIVED + && !team_type_check (team_or_team_number, 0)) + return false; return true; } @@ -6625,94 +6655,120 @@ gfc_check_team_number (gfc_expr *team) return false; } - if (team) - { - if (team->ts.type != BT_DERIVED - || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) - { - gfc_error ("TEAM argument at %L to the intrinsic TEAM_NUMBER " - "shall be of type TEAM_TYPE", &team->where); - return false; - } - } - else - return true; - - return true; + return !team || (scalar_check (team, 0) && team_type_check (team, 0)); } bool -gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance) +gfc_check_this_image (gfc_actual_arglist *args) { + gfc_expr *coarray, *dim, *team, *cur; + + coarray = dim = team = NULL; + if (flag_coarray == GFC_FCOARRAY_NONE) { gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); return false; } - if (coarray == NULL && dim == NULL && distance == NULL) + /* Shortcut when no arguments are given. */ + if (!args->expr && !args->next->expr && !args->next->next->expr) return true; - if (dim != NULL && coarray == NULL) - { - gfc_error ("DIM argument without COARRAY argument not allowed for " - "THIS_IMAGE intrinsic at %L", &dim->where); - return false; - } + cur = args->expr; - if (distance && (coarray || dim)) + if (cur) { - gfc_error ("The DISTANCE argument may not be specified together with the " - "COARRAY or DIM argument in intrinsic at %L", - &distance->where); - return false; + gfc_push_suppress_errors (); + if (coarray_check (cur, 0)) + coarray = cur; + else if (scalar_check (cur, 2) && team_type_check (cur, 2)) + team = cur; + else + { + gfc_pop_suppress_errors (); + gfc_error ("First argument of %<this_image%> intrinsic at %L must be " + "a coarray " + "variable or an object of type %<team_type%> from the " + "intrinsic module " + "%<ISO_FORTRAN_ENV%>", + &cur->where); + return false; + } + gfc_pop_suppress_errors (); } - /* Assume that we have "this_image (distance)". */ - if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER) + cur = args->next->expr; + if (cur) { - if (dim) + gfc_push_suppress_errors (); + if (dim_check (cur, 1, true) && cur->corank == 0) + dim = cur; + else if (scalar_check (cur, 2) && team_type_check (cur, 2)) + { + if (team) + { + gfc_pop_suppress_errors (); + goto team_type_error; + } + team = cur; + } + else { - gfc_error ("Unexpected DIM argument with noncoarray argument at %L", - &coarray->where); + gfc_pop_suppress_errors (); + gfc_error ("Second argument of %<this_image%> intrinsic at %L must " + "be an %<INTEGER%> " + "typed scalar or an object of type %<team_type%> from the " + "intrinsic " + "module %<ISO_FORTRAN_ENV%>", + &cur->where); return false; } - distance = coarray; + gfc_pop_suppress_errors (); } - if (distance) + cur = args->next->next->expr; + if (cur) { - if (!type_check (distance, 2, BT_INTEGER)) - return false; - - if (!nonnegative_check ("DISTANCE", distance)) - return false; - - if (!scalar_check (distance, 2)) - return false; - - if (!gfc_notify_std (GFC_STD_F2018, "DISTANCE= argument to " - "THIS_IMAGE at %L", &distance->where)) + if (team_type_check (cur, 2) && scalar_check (cur, 2)) + { + if (team) + goto team_type_error; + team = cur; + } + else return false; + } - return true; + if (dim != NULL && coarray == NULL) + { + gfc_error ("%<dim%> argument without %<coarray%> argument not allowed " + "for %<this_image%> intrinsic at %L", + &dim->where); + return false; } - if (!coarray_check (coarray, 0)) + if (dim && !dim_corank_check (dim, coarray)) return false; - if (dim != NULL) - { - if (!dim_check (dim, 1, false)) - return false; - - if (!dim_corank_check (dim, coarray)) - return false; - } + if (team + && !gfc_notify_std (GFC_STD_F2018, + "%<team%> argument to %<this_image%> at %L", + &team->where)) + return false; + args->expr = coarray; + args->next->expr = dim; + args->next->next->expr = team; return true; + +team_type_error: + gfc_error ( + "At most one argument of type %<team_type%> from the intrinsic module " + "%<ISO_FORTRAN_ENV%> to %<this_image%> at %L allowed", + &cur->where); + return false; } /* Calculate the sizes for transfer, used by gfc_check_transfer and also diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index 7058325..2f067f8 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -357,7 +357,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, gcc_assert (expr->expr_type == EXPR_VARIABLE); caf_ts = &expr->symtree->n.sym->ts; - if (!expr->symtree->n.sym->attr.codimension) + if (!(expr->symtree->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (expr->symtree->n.sym)->attr.codimension + : expr->symtree->n.sym->attr.codimension)) { /* The coarray is in some component. Find it. */ caf_ref = expr->ref; @@ -432,6 +434,9 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, else if (base->ts.type == BT_CLASS) convert_coarray_class_to_derived_type (base, ns); + memset (&(*post_caf_ref_expr)->ts, 0, sizeof (gfc_typespec)); + gfc_resolve_expr (*post_caf_ref_expr); + (*post_caf_ref_expr)->corank = 0; gfc_expression_rank (*post_caf_ref_expr); if (for_send) gfc_expression_rank (expr); @@ -1130,8 +1135,8 @@ create_allocated_callback (gfc_expr *expr) // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN); base = post_caf_ref_expr->symtree->n.sym; + base->attr.pointer = !base->attr.dimension; gfc_set_sym_referenced (base); - gfc_commit_symbol (base); *argptr = gfc_get_formal_arglist (); (*argptr)->sym = base; argptr = &(*argptr)->next; @@ -1420,7 +1425,8 @@ coindexed_expr_callback (gfc_expr **e, int *walk_subtrees, { case GFC_ISYM_ALLOCATED: if ((*e)->value.function.actual->expr - && gfc_is_coindexed ((*e)->value.function.actual->expr)) + && (gfc_is_coarray ((*e)->value.function.actual->expr) + || gfc_is_coindexed ((*e)->value.function.actual->expr))) { rewrite_caf_allocated (e); *walk_subtrees = 0; diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index feb454e..69acd2d 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -8459,6 +8459,7 @@ gfc_match_end (gfc_statement *st) { case COMP_ASSOCIATE: case COMP_BLOCK: + case COMP_CHANGE_TEAM: if (startswith (block_name, "block@")) block_name = NULL; break; @@ -8515,7 +8516,7 @@ gfc_match_end (gfc_statement *st) case COMP_SUBROUTINE: *st = ST_END_SUBROUTINE; if (!abbreviated_modproc_decl) - target = " subroutine"; + target = " subroutine"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -8524,7 +8525,7 @@ gfc_match_end (gfc_statement *st) case COMP_FUNCTION: *st = ST_END_FUNCTION; if (!abbreviated_modproc_decl) - target = " function"; + target = " function"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -8646,6 +8647,12 @@ gfc_match_end (gfc_statement *st) eos_ok = 0; break; + case COMP_CHANGE_TEAM: + *st = ST_END_TEAM; + target = " team"; + eos_ok = 0; + break; + default: gfc_error ("Unexpected END statement at %C"); goto cleanup; @@ -8683,14 +8690,19 @@ gfc_match_end (gfc_statement *st) else got_matching_end = true; + if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR) + /* Emit errors of stat and errmsg parsing now to finish the block and + continue analysis of compilation unit. */ + gfc_error_check (); + old_loc = gfc_current_locus; /* If we're at the end, make sure a block name wasn't required. */ if (gfc_match_eos () == MATCH_YES) { - if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK - && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) + && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL + && *st != ST_END_TEAM) return MATCH_YES; if (!block_name) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index 9501bcc..dd920f3 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2607,6 +2607,20 @@ show_omp_node (int level, gfc_code *c) fprintf (dumpfile, " (%s)", c->ext.omp_clauses->critical_name); } +static void +show_sync_stat (struct sync_stat *sync_stat) +{ + if (sync_stat->stat) + { + fputs (" stat=", dumpfile); + show_expr (sync_stat->stat); + } + if (sync_stat->errmsg) + { + fputs (" errmsg=", dumpfile); + show_expr (sync_stat->errmsg); + } +} /* Show a single code node and everything underneath it if necessary. */ @@ -2755,20 +2769,27 @@ show_code_node (int level, gfc_code *c) fputs ("FAIL IMAGE ", dumpfile); break; - case EXEC_CHANGE_TEAM: - fputs ("CHANGE TEAM", dumpfile); - break; - case EXEC_END_TEAM: fputs ("END TEAM", dumpfile); + show_sync_stat (&c->ext.sync_stat); break; case EXEC_FORM_TEAM: - fputs ("FORM TEAM", dumpfile); + fputs ("FORM TEAM ", dumpfile); + show_expr (c->expr1); + show_expr (c->expr2); + if (c->expr3) + { + fputs (" NEW_INDEX", dumpfile); + show_expr (c->expr3); + } + show_sync_stat (&c->ext.sync_stat); break; case EXEC_SYNC_TEAM: - fputs ("SYNC TEAM", dumpfile); + fputs ("SYNC TEAM ", dumpfile); + show_expr (c->expr1); + show_sync_stat (&c->ext.sync_stat); break; case EXEC_SYNC_ALL: @@ -2913,6 +2934,7 @@ show_code_node (int level, gfc_code *c) fputs ("ENDIF", dumpfile); break; + case EXEC_CHANGE_TEAM: case EXEC_BLOCK: { const char *blocktype, *sname = NULL; @@ -2928,17 +2950,23 @@ show_code_node (int level, gfc_code *c) if (fcn && fcn->expr_type == EXPR_FUNCTION) sname = fcn->value.function.actual->expr->symtree->n.sym->name; } + else if (c->op == EXEC_CHANGE_TEAM) + blocktype = "CHANGE TEAM"; else if (c->ext.block.assoc) blocktype = "ASSOCIATE"; else blocktype = "BLOCK"; show_indent (); fprintf (dumpfile, "%s ", blocktype); + if (c->op == EXEC_CHANGE_TEAM) + show_expr (c->expr1); for (alist = c->ext.block.assoc; alist; alist = alist->next) { fprintf (dumpfile, " %s = ", sname ? sname : alist->name); show_expr (alist->target); } + if (c->op == EXEC_CHANGE_TEAM) + show_sync_stat (&c->ext.block.sync_stat); ++show_level; ns = c->ext.block.ns; @@ -2948,8 +2976,13 @@ show_code_node (int level, gfc_code *c) gfc_current_ns = saved_ns; show_code (show_level, ns->code); --show_level; - show_indent (); - fprintf (dumpfile, "END %s ", blocktype); + if (c->op != EXEC_CHANGE_TEAM) + { + /* A CHANGE_TEAM is terminated by a END_TEAM, which have its own + stat and errmsg. Therefore, let it print itself. */ + show_indent (); + fprintf (dumpfile, "END %s ", blocktype); + } break; } @@ -3048,7 +3081,9 @@ show_code_node (int level, gfc_code *c) break; case EXEC_CRITICAL: - fputs ("CRITICAL\n", dumpfile); + fputs ("CRITICAL", dumpfile); + show_sync_stat (&c->ext.sync_stat); + fputc ('\n', dumpfile); show_code (level + 1, c->block->next); code_indent (level, 0); fputs ("END CRITICAL", dumpfile); diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 0753667..07e9bac 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -3836,7 +3836,13 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, if (has_pointer && (ref == NULL || ref->next == NULL) && lvalue->symtree->n.sym->attr.data) return true; - else + /* Prevent the following error message for caf-single mode, because there + are no teams in single mode and the simplify returns a null then. */ + else if (!(flag_coarray == GFC_FCOARRAY_SINGLE + && rvalue->ts.type == BT_DERIVED + && rvalue->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && rvalue->ts.u.derived->intmod_sym_id + == ISOFORTRAN_TEAM_TYPE)) { gfc_error ("NULL appears on right-hand side in assignment at %L", &rvalue->where); diff --git a/gcc/fortran/frontend-passes.cc b/gcc/fortran/frontend-passes.cc index ef9c801..02a0a23 100644 --- a/gcc/fortran/frontend-passes.cc +++ b/gcc/fortran/frontend-passes.cc @@ -5340,6 +5340,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, { case EXEC_BLOCK: + case EXEC_CHANGE_TEAM: WALK_SUBCODE (co->ext.block.ns->code); if (co->ext.block.assoc) { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5ef7037..46310a0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3162,6 +3162,11 @@ enum locality_type LOCALITY_NUM }; +struct sync_stat +{ + gfc_expr *stat, *errmsg; +}; + typedef struct gfc_code { gfc_exec_op op; @@ -3197,6 +3202,7 @@ typedef struct gfc_code gfc_omp_variant *omp_variants; bool omp_bool; int stop_code; + struct sync_stat sync_stat; struct { @@ -3207,6 +3213,7 @@ typedef struct gfc_code unsigned arr_spec_from_expr3:1; /* expr3 is not explicit */ unsigned expr3_not_explicit:1; + struct sync_stat sync_stat; } alloc; @@ -3215,6 +3222,7 @@ typedef struct gfc_code gfc_namespace *ns; gfc_association_list *assoc; gfc_case *case_list; + struct sync_stat sync_stat; } block; @@ -3985,6 +3993,7 @@ bool gfc_resolve_index (gfc_expr *, int); bool gfc_resolve_dim_arg (gfc_expr *); bool gfc_resolve_substring (gfc_ref *, bool *); void gfc_resolve_substring_charlen (gfc_expr *); +void gfc_resolve_sync_stat (struct sync_stat *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); bool gfc_type_is_extensible (gfc_symbol *); bool gfc_resolve_intrinsic (gfc_symbol *, locus *); diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 9632161..841f613 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -4230,6 +4230,12 @@ future implementation of teams. It is about to change without further notice. * _gfortran_caf_co_min:: Collective minimum reduction * _gfortran_caf_co_sum:: Collective summing reduction * _gfortran_caf_co_reduce:: Generic collective reduction +* _gfortran_caf_form_team:: Team creation function +* _gfortran_caf_change_team:: Team activation function +* _gfortran_caf_end_team:: Team termination function +* _gfortran_caf_sync_team:: Synchronize all images of a given team +* _gfortran_caf_get_team:: Get the opaque handle of the specified team +* _gfortran_caf_team_number:: Get the unique id of the given team @end menu @@ -4294,21 +4300,23 @@ using the STOP and ERROR STOP statements; those use different library calls. @table @asis @item @emph{Synopsis}: -@code{int _gfortran_caf_this_image (int distance)} +@code{int _gfortran_caf_this_image (caf_team_t team)} @item @emph{Description}: -This function returns the current image number, which is a positive number. +Return the current image number in the @var{team}, or in the current team, if +no @var{team} is given. @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{distance} @tab As specified for the @code{this_image} intrinsic -in TS18508. Shall be a nonnegative number. +@item @var{team} @tab intent(in), optional; The team this image's number is +requested for. If null, the image number in the current team is returned. @end multitable @item @emph{Notes}: -If the Fortran intrinsic @code{this_image} is invoked without an argument, which -is the only permitted form in Fortran 2008, GCC passes @code{0} as -first argument. +Available since Fortran 2008 without argument; Since Fortran 2018 with optional +team argument. Fortran 2008 uses 0 as argument for team, which is permissible, +because a team handle is always an opaque pointer, which as a special case can +be null here. @end table @@ -4318,25 +4326,29 @@ first argument. @table @asis @item @emph{Synopsis}: -@code{int _gfortran_caf_num_images(int distance, int failed)} +@code{int _gfortran_caf_num_images (caf_team_t team, int32_t *team_number)} @item @emph{Description}: -This function returns the number of images in the current team, if -@var{distance} is 0 or the number of images in the parent team at the specified -distance. If @var{failed} is -1, the function returns the number of all images at -the specified distance; if it is 0, the function returns the number of -nonfailed images, and if it is 1, it returns the number of failed images. +This function returns the number of images in the team given by @var{team} or +@var{team_number}, if either one is present. If both are null, then the number +of images in the current team is returned. @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{distance} @tab the distance from this image to the ancestor. -Shall be positive. -@item @var{failed} @tab shall be -1, 0, or 1 +@item @var{team} @tab intent(in), optional; The team the number of images is +requested for. If null, the number of images in the current team is returned. +@item @var{team_number} @tab intent(in), optional; The team id for which the +number of teams is requested; if unset, then number of images in the current +team is returned. @end multitable @item @emph{Notes}: -This function follows TS18508. If the num_image intrinsic has no arguments, -then the compiler passes @code{distance=0} and @code{failed=-1} to the function. +When both argument are given, then it is caf-library dependent which argument +is examined first. Current implementations prioritize the @var{team} argument, +because it is easier to retrive the number of images from it. + +Fortran 2008 or later, with no arguments; Fortran 2018 or later with two +arguments. @end table @@ -4705,9 +4717,9 @@ structure. operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{team_number} @tab intent(in) The number of the team this access is -to be part of. Unused at the moment. +to be part of. @end multitable @item @emph{Notes}: @@ -4806,9 +4818,9 @@ structure. operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{team_number} @tab intent(in) The number of the team this access is -to be part of. Unused at the moment. +to be part of. @end multitable @item @emph{Notes}: @@ -4906,13 +4918,13 @@ the operation on the sending side, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. @item @var{dst_team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{dst_team_number} @tab intent(in) The number of the team this access -is to be part of. Unused at the moment. +is to be part of. @item @var{src_team} @tab intent(in) The opaque team handle as returned by -@code{FORM TEAM}. Unused at the moment. +@code{FORM TEAM}. @item @var{src_team_number} @tab intent(in) The number of the team this access -is to be part of. Unused at the moment. +is to be part of. @end multitable @item @emph{Notes}: @@ -5656,6 +5668,180 @@ or an array descriptor. @end table + +@node _gfortran_caf_form_team +@subsection @code{_gfortran_caf_form_team} --- Team creation function +@cindex Coarray, _gfortran_caf_form_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_form_team (int team_id, caf_team_t *team, +int *new_index, int *stat, char *errmsg, size_t errmsg_len)} + +@item @emph{Description}: +Create a team. All images giving the same @var{team_id} in a call to +@code{FORM TEAM} will form a new team addressable by the opaque handle +@var{team} which is of type @code{team_type} from the intrinsic module +@ref{ISO_FORTRAN_ENV}. In the team the image gets the image index given by +@var{new_index} if present. If @var{new_index} is absent, then an +implementation specific index is assigned. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team_id} @tab intent(in) A unique id for each team to form. Images +giving the same @var{team_id} in a call to @code{FORM TEAM} belong to the same +team. +@item @var{team} @tab intent(out) The opaque pointer to the newly formed team +@item @var{new_index} @tab intent(in) If non-null gives the unique index of +this image in the newly formed team. When no @var{new_index} is given, the +caf-library is free to choose a unique index. +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable + +@item @emph{Notes}: +The id given in @var{team_id} has to be unique in all subsequent calls to +@code{FORM TEAM} on the same image. That id is the same used in +@code{TEAM_NUMBER=} of coarray indexes, which motivates the uniqueness. + +The index given in @var{new_index} needs to be unique among all members of +team to create. Failing uniqueness may lead to misbehaviour, which depends +on the caf-library's implementation. The library is free to implement +checks for this, which imposes overhead and therefore may be avoided. +@end table + + + +@node _gfortran_caf_change_team +@subsection @code{_gfortran_caf_change_team} --- Team activation function +@cindex Coarray, _gfortran_caf_change_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_change_team (caf_team_t team, int *stat, char *errmsg, +size_t errmsg_len)} + +@item @emph{Description}: +Actives the team given by @var{team}, which must be formed but not active +yet. This routine starts a new epoch on the coarray memory pool. All +coarrays registered from now on, will be freeed once the team is terminated. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(inout) The opaque pointer to an already formed +team +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable + +@item @emph{Notes}: +When an error occurs and @var{stat} is non-null, it will be set. Nevertheless +will the Fortran program continue with the first statement in the change team +block. +@end table + + + +@node _gfortran_caf_end_team +@subsection @code{_gfortran_caf_end_team} --- Team termination function +@cindex Coarray, _gfortran_caf_end_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)} + +@item @emph{Description}: +Terminates the last team changed to. The coarray memory epoch is +terminated and all coarrays allocated since the execution of @code{CHANGE TEAM} +are freeed. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable +@end table + + + +@node _gfortran_caf_sync_team +@subsection @code{_gfortran_caf_sync_team} --- Synchronize all images of a given team +@cindex Coarray, _gfortran_caf_sync_team + +@table @asis +@item @emph{Synopsis}: +@code{void _gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg, +size_t errmsg_len)} + +@item @emph{Description}: +Blocks execution of the image calling @code{SYNC TEAM} until all images of the +team given by @var{team} have joined the synchronisation call. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(in) The opaque pointer to an active team +@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL. +@item @var{errmsg} @tab intent(out) When an error occurs, this is set to +an error message; may be NULL. +@item @var{errmsg_len} @tab intent(in) the buffer size of errmsg +@end multitable +@end table + + + +@node _gfortran_caf_get_team +@subsection @code{_gfortran_caf_get_team} --- Get the opaque handle of the specified team +@cindex Coarray, _gfortran_caf_get_team + +@table @asis +@item @emph{Synopsis}: +@code{caf_team_t _gfortran_caf_get_team (int32_t *level)} + +@item @emph{Description}: +Get the current team, when @var{level} is null, or the team specified by +@var{level} set to @code{INITIAL_TEAM}, @code{PARENT_TEAM} or +@code{CURRENT_TEAM} from the @code{ISO_FORTRAN_ENV} intrinsic module. When +being on the @code{INITIAL_TEAM} and requesting its @code{PARENT_TEAM}, then +the initial team is returned. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{level} @tab intent(in) If set to one of the levels specified in +the @code{ISO_FORTRAN_ENV} module, the function returns the handle of the given +team. Values different from the allowed ones lead to a runtime error. +@end multitable +@end table + + + +@node _gfortran_caf_team_number +@subsection @code{_gfortran_caf_team_number} --- Get the unique id of the given team +@cindex Coarray, _gfortran_caf_team_number + +@table @asis +@item @emph{Synopsis}: +@code{int _gfortran_caf_team_number (caf_team_t team)} + +@item @emph{Description}: +The team id given when forming the team @ref{_gfortran_caf_form_team} of the +team specified by @var{team}, if given, or of the current team, if @var{team} +is absent. It is a runtime error to specify a non-existing team. +The team has to be formed, i.e., it is not necessary that it is changed +into to get the team number. The initial team has the team number @code{-1}. + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{team} @tab intent(in) The team for which the team id is desired. +@end multitable +@end table + + @c Intrinsic Procedures @c --------------------------------------------------------------------- diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index d2ce74f..2eba209 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -1395,26 +1395,24 @@ add_functions (void) { /* Argument names. These are used as argument keywords and so need to match the documentation. Please keep this list in sorted order. */ - const char - *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", - *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", - *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command", - *dist = "distance", *dm = "dim", *f = "field", *failed="failed", - *fs = "fsource", *han = "handler", *i = "i", - *idy = "identity", *image = "image", *j = "j", *kind = "kind", - *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a", - *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask", - *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number", - *op = "operation", *ord = "order", *odd = "ordered", *p = "p", - *p1 = "path1", *p2 = "path2", *pad = "pad", *pid = "pid", *pos = "pos", - *pt = "pointer", *r = "r", *rd = "round", - *s = "s", *set = "set", *sh = "shift", *shp = "shape", - *sig = "sig", *src = "source", *ssg = "substring", - *sta = "string_a", *stb = "string_b", *stg = "string", - *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time", - *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", - *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", - *z = "z"; + const char *a + = "a", + *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", *bck = "back", + *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", *c_ptr_2 = "c_ptr_2", + *ca = "coarray", *com = "command", *dm = "dim", *f = "field", + *fs = "fsource", *han = "handler", *i = "i", *idy = "identity", + *image = "image", *j = "j", *kind = "kind", *l = "l", *ln = "len", + *level = "level", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b", + *md = "mode", *mo = "mold", *msk = "mask", *n = "n", *ncopies = "ncopies", + *nm = "name", *num = "number", *op = "operation", *ord = "order", + *odd = "ordered", *p = "p", *p1 = "path1", *p2 = "path2", *pad = "pad", + *pid = "pid", *pos = "pos", *pt = "pointer", *r = "r", *rd = "round", + *s = "s", *set = "set", *sh = "shift", *shp = "shape", *sig = "sig", + *src = "source", *ssg = "substring", *sta = "string_a", *stb = "string_b", + *stg = "string", *sub = "sub", *sz = "size", *tg = "target", *team = "team", + *team_or_team_number = "team/team_number", *tm = "time", *ts = "tsource", + *ut = "unit", *v = "vector", *va = "vector_a", *vb = "vector_b", + *vl = "values", *val = "value", *x = "x", *y = "y", *z = "z"; int di, dr, dd, dl, dc, dz, ii; @@ -2112,10 +2110,10 @@ add_functions (void) make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); - add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, - gfc_check_get_team, NULL, gfc_resolve_get_team, - level, BT_INTEGER, di, OPTIONAL); + add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_DERIVED, di, GFC_STD_F2018, gfc_check_get_team, + gfc_simplify_get_team, gfc_resolve_get_team, level, BT_INTEGER, di, + OPTIONAL); add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); @@ -2265,9 +2263,11 @@ add_functions (void) make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); - add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, - ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); + add_sym_3 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_image_index, + gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, dr, + REQUIRED, sub, BT_INTEGER, ii, REQUIRED, team_or_team_number, + BT_VOID, di, OPTIONAL); add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status, @@ -2848,11 +2848,10 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); - add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, - ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_num_images, gfc_simplify_num_images, NULL, - dist, BT_INTEGER, di, OPTIONAL, - failed, BT_LOGICAL, dl, OPTIONAL); + add_sym_1 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, + ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, gfc_check_num_images, + gfc_simplify_num_images, NULL, team_or_team_number, BT_VOID, di, + OPTIONAL); add_sym_3 ("out_of_range", GFC_ISYM_OUT_OF_RANGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2018, @@ -3338,10 +3337,11 @@ add_functions (void) gfc_check_team_number, NULL, gfc_resolve_team_number, team, BT_DERIVED, di, OPTIONAL); - add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, - ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, - dist, BT_INTEGER, di, OPTIONAL); + add_sym_3red ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, di, GFC_STD_F2008, gfc_check_this_image, + gfc_simplify_this_image, gfc_resolve_this_image, ca, BT_REAL, + dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, team, BT_DERIVED, + di, OPTIONAL); add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); @@ -3835,11 +3835,11 @@ add_subroutines (void) st, BT_INTEGER, di, OPTIONAL, INTENT_OUT, trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN); - add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, - GFC_STD_F2003, - gfc_check_move_alloc, NULL, NULL, - f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, - t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); + add_sym_4s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, + GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL, f, BT_UNKNOWN, 0, + REQUIRED, INTENT_INOUT, t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT, + stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, errmsg, BT_CHARACTER, + dc, OPTIONAL, INTENT_INOUT); add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits, @@ -4956,6 +4956,9 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) else if (specific->check.f3red == gfc_check_transf_bit_intrins) /* Same as for PRODUCT and SUM, but different checks. */ t = gfc_check_transf_bit_intrins (*ap); + else if (specific->check.f3red == gfc_check_this_image) + /* May need to reassign arguments. */ + t = gfc_check_this_image (*ap); else { if (specific->check.f1 == NULL) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index fec1c24..767792c 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -132,7 +132,7 @@ bool gfc_check_nearest (gfc_expr *, gfc_expr *); bool gfc_check_new_line (gfc_expr *); bool gfc_check_norm2 (gfc_expr *, gfc_expr *); bool gfc_check_null (gfc_expr *); -bool gfc_check_num_images (gfc_expr *, gfc_expr *); +bool gfc_check_num_images (gfc_expr *); bool gfc_check_out_of_range (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_parity (gfc_expr *, gfc_expr *); @@ -208,7 +208,8 @@ bool gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_gerror (gfc_expr *); bool gfc_check_getarg (gfc_expr *, gfc_expr *); bool gfc_check_getlog (gfc_expr *); -bool gfc_check_move_alloc (gfc_expr *, gfc_expr *); +bool gfc_check_move_alloc (gfc_expr *, gfc_expr *, gfc_expr *stat, + gfc_expr *errmsg); bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_random_init (gfc_expr *, gfc_expr *); @@ -221,7 +222,7 @@ bool gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ftell_sub (gfc_expr *, gfc_expr *); bool gfc_check_getcwd_sub (gfc_expr *, gfc_expr *); bool gfc_check_hostnm_sub (gfc_expr *, gfc_expr *); -bool gfc_check_image_index (gfc_expr *, gfc_expr *); +bool gfc_check_image_index (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_itime_idate (gfc_expr *); bool gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *); @@ -233,7 +234,7 @@ bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_sleep_sub (gfc_expr *); bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_system_sub (gfc_expr *, gfc_expr *); -bool gfc_check_this_image (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_this_image (gfc_actual_arglist *); bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *); bool gfc_check_umask_sub (gfc_expr *, gfc_expr *); bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *); @@ -327,7 +328,7 @@ gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *); -gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); @@ -382,7 +383,7 @@ gfc_expr *gfc_simplify_new_line (gfc_expr *); gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_null (gfc_expr *); -gfc_expr *gfc_simplify_num_images (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_num_images (gfc_expr *); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); @@ -478,6 +479,7 @@ void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a); void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_c_loc (gfc_expr *, gfc_expr *); void gfc_resolve_c_funloc (gfc_expr *, gfc_expr *); +void gfc_resolve_get_team (gfc_expr *, gfc_expr *); void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_chdir (gfc_expr *, gfc_expr *); @@ -522,7 +524,6 @@ void gfc_resolve_gamma (gfc_expr *, gfc_expr *); void gfc_resolve_getcwd (gfc_expr *, gfc_expr *); void gfc_resolve_getgid (gfc_expr *); void gfc_resolve_getpid (gfc_expr *); -void gfc_resolve_get_team (gfc_expr *, gfc_expr *); void gfc_resolve_getuid (gfc_expr *); void gfc_resolve_hostnm (gfc_expr *, gfc_expr *); void gfc_resolve_hypot (gfc_expr *, gfc_expr *, gfc_expr *); @@ -530,7 +531,7 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); -void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 8c160e5..3a105bc 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -170,6 +170,7 @@ Some basic guidelines for editing this document: * @code{GETGID}: GETGID, Group ID function * @code{GETLOG}: GETLOG, Get login name * @code{GETPID}: GETPID, Process ID function +* @code{GET_TEAM}: GET_TEAM, Get the handle of a team * @code{GETUID}: GETUID, User ID function * @code{GMTIME}: GMTIME, Convert time to GMT info * @code{HOSTNM}: HOSTNM, Get system host name @@ -311,6 +312,7 @@ Some basic guidelines for editing this document: * @code{TAN}: TAN, Tangent function * @code{TAND}: TAND, Tangent function, degrees * @code{TANH}: TANH, Hyperbolic tangent function +* @code{TEAM_NUMBER}: TEAM_NUMBER, Retrieve team id of given team * @code{THIS_IMAGE}: THIS_IMAGE, Cosubscript index of this image * @code{TIME}: TIME, Time function * @code{TIME8}: TIME8, Time function (64-bit) @@ -7336,6 +7338,59 @@ GNU extension +@node GET_TEAM +@section @code{GET_TEAM} --- Get the handle of a team +@fnindex GET_TEAM +@cindex coarray, @code{GET_TEAM} +@cindex images, get a handle to a team + +@table @asis +@item @emph{Synopsis}: +@code{RESULT = GET_TEAM([LEVEL])} + +@item @emph{Description}: +Returns the handle of the current team, if @var{LEVEL} is not given. Or the +team specified by @var{LEVEL}, where @var{LEVEL} is one of the constants +@code{INITIAL_TEAM}, @code{PARENT_TEAM} or @code{CURRENT_TEAM} from the +intrinsic module @code{ISO_FORTRAN_ENV}. Calling the function with +@code{PARENT_TEAM} while being on the initial team, returns a handle to the +initial team. This ensures that always a valid team is returned, given that +team handles can neither be checked for validity nor compared with each other +or null. + +@item @emph{Class}: +Transformational function + +@item @emph{Return value}: +An opaque handle of @code{TEAM_TYPE} from the intrinsic module +@code{ISO_FORTRAN_ENV}. + +@item @emph{Example}: +@smallexample +program info + use, intrinsic :: iso_fortran_env + type(team_type) :: init, curr, par, nt + + init = get_team() + curr = get_team(current_team) ! init equals curr here + form team(1, nt) + change team(nt) + curr = get_team() ! or get_team(current_team) + par = get_team(parent_team) ! par equals init here + end team +end program info +@end smallexample + +@item @emph{Standard}: +Fortran 2018 or later + +@item @emph{See also}: +@ref{THIS_IMAGE}, @* +@ref{ISO_FORTRAN_ENV} +@end table + + + @node GETUID @section @code{GETUID} --- User ID function @fnindex GETUID @@ -11372,47 +11427,48 @@ Fortran 95 and later @table @asis @item @emph{Synopsis}: -@code{RESULT = NUM_IMAGES(DISTANCE, FAILED)} +@multitable @columnfractions .80 +@item @code{RESULT = NUM_IMAGES([TEAM])} +@item @code{RESULT = NUM_IMAGES(TEAM_NUMBER)} +@end multitable @item @emph{Description}: -Returns the number of images. +Returns the number of images in the current team or the given team. @item @emph{Class}: Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer -@item @var{FAILED} @tab (optional, intent(in)) Scalar logical expression +@item @var{TEAM} @tab (optional, intent(in)) If present, return the number of +images in the given team; if absent, return the number of images in the +current team. +@item @var{TEAM_NUMBER} @tab (intent(in)) The number as given in the +@code{FORM TEAM} statement. @end multitable @item @emph{Return value}: -Scalar default-kind integer. If @var{DISTANCE} is not present or has value 0, -the number of images in the current team is returned. For values smaller or -equal distance to the initial team, it returns the number of images index -on the ancestor team that has a distance of @var{DISTANCE} from the invoking -team. If @var{DISTANCE} is larger than the distance to the initial team, the -number of images of the initial team is returned. If @var{FAILED} is not present -the total number of images is returned; if it has the value @code{.TRUE.}, -the number of failed images is returned, otherwise, the number of images that -do have not the failed status. +Scalar default-kind integer. Can be called without any arguments or a team +type argument or a team_number argument. @item @emph{Example}: @smallexample +use, intrinsic :: iso_fortran_env INTEGER :: value[*] INTEGER :: i -value = THIS_IMAGE() -SYNC ALL -IF (THIS_IMAGE() == 1) THEN - DO i = 1, NUM_IMAGES() - WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i] - END DO -END IF +type(team_type) :: t + +! When running with 4 images +print *, num_images() ! 4 + +form team (mod(this_image(), 2), t) +print *, num_images(t) ! 2 +print *, num_images(-1) ! 4 @end smallexample @item @emph{Standard}: -Fortran 2008 and later. With @var{DISTANCE} or @var{FAILED} argument, -Technical Specification (TS) 18508 or later +Fortran 2008 and later. With @var{TEAM} or @var{TEAM_NUMBER} argument, +Fortran 2018 and later. @item @emph{See also}: @ref{THIS_IMAGE}, @* @@ -14467,6 +14523,54 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later +@node TEAM_NUMBER +@section @code{TEAM_NUMBER} --- Retrieve team id of given team +@fnindex TEAM_NUMBER +@cindex coarray, @code{TEAM_NUMBER} +@cindex teams, index of given team + +@table @asis +@item @emph{Synopsis}: +@item @code{RESULT = TEAM_NUMBER([TEAM])} + +@item @emph{Description}: +Returns the team id for the given @var{TEAM} as assigned by @code{FORM TEAM}. +If @var{TEAM} is absent, returns the team number of the current team. + +@item @emph{Class}: +Transformational function + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{TEAM} @tab (optional, intent(in)) The handle of the team for which +the number, aka id, is desired. +@end multitable + +@item @emph{Return value}: +Default integer. The id as given in a call @code{FORM TEAM}. Applying +@code{TEAM_NUMBER} to the initial team will result in @code{-1} to be returned. +Returns the id of the current team, if @var{TEAM} is null. + +@item @emph{Example}: +@smallexample +use, intrinsic :: iso_fortran_env +type(team_type) :: t + +print *, team_number() ! -1 +form team (99, t) +print *, team_number(t) ! 99 +@end smallexample + +@item @emph{Standard}: +Fortran 2018 and later. + +@item @emph{See also}: +@ref{GET_TEAM}, @* +@ref{TEAM_NUMBER} +@end table + + + @node THIS_IMAGE @section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image @fnindex THIS_IMAGE @@ -14476,9 +14580,8 @@ Fortran 77 and later, for a complex argument Fortran 2008 or later @table @asis @item @emph{Synopsis}: @multitable @columnfractions .80 -@item @code{RESULT = THIS_IMAGE()} -@item @code{RESULT = THIS_IMAGE(DISTANCE)} -@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])} +@item @code{RESULT = THIS_IMAGE([TEAM])} +@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM][, TEAM])} @end multitable @item @emph{Description}: @@ -14489,8 +14592,8 @@ Transformational function @item @emph{Arguments}: @multitable @columnfractions .15 .70 -@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer -(not permitted together with @var{COARRAY}). +@item @var{TEAM} @tab (optional, intent(in)) The team for which the index of +this image is desired. The current team is used, when no team is given. @item @var{COARRAY} @tab Coarray of any type (optional; if @var{DIM} present, required). @item @var{DIM} @tab default integer scalar (optional). If present, @@ -14499,16 +14602,16 @@ present, required). @item @emph{Return value}: Default integer. If @var{COARRAY} is not present, it is scalar; if -@var{DISTANCE} is not present or has value 0, its value is the image index on -the invoking image for the current team, for values smaller or equal -distance to the initial team, it returns the image index on the ancestor team -that has a distance of @var{DISTANCE} from the invoking team. If -@var{DISTANCE} is larger than the distance to the initial team, the image -index of the initial team is returned. Otherwise when the @var{COARRAY} is +@var{TEAM} is not present, its value is the image index on the invoking image +for the current team; if @var{TEAM} is present, returns the image index of +the invoking image as given to the @code{FORM TEAM (..., NEW_INDEX=..)} call, +or a implementation specific unique number, when @code{NEW_INDEX=} was absent +from @code{FORM TEAM}. Otherwise when the @var{COARRAY} is present, if @var{DIM} is not present, a rank-1 array with corank elements is returned, containing the cosubscripts for @var{COARRAY} specifying the invoking -image. If @var{DIM} is present, a scalar is returned, with the value of -the @var{DIM} element of @code{THIS_IMAGE(COARRAY)}. +image (in the team when @var{TEAM} is present). If @var{DIM} is present, a +scalar is returned, with the value of the @var{DIM} element of +@code{THIS_IMAGE(COARRAY)}. @item @emph{Example}: @smallexample @@ -14523,13 +14626,12 @@ IF (THIS_IMAGE() == 1) THEN END IF ! Check whether the current image is the initial image -IF (THIS_IMAGE(HUGE(1)) /= THIS_IMAGE()) +IF (THIS_IMAGE(GET_TEAM(INITIAL_TEAM)) /= THIS_IMAGE()) error stop "something is rotten here" @end smallexample @item @emph{Standard}: -Fortran 2008 and later. With @var{DISTANCE} argument, -Technical Specification (TS) 18508 or later +Fortran 2008 and later. With @var{TEAM} argument, Fortran 2018 or later @item @emph{See also}: @ref{NUM_IMAGES}, @* @@ -15354,12 +15456,18 @@ parameters of the @code{CHARACTER} type. (Fortran 2008 or later.) @item @code{CHARACTER_STORAGE_SIZE}: Size in bits of the character storage unit. +@item @code{CURRENT_TEAM}: +The argument to @ref{GET_TEAM} to retrieve a handle of the current team. + @item @code{ERROR_UNIT}: Identifies the preconnected unit used for error reporting. @item @code{FILE_STORAGE_SIZE}: Size in bits of the file-storage unit. +@item @code{INTIAL_TEAM}: +Argument to @ref{GET_TEAM} to retrieve a handle of the initial team. + @item @code{INPUT_UNIT}: Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{READ} statement. @@ -15397,6 +15505,9 @@ parameters of the @code{LOGICAL} type. (Fortran 2008 or later.) Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{WRITE} statement. +@item @code{PARENT_TEAM}: +Argument to @ref{GET_TEAM} to retrieve a handle to the parent team. + @item @code{REAL32}, @code{REAL64}, @code{REAL128}: Kind type parameters to specify a REAL type with a storage size of 32, 64, and 128 bits. It is negative if a target platform @@ -15445,6 +15556,10 @@ Derived type with private components to be use with the @code{LOCK} and @code{UNLOCK} statement. A variable of its type has to be always declared as coarray and may not appear in a variable-definition context. (Fortran 2008 or later.) +@item @code{TEAM_TYPE}: +An opaque type for handling teams. Note that a variable of type +@code{TEAM_TYPE} is not comparable with other variables of the same or other +types nor with null. @end table The module also provides the following intrinsic procedures: diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 858ffb1..6930e2c 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3209,17 +3209,28 @@ gfc_resolve_get_team (gfc_expr *f, gfc_expr *level ATTRIBUTE_UNUSED) { static char get_team[] = "_gfortran_caf_get_team"; f->rank = 0; - f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + f->ts.type = BT_DERIVED; + gfc_find_symbol ("team_type", gfc_current_ns, 1, &f->ts.u.derived); + if (!f->ts.u.derived + || f->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV) + { + gfc_error ( + "GET_TEAM at %L needs USE of the intrinsic module ISO_FORTRAN_ENV " + "to define its result type TEAM_TYPE", + &f->where); + f->ts.type = BT_UNKNOWN; + } f->value.function.name = get_team; -} + /* No requirements to resolve for level argument now. */ +} /* Resolve image_index (...). */ void gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, - gfc_expr *sub ATTRIBUTE_UNUSED) + gfc_expr *sub ATTRIBUTE_UNUSED, + gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { static char image_index[] = "__image_index"; f->ts.type = BT_INTEGER; @@ -3248,31 +3259,46 @@ gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED, /* Resolve team_number (team). */ void -gfc_resolve_team_number (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED) +gfc_resolve_team_number (gfc_expr *f, gfc_expr *team) { static char team_number[] = "_gfortran_caf_team_number"; f->rank = 0; f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; f->value.function.name = team_number; -} + if (team) + gfc_resolve_expr (team); +} void -gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) +gfc_resolve_this_image (gfc_expr *f, gfc_expr *coarray, gfc_expr *dim, + gfc_expr *team) { static char this_image[] = "__this_image"; - if (array && gfc_is_coarray (array)) - resolve_bound (f, array, dim, NULL, "__this_image", true); + if (coarray && dim) + resolve_bound (f, coarray, dim, NULL, this_image, true); + else if (coarray) + { + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; + if (f->shape && f->rank != 1) + gfc_free_shape (&f->shape, f->rank); + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray->corank); + } else { f->ts.type = BT_INTEGER; f->ts.kind = gfc_default_integer_kind; f->value.function.name = this_image; } -} + if (team) + gfc_resolve_expr (team); +} void gfc_resolve_time (gfc_expr *f) diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index b8926f4..250a730 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -83,17 +83,23 @@ NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \ gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \ gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \ +NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED, "stat_locked", \ GFC_STAT_LOCKED, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \ +NAMED_INTCST (ISOFORTRANENV_STAT_LOCKED_OTHER_IMAGE, \ "stat_locked_other_image", \ GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \ - GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \ - GFC_STAT_FAILED_IMAGE, GFC_STD_F2018) -NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \ - GFC_STAT_UNLOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_STAT_STOPPED_IMAGE, "stat_stopped_image", \ + GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_STAT_FAILED_IMAGE, "stat_failed_image", \ + GFC_STAT_FAILED_IMAGE, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_STAT_UNLOCKED, "stat_unlocked", \ + GFC_STAT_UNLOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_INITIAL_TEAM, "initial_team", \ + GFC_CAF_INITIAL_TEAM, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_PARENT_TEAM, "parent_team", \ + GFC_CAF_PARENT_TEAM, GFC_STD_F2018) +NAMED_INTCST (ISOFORTRANENV_CURRENT_TEAM, "current_team", \ + GFC_CAF_CURRENT_TEAM, GFC_STD_F2018) /* The arguments to NAMED_KINDARRAY are: @@ -134,9 +140,7 @@ NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \ : gfc_default_integer_kind, GFC_STD_F2018) NAMED_DERIVED_TYPE (ISOFORTRAN_TEAM_TYPE, "team_type", \ - flag_coarray == GFC_FCOARRAY_LIB - ? get_int_kind_from_node (ptr_type_node) - : gfc_default_integer_kind, GFC_STD_F2018) + get_int_kind_from_node (ptr_type_node), GFC_STD_F2018) NAMED_INTCST (ISOFORTRANENV_LOGICAL8, "logical8", \ gfc_get_int_kind_from_width_isofortranenv (8), GFC_STD_F2023) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 9565365..9de5afb 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -154,12 +154,20 @@ typedef enum GFC_STAT_LOCKED, GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */ - GFC_STAT_FAILED_IMAGE = 6001 + GFC_STAT_FAILED_IMAGE = 6001, + GFC_STAT_UNLOCKED_FAILED_IMAGE = 6002 } libgfortran_stat_codes; typedef enum { + GFC_CAF_INITIAL_TEAM = 0, + GFC_CAF_PARENT_TEAM, + GFC_CAF_CURRENT_TEAM +} libgfortran_team_levels; + +typedef enum +{ GFC_CAF_ATOMIC_ADD = 1, GFC_CAF_ATOMIC_AND, GFC_CAF_ATOMIC_OR, diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index ec9e587..474ba81 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -1814,12 +1814,53 @@ gfc_free_iterator (gfc_iterator *iter, int flag) free (iter); } +static match +match_named_arg (const char *pat, const char *name, gfc_expr **e, + gfc_statement st_code) +{ + match m; + gfc_expr *tmp; + + m = gfc_match (pat, &tmp); + if (m == MATCH_ERROR) + { + gfc_syntax_error (st_code); + return m; + } + if (m == MATCH_YES) + { + if (*e) + { + gfc_error ("Duplicate %s attribute in %C", name); + gfc_free_expr (tmp); + return MATCH_ERROR; + } + *e = tmp; + + return MATCH_YES; + } + return MATCH_NO; +} + +static match +match_stat_errmsg (struct sync_stat *sync_stat, gfc_statement st_code) +{ + match m; + + m = match_named_arg (" stat = %v", "STAT", &sync_stat->stat, st_code); + if (m != MATCH_NO) + return m; + + m = match_named_arg (" errmsg = %v", "ERRMSG", &sync_stat->errmsg, st_code); + return m; +} /* Match a CRITICAL statement. */ match gfc_match_critical (void) { gfc_st_label *label = NULL; + match m; if (gfc_match_label () == MATCH_ERROR) return MATCH_ERROR; @@ -1830,12 +1871,29 @@ gfc_match_critical (void) if (gfc_match_st_label (&label) == MATCH_ERROR) return MATCH_ERROR; - if (gfc_match_eos () != MATCH_YES) + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) { - gfc_syntax_error (ST_CRITICAL); - return MATCH_ERROR; + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_CRITICAL); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; } + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + if (gfc_pure (NULL)) { gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); @@ -1856,9 +1914,9 @@ gfc_match_critical (void) if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " - "enable"); - return MATCH_ERROR; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " + "enable"); + return MATCH_ERROR; } if (gfc_find_state (COMP_CRITICAL)) @@ -1869,13 +1927,21 @@ gfc_match_critical (void) new_st.op = EXEC_CRITICAL; - if (label != NULL - && !gfc_reference_st_label (label, ST_LABEL_TARGET)) - return MATCH_ERROR; + if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_TARGET)) + goto cleanup; return MATCH_YES; -} +syntax: + gfc_syntax_error (ST_CRITICAL); + +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + return MATCH_ERROR; +} /* Match a BLOCK statement. */ @@ -1900,29 +1966,29 @@ gfc_match_block (void) return MATCH_YES; } - -/* Match an ASSOCIATE statement. */ - -match -gfc_match_associate (void) +bool +check_coarray_assoc (const char *name, gfc_association_list *assoc) { - if (gfc_match_label () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" associate") != MATCH_YES) - return MATCH_NO; - - /* Match the association list. */ - if (gfc_match_char ('(') != MATCH_YES) + if (assoc->target->expr_type == EXPR_VARIABLE + && !strcmp (assoc->target->symtree->name, name)) { - gfc_error ("Expected association list at %C"); - return MATCH_ERROR; + gfc_error ("Codimension decl name %qs in association at %L " + "must not be the same as a selector", + name, &assoc->where); + return false; } + return true; +} + +match +match_association_list (bool for_change_team = false) +{ new_st.ext.block.assoc = NULL; while (true) { - gfc_association_list* newAssoc = gfc_get_association_list (); - gfc_association_list* a; + gfc_association_list *newAssoc = gfc_get_association_list (); + gfc_association_list *a; + locus pre_name = gfc_current_locus; /* Match the next association. */ if (gfc_match (" %n ", newAssoc->name) != MATCH_YES) @@ -1932,7 +1998,7 @@ gfc_match_associate (void) } /* Required for an assumed rank target. */ - if (gfc_peek_char () == '(') + if (!for_change_team && gfc_peek_char () == '(') { newAssoc->ar = gfc_get_array_ref (); if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES) @@ -1946,26 +2012,53 @@ gfc_match_associate (void) gfc_error_now ("The bounds remapping list at %C is an experimental " "F202y feature. Use std=f202y to enable"); + if (for_change_team && gfc_peek_char () == '[') + { + if (!newAssoc->ar) + newAssoc->ar = gfc_get_array_ref (); + if (gfc_match_array_spec (&newAssoc->ar->as, false, true) + == MATCH_ERROR) + goto assocListError; + } + /* Match the next association. */ if (gfc_match (" =>", newAssoc->name) != MATCH_YES) { - gfc_error ("Expected association at %C"); - goto assocListError; + if (for_change_team) + gfc_current_locus = pre_name; + + free (newAssoc); + return MATCH_NO; } - if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + if (!for_change_team) { - /* Have another go, allowing for procedure pointer selectors. */ - gfc_matching_procptr_assignment = 1; if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) { + /* Have another go, allowing for procedure pointer selectors. */ + gfc_matching_procptr_assignment = 1; + if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + { + gfc_matching_procptr_assignment = 0; + gfc_error ("Invalid association target at %C"); + goto assocListError; + } gfc_matching_procptr_assignment = 0; - gfc_error ("Invalid association target at %C"); + } + newAssoc->where = gfc_current_locus; + } + else + { + newAssoc->where = gfc_current_locus; + /* F2018, C1116: A selector in a coarray-association shall be a named + coarray. */ + if (gfc_match (" %v", &newAssoc->target) != MATCH_YES) + { + gfc_error ("Selector in coarray association as %C shall be a " + "named coarray"); goto assocListError; } - gfc_matching_procptr_assignment = 0; } - newAssoc->where = gfc_current_locus; /* Check that the current name is not yet in the list. */ for (a = new_st.ext.block.assoc; a; a = a->next) @@ -1976,6 +2069,35 @@ gfc_match_associate (void) goto assocListError; } + if (for_change_team) + { + /* F2018, C1113: In a change-team-stmt, a coarray-name in a + codimension-decl shall not be the same as a selector, or another + coarray-name, in that statement. + The latter is already checked for above. So check only the + former. + */ + if (!check_coarray_assoc (newAssoc->name, newAssoc)) + goto assocListError; + + for (a = new_st.ext.block.assoc; a; a = a->next) + { + if (!check_coarray_assoc (newAssoc->name, a) + || !check_coarray_assoc (a->name, newAssoc)) + goto assocListError; + + /* F2018, C1115: No selector shall appear more than once in a + * given change-team-stmt. */ + if (!strcmp (newAssoc->target->symtree->name, + a->target->symtree->name)) + { + gfc_error ("Selector at %L duplicates selector at %L", + &newAssoc->target->where, &a->target->where); + goto assocListError; + } + } + } + /* The target expression must not be coindexed. */ if (gfc_is_coindexed (newAssoc->target)) { @@ -2042,8 +2164,40 @@ gfc_match_associate (void) assocListError: free (newAssoc); + return MATCH_ERROR; + } + + return MATCH_YES; +} + +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + match m; + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + + m = match_association_list (); + if (m == MATCH_ERROR) + goto error; + else if (m == MATCH_NO) + { + gfc_error ("Expected association at %C"); goto error; } + if (gfc_match_char (')') != MATCH_YES) { /* This should never happen as we peek above. */ @@ -3171,6 +3325,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) case COMP_ASSOCIATE: case COMP_BLOCK: + case COMP_CHANGE_TEAM: case COMP_IF: case COMP_SELECT: case COMP_SELECT_TYPE: @@ -3848,7 +4003,9 @@ match gfc_match_form_team (void) { match m; - gfc_expr *teamid,*team; + gfc_expr *teamid, *team, *new_index; + + teamid = team = new_index = NULL; if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C")) return MATCH_ERROR; @@ -3866,18 +4023,61 @@ gfc_match_form_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = match_named_arg (" new_index = %e", "NEW_INDEX", &new_index, + ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = teamid; new_st.expr2 = team; + new_st.expr3 = new_index; return MATCH_YES; syntax: gfc_syntax_error (ST_FORM_TEAM); +cleanup: + gfc_free_expr (new_index); + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + gfc_free_expr (teamid); + return MATCH_ERROR; } @@ -3887,7 +4087,13 @@ match gfc_match_change_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" change% team") != MATCH_YES) + return MATCH_NO; if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C")) return MATCH_ERROR; @@ -3895,15 +4101,41 @@ gfc_match_change_team (void) if (gfc_match_char ('(') == MATCH_NO) goto syntax; - new_st.op = EXEC_CHANGE_TEAM; - if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + m = match_association_list (true); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + for (;;) + { + m = match_stat_errmsg (&new_st.ext.block.sync_stat, ST_CHANGE_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3911,20 +4143,49 @@ gfc_match_change_team (void) syntax: gfc_syntax_error (ST_CHANGE_TEAM); +cleanup: + gfc_free_expr (new_st.ext.block.sync_stat.stat); + gfc_free_expr (new_st.ext.block.sync_stat.errmsg); + new_st.ext.block.sync_stat = {NULL, NULL}; + gfc_free_association_list (new_st.ext.block.assoc); + new_st.ext.block.assoc = NULL; + gfc_free_expr (team); + return MATCH_ERROR; } -/* Match a END TEAM statement. */ +/* Match an END TEAM statement. */ match gfc_match_end_team (void) { - if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C")) - return MATCH_ERROR; + if (gfc_match_eos () == MATCH_YES) + goto done; - if (gfc_match_char ('(') == MATCH_YES) + if (gfc_match_char ('(') != MATCH_YES) + { + /* There could be a team-construct-name following. Let caller decide + about error. */ + new_st.op = EXEC_END_TEAM; + return MATCH_NO; + } + + for (;;) + { + if (match_stat_errmsg (&new_st.ext.sync_stat, ST_END_TEAM) == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match_char (')') != MATCH_YES) goto syntax; +done: + new_st.op = EXEC_END_TEAM; return MATCH_YES; @@ -3932,6 +4193,14 @@ gfc_match_end_team (void) syntax: gfc_syntax_error (ST_END_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + /* Try to match the closing bracket to allow error recovery. */ + gfc_match_char (')'); + return MATCH_ERROR; } @@ -3941,7 +4210,7 @@ match gfc_match_sync_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C")) return MATCH_ERROR; @@ -3954,10 +4223,34 @@ gfc_match_sync_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_SYNC_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3965,6 +4258,13 @@ gfc_match_sync_team (void) syntax: gfc_syntax_error (ST_SYNC_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + return MATCH_ERROR; } @@ -5261,6 +5561,15 @@ gfc_match_return (void) return MATCH_ERROR; } + if (gfc_find_state (COMP_CHANGE_TEAM)) + { + /* F2018, C1111: A RETURN statement shall not appear within a CHANGE TEAM + construct. */ + gfc_error ( + "Image control statement RETURN at %C in CHANGE TEAM-END TEAM block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) goto done; diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index a95bb62..538eb65 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -488,6 +488,7 @@ decode_statement (void) match (NULL, gfc_match_do, ST_DO); match (NULL, gfc_match_block, ST_BLOCK); match (NULL, gfc_match_associate, ST_ASSOCIATE); + match (NULL, gfc_match_change_team, ST_CHANGE_TEAM); match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); @@ -517,7 +518,6 @@ decode_statement (void) case 'c': match ("call", gfc_match_call, ST_CALL); - match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); @@ -537,7 +537,6 @@ decode_statement (void) case 'e': match ("end file", gfc_match_endfile, ST_END_FILE); - match ("end team", gfc_match_end_team, ST_END_TEAM); match ("exit", gfc_match_exit, ST_EXIT); match ("else", gfc_match_else, ST_ELSE); match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); @@ -1927,8 +1926,7 @@ next_statement (void) case ST_OMP_INTEROP: \ case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \ - case ST_FORM_TEAM: case ST_CHANGE_TEAM: \ - case ST_END_TEAM: case ST_SYNC_TEAM: \ + case ST_FORM_TEAM: case ST_SYNC_TEAM: \ case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \ case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \ case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA @@ -2032,7 +2030,8 @@ next_statement (void) #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \ - case ST_END_BLOCK: case ST_END_ASSOCIATE + case ST_END_BLOCK: case ST_END_ASSOCIATE: \ + case ST_END_TEAM /* Push a new state onto the stack. */ @@ -2164,6 +2163,7 @@ check_statement_label (gfc_statement st) case ST_END_CRITICAL: case ST_END_BLOCK: case ST_END_ASSOCIATE: + case ST_END_TEAM: case_executable: case_exec_markers: if (st == ST_ENDDO || st == ST_CONTINUE) @@ -3199,6 +3199,8 @@ accept_statement (gfc_statement st) case ST_ENTRY: case ST_OMP_METADIRECTIVE: case ST_OMP_BEGIN_METADIRECTIVE: + case ST_CHANGE_TEAM: + case ST_END_TEAM: case_executable: case_exec_markers: add_statement (); @@ -3383,6 +3385,8 @@ verify_st_order (st_state *p, gfc_statement st, bool silent) goto order; break; + case ST_CHANGE_TEAM: + case ST_END_TEAM: case_executable: case_exec_markers: if (p->state < ORDER_EXEC) @@ -5238,30 +5242,12 @@ parse_block_construct (void) pop_state (); } - -/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct - behind the scenes with compiler-generated variables. */ - static void -parse_associate (void) +move_associates_to_block () { - gfc_namespace* my_ns; - gfc_state_data s; - gfc_statement st; - gfc_association_list* a; + gfc_association_list *a; gfc_array_spec *as; - gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); - - my_ns = gfc_build_block_ns (gfc_current_ns); - - new_st.op = EXEC_BLOCK; - new_st.ext.block.ns = my_ns; - gcc_assert (new_st.ext.block.assoc); - - /* Add all associate-names as BLOCK variables. Creating them is enough - for now, they'll get their values during trans-* phase. */ - gfc_current_ns = my_ns; for (a = new_st.ext.block.assoc; a; a = a->next) { gfc_symbol *sym, *tsym; @@ -5298,26 +5284,23 @@ parse_associate (void) /* Don’t share the character length information between associate variable and target if the length is not a compile-time constant, - as we don’t want to touch some other character length variable when - we try to initialize the associate variable’s character length - variable. - We do it here rather than later so that expressions referencing the - associate variable will automatically have the correctly setup length - information. If we did it at resolution stage the expressions would - use the original length information, and the variable a new different - one, but only the latter one would be correctly initialized at - translation stage, and the former one would need some additional setup - there. */ - if (sym->ts.type == BT_CHARACTER - && sym->ts.u.cl + as we don’t want to touch some other character length variable + when we try to initialize the associate variable’s character + length variable. We do it here rather than later so that expressions + referencing the associate variable will automatically have the + correctly setup length information. If we did it at resolution stage + the expressions would use the original length information, and the + variable a new different one, but only the latter one would be + correctly initialized at translation stage, and the former one would + need some additional setup there. */ + if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl && !(sym->ts.u.cl->length && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); /* If the function has been parsed, go straight to the result to obtain the expression rank. */ - if (target->expr_type == EXPR_FUNCTION - && target->symtree + if (target->expr_type == EXPR_FUNCTION && target->symtree && target->symtree->n.sym) { tsym = target->symtree->n.sym; @@ -5344,8 +5327,7 @@ parse_associate (void) by calling gfc_resolve_expr because the context is unavailable. However, the references can be resolved and the rank of the target expression set. */ - if (!sym->assoc->inferred_type - && target->ref && gfc_resolve_ref (target) + if (!sym->assoc->inferred_type && target->ref && gfc_resolve_ref (target) && target->expr_type != EXPR_ARRAY && target->expr_type != EXPR_COMPCALL) gfc_expression_rank (target); @@ -5353,13 +5335,12 @@ parse_associate (void) /* Determine whether or not function expressions with unknown type are structure constructors. If so, the function result can be converted to be a derived type. */ - if (target->expr_type == EXPR_FUNCTION - && target->ts.type == BT_UNKNOWN) + if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN) { gfc_symbol *derived; /* The derived type has a leading uppercase character. */ gfc_find_symbol (gfc_dt_upper_string (target->symtree->name), - my_ns->parent, 1, &derived); + gfc_current_ns->parent, 1, &derived); if (derived && derived->attr.flavor == FL_DERIVED) { sym->ts.type = BT_DERIVED; @@ -5394,7 +5375,7 @@ parse_associate (void) attr.codimension = as->corank ? 1 : 0; sym->assoc->variable = true; } - else if (rank || corank) + else if (rank || corank) { as = gfc_get_array_spec (); as->type = AS_DEFERRED; @@ -5449,6 +5430,30 @@ parse_associate (void) } gfc_commit_symbols (); } +} + +/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct + behind the scenes with compiler-generated variables. */ + +static void +parse_associate (void) +{ + gfc_namespace* my_ns; + gfc_state_data s; + gfc_statement st; + + gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_BLOCK; + new_st.ext.block.ns = my_ns; + gcc_assert (new_st.ext.block.assoc); + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + move_associates_to_block (); accept_statement (ST_ASSOCIATE); push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); @@ -5474,6 +5479,49 @@ loop: pop_state (); } +static void +parse_change_team (void) +{ + gfc_namespace *my_ns; + gfc_state_data s; + gfc_statement st; + + gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C"); + + my_ns = gfc_build_block_ns (gfc_current_ns); + + new_st.op = EXEC_CHANGE_TEAM; + new_st.ext.block.ns = my_ns; + + /* Add all associate-names as BLOCK variables. Creating them is enough + for now, they'll get their values during trans-* phase. */ + gfc_current_ns = my_ns; + if (new_st.ext.block.assoc) + move_associates_to_block (); + + accept_statement (ST_CHANGE_TEAM); + push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name); + +loop: + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case_end: + accept_statement (st); + my_ns->code = gfc_state_stack->head; + break; + + default: + unexpected_statement (st); + goto loop; + } + + gfc_current_ns = gfc_current_ns->parent; + pop_state (); +} /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are handled inside of parse_executable(), because they aren't really @@ -6576,6 +6624,7 @@ parse_executable (gfc_statement st) case ST_STOP: case ST_ERROR_STOP: case ST_END_SUBROUTINE: + case ST_END_TEAM: case ST_DO: case ST_FORALL: @@ -6615,6 +6664,10 @@ parse_executable (gfc_statement st) parse_associate (); break; + case ST_CHANGE_TEAM: + parse_change_team (); + break; + case ST_IF_BLOCK: parse_if_block (); break; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 722e94c..7bf0fa4 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -32,7 +32,7 @@ enum gfc_compile_state COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT, COMP_OMP_STRICTLY_STRUCTURED_BLOCK, - COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE + COMP_OMP_METADIRECTIVE, COMP_OMP_BEGIN_METADIRECTIVE, COMP_CHANGE_TEAM }; /* Stack element for the current compilation state. These structures diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 2ecbd50..e51f83b 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -3260,14 +3260,30 @@ static bool check_pure_function (gfc_expr *e) gfc_do_concurrent_flag = 0 when the check for an impure function occurs. Check the stack to see if the source code has a nested BLOCK construct. */ + for (stack = cs_base; stack; stack = stack->prev) { - if (stack->current->op == EXEC_BLOCK) saw_block = true; + if (!saw_block && stack->current->op == EXEC_BLOCK) + { + saw_block = true; + continue; + } + if (saw_block && stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("Reference to impure function at %L inside a " - "DO CONCURRENT", &e->where); - return false; + bool is_pure; + is_pure = (e->value.function.isym + && (e->value.function.isym->pure + || e->value.function.isym->elemental)) + || (e->value.function.esym + && (e->value.function.esym->attr.pure + || e->value.function.esym->attr.elemental)); + if (!is_pure) + { + gfc_error ("Reference to impure function at %L inside a " + "DO CONCURRENT", &e->where); + return false; + } } } @@ -3663,16 +3679,29 @@ pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) /* A BLOCK construct within a DO CONCURRENT construct leads to gfc_do_concurrent_flag = 0 when the check for an impure subroutine - occurs. Check the stack to see if the source code has a nested - BLOCK construct. */ + occurs. Walk up the stack to see if the source code has a nested + construct. */ + for (stack = cs_base; stack; stack = stack->prev) { - if (stack->current->op == EXEC_BLOCK) saw_block = true; + if (stack->current->op == EXEC_BLOCK) + { + saw_block = true; + continue; + } + if (saw_block && stack->current->op == EXEC_DO_CONCURRENT) { - gfc_error ("Subroutine call at %L in a DO CONCURRENT block " - "is not PURE", loc); - return false; + + bool is_pure = true; + is_pure = sym->attr.pure || sym->attr.elemental; + + if (!is_pure) + { + gfc_error ("Subroutine call at %L in a DO CONCURRENT block " + "is not PURE", loc); + return false; + } } } @@ -11455,6 +11484,109 @@ resolve_lock_unlock_event (gfc_code *code) } } +static void +resolve_team_argument (gfc_expr *team) +{ + gfc_resolve_expr (team); + if (team->rank != 0 || team->ts.type != BT_DERIVED + || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) + { + gfc_error ("TEAM argument at %L must be a scalar expression " + "of type TEAM_TYPE from the intrinsic module ISO_FORTRAN_ENV", + &team->where); + } +} + +static void +resolve_scalar_variable_as_arg (const char *name, bt exp_type, int exp_kind, + gfc_expr *e) +{ + gfc_resolve_expr (e); + if (e + && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0 + || e->expr_type != EXPR_VARIABLE)) + gfc_error ("%s argument at %L must be a scalar %s variable of at least " + "kind %d", name, &e->where, gfc_basic_typename (exp_type), + exp_kind); +} + +void +gfc_resolve_sync_stat (struct sync_stat *sync_stat) +{ + resolve_scalar_variable_as_arg ("STAT=", BT_INTEGER, 2, sync_stat->stat); + resolve_scalar_variable_as_arg ("ERRMSG=", BT_CHARACTER, + gfc_default_character_kind, + sync_stat->errmsg); +} + +static void +resolve_scalar_argument (const char *name, bt exp_type, int exp_kind, + gfc_expr *e) +{ + gfc_resolve_expr (e); + if (e + && (e->ts.type != exp_type || e->ts.kind < exp_kind || e->rank != 0)) + gfc_error ("%s argument at %L must be a scalar %s of at least kind %d", + name, &e->where, gfc_basic_typename (exp_type), exp_kind); +} + +static void +resolve_form_team (gfc_code *code) +{ + resolve_scalar_argument ("TEAM NUMBER", BT_INTEGER, gfc_default_integer_kind, + code->expr1); + resolve_team_argument (code->expr2); + resolve_scalar_argument ("NEW_INDEX=", BT_INTEGER, gfc_default_integer_kind, + code->expr3); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void resolve_block_construct (gfc_code *); + +static void +resolve_change_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.block.sync_stat); + resolve_block_construct (code); + /* Map the coarray bounds as selected. */ + for (gfc_association_list *a = code->ext.block.assoc; a; a = a->next) + if (a->ar) + { + gfc_array_spec *src = a->ar->as, *dst; + if (a->st->n.sym->ts.type == BT_CLASS) + dst = CLASS_DATA (a->st->n.sym)->as; + else + dst = a->st->n.sym->as; + dst->corank = src->corank; + dst->cotype = src->cotype; + for (int i = 0; i < src->corank; ++i) + { + dst->lower[dst->rank + i] = src->lower[i]; + dst->upper[dst->rank + i] = src->upper[i]; + src->lower[i] = src->upper[i] = nullptr; + } + gfc_free_array_spec (src); + free (a->ar); + a->ar = nullptr; + dst->resolved = false; + gfc_resolve_array_spec (dst, 0); + } +} + +static void +resolve_sync_team (gfc_code *code) +{ + resolve_team_argument (code->expr1); + gfc_resolve_sync_stat (&code->ext.sync_stat); +} + +static void +resolve_end_team (gfc_code *code) +{ + gfc_resolve_sync_stat (&code->ext.sync_stat); +} static void resolve_critical (gfc_code *code) @@ -11464,6 +11596,8 @@ resolve_critical (gfc_code *code) char name[GFC_MAX_SYMBOL_LEN]; static int serial = 0; + gfc_resolve_sync_stat (&code->ext.sync_stat); + if (flag_coarray != GFC_FCOARRAY_LIB) return; @@ -11587,8 +11721,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code) if (code->here == label) { - gfc_warning (0, - "Branch at %L may result in an infinite loop", &code->loc); + gfc_warning (0, "Branch at %L may result in an infinite loop", + &code->loc); return; } @@ -11611,6 +11745,10 @@ resolve_branch (gfc_st_label *label, gfc_code *code) && bitmap_bit_p (stack->reachable_labels, label->value)) gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " "for label at %L", &code->loc, &label->where); + else if (stack->current->op == EXEC_CHANGE_TEAM + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CHANGE TEAM construct " + "for label at %L", &code->loc, &label->where); } return; @@ -13247,23 +13385,6 @@ deferred_op_assign (gfc_code **code, gfc_namespace *ns) } -static bool -check_team (gfc_expr *team, const char *intrinsic) -{ - if (team->rank != 0 - || team->ts.type != BT_DERIVED - || team->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV - || team->ts.u.derived->intmod_sym_id != ISOFORTRAN_TEAM_TYPE) - { - gfc_error ("TEAM argument to %qs at %L must be a scalar expression " - "of type TEAM_TYPE", intrinsic, &team->where); - return false; - } - - return true; -} - - /* Given a block of code, recursively resolve everything pointed to by this code block. */ @@ -13452,22 +13573,19 @@ start: break; case EXEC_FORM_TEAM: - if (code->expr1 != NULL - && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) - gfc_error ("TEAM NUMBER argument to FORM TEAM at %L must be " - "a scalar INTEGER", &code->expr1->where); - check_team (code->expr2, "FORM TEAM"); + resolve_form_team (code); break; case EXEC_CHANGE_TEAM: - check_team (code->expr1, "CHANGE TEAM"); + resolve_change_team (code); break; case EXEC_END_TEAM: + resolve_end_team (code); break; case EXEC_SYNC_TEAM: - check_team (code->expr1, "SYNC TEAM"); + resolve_sync_team (code); break; case EXEC_ENTRY: diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc index 92ab17b..208251b 100644 --- a/gcc/fortran/simplify.cc +++ b/gcc/fortran/simplify.cc @@ -3133,8 +3133,10 @@ gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED) if (flag_coarray == GFC_FCOARRAY_SINGLE) { gfc_expr *result; - result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - result->rank = 0; + result = gfc_get_null_expr (&gfc_current_locus); + result->ts.type = BT_DERIVED; + gfc_find_symbol ("team_type", gfc_current_ns, 1, &result->ts.u.derived); + return result; } @@ -6727,7 +6729,7 @@ gfc_simplify_null (gfc_expr *mold) gfc_expr * -gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) +gfc_simplify_num_images (gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { gfc_expr *result; @@ -6740,16 +6742,9 @@ gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed) if (flag_coarray != GFC_FCOARRAY_SINGLE) return NULL; - if (failed && failed->expr_type != EXPR_CONSTANT) - return NULL; - /* FIXME: gfc_current_locus is wrong. */ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); - - if (failed && failed->value.logical != 0) - mpz_set_si (result->value.integer, 0); - else mpz_set_si (result->value.integer, 1); return result; @@ -8925,7 +8920,8 @@ gfc_simplify_trim (gfc_expr *e) gfc_expr * -gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub) +gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub, + gfc_expr *team_or_team_number ATTRIBUTE_UNUSED) { gfc_expr *result; gfc_ref *ref; @@ -9067,14 +9063,13 @@ gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED) gfc_expr * gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim, - gfc_expr *distance ATTRIBUTE_UNUSED) + gfc_expr *team ATTRIBUTE_UNUSED) { if (flag_coarray != GFC_FCOARRAY_SINGLE) return NULL; - /* If no coarray argument has been passed or when the first argument - is actually a distance argument. */ - if (coarray == NULL || !gfc_is_coarray (coarray)) + /* If no coarray argument has been passed. */ + if (coarray == NULL) { gfc_expr *result; /* FIXME: gfc_current_locus is wrong. */ diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index ddc4960..ee48a82 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4043,9 +4043,9 @@ gfc_build_builtin_function_decls (void) gfor_fndecl_caf_finalize = gfc_build_library_function_decl ( get_identifier (PREFIX("caf_finalize")), void_type_node, 0); - gfor_fndecl_caf_this_image = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_this_image")), integer_type_node, - 1, integer_type_node); + gfor_fndecl_caf_this_image = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_this_image")), ". r ", integer_type_node, + 1, pvoid_type_node); gfor_fndecl_caf_num_images = gfc_build_library_function_decl ( get_identifier (PREFIX("caf_num_images")), integer_type_node, @@ -4201,42 +4201,36 @@ gfc_build_builtin_function_decls (void) void_type_node, 3, pvoid_type_node, ppvoid_type_node, integer_type_node); - gfor_fndecl_caf_form_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_form_team")), ". . W . ", - void_type_node, 3, integer_type_node, ppvoid_type_node, - integer_type_node); + gfor_fndecl_caf_form_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_form_team")), ". r w r w w w ", + void_type_node, 6, integer_type_node, ppvoid_type_node, pint_type, + pint_type, pchar_type_node, size_type_node); - gfor_fndecl_caf_change_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_change_team")), ". w . ", - void_type_node, 2, ppvoid_type_node, - integer_type_node); + gfor_fndecl_caf_change_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_change_team")), ". r w w w ", + void_type_node, 4, pvoid_type_node, pint_type, pchar_type_node, + size_type_node); - gfor_fndecl_caf_end_team - = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_end_team")), void_type_node, 0); + gfor_fndecl_caf_end_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_end_team")), ". w w w ", void_type_node, 3, + pint_type, pchar_type_node, size_type_node); - gfor_fndecl_caf_get_team - = gfc_build_library_function_decl ( - get_identifier (PREFIX("caf_get_team")), - void_type_node, 1, integer_type_node); + gfor_fndecl_caf_get_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_get_team")), ". r ", pvoid_type_node, 1, + pint_type); - gfor_fndecl_caf_sync_team - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sync_team")), ". r . ", - void_type_node, 2, ppvoid_type_node, - integer_type_node); + gfor_fndecl_caf_sync_team = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_sync_team")), ". r w w w ", void_type_node, + 4, pvoid_type_node, pint_type, pchar_type_node, size_type_node); gfor_fndecl_caf_team_number = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_team_number")), ". r ", integer_type_node, 1, integer_type_node); - gfor_fndecl_caf_image_status - = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_image_status")), ". . r ", - integer_type_node, 2, integer_type_node, ppvoid_type_node); + gfor_fndecl_caf_image_status = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("caf_image_status")), ". r r ", + integer_type_node, 2, integer_type_node, ppvoid_type_node); gfor_fndecl_caf_stopped_images = gfc_build_library_function_decl_with_spec ( diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 62dd38d..19e5669b 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2579,10 +2579,8 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc) gcc_assert (ref != NULL); if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE) - { - return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - integer_zero_node); - } + return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, + null_pointer_node); img_idx = build_zero_cst (gfc_array_index_type); extent = build_one_cst (gfc_array_index_type); @@ -9836,7 +9834,12 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, && !cm->attr.proc_pointer) { if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + { + gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); + if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB) + gfc_add_modify (&block, gfc_conv_descriptor_token (dest), + null_pointer_node); + } else if (cm->attr.allocatable || cm->attr.pdt_array) { tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 6ffc3e0..440cbdd 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -1183,8 +1183,10 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team, { gfc_se team_se; gfc_init_se (&team_se, NULL); - gfc_conv_expr_reference (&team_se, team_e); - *team = team_se.expr; + gfc_conv_expr (&team_se, team_e); + *team + = gfc_build_addr_expr (NULL_TREE, gfc_trans_force_lval (&team_se.pre, + team_se.expr)); gfc_add_block_to_block (block, &team_se.pre); gfc_add_block_to_block (block, &team_se.post); } @@ -1196,8 +1198,11 @@ conv_stat_and_team (stmtblock_t *block, gfc_expr *expr, tree *stat, tree *team, { gfc_se team_se; gfc_init_se (&team_se, NULL); - gfc_conv_expr_reference (&team_se, team_e); - *team_no = team_se.expr; + gfc_conv_expr (&team_se, team_e); + *team_no = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&team_se.pre, + fold_convert (integer_type_node, team_se.expr))); gfc_add_block_to_block (block, &team_se.pre); gfc_add_block_to_block (block, &team_se.post); } @@ -1379,9 +1384,9 @@ gfc_conv_intrinsic_caf_is_present_remote (gfc_se *se, gfc_expr *e) present_fn = e->value.function.actual->next->next->expr; add_data_sym = present_fn->symtree->n.sym->formal->sym; - fn_index = conv_caf_func_index (&se->pre, gfc_current_ns, + fn_index = conv_caf_func_index (&se->pre, e->symtree->n.sym->ns, "__caf_present_on_remote_fn_index_%d", hash); - add_data_tree = conv_caf_add_call_data (&se->pre, gfc_current_ns, + add_data_tree = conv_caf_add_call_data (&se->pre, e->symtree->n.sym->ns, "__caf_present_on_remote_add_data_%d", add_data_sym, &add_data_size); ++caf_call_cnt; @@ -1790,13 +1795,13 @@ conv_caf_sendget (gfc_code *code) ++caf_call_cnt; tmp = build_call_expr_loc ( - input_location, gfor_fndecl_caf_transfer_between_remotes, 20, lhs_token, + input_location, gfor_fndecl_caf_transfer_between_remotes, 22, lhs_token, opt_lhs_desc, opt_lhs_charlen, lhs_image_index, receiver_fn_index_tree, lhs_add_data_tree, lhs_add_data_size, rhs_token, opt_rhs_desc, opt_rhs_charlen, rhs_image_index, sender_fn_index_tree, rhs_add_data_tree, rhs_add_data_size, rhs_size, transfer_rank == 0 ? boolean_true_node : boolean_false_node, lhs_stat, - lhs_team, lhs_team_no, rhs_stat, rhs_team, rhs_team_no); + rhs_stat, lhs_team, lhs_team_no, rhs_team, rhs_team_no); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &lhs_se.post); @@ -1818,34 +1823,31 @@ static void trans_this_image (gfc_se * se, gfc_expr *expr) { stmtblock_t loop; - tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, - lbound, ubound, extent, ml; + tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var, lbound, + ubound, extent, ml, team; gfc_se argse; int rank, corank; - gfc_expr *distance = expr->value.function.actual->next->next->expr; - - if (expr->value.function.actual->expr - && !gfc_is_coarray (expr->value.function.actual->expr)) - distance = expr->value.function.actual->expr; /* The case -fcoarray=single is handled elsewhere. */ gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE); + /* Translate team, if present. */ + if (expr->value.function.actual->next->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, expr->value.function.actual->next->next->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + team = fold_convert (pvoid_type_node, argse.expr); + } + else + team = null_pointer_node; + /* Argument-free version: THIS_IMAGE(). */ - if (distance || expr->value.function.actual->expr == NULL) + if (expr->value.function.actual->expr == NULL) { - if (distance) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, distance); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - tmp = fold_convert (integer_type_node, argse.expr); - } - else - tmp = integer_zero_node; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - tmp); + team); se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); return; @@ -1940,8 +1942,8 @@ trans_this_image (gfc_se * se, gfc_expr *expr) */ /* this_image () - 1. */ - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, - integer_zero_node); + tmp + = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, team); tmp = fold_build2_loc (input_location, MINUS_EXPR, type, fold_convert (type, tmp), build_int_cst (type, 1)); if (corank == 1) @@ -2072,7 +2074,8 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) } else if (flag_coarray == GFC_FCOARRAY_LIB) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2, - args[0], build_int_cst (integer_type_node, -1)); + args[0], + num_args < 2 ? null_pointer_node : args[1]); else gcc_unreachable (); @@ -2092,18 +2095,7 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) if (flag_coarray == GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr) - { - tree arg; - - arg = gfc_evaluate_now (args[0], &se->pre); - tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - fold_convert (integer_type_node, arg), - integer_one_node); - tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, - tmp, integer_zero_node, - build_int_cst (integer_type_node, - GFC_STAT_STOPPED_IMAGE)); - } + tmp = gfc_evaluate_now (args[0], &se->pre); else if (flag_coarray == GFC_FCOARRAY_SINGLE) { // the value -1 represents that no team has been created yet @@ -2111,10 +2103,10 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) } else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - args[0], build_int_cst (integer_type_node, -1)); + args[0]); else if (flag_coarray == GFC_FCOARRAY_LIB) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1, - integer_zero_node, build_int_cst (integer_type_node, -1)); + null_pointer_node); else gcc_unreachable (); @@ -2125,8 +2117,8 @@ conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr) static void trans_image_index (gfc_se * se, gfc_expr *expr) { - tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, - tmp, invalid_bound; + tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc, tmp, + invalid_bound, team = null_pointer_node, team_number = null_pointer_node; gfc_se argse, subse; int rank, corank, codim; @@ -2150,6 +2142,22 @@ trans_image_index (gfc_se * se, gfc_expr *expr) subdesc = build_fold_indirect_ref_loc (input_location, gfc_conv_descriptor_data_get (subse.expr)); + if (expr->value.function.actual->next->next->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_descriptor (&argse, + expr->value.function.actual->next->next->expr); + if (expr->value.function.actual->next->next->expr->ts.type == BT_DERIVED) + team = argse.expr; + else + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&argse.pre, + fold_convert (integer_type_node, argse.expr))); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + /* Fortran 2008 does not require that the values remain in the cobounds, thus we need explicitly check this - and return 0 if they are exceeded. */ @@ -2225,8 +2233,7 @@ trans_image_index (gfc_se * se, gfc_expr *expr) else { tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - integer_zero_node, - build_int_cst (integer_type_node, -1)); + team, team_number); num_images = fold_convert (type, tmp); } @@ -2245,32 +2252,26 @@ trans_image_index (gfc_se * se, gfc_expr *expr) static void trans_num_images (gfc_se * se, gfc_expr *expr) { - tree tmp, distance, failed; + tree tmp, team = null_pointer_node, team_number = null_pointer_node; gfc_se argse; if (expr->value.function.actual->expr) { gfc_init_se (&argse, NULL); gfc_conv_expr_val (&argse, expr->value.function.actual->expr); + if (expr->value.function.actual->expr->ts.type == BT_DERIVED) + team = argse.expr; + else + team_number = gfc_build_addr_expr ( + NULL_TREE, + gfc_trans_force_lval (&se->pre, + fold_convert (integer_type_node, argse.expr))); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - distance = fold_convert (integer_type_node, argse.expr); } - else - distance = integer_zero_node; - if (expr->value.function.actual->next->expr) - { - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - failed = fold_convert (integer_type_node, argse.expr); - } - else - failed = build_int_cst (integer_type_node, -1); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, - distance, failed); + team, team_number); se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); } @@ -2700,8 +2701,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, fold_convert (gfc_array_index_type, tmp), @@ -2716,8 +2716,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) { /* ubound = lbound + num_images() - 1. */ tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, fold_convert (gfc_array_index_type, tmp), @@ -11475,6 +11474,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_GETGID: case GFC_ISYM_GETPID: case GFC_ISYM_GETUID: + case GFC_ISYM_GET_TEAM: case GFC_ISYM_HOSTNM: case GFC_ISYM_IERRNO: case GFC_ISYM_IRAND: @@ -12970,6 +12970,9 @@ gfc_conv_intrinsic_mvbits (gfc_se *se, gfc_actual_arglist *actual_args, void_type_node, to, se->expr); } +/* Comes from trans-stmt.cc, but we don't want the whole header included. */ +extern void gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, + tree *stat, tree *errmsg, tree *errmsg_len); static tree conv_intrinsic_move_alloc (gfc_code *code) @@ -12977,17 +12980,37 @@ conv_intrinsic_move_alloc (gfc_code *code) stmtblock_t block; gfc_expr *from_expr, *to_expr; gfc_se from_se, to_se; - tree tmp, to_tree, from_tree; + tree tmp, to_tree, from_tree, stat, errmsg, errmsg_len, fin_label = NULL_TREE; bool coarray, from_is_class, from_is_scalar; + gfc_actual_arglist *arg = code->ext.actual; + sync_stat tmp_sync_stat = {nullptr, nullptr}; gfc_start_block (&block); - from_expr = code->ext.actual->expr; - to_expr = code->ext.actual->next->expr; + from_expr = arg->expr; + arg = arg->next; + to_expr = arg->expr; + arg = arg->next; + + while (arg) + { + if (arg->expr) + { + if (!strcmp ("stat", arg->name)) + tmp_sync_stat.stat = arg->expr; + else if (!strcmp ("errmsg", arg->name)) + tmp_sync_stat.errmsg = arg->expr; + } + arg = arg->next; + } gfc_init_se (&from_se, NULL); gfc_init_se (&to_se, NULL); + gfc_trans_sync_stat (&tmp_sync_stat, &from_se, &stat, &errmsg, &errmsg_len); + if (stat != null_pointer_node) + fin_label = gfc_build_label_decl (NULL_TREE); + gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS); coarray = from_expr->corank != 0; @@ -13030,9 +13053,10 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Deallocate "to". */ if (to_expr->rank == 0) { - tmp - = gfc_deallocate_scalar_with_status (to_tree, NULL_TREE, NULL_TREE, - true, to_expr, to_expr->ts); + tmp = gfc_deallocate_scalar_with_status (to_tree, stat, fin_label, + true, to_expr, to_expr->ts, + NULL_TREE, false, true, + errmsg, errmsg_len); gfc_add_expr_to_block (&block, tmp); } @@ -13105,9 +13129,12 @@ conv_intrinsic_move_alloc (gfc_code *code) { tree cond; - tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_DEALLOCATE_ONLY); + tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len, + fin_label, true, to_expr, + GFC_CAF_COARRAY_DEALLOCATE_ONLY, + NULL_TREE, NULL_TREE, + gfc_conv_descriptor_token (to_se.expr), + true); gfc_add_expr_to_block (&block, tmp); tmp = gfc_conv_descriptor_data_get (to_se.expr); @@ -13133,9 +13160,10 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_expr_to_block (&block, tmp); } - tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, true, to_expr, - GFC_CAF_COARRAY_NOCOARRAY); + tmp = gfc_deallocate_with_status (to_se.expr, stat, errmsg, errmsg_len, + fin_label, true, to_expr, + GFC_CAF_COARRAY_NOCOARRAY, NULL_TREE, + NULL_TREE, NULL_TREE, true); gfc_add_expr_to_block (&block, tmp); } @@ -13147,6 +13175,13 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_modify_loc (input_location, &block, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); + if (coarray && flag_coarray == GFC_FCOARRAY_LIB) + { + /* Copy the array descriptor data has overwritten the to-token and cleared + from.data. Now also clear the from.token. */ + gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr), + null_pointer_node); + } if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) { @@ -13157,6 +13192,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_modify_loc (input_location, &block, from_se.string_length, build_int_cst (TREE_TYPE (from_se.string_length), 0)); } + if (fin_label) + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label)); return gfc_finish_block (&block); } diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 37f8aca..487b768 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -721,6 +721,15 @@ gfc_trans_stop (gfc_code *code, bool error_stop) return gfc_finish_block (&se.pre); } +tree +trans_exit () +{ + const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); + gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); + tree tmp = gfc_get_symbol_decl (exsym); + return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); +} + /* Translate the FAIL IMAGE statement. */ tree @@ -730,11 +739,49 @@ gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) return build_call_expr_loc (input_location, gfor_fndecl_caf_fail_image, 0); else + return trans_exit (); +} + +void +gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat, + tree *errmsg, tree *errmsg_len) +{ + gfc_se argse; + + if (sync_stat->stat) { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, sync_stat->stat); + gfc_add_block_to_block (&se->pre, &argse.pre); + + if (TREE_TYPE (argse.expr) != integer_type_node) + { + tree tstat = gfc_create_var (integer_type_node, "stat"); + TREE_THIS_VOLATILE (tstat) = 1; + gfc_add_modify (&se->pre, tstat, + fold_convert (integer_type_node, argse.expr)); + gfc_add_modify (&se->post, argse.expr, + fold_convert (TREE_TYPE (argse.expr), tstat)); + *stat = build_fold_addr_expr (tstat); + } + else + *stat = build_fold_addr_expr (argse.expr); + } + else + *stat = null_pointer_node; + + if (sync_stat->errmsg) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_reference (&argse, sync_stat->errmsg); + gfc_add_block_to_block (&se->pre, &argse.pre); + *errmsg = argse.expr; + *errmsg_len = fold_convert (size_type_node, argse.string_length); + } + else + { + *errmsg = null_pointer_node; + *errmsg_len = build_zero_cst (size_type_node); } } @@ -745,38 +792,42 @@ gfc_trans_form_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se se; - gfc_se argse1, argse2; - tree team_id, team_type, tmp; + gfc_se se, argse; + tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp; gfc_init_se (&se, NULL); - gfc_init_se (&argse1, NULL); - gfc_init_se (&argse2, NULL); - gfc_start_block (&se.pre); + gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse1, code->expr1); - gfc_conv_expr_val (&argse2, code->expr2); - team_id = fold_convert (integer_type_node, argse1.expr); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); + gfc_conv_expr_val (&argse, code->expr1); + team_id = fold_convert (integer_type_node, argse.expr); + gfc_conv_expr_reference (&argse, code->expr2); + team_type = argse.expr; - gfc_add_block_to_block (&se.pre, &argse1.pre); - gfc_add_block_to_block (&se.pre, &argse2.pre); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_form_team, 3, - team_id, team_type, - integer_zero_node); + /* NEW_INDEX=. */ + if (code->expr3) + { + gfc_conv_expr_reference (&argse, code->expr3); + new_index = argse.expr; + } + else + new_index = null_pointer_node; + + gfc_add_block_to_block (&se.post, &argse.post); + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + gfc_add_block_to_block (&se.pre, &argse.pre); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6, + team_id, team_type, new_index, stat, errmsg, + errmsg_len); gfc_add_expr_to_block (&se.pre, tmp); - gfc_add_block_to_block (&se.pre, &argse1.post); - gfc_add_block_to_block (&se.pre, &argse2.post); + gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); - } + } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the CHANGE TEAM statement. */ @@ -786,47 +837,56 @@ gfc_trans_change_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + stmtblock_t block; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); + gfc_start_block (&block); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_change_team, 2, team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4, + team_type, stat, errmsg, errmsg_len); + + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_expr_to_block (&block, gfc_trans_block_construct (code)); + return gfc_finish_block (&block); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the END TEAM statement. */ tree -gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) +gfc_trans_end_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - return build_call_expr_loc (input_location, - gfor_fndecl_caf_end_team, 1, - build_int_cst (pchar_type_node, 0)); + gfc_se se; + tree stat, errmsg, errmsg_len, tmp; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3, + stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } /* Translate the SYNC TEAM statement. */ @@ -836,28 +896,25 @@ gfc_trans_sync_team (gfc_code *code) { if (flag_coarray == GFC_FCOARRAY_LIB) { - gfc_se argse; - tree team_type, tmp; + gfc_se se; + tree team_type, stat, errmsg, errmsg_len, tmp; - gfc_init_se (&argse, NULL); - gfc_conv_expr_val (&argse, code->expr1); - team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); + gfc_init_se (&se, NULL); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sync_team, 2, - team_type, - integer_zero_node); - gfc_add_expr_to_block (&argse.pre, tmp); - gfc_add_block_to_block (&argse.pre, &argse.post); - return gfc_finish_block (&argse.pre); + gfc_conv_expr_val (&se, code->expr1); + team_type = se.expr; + + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_team, 4, + team_type, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); } else - { - const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); - gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); - tree tmp = gfc_get_symbol_decl (exsym); - return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); - } + return trans_exit (); } tree @@ -1280,8 +1337,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree cond2; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, - 2, integer_zero_node, - build_int_cst (integer_type_node, -1)); + 2, null_pointer_node, null_pointer_node); cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, images2, tmp); cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, @@ -1609,35 +1665,41 @@ gfc_trans_arithmetic_if (gfc_code * code) /* Translate a CRITICAL block. */ + tree gfc_trans_critical (gfc_code *code) -{ - stmtblock_t block; - tree tmp, token = NULL_TREE; + { + stmtblock_t block; + tree tmp, token = NULL_TREE; + tree stat = NULL_TREE, errmsg, errmsg_len; - gfc_start_block (&block); + gfc_start_block (&block); - if (flag_coarray == GFC_FCOARRAY_LIB) - { - tree zero_size = build_zero_cst (size_type_node); - token = gfc_get_symbol_decl (code->resolved_sym); - token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - null_pointer_node, zero_size); - gfc_add_expr_to_block (&block, tmp); + if (flag_coarray == GFC_FCOARRAY_LIB) + { + gfc_se se; - /* It guarantees memory consistency within the same segment */ - tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), - tmp = build5_loc (input_location, ASM_EXPR, void_type_node, - gfc_build_string_const (1, ""), - NULL_TREE, NULL_TREE, - tree_cons (NULL_TREE, tmp, NULL_TREE), - NULL_TREE); - ASM_VOLATILE_P (tmp) = 1; + gfc_init_se (&se, NULL); + gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg, + &errmsg_len); + gfc_add_block_to_block (&block, &se.pre); - gfc_add_expr_to_block (&block, tmp); + token = gfc_get_symbol_decl (code->resolved_sym); + token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, + token, integer_zero_node, integer_one_node, + null_pointer_node, stat, errmsg, errmsg_len); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se.post); + + /* It guarantees memory consistency within the same segment. */ + tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"), + tmp = build5_loc (input_location, ASM_EXPR, void_type_node, + gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, + tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); + ASM_VOLATILE_P (tmp) = 1; + + gfc_add_expr_to_block (&block, tmp); } tmp = gfc_trans_code (code->block->next); @@ -1645,11 +1707,19 @@ gfc_trans_critical (gfc_code *code) if (flag_coarray == GFC_FCOARRAY_LIB) { - tree zero_size = build_zero_cst (size_type_node); - tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, - token, zero_size, integer_one_node, - null_pointer_node, null_pointer_node, - zero_size); + /* END CRITICAL does not accept STAT or ERRMSG arguments. + * If STAT= is specified for CRITICAL, pass a stat argument to + * _gfortran_caf_lock_unlock to prevent termination in the event of an + * error, but ignore any value assigned to it. + */ + tmp = build_call_expr_loc ( + input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node, + integer_one_node, + stat != NULL_TREE + ? gfc_build_addr_expr (NULL, + gfc_create_var (integer_type_node, "stat")) + : null_pointer_node, + null_pointer_node, integer_zero_node); gfc_add_expr_to_block (&block, tmp); /* It guarantees memory consistency within the same segment */ @@ -1981,11 +2051,35 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; } - if (sym->attr.codimension && !sym->attr.dimension) + if (sym->attr.codimension) se.want_coarray = 1; gfc_conv_expr_descriptor (&se, e); + if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) + { + tree token = gfc_conv_descriptor_token (se.expr), + size + = sym->attr.dimension + ? fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_size (se.expr, e->rank), + gfc_conv_descriptor_span_get (se.expr)) + : gfc_conv_descriptor_span_get (se.expr); + /* Create a new token, because in the token the modified descriptor + is stored. The modified descriptor is needed for accesses on the + remote image. In the scalar case, the base address needs to be + associated correctly, which also needs a new token. + The token is freed automatically be the end team statement. */ + gfc_add_expr_to_block ( + &se.pre, + build_call_expr_loc ( + input_location, gfor_fndecl_caf_register, 7, size, + build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING), + gfc_build_addr_expr (pvoid_type_node, token), + gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node, + null_pointer_node, integer_zero_node)); + } + if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary && sym->ts.u.cl->backend_decl diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 67b1970..8fbcdcb 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -58,6 +58,7 @@ tree gfc_trans_sync (gfc_code *, gfc_exec_op); tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op); tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op); tree gfc_trans_fail_image (gfc_code *); +void gfc_trans_sync_stat (struct sync_stat *, gfc_se *, tree *, tree *, tree *); tree gfc_trans_forall (gfc_code *); tree gfc_trans_form_team (gfc_code *); tree gfc_trans_change_team (gfc_code *); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index b03dcc1..fdeb1e8 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -1795,11 +1795,11 @@ gfc_finalize_tree_expr (gfc_se *se, gfc_symbol *derived, analyzed and set by this routine, and -2 to indicate that a non-coarray is to be deallocated. */ tree -gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, - tree errlen, tree label_finish, - bool can_fail, gfc_expr* expr, +gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen, + tree label_finish, bool can_fail, gfc_expr *expr, int coarray_dealloc_mode, tree class_container, - tree add_when_allocated, tree caf_token) + tree add_when_allocated, tree caf_token, + bool unalloc_ok) { stmtblock_t null, non_null; tree cond, tmp, error; @@ -1891,7 +1891,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), - build_int_cst (status_type, 1)); + build_int_cst (status_type, unalloc_ok ? 0 : 1)); error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } @@ -1975,10 +1975,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, token = gfc_build_addr_expr (NULL_TREE, token); gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5, + token, + build_int_cst (integer_type_node, + caf_dereg_type), pstat, errmsg, errlen); gfc_add_expr_to_block (&non_null, tmp); @@ -1990,7 +1990,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, ASM_VOLATILE_P (tmp) = 1; gfc_add_expr_to_block (&non_null, tmp); - if (status != NULL_TREE) + if (status != NULL_TREE && !integer_zerop (status)) { tree stat = build_fold_indirect_ref_loc (input_location, status); tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, @@ -2024,9 +2024,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, - bool can_fail, gfc_expr* expr, + bool can_fail, gfc_expr *expr, gfc_typespec ts, tree class_container, - bool coarray) + bool coarray, bool unalloc_ok, tree errmsg, + tree errmsg_len) { stmtblock_t null, non_null; tree cond, tmp, error; @@ -2069,7 +2070,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, status_type, status), - build_int_cst (status_type, 1)); + build_int_cst (status_type, unalloc_ok ? 0 : 1)); error = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2, tmp, error); } @@ -2134,7 +2135,8 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, else { tree token; - tree pstat = null_pointer_node; + tree pstat = null_pointer_node, perrmsg = null_pointer_node, + perrlen = size_zero_node; gfc_se se; gfc_init_se (&se, NULL); @@ -2147,11 +2149,17 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, pstat = status; } - tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_deregister, 5, - token, build_int_cst (integer_type_node, - caf_dereg_type), - pstat, null_pointer_node, integer_zero_node); + if (errmsg != NULL_TREE) + { + perrmsg = errmsg; + perrlen = errmsg_len; + } + + tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_deregister, 5, + token, + build_int_cst (integer_type_node, + caf_dereg_type), + pstat, perrmsg, perrlen); gfc_add_expr_to_block (&non_null, tmp); /* It guarantees memory consistency within the same segment. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index ae7be9f..461b0cd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -139,10 +139,10 @@ enum gfc_coarray_regtype GFC_CAF_EVENT_STATIC, GFC_CAF_EVENT_ALLOC, GFC_CAF_COARRAY_ALLOC_REGISTER_ONLY, - GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY + GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY, + GFC_CAF_COARRAY_MAP_EXISTING }; - /* Describes the action to take on _caf_deregister. Keep in sync with gcc/fortran/trans.h. The negative values are not valid for the library and are used by the drivers for building the correct call. */ @@ -774,12 +774,13 @@ void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree, tree = NULL_TREE); /* Generate code to deallocate an array. */ -tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, - gfc_expr *, int, tree = NULL_TREE, - tree a = NULL_TREE, tree c = NULL_TREE); -tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr*, +tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, gfc_expr *, + int, tree = NULL_TREE, tree a = NULL_TREE, + tree c = NULL_TREE, bool u = false); +tree gfc_deallocate_scalar_with_status (tree, tree, tree, bool, gfc_expr *, gfc_typespec, tree = NULL_TREE, - bool c = false); + bool c = false, bool u = false, + tree = NULL_TREE, tree = NULL_TREE); /* Generate code to call realloc(). */ tree gfc_call_realloc (stmtblock_t *, tree, tree); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4e61317..4c219bd 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,140 @@ +2025-04-21 Jason Merrill <jason@redhat.com> + + PR c++/118775 + * g++.dg/cpp2a/constexpr-new24.C: Adjust diagnostic. + +2025-04-21 Andrew Bennett <andrew.bennett@imgtec.com> + + * gcc.dg/memcpy-4.c: Remove mips specific code. + * gcc.target/mips/memcpy-2.c: New test. + +2025-04-21 Matthew Fortune <matthew.fortune@imgtec.com> + + * gcc.target/mips/clear-cache-1.c: Also allow jrc. + +2025-04-21 Matthew Fortune <matthew.fortune@imgtec.com> + + * gcc.dg/tree-ssa/ssa-dom-cse-2.c: Do not check output for + MIPS lp64 abi. + +2025-04-21 Andrew Pinski <quic_apinski@quicinc.com> + + PR middle-end/119507 + * g++.dg/eh/pr119507.C: New test. + +2025-04-21 hongtao.liu <hongtao.liu@intel.com> + + * gcc.target/i386/recip-vec-divf-fma.c: New test. + +2025-04-20 H.J. Lu <hjl.tools@gmail.com> + + PR target/117863 + * gcc.dg/rtl/i386/vector_eq-2.c: New test. + * gcc.dg/rtl/i386/vector_eq-3.c: Likewise. + +2025-04-19 Thomas Schwinge <tschwinge@baylibre.com> + + PR testsuite/119508 + * rust/compile/nr2/compile.exp: Disable parallel testing. + +2025-04-19 Co-authored-by: Jeff Law <jlaw@ventanamicro.com> + + PR target/118410 + * gcc.target/riscv/pr118410-1.c: New test. + * gcc.target/riscv/pr118410-2.c: Likewise. + +2025-04-19 Andrew Pinski <quic_apinski@quicinc.com> + + * gcc.dg/pr118947-1.c: Use 1025 as the size of the buf. + * gcc.dg/pr78408-3.c: Likewise. + +2025-04-19 Andrew Pinski <quic_apinski@quicinc.com> + + PR rtl-optimization/111949 + * gcc.target/aarch64/bic-1.c: New test. + +2025-04-19 Jiaxun Yang <jiaxun.yang@flygoat.com> + + PR target/111814 + * gcc.target/sh/pr111814.c: New test. + +2025-04-19 Maciej W. Rozycki <macro@orcam.me.uk> + + * gcc.target/alpha/memcpy-nested-offset-long.c: New file. + * gcc.target/alpha/memcpy-nested-offset-quad.c: New file. + +2025-04-19 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/119836 + * gfortran.dg/do_concurrent_all_clauses.f90: Remove invalid + dg-error test. + * gfortran.dg/pr119836_1.f90: New test. + * gfortran.dg/pr119836_2.f90: New test. + * gfortran.dg/pr119836_3.f90: New test. + * gfortran.dg/pr119836_4.f90: New test. + +2025-04-18 Thomas Schwinge <tschwinge@baylibre.com> + + PR cobol/119818 + * cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob: + 'dg-set-target-env-var TZ UTC0'. + +2025-04-18 Jeff Law <jlaw@ventanamicro.com> + + * gcc.target/riscv/bext-ext-2.c: New test + +2025-04-18 Jonathan Yong <10walls@gmail.com> + + * g++.dg/abi/ref-temp1.C: Replicate some test based on + PE expectations. + * lib/target-supports.exp: New check_effective_target_pe. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/87901 + * gcc.dg/tree-ssa/ssa-dse-53.c: New test. + * gcc.dg/tree-ssa/ssa-dse-54.c: New test. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/87901 + * gcc.dg/tree-ssa/ssa-dse-52.c: New test. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/118902 + * gcc.dg/tree-ssa/pr118902-1.c: New test. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/118947 + * gcc.dg/pr118947-1.c: New test. + +2025-04-18 Andrew Pinski <quic_apinski@quicinc.com> + + PR tree-optimization/78408 + PR tree-optimization/118947 + * gcc.dg/pr78408-3.c: New test. + +2025-04-18 Dimitar Dimitrov <dimitar@dinux.eu> + + * gcc.dg/pr116357.c: Use sizeof(int) instead of alignof(int). + +2025-04-18 Alexey Merzlyakov <alexey.merzlyakov@samsung.com> + + PR middle-end/108016 + * gcc.target/riscv/pr108016.c: New test. + +2025-04-18 kelefth <konstantinos.eleftheriou@vrull.eu> + + PR rtl-optimization/119160 + * gcc.dg/pr119160.c: New test. + +2025-04-18 Xing Li <lixing@loongson.cn> + + * gcc.target/loongarch/vector/loongarch-vector.exp: Change + {dg-do-what-default} save and restore logical. + 2025-04-17 Jason Merrill <jason@redhat.com> * g++.dg/cpp2a/constexpr-dtor16.C: Adjust diagnostic. diff --git a/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob index cc2a4e1..88b1b84 100644 --- a/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob +++ b/gcc/testsuite/cobol.dg/group2/FUNCTION_DATE___TIME_OMNIBUS.cob @@ -1,4 +1,5 @@ *> { dg-do run } + *> { dg-set-target-env-var TZ UTC0 } identification division. program-id. test. diff --git a/gcc/testsuite/g++.dg/abi/ref-temp1.C b/gcc/testsuite/g++.dg/abi/ref-temp1.C index 70c9a7a..b02dcf6 100644 --- a/gcc/testsuite/g++.dg/abi/ref-temp1.C +++ b/gcc/testsuite/g++.dg/abi/ref-temp1.C @@ -7,11 +7,16 @@ struct B { const A (&x)[2]; }; template <typename T> B &&b = { { { { 1, 2, 3 } }, { { 4, 5, 6 } } } }; B &temp = b<void>; -// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE_" } } -// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE0_" } } -// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE1_" } } -// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE2_" } } +// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE_" { target { ! pe } } } } +// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE0_" { target { ! pe } } } } +// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE1_" { target { ! pe } } } } +// { dg-final { scan-assembler ".weak\(_definition\)?\[ \t\]_?_ZGR1bIvE2_" { target { ! pe } } } } +// { dg-final { scan-assembler "\.section\t\.data\\\$_ZGR1bIvE_,\"w\"\n\t\.linkonce same_size" { target pe } } } +// { dg-final { scan-assembler "\.section\t\.rdata\\\$_ZGR1bIvE0_,\"dr\"\n\t\.linkonce same_size" { target pe } } } +// { dg-final { scan-assembler "\.section\t\.rdata\\\$_ZGR1bIvE1_,\"dr\"\n\t\.linkonce same_size" { target pe } } } +// { dg-final { scan-assembler "\.section\t\.rdata\\\$_ZGR1bIvE2_,\"dr\"\n\t\.linkonce same_size" { target pe } } } +// // { dg-final { scan-assembler "_ZGR1bIvE_:\n\[^\n]+_ZGR1bIvE0_" } } // { dg-final { scan-assembler "_ZGR1bIvE0_:\n\[^\n]+_ZGR1bIvE1_" } } // { dg-final { scan-assembler "_ZGR1bIvE1_:\n\[^\n]+\[ \t\]1" } } diff --git a/gcc/testsuite/g++.dg/cpp2a/constexpr-new24.C b/gcc/testsuite/g++.dg/cpp2a/constexpr-new24.C index ee62f18..17c9f54 100644 --- a/gcc/testsuite/g++.dg/cpp2a/constexpr-new24.C +++ b/gcc/testsuite/g++.dg/cpp2a/constexpr-new24.C @@ -6,14 +6,14 @@ int a; constexpr char * f1 () { - constexpr auto p = new char[(long int) &a]; // { dg-error "size not constant" } + constexpr auto p = new char[(long int) &a]; // { dg-error "conversion from pointer" } return p; } constexpr char * f2 () { - auto p = new char[(long int) &a]; // { dg-error "size not constant" } + auto p = new char[(long int) &a]; // { dg-error "conversion from pointer" } return p; } diff --git a/gcc/testsuite/g++.dg/eh/pr119507.C b/gcc/testsuite/g++.dg/eh/pr119507.C new file mode 100644 index 0000000..c68536f --- /dev/null +++ b/gcc/testsuite/g++.dg/eh/pr119507.C @@ -0,0 +1,19 @@ +// { dg-do compile { target comdat_group } } +// ARM EABI has its own exception handling data handling and does not use gcc_except_table +// { dg-skip-if "!TARGET_EXCEPTION_DATA" { arm_eabi } } +// Force off function sections +// Force on exceptions +// { dg-options "-fno-function-sections -fexceptions" } +// PR middle-end/119507 + + +inline int comdat() { try { throw 1; } catch (int) { return 1; } return 0; } +int another_func_with_exception() { try { throw 1; } catch (int) { return 1; } return 0; } +inline int comdat1() { try { throw 1; } catch (int) { return 1; } return 0; } +int foo() { return comdat() + comdat1(); } + +// Make sure the gcc puts the exception table for both comdat and comdat1 in their own section +// { dg-final { scan-assembler-times ".section\[\t \]\[^\n\]*.gcc_except_table._Z6comdatv" 1 } } +// { dg-final { scan-assembler-times ".section\[\t \]\[^\n\]*.gcc_except_table._Z7comdat1v" 1 } } +// There should be 3 exception tables, +// { dg-final { scan-assembler-times ".section\[\t \]\[^\n\]*.gcc_except_table" 3 } } diff --git a/gcc/testsuite/g++.dg/gcov/gcov.exp b/gcc/testsuite/g++.dg/gcov/gcov.exp index 50f60c4..04c7c95 100644 --- a/gcc/testsuite/g++.dg/gcov/gcov.exp +++ b/gcc/testsuite/g++.dg/gcov/gcov.exp @@ -21,12 +21,19 @@ load_lib g++-dg.exp load_lib gcov.exp global GXX_UNDER_TEST +global GCOV_UNDER_TEST -# Find gcov in the same directory as $GXX_UNDER_TEST. -if { ![is_remote host] && [string match "*/*" [lindex $GXX_UNDER_TEST 0]] } { - set GCOV [file dirname [lindex $GXX_UNDER_TEST 0]]/[gcc-transform-out-of-tree gcov] +# Find gcov in the same directory as $GXX_UNDER_TEST, unless +# GCOV_UNDER_TEST is defined. + +if ![info exists GCOV_UNDER_TEST] { + if { ![is_remote host] && [string match "*/*" [lindex $GXX_UNDER_TEST 0]] } { + set GCOV [file dirname [lindex $GXX_UNDER_TEST 0]]/[gcc-transform-out-of-tree gcov] + } else { + set GCOV [gcc-transform-out-of-tree gcov] + } } else { - set GCOV [gcc-transform-out-of-tree gcov] + set GCOV $GCOV_UNDER_TEST } # Initialize harness. diff --git a/gcc/testsuite/g++.dg/modules/tpl-friend-18_a.C b/gcc/testsuite/g++.dg/modules/tpl-friend-18_a.C new file mode 100644 index 0000000..333c976 --- /dev/null +++ b/gcc/testsuite/g++.dg/modules/tpl-friend-18_a.C @@ -0,0 +1,25 @@ +// PR c++/119863 +// { dg-additional-options "-fmodules" } +// { dg-module-cmi A } + +export module A; + +template<typename> +class T; + +template<typename> +class U +{ + template<typename> + friend class T; +}; + +template<typename V> +class T +{ + U<V> x = {}; +}; + +export +template<typename V> +T<V> f(V) { return {}; } diff --git a/gcc/testsuite/g++.dg/modules/tpl-friend-18_b.C b/gcc/testsuite/g++.dg/modules/tpl-friend-18_b.C new file mode 100644 index 0000000..2e537ed --- /dev/null +++ b/gcc/testsuite/g++.dg/modules/tpl-friend-18_b.C @@ -0,0 +1,9 @@ +// PR c++/119863 +// { dg-additional-options "-fmodules" } +// { dg-module-cmi B } + +export module B; + +// this should not be considered conflicting +template <typename> +class T; diff --git a/gcc/testsuite/g++.dg/modules/tpl-friend-18_c.C b/gcc/testsuite/g++.dg/modules/tpl-friend-18_c.C new file mode 100644 index 0000000..6c8d85b --- /dev/null +++ b/gcc/testsuite/g++.dg/modules/tpl-friend-18_c.C @@ -0,0 +1,10 @@ +// PR c++/119863 +// { dg-additional-options "-fmodules" } + +import A; +import B; + +int main() +{ + auto const x = f(1); +} diff --git a/gcc/testsuite/g++.target/aarch64/spaceship_1.C b/gcc/testsuite/g++.target/aarch64/spaceship_1.C new file mode 100644 index 0000000..e6daf62 --- /dev/null +++ b/gcc/testsuite/g++.target/aarch64/spaceship_1.C @@ -0,0 +1,192 @@ +// PR117013 +/* { dg-do run } */ +/* { dg-options "-O2 -std=c++20 -save-temps -fno-schedule-insns2" } */ +/* { dg-final { check-function-bodies "**" "" ""} } */ + +#include <compare> +#include <stdint.h> + +/* Some implementation-defined value (other than 2) to represent + partial_ordering::unordered (that for libc++ in this case). */ +#define IMP_UN -127 + +#define SPACESHIP_FN(TYPE) \ + [[gnu::noipa]] \ + auto ss_##TYPE (TYPE a, TYPE b) \ + { return a <=> b; } \ + +#define SPACESHIP_FN_NN(TYPE) \ + [[gnu::noipa, gnu::optimize ("-ffinite-math-only")]] \ + auto ss_##TYPE##_no_nans (TYPE a, TYPE b) \ + { return a <=> b; } \ + +/* <=> implementation for floating-point operands. */ +#define SPACESHIP_FP_IDIOM(TYPE) \ + [[gnu::noipa]] \ + int ss_##TYPE##_idiom (TYPE a, TYPE b) \ + { return ((a) == (b) ? 0 : (a) < (b) ? -1 : (a) > (b) ? 1 : IMP_UN); } \ + +#define RUN_TEST(TYPE, ARGA, ARGB, EXPECT, SUFF) \ + if (ss_##TYPE##SUFF ((ARGA), (ARGB)) != (EXPECT)) \ + __builtin_abort(); \ + +/* +** _Z8ss_floatff: +** fcmpe s0, s1 +** csinv (w[0-9]+), wzr, wzr, pl +** cset (w[0-9]+), vs +** csinc w0, \1, \2, ls +** ret +*/ +SPACESHIP_FN(float); + +/* +** _Z16ss_float_no_nansff: +** fcmpe s0, s1 +** csinv (w[0-9]+), wzr, wzr, pl +** csinc w0, \1, wzr, ls +** ret +*/ +SPACESHIP_FN_NN(float); + +/* +** _Z9ss_doubledd: +** fcmpe d0, d1 +** csinv (w[0-9]+), wzr, wzr, pl +** cset (w[0-9]+), vs +** csinc w0, \1, \2, ls +** ret +*/ +SPACESHIP_FN(double); + +/* +** _Z17ss_double_no_nansdd: +** fcmpe d0, d1 +** csinv (w[0-9]+), wzr, wzr, pl +** csinc w0, \1, wzr, ls +** ret +*/ +SPACESHIP_FN_NN(double); + +/* +** _Z14ss_float_idiomff: +** fcmpe s0, s1 +** csinv (w[0-9]+), wzr, wzr, pl +** mov (w[0-9]+), -128 +** csel (w[0-9]+), \2, wzr, vs +** csinc w0, \1, \3, ls +** ret +*/ +SPACESHIP_FP_IDIOM(float); + +/* +** _Z15ss_double_idiomdd: +** fcmpe d0, d1 +** csinv (w[0-9]+), wzr, wzr, pl +** mov (w[0-9]+), -128 +** csel (w[0-9]+), \2, wzr, vs +** csinc w0, \1, \3, ls +** ret +*/ +SPACESHIP_FP_IDIOM(double); + +/* +** _Z10ss_int32_tii: +** cmp w0, w1 +** cset (w[0-9]+), gt +** csinv w0, \1, wzr, ge +** ret +*/ +SPACESHIP_FN(int32_t); + +/* +** _Z10ss_int64_tll: +** cmp x0, x1 +** cset (w[0-9]+), gt +** csinv w0, \1, wzr, ge +** ret +*/ +SPACESHIP_FN(int64_t); + +/* +** _Z11ss_uint32_tjj: +** cmp w0, w1 +** cset (w[0-9]+), hi +** csinv w0, \1, wzr, cs +** ret +*/ +SPACESHIP_FN(uint32_t); + +/* +** _Z11ss_uint64_tmm: +** cmp x0, x1 +** cset (w[0-9]+), hi +** csinv w0, \1, wzr, cs +** ret +*/ +SPACESHIP_FN(uint64_t); + + +int +main() +{ + /* Single precision floating point. */ + RUN_TEST (float, -1.0f, 1.0f, std::partial_ordering::less,); + RUN_TEST (float, -1.0f, 1.0f, -1, _idiom); + + RUN_TEST (float, 1.0f, -1.0f, std::partial_ordering::greater,); + RUN_TEST (float, 1.0f, -1.0f, 1, _idiom); + + RUN_TEST (float, -1.0f, -1.0f, std::partial_ordering::equivalent,); + RUN_TEST (float, -1.0f, -1.0f, 0, _idiom); + + RUN_TEST (float, __builtin_nanf(""), 1.0f, std::partial_ordering::unordered,); + RUN_TEST (float, __builtin_nanf(""), 1.0f, IMP_UN, _idiom); + RUN_TEST (float, 1.0f ,__builtin_nanf(""), std::partial_ordering::unordered,); + RUN_TEST (float, 1.0f, __builtin_nanf(""), IMP_UN, _idiom); + + /* No-NaNs. */ + RUN_TEST (float, -1.0f, 1.0f, std::partial_ordering::less, _no_nans); + RUN_TEST (float, 1.0f, -1.0f, std::partial_ordering::greater, _no_nans); + RUN_TEST (float, -1.0f, -1.0f, std::partial_ordering::equivalent, _no_nans); + + /* Double precision floating point. */ + RUN_TEST (double, -1.0f, 1.0f, std::partial_ordering::less,); + RUN_TEST (double, -1.0f, 1.0f, -1, _idiom); + + RUN_TEST (double, 1.0f, -1.0f, std::partial_ordering::greater,); + RUN_TEST (double, 1.0f, -1.0f, 1, _idiom); + + RUN_TEST (double, -1.0f, -1.0f, std::partial_ordering::equivalent,); + RUN_TEST (double, -1.0f, -1.0f, 0, _idiom); + + RUN_TEST (double, __builtin_nanf(""), 1.0f, std::partial_ordering::unordered,); + RUN_TEST (double, __builtin_nanf(""), 1.0f, IMP_UN, _idiom); + RUN_TEST (double, 1.0f, __builtin_nanf(""), std::partial_ordering::unordered,); + RUN_TEST (double, 1.0f, __builtin_nanf(""), IMP_UN, _idiom); + + /* No-NaNs. */ + RUN_TEST (double, -1.0f, 1.0f, std::partial_ordering::less, _no_nans); + RUN_TEST (double, 1.0f, -1.0f, std::partial_ordering::greater, _no_nans); + RUN_TEST (double, -1.0f, -1.0f, std::partial_ordering::equivalent, _no_nans); + + /* Single integer. */ + RUN_TEST (int32_t, -42, 0, std::strong_ordering::less,); + RUN_TEST (int32_t, 0, -42, std::strong_ordering::greater,); + RUN_TEST (int32_t, 42, 42, std::strong_ordering::equal,); + + RUN_TEST (uint32_t, 0, 42, std::strong_ordering::less,); + RUN_TEST (uint32_t, 42, 0, std::strong_ordering::greater,); + RUN_TEST (uint32_t, 42, 42, std::strong_ordering::equal,); + + /* Double integer. */ + RUN_TEST (int64_t, -42, 0, std::strong_ordering::less,); + RUN_TEST (int64_t, 42, 0, std::strong_ordering::greater,); + RUN_TEST (int64_t, 42, 42, std::strong_ordering::equal,); + + RUN_TEST (uint64_t, 0, 42, std::strong_ordering::less,); + RUN_TEST (uint64_t, 42, 0, std::strong_ordering::greater,); + RUN_TEST (uint64_t, 42, 42, std::strong_ordering::equal,); + + return 0; +}
\ No newline at end of file diff --git a/gcc/testsuite/g++.target/aarch64/spaceship_2.C b/gcc/testsuite/g++.target/aarch64/spaceship_2.C new file mode 100644 index 0000000..c1d3900 --- /dev/null +++ b/gcc/testsuite/g++.target/aarch64/spaceship_2.C @@ -0,0 +1,72 @@ +// PR117013 +/* { dg-do run } */ +// { dg-options "-O2 -std=c++20 -save-temps" } + +#include <compare> + +#ifndef fp_type +#define fp_type float +#endif + +#define TEST_SS_IDIOM(ARGA, ARGB, EXPECT) \ + if (spaceship_idiom ((ARGA), (ARGB)) != (EXPECT)) \ + __builtin_abort(); \ + +#define TEST_BR_ON_SS(ARGA, ARGB, EXPECT) \ + if(branch_on_spaceship ((ARGA), (ARGB)) != (EXPECT)) \ + __builtin_abort(); \ + + +#define RUN_TEST(ARGA, ARGB, EXPECT) \ + TEST_SS_IDIOM(ARGA, ARGB, EXPECT) \ + TEST_BR_ON_SS(ARGA, ARGB, EXPECT) \ + +/* Test when .SPACESHIP prompts the back end to implement <=> with + conditional branches (only applies to floating-point operands). */ + +[[gnu::noipa]] auto +equiv() { return std::partial_ordering::equivalent; } +[[gnu::noipa]] auto +less() { return std::partial_ordering::less; } +[[gnu::noipa]] auto +greater() { return std::partial_ordering::greater; } +[[gnu::noipa]] auto +unordered() { return std::partial_ordering::unordered; } + +auto +spaceship_idiom(fp_type a, fp_type b) +{ + if (a == b) + return equiv(); + if (a < b) + return less(); + if (a > b) + return greater(); + return unordered(); +} + +auto +branch_on_spaceship(fp_type a, fp_type b) +{ + auto res = a <=> b; + if (res == 0) + return equiv(); + else if (res < 0) + return less(); + else if (res > 0) + return greater(); + return unordered(); +} + +int +main() +{ + RUN_TEST (-1.0f, 1.0f, std::partial_ordering::less); + RUN_TEST (1.0f, -1.0f, std::partial_ordering::greater); + RUN_TEST (1.0f, 1.0f, std::partial_ordering::equivalent); + RUN_TEST (1.0f, __builtin_nanf(""), std::partial_ordering::unordered); + RUN_TEST (__builtin_nanf(""), 1.0f, std::partial_ordering::unordered); +} + +/* { dg-final { scan-assembler-not "\tfcmp\t" } } */ +/* { dg-final { scan-assembler-times "\tfcmpe\t" 2 } } */
\ No newline at end of file diff --git a/gcc/testsuite/g++.target/aarch64/spaceship_3.C b/gcc/testsuite/g++.target/aarch64/spaceship_3.C new file mode 100644 index 0000000..f58b084 --- /dev/null +++ b/gcc/testsuite/g++.target/aarch64/spaceship_3.C @@ -0,0 +1,9 @@ +// PR117013 +/* { dg-do run } */ +// { dg-options "-O2 -std=c++20 -save-temps" } + +#define fp_type double +#include "spaceship_2.C" + +/* { dg-final { scan-assembler-not "\tfcmp\t" } } */ +/* { dg-final { scan-assembler-times "\tfcmpe\t" 2 } } */
\ No newline at end of file diff --git a/gcc/testsuite/gcc.dg/memcpy-4.c b/gcc/testsuite/gcc.dg/memcpy-4.c index 4c726f0..b17b369 100644 --- a/gcc/testsuite/gcc.dg/memcpy-4.c +++ b/gcc/testsuite/gcc.dg/memcpy-4.c @@ -1,13 +1,8 @@ /* { dg-do compile } */ -/* { dg-options "-O2 -fdump-rtl-expand" } */ +/* { dg-options "-O2" } */ -#ifdef __mips -__attribute__((nomips16)) -#endif void f1 (char *p) { __builtin_memcpy (p, "12345", 5); } - -/* { dg-final { scan-rtl-dump "mem/u.*mem/u" "expand" { target mips*-*-* } } } */ diff --git a/gcc/testsuite/gcc.dg/pr118947-1.c b/gcc/testsuite/gcc.dg/pr118947-1.c index 70b7f80..8733e8d 100644 --- a/gcc/testsuite/gcc.dg/pr118947-1.c +++ b/gcc/testsuite/gcc.dg/pr118947-1.c @@ -6,10 +6,10 @@ void* aaa(); void* bbb() { - char buf[32] = {}; + char buf[1025] = {}; /* Tha call to aaa should not matter and clobber buf. */ void* ret = aaa(); - __builtin_memcpy(ret, buf, 32); + __builtin_memcpy(ret, buf, sizeof(buf)); return ret; } diff --git a/gcc/testsuite/gcc.dg/pr78408-3.c b/gcc/testsuite/gcc.dg/pr78408-3.c index 3de90d0..5ea5458 100644 --- a/gcc/testsuite/gcc.dg/pr78408-3.c +++ b/gcc/testsuite/gcc.dg/pr78408-3.c @@ -7,8 +7,8 @@ void* aaa(); void* bbb() { void* ret = aaa(); - char buf[32] = {}; - __builtin_memcpy(ret, buf, 32); + char buf[1025] = {}; + __builtin_memcpy(ret, buf, sizeof(buf)); return ret; } diff --git a/gcc/testsuite/gcc.dg/rtl/i386/vector_eq-2.c b/gcc/testsuite/gcc.dg/rtl/i386/vector_eq-2.c new file mode 100644 index 0000000..871d489 --- /dev/null +++ b/gcc/testsuite/gcc.dg/rtl/i386/vector_eq-2.c @@ -0,0 +1,71 @@ +/* { dg-do compile { target { i?86-*-* x86_64-*-* } } } */ +/* { dg-additional-options "-O2 -march=x86-64-v3" } */ + +typedef int v4si __attribute__((vector_size(16))); +typedef int v8si __attribute__((vector_size(32))); +typedef int v2di __attribute__((vector_size(16))); + +v4si __RTL (startwith ("vregs1")) foo1 (void) +{ +(function "foo1" + (insn-chain + (block 2 + (edge-from entry (flags "FALLTHRU")) + (cnote 1 [bb 2] NOTE_INSN_BASIC_BLOCK) + (cnote 2 NOTE_INSN_FUNCTION_BEG) + (cinsn 3 (set (reg:V4SI <0>) (const_vector:V4SI [(const_int -1) (const_int -1) (const_int -1) (const_int -1)]))) + (cinsn 4 (set (reg:V4SI <1>) (const_vector:V4SI [(const_int -1) (const_int -1) (const_int -1) (const_int -1)]))) + (cinsn 5 (set (reg:V4SI <2>) + (eq:V4SI (reg:V4SI <0>) (reg:V4SI <1>)))) + (cinsn 6 (set (reg:V4SI <3>) (reg:V4SI <2>))) + (cinsn 7 (set (reg:V4SI xmm0) (reg:V4SI <3>))) + (edge-to exit (flags "FALLTHRU")) + ) + ) + (crtl (return_rtx (reg/i:V4SI xmm0))) +) +} + +v8si __RTL (startwith ("vregs1")) foo2 (void) +{ +(function "foo2" + (insn-chain + (block 2 + (edge-from entry (flags "FALLTHRU")) + (cnote 1 [bb 2] NOTE_INSN_BASIC_BLOCK) + (cnote 2 NOTE_INSN_FUNCTION_BEG) + (cinsn 3 (set (reg:V8SI <0>) (const_vector:V8SI [(const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1)]))) + (cinsn 4 (set (reg:V8SI <1>) (const_vector:V8SI [(const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1) (const_int -1)]))) + (cinsn 5 (set (reg:V8SI <2>) + (eq:V8SI (reg:V8SI <0>) (reg:V8SI <1>)))) + (cinsn 6 (set (reg:V8SI <3>) (reg:V8SI <2>))) + (cinsn 7 (set (reg:V8SI xmm0) (reg:V8SI <3>))) + (edge-to exit (flags "FALLTHRU")) + ) + ) + (crtl (return_rtx (reg/i:V8SI xmm0))) +) +} + +v2di __RTL (startwith ("vregs1")) foo3 (void) +{ +(function "foo3" + (insn-chain + (block 2 + (edge-from entry (flags "FALLTHRU")) + (cnote 1 [bb 2] NOTE_INSN_BASIC_BLOCK) + (cnote 2 NOTE_INSN_FUNCTION_BEG) + (cinsn 3 (set (reg:V2DI <0>) (const_vector:V2DI [(const_int -1) (const_int -1)]))) + (cinsn 4 (set (reg:V2DI <1>) (const_vector:V2DI [(const_int -1) (const_int -1)]))) + (cinsn 5 (set (reg:V2DI <2>) + (eq:V2DI (reg:V2DI <0>) (reg:V2DI <1>)))) + (cinsn 6 (set (reg:V2DI <3>) (reg:V2DI <2>))) + (cinsn 7 (set (reg:V2DI xmm0) (reg:V2DI <3>))) + (edge-to exit (flags "FALLTHRU")) + ) + ) + (crtl (return_rtx (reg/i:V2DI xmm0))) +) +} + +/* { dg-final { scan-assembler-times "vpcmpeq" 3 } } */ diff --git a/gcc/testsuite/gcc.dg/rtl/i386/vector_eq-3.c b/gcc/testsuite/gcc.dg/rtl/i386/vector_eq-3.c new file mode 100644 index 0000000..276c4c2 --- /dev/null +++ b/gcc/testsuite/gcc.dg/rtl/i386/vector_eq-3.c @@ -0,0 +1,74 @@ +/* { dg-do compile { target { i?86-*-* x86_64-*-* } } } */ +/* { dg-additional-options "-O2 -march=x86-64-v3" } */ + +typedef int v4si __attribute__((vector_size(16))); +typedef int v8si __attribute__((vector_size(32))); +typedef int v2di __attribute__((vector_size(16))); + +v4si __RTL (startwith ("vregs1")) foo1 (void) +{ +(function "foo1" + (insn-chain + (block 2 + (edge-from entry (flags "FALLTHRU")) + (cnote 1 [bb 2] NOTE_INSN_BASIC_BLOCK) + (cnote 2 NOTE_INSN_FUNCTION_BEG) + (cinsn 3 (set (reg:V4SI <1>) + (mem:V4SI (reg:SI di) [0 ptr S128 A128]))) + (cinsn 4 (set (reg:V4SI <2>) + (eq:V4SI (reg:V4SI <1>) + (mem:V4SI (reg:SI di) [0 ptr S128 A128])))) + (cinsn 5 (set (reg:V4SI <3>) (reg:V4SI <2>))) + (cinsn 6 (set (reg:V4SI xmm0) (reg:V4SI <3>))) + (edge-to exit (flags "FALLTHRU")) + ) + ) + (crtl (return_rtx (reg/i:V4SI xmm0))) +) +} + +v8si __RTL (startwith ("vregs1")) foo2 (void) +{ +(function "foo2" + (insn-chain + (block 2 + (edge-from entry (flags "FALLTHRU")) + (cnote 1 [bb 2] NOTE_INSN_BASIC_BLOCK) + (cnote 2 NOTE_INSN_FUNCTION_BEG) + (cinsn 3 (set (reg:V8SI <1>) + (mem:V8SI (reg:SI di) [0 ptr S256 A256]))) + (cinsn 4 (set (reg:V8SI <2>) + (eq:V8SI (mem:V8SI (reg:SI di) [0 ptr S256 A256]) + (reg:V8SI <1>)))) + (cinsn 5 (set (reg:V8SI <3>) (reg:V8SI <2>))) + (cinsn 6 (set (reg:V8SI xmm0) (reg:V8SI <3>))) + (edge-to exit (flags "FALLTHRU")) + ) + ) + (crtl (return_rtx (reg/i:V8SI xmm0))) +) +} + +v2di __RTL (startwith ("vregs1")) foo3 (void) +{ +(function "foo3" + (insn-chain + (block 2 + (edge-from entry (flags "FALLTHRU")) + (cnote 1 [bb 2] NOTE_INSN_BASIC_BLOCK) + (cnote 2 NOTE_INSN_FUNCTION_BEG) + (cinsn 3 (set (reg:V2DI <1>) + (mem:V2DI (reg:SI di) [0 ptr S128 A128]))) + (cinsn 4 (set (reg:V2DI <2>) + (eq:V2DI (reg:V2DI <1>) + (mem:V2DI (reg:SI di) [0 ptr S128 A128])))) + (cinsn 5 (set (reg:V2DI <3>) (reg:V2DI <2>))) + (cinsn 6 (set (reg:V2DI xmm0) (reg:V2DI <3>))) + (edge-to exit (flags "FALLTHRU")) + ) + ) + (crtl (return_rtx (reg/i:V2DI xmm0))) +) +} + +/* { dg-final { scan-assembler-times "vpcmpeq" 3 } } */ diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-cse-2.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-cse-2.c index a879d30..6fa52f6 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-cse-2.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-cse-2.c @@ -27,4 +27,4 @@ foo () but the loop reads only one element at a time, and DOM cannot resolve these. The same happens on powerpc depending on the SIMD support available. */ -/* { dg-final { scan-tree-dump "return 28;" "optimized" { xfail { { alpha*-*-* hppa*64*-*-* nvptx*-*-* mmix-knuth-mmixware } || { { { lp64 && { powerpc*-*-* sparc*-*-* riscv*-*-* } } || aarch64_sve } || { arm*-*-* && { ! arm_neon } } } } } } } */ +/* { dg-final { scan-tree-dump "return 28;" "optimized" { xfail { { alpha*-*-* hppa*64*-*-* nvptx*-*-* mmix-knuth-mmixware } || { { { lp64 && { mips*-*-* powerpc*-*-* sparc*-*-* riscv*-*-* } } || aarch64_sve } || { arm*-*-* && { ! arm_neon } } } } } } } */ diff --git a/gcc/testsuite/gcc.misc-tests/gcov-31.c b/gcc/testsuite/gcc.misc-tests/gcov-31.c index 6c42d34..5f060e9 100644 --- a/gcc/testsuite/gcc.misc-tests/gcov-31.c +++ b/gcc/testsuite/gcc.misc-tests/gcov-31.c @@ -20,7 +20,7 @@ run_pending_traps () jump_to_top_level (2); for (sig = 1; sig < (64 + 1) ; sig++) - __sigsetjmp ((return_catch), 0); + sigsetjmp ((return_catch), 0); } /* Distilled from alsalib-1.2.11 pcm/pcm_route.c. */ diff --git a/gcc/testsuite/gcc.misc-tests/gcov.exp b/gcc/testsuite/gcc.misc-tests/gcov.exp index c8f20e1..4d427c8 100644 --- a/gcc/testsuite/gcc.misc-tests/gcov.exp +++ b/gcc/testsuite/gcc.misc-tests/gcov.exp @@ -21,12 +21,19 @@ load_lib gcc-dg.exp load_lib gcov.exp global GCC_UNDER_TEST +global GCOV_UNDER_TEST -# For now find gcov in the same directory as $GCC_UNDER_TEST. -if { ![is_remote host] && [string match "*/*" [lindex $GCC_UNDER_TEST 0]] } { - set GCOV [file dirname [lindex $GCC_UNDER_TEST 0]]/[gcc-transform-out-of-tree gcov] +# For now find gcov in the same directory as $GCC_UNDER_TEST, unless +# GCOV_UNDER_TEST is defined. + +if ![info exists GCOV_UNDER_TEST] { + if { ![is_remote host] && [string match "*/*" [lindex $GCC_UNDER_TEST 0]] } { + set GCOV [file dirname [lindex $GCC_UNDER_TEST 0]]/[gcc-transform-out-of-tree gcov] + } else { + set GCOV [gcc-transform-out-of-tree gcov] + } } else { - set GCOV [gcc-transform-out-of-tree gcov] + set GCOV $GCOV_UNDER_TEST } # Initialize harness. diff --git a/gcc/testsuite/gcc.target/aarch64/_Float16_cmp_1.c b/gcc/testsuite/gcc.target/aarch64/_Float16_cmp_1.c new file mode 100644 index 0000000..e49ace1 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/_Float16_cmp_1.c @@ -0,0 +1,54 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -march=armv8.2-a+fp16" } */ + +/* +** test_fcmp_store: +** fcmp h0, h1 +** cset w0, eq +** ret +*/ +int +test_fcmp_store(_Float16 a, _Float16 b) +{ + return a == b; +} + +/* +** test_fcmpe_store: +** fcmpe h0, h1 +** cset w0, mi +** ret +*/ +int +test_fcmpe_store(_Float16 a, _Float16 b) +{ + return a < b; +} + +/* +** test_fcmp_branch: +** fcmp h0, h1 +** ... +*/ +_Float16 +test_fcmp_branch(_Float16 a, _Float16 b) +{ + if (a == b) + return a * b; + return a; +} + +/* +** test_fcmpe_branch: +** fcmpe h0, h1 +** ... +*/ +_Float16 +test_fcmpe_branch(_Float16 a, _Float16 b) +{ + if (a < b) + return a * b; + return a; +} + +/* { dg-final { check-function-bodies "**" "" "" } } */
\ No newline at end of file diff --git a/gcc/testsuite/gcc.target/aarch64/_Float16_cmp_2.c b/gcc/testsuite/gcc.target/aarch64/_Float16_cmp_2.c new file mode 100644 index 0000000..0ff7cda --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/_Float16_cmp_2.c @@ -0,0 +1,7 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -march=armv8.2-a+nofp16" } */ + +#include "_Float16_cmp_1.c" + +/* { dg-final { scan-assembler-not {\tfcmp\th[0-9]+} } } */ +/* { dg-final { scan-assembler-not {\tfcmpe\th[0-9]+} } } */ diff --git a/gcc/testsuite/gcc.target/aarch64/bic-1.c b/gcc/testsuite/gcc.target/aarch64/bic-1.c new file mode 100644 index 0000000..65e1514 --- /dev/null +++ b/gcc/testsuite/gcc.target/aarch64/bic-1.c @@ -0,0 +1,40 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ +/* { dg-final { check-function-bodies "**" "" "" } } */ + +/* PR rtl-optmization/111949 */ + +/* +**func1: +** bic w([0-9]+), w0, w1 +** and w0, w\1, 1 +** ret +*/ + +unsigned func1(unsigned a, bool b) +{ + int c = a & b; + return (c ^ a)&1; +} + +/* +**func2: +** bic w([0-9]+), w1, w0 +** and w0, w\1, 255 +** ret +*/ +unsigned func2(bool a, bool b) +{ + return ~a & b; +} + +/* +**func3: +** bic w([0-9]+), w1, w0 +** and w0, w\1, 1 +** ret +*/ +bool func3(bool a, unsigned char b) +{ + return !a & b; +} diff --git a/gcc/testsuite/gcc.target/aarch64/pragma_cpp_predefs_4.c b/gcc/testsuite/gcc.target/aarch64/pragma_cpp_predefs_4.c index dcac6d5..3799fb4 100644 --- a/gcc/testsuite/gcc.target/aarch64/pragma_cpp_predefs_4.c +++ b/gcc/testsuite/gcc.target/aarch64/pragma_cpp_predefs_4.c @@ -315,3 +315,18 @@ #ifndef __ARM_FEATURE_FP8DOT2 #error Foo #endif + +#pragma GCC target "arch=armv9.4-a" +#ifdef __ARM_FEATURE_FAMINMAX +#error Foo +#endif + +#pragma GCC target "arch=armv9.5-a" +#ifndef __ARM_FEATURE_FAMINMAX +#error Foo +#endif + +#pragma GCC target "arch=armv8-a+faminmax" +#ifndef __ARM_FEATURE_FAMINMAX +#error Foo +#endif diff --git a/gcc/testsuite/gcc.target/alpha/memcpy-nested-offset-long.c b/gcc/testsuite/gcc.target/alpha/memcpy-nested-offset-long.c new file mode 100644 index 0000000..631d14f --- /dev/null +++ b/gcc/testsuite/gcc.target/alpha/memcpy-nested-offset-long.c @@ -0,0 +1,76 @@ +/* { dg-do compile } */ +/* { dg-options "" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" } } */ + +typedef unsigned int __attribute__ ((mode (DI))) int64_t; +typedef unsigned int __attribute__ ((mode (SI))) int32_t; + +typedef union + { + int32_t l[8]; + } +val; + +typedef struct + { + int32_t l[2]; + val v; + } +tre; + +typedef struct + { + int32_t l[3]; + tre t; + } +due; + +typedef struct + { + val v; + int64_t q; + int32_t l[2]; + due d; + } +uno; + +void +memcpy_nested_offset_long (uno *u) +{ + u->d.t.v = u->v; +} + +/* Expect assembly such as: + + ldq $4,0($16) + ldq $3,8($16) + ldq $2,16($16) + srl $4,32,$7 + ldq $1,24($16) + srl $3,32,$6 + stl $4,68($16) + srl $2,32,$5 + stl $7,72($16) + srl $1,32,$4 + stl $3,76($16) + stl $6,80($16) + stl $2,84($16) + stl $5,88($16) + stl $1,92($16) + stl $4,96($16) + + that is with four quadword loads at offsets 0, 8, 16, 24 each and + eight longword stores at offsets 68, 72, 76, 80, 84, 88, 92, 96 each. */ + +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,0\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,8\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,16\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,24\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,68\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,72\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,76\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,80\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,84\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,88\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,92\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstl\\s\\\$\[0-9\]+,96\\\(\\\$16\\\)\\s" 1 } } */ diff --git a/gcc/testsuite/gcc.target/alpha/memcpy-nested-offset-quad.c b/gcc/testsuite/gcc.target/alpha/memcpy-nested-offset-quad.c new file mode 100644 index 0000000..1d2227e --- /dev/null +++ b/gcc/testsuite/gcc.target/alpha/memcpy-nested-offset-quad.c @@ -0,0 +1,64 @@ +/* { dg-do compile } */ +/* { dg-options "" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" } } */ + +typedef unsigned int __attribute__ ((mode (DI))) int64_t; +typedef unsigned int __attribute__ ((mode (SI))) int32_t; + +typedef union + { + int32_t l[8]; + } +val; + +typedef struct + { + int32_t l[2]; + val v; + } +tre; + +typedef struct + { + int32_t l[3]; + tre t; + } +due; + +typedef struct + { + val v; + int64_t q; + int32_t l[3]; + due d; + } +uno; + +void +memcpy_nested_offset_quad (uno *u) +{ + u->d.t.v = u->v; +} + +/* Expect assembly such as: + + ldq $4,0($16) + ldq $3,8($16) + ldq $2,16($16) + ldq $1,24($16) + stq $4,72($16) + stq $3,80($16) + stq $2,88($16) + stq $1,96($16) + + that is with four quadword loads at offsets 0, 8, 16, 24 each + and four quadword stores at offsets 72, 80, 88, 96 each. */ + +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,0\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,8\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,16\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sldq\\s\\\$\[0-9\]+,24\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstq\\s\\\$\[0-9\]+,72\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstq\\s\\\$\[0-9\]+,80\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstq\\s\\\$\[0-9\]+,88\\\(\\\$16\\\)\\s" 1 } } */ +/* { dg-final { scan-assembler-times "\\sstq\\s\\\$\[0-9\]+,96\\\(\\\$16\\\)\\s" 1 } } */ diff --git a/gcc/testsuite/gcc.target/i386/recip-vec-divf-fma.c b/gcc/testsuite/gcc.target/i386/recip-vec-divf-fma.c new file mode 100644 index 0000000..ad9e07b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/recip-vec-divf-fma.c @@ -0,0 +1,12 @@ +/* { dg-do compile } */ +/* { dg-options "-Ofast -mfma -mavx2" } */ +/* { dg-final { scan-assembler-times {(?n)vfn?m(add|sub)[1-3]*ps} 2 } } */ + +typedef float v4sf __attribute__((vector_size(16))); +/* (a - (rcp(b) * a * b)) * rcp(b) + rcp(b) * a */ + +v4sf +foo (v4sf a, v4sf b) +{ + return a / b; +} diff --git a/gcc/testsuite/gcc.target/mips/clear-cache-1.c b/gcc/testsuite/gcc.target/mips/clear-cache-1.c index f1554f5..cd11c66 100644 --- a/gcc/testsuite/gcc.target/mips/clear-cache-1.c +++ b/gcc/testsuite/gcc.target/mips/clear-cache-1.c @@ -1,7 +1,7 @@ /* { dg-do compile } */ /* { dg-options "-msynci isa_rev>=2" } */ /* { dg-final { scan-assembler "\tsynci\t" } } */ -/* { dg-final { scan-assembler "\tjr.hb\t" } } */ +/* { dg-final { scan-assembler "\tjrc?.hb\t" } } */ /* { dg-final { scan-assembler-not "_flush_cache|mips_sync_icache|_cacheflush" } } */ NOMIPS16 void f() diff --git a/gcc/testsuite/gcc.target/mips/memcpy-2.c b/gcc/testsuite/gcc.target/mips/memcpy-2.c new file mode 100644 index 0000000..df0cd18 --- /dev/null +++ b/gcc/testsuite/gcc.target/mips/memcpy-2.c @@ -0,0 +1,12 @@ +/* { dg-do compile } */ +/* { dg-options "isa_rev<=5 -fdump-rtl-expand" } */ +/* { dg-skip-if "code quality test" { *-*-* } { "-Os" } { "" } } */ + +__attribute__((nomips16)) +void +f1 (char *p) +{ + __builtin_memcpy (p, "12345", 5); +} + +/* { dg-final { scan-rtl-dump "mem/u.*mem/u" "expand" } } */ diff --git a/gcc/testsuite/gcc.target/powerpc/power11-3.c b/gcc/testsuite/gcc.target/powerpc/power11-3.c index fa1aedd..56bf881 100644 --- a/gcc/testsuite/gcc.target/powerpc/power11-3.c +++ b/gcc/testsuite/gcc.target/powerpc/power11-3.c @@ -1,5 +1,6 @@ /* { dg-do compile } */ /* { dg-options "-mdejagnu-cpu=power8 -O2" } */ +/* { dg-require-ifunc "" } */ /* Check if we can set the power11 target via a target_clones attribute. */ diff --git a/gcc/testsuite/gcc.target/riscv/bext-ext-2.c b/gcc/testsuite/gcc.target/riscv/bext-ext-2.c new file mode 100644 index 0000000..aa170d0 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/bext-ext-2.c @@ -0,0 +1,74 @@ +/* { dg-do compile } */ +/* { dg-options "-march=rv64gcb -mabi=lp64" } */ +/* { dg-skip-if "" { *-*-* } { "-O0" } } */ + +struct obstack; +struct bitmap_head_def; +typedef struct bitmap_head_def *bitmap; +struct obstack +{ + long chunk_size; + struct _obstack_chunk *chunk; + char *object_base; + char *next_free; + char *chunk_limit; + long int temp; + int alignment_mask; + + + + struct _obstack_chunk *(*chunkfun) (void *, long); + void (*freefun) (void *, struct _obstack_chunk *); + void *extra_arg; + unsigned use_extra_arg:1; + unsigned maybe_empty_object:1; + + + + unsigned alloc_failed:1; + + +}; + +typedef unsigned long BITMAP_WORD; +typedef struct bitmap_obstack { + struct bitmap_element_def *elements; + struct bitmap_head_def *heads; + struct obstack obstack; +} bitmap_obstack; +typedef struct bitmap_element_def { + struct bitmap_element_def *next; + struct bitmap_element_def *prev; + unsigned int indx; + BITMAP_WORD bits[((128 + (8 + * 8 * 1u) - 1) / (8 + * 8 * 1u))]; +} bitmap_element; +bitmap_element *bitmap_find_bit (bitmap, unsigned int); + + +int +bitmap_bit_p (bitmap head, int bit) +{ + bitmap_element *ptr; + unsigned bit_num; + unsigned word_num; + + ptr = bitmap_find_bit (head, bit); + if (ptr == 0) + return 0; + + bit_num = bit % (8 + * 8 * 1u); + word_num = bit / (8 + * 8 * 1u) % ((128 + (8 + * 8 * 1u) - 1) / (8 + * 8 * 1u)); + + return (ptr->bits[word_num] >> bit_num) & 1; +} + +/* { dg-final { scan-assembler-times "bext\t" 1 } } */ +/* { dg-final { scan-assembler-not "slr\t"} } */ +/* { dg-final { scan-assembler-not "andi\t"} } */ + diff --git a/gcc/testsuite/gcc.target/riscv/mcpu-xt-c908.c b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c908.c new file mode 100644 index 0000000..cb28baf --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c908.c @@ -0,0 +1,48 @@ +/* { dg-do compile } */ +/* { dg-skip-if "-march given" { *-*-* } { "-march=*" } } */ +/* { dg-options "-mcpu=xt-c908" { target { rv64 } } } */ +/* XuanTie C908 => rv64imafdc_zicbom_zicbop_zicboz_zicntr_zicsr_zifencei_ +zihintpause_zihpm_zfh_zba_zbb_zbc_zbs_sstc_svinval_svnapot_svpbmt_xtheadba_ +xtheadbb_xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_xtheadmac_ +xtheadmemidx_xtheadmempair_xtheadsync */ + +#if !((__riscv_xlen == 64) \ + && !defined(__riscv_32e) \ + && defined(__riscv_mul) \ + && defined(__riscv_atomic) \ + && (__riscv_flen == 64) \ + && defined(__riscv_compressed) \ + && defined(__riscv_zicbom) \ + && defined(__riscv_zicbop) \ + && defined(__riscv_zicboz) \ + && defined(__riscv_zicntr) \ + && defined(__riscv_zicsr) \ + && defined(__riscv_zifencei) \ + && defined(__riscv_zihintpause) \ + && defined(__riscv_zihpm) \ + && defined(__riscv_zfh) \ + && defined(__riscv_zba) \ + && defined(__riscv_zbb) \ + && defined(__riscv_zbc) \ + && defined(__riscv_zbs) \ + && defined(__riscv_sstc) \ + && defined(__riscv_svinval) \ + && defined(__riscv_svnapot) \ + && defined(__riscv_svpbmt) \ + && defined(__riscv_xtheadba) \ + && defined(__riscv_xtheadbb) \ + && defined(__riscv_xtheadbs) \ + && defined(__riscv_xtheadcmo) \ + && defined(__riscv_xtheadcondmov) \ + && defined(__riscv_xtheadfmemidx) \ + && defined(__riscv_xtheadmac) \ + && defined(__riscv_xtheadmemidx) \ + && defined(__riscv_xtheadmempair) \ + && defined(__riscv_xtheadsync)) +#error "unexpected arch" +#endif + +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/mcpu-xt-c908v.c b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c908v.c new file mode 100644 index 0000000..1b1ee18 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c908v.c @@ -0,0 +1,50 @@ +/* { dg-do compile } */ +/* { dg-skip-if "-march given" { *-*-* } { "-march=*" } } */ +/* { dg-options "-mcpu=xt-c908v" { target { rv64 } } } */ +/* XuanTie C908v => rv64imafdcv_zicbom_zicbop_zicboz_zicntr_zicsr_zifencei_ +zihintpause_zihpm_zfh_zba_zbb_zbc_zbs_sstc_svinval_svnapot_svpbmt_xtheadba_ +xtheadbb_xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_xtheadmac_ +xtheadmemidx_xtheadmempair_xtheadsync_xtheadvdot */ + +#if !((__riscv_xlen == 64) \ + && !defined(__riscv_32e) \ + && defined(__riscv_mul) \ + && defined(__riscv_atomic) \ + && (__riscv_flen == 64) \ + && defined(__riscv_compressed) \ + && defined(__riscv_v) \ + && defined(__riscv_zicbom) \ + && defined(__riscv_zicbop) \ + && defined(__riscv_zicboz) \ + && defined(__riscv_zicntr) \ + && defined(__riscv_zicsr) \ + && defined(__riscv_zifencei) \ + && defined(__riscv_zihintpause) \ + && defined(__riscv_zihpm) \ + && defined(__riscv_zfh) \ + && defined(__riscv_zba) \ + && defined(__riscv_zbb) \ + && defined(__riscv_zbc) \ + && defined(__riscv_zbs) \ + && defined(__riscv_sstc) \ + && defined(__riscv_svinval) \ + && defined(__riscv_svnapot) \ + && defined(__riscv_svpbmt) \ + && defined(__riscv_xtheadba) \ + && defined(__riscv_xtheadbb) \ + && defined(__riscv_xtheadbs) \ + && defined(__riscv_xtheadcmo) \ + && defined(__riscv_xtheadcondmov) \ + && defined(__riscv_xtheadfmemidx) \ + && defined(__riscv_xtheadmac) \ + && defined(__riscv_xtheadmemidx) \ + && defined(__riscv_xtheadmempair) \ + && defined(__riscv_xtheadsync) \ + && defined (__riscv__xtheadvdot)) +#error "unexpected arch" +#endif + +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/mcpu-xt-c910.c b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c910.c new file mode 100644 index 0000000..1e27665 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c910.c @@ -0,0 +1,35 @@ +/* { dg-do compile } */ +/* { dg-skip-if "-march given" { *-*-* } { "-march=*" } } */ +/* { dg-options "-mcpu=xt-c910" { target { rv64 } } } */ +/* XuanTie C910 => rv64imafdc_zicntr_zicsr_zifencei_zihpm_zfh_xtheadba_ +xtheadbb_xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_xtheadmac_ +xtheadmemidx_xtheadmempair_xtheadsync */ + +#if !((__riscv_xlen == 64) \ + && !defined(__riscv_32e) \ + && defined(__riscv_mul) \ + && defined(__riscv_atomic) \ + && (__riscv_flen == 64) \ + && defined(__riscv_compressed) \ + && defined(__riscv_zicntr) \ + && defined(__riscv_zicsr) \ + && defined(__riscv_zifencei) \ + && defined(__riscv_zihpm) \ + && defined(__riscv_zfh) \ + && defined(__riscv_xtheadba) \ + && defined(__riscv_xtheadbb) \ + && defined(__riscv_xtheadbs) \ + && defined(__riscv_xtheadcmo) \ + && defined(__riscv_xtheadcondmov) \ + && defined(__riscv_xtheadfmemidx) \ + && defined(__riscv_xtheadmac) \ + && defined(__riscv_xtheadmemidx) \ + && defined(__riscv_xtheadmempair) \ + && defined(__riscv_xtheadsync)) +#error "unexpected arch" +#endif + +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/mcpu-xt-c910v2.c b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c910v2.c new file mode 100644 index 0000000..6a54f09 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c910v2.c @@ -0,0 +1,51 @@ +/* { dg-do compile } */ +/* { dg-skip-if "-march given" { *-*-* } { "-march=*" } } */ +/* { dg-options "-mcpu=xt-c910v2" { target { rv64 } } } */ +/* XuanTie C910v2 => rv64imafdc_zicbom_zicbop_zicboz_zicntr_zicond_zicsr_ +zifencei _zihintntl_zihintpause_zihpm_zawrs_zfa_zfbfmin_zfh_zca_zcb_zcd_zba_ +zbb_zbc_xtheadba_xtheadbb_xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_ +xtheadmac_xtheadmemidx_xtheadmempair_xtheadsync */ + +#if !((__riscv_xlen == 64) \ + && !defined(__riscv_32e) \ + && defined(__riscv_mul) \ + && defined(__riscv_atomic) \ + && (__riscv_flen == 64) \ + && defined(__riscv_compressed) \ + && defined(__riscv_zicbom) \ + && defined(__riscv_zicbop) \ + && defined(__riscv_zicboz) \ + && defined(__riscv_zicntr) \ + && defined(__riscv_zicond) \ + && defined(__riscv_zicsr) \ + && defined(__riscv_zifencei ) \ + && defined(__riscv_zihintntl) \ + && defined(__riscv_zihintpause) \ + && defined(__riscv_zihpm) \ + && defined(__riscv_zawrs) \ + && defined(__riscv_zfa) \ + && defined(__riscv_zfbfmin) \ + && defined(__riscv_zfh) \ + && defined(__riscv_zca) \ + && defined(__riscv_zcb) \ + && defined(__riscv_zcd) \ + && defined(__riscv_zba) \ + && defined(__riscv_zbb) \ + && defined(__riscv_zbc) \ + && defined(__riscv_xtheadba) \ + && defined(__riscv_xtheadbb) \ + && defined(__riscv_xtheadbs) \ + && defined(__riscv_xtheadcmo) \ + && defined(__riscv_xtheadcondmov) \ + && defined(__riscv_xtheadfmemidx) \ + && defined(__riscv_xtheadmac) \ + && defined(__riscv_xtheadmemidx) \ + && defined(__riscv_xtheadmempair) \ + && defined(__riscv_xtheadsync)) +#error "unexpected arch" +#endif + +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/mcpu-xt-c920.c b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c920.c new file mode 100644 index 0000000..6bcd687 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c920.c @@ -0,0 +1,34 @@ +/* { dg-do compile } */ +/* { dg-skip-if "-march given" { *-*-* } { "-march=*" } } */ +/* { dg-options "-mcpu=xt-c920" { target { rv64 } } } */ +/* XuanTie c920 => rv64imafdc_zicntr_zicsr_zifencei_zihpm_zfh_"xtheadba_xtheadbb_xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_xtheadmac_xtheadmemidx_xtheadmempair_xtheadsync_xtheadvector */ + +#if !((__riscv_xlen == 64) \ + && !defined(__riscv_32e) \ + && defined(__riscv_mul) \ + && defined(__riscv_atomic) \ + && (__riscv_flen == 64) \ + && defined(__riscv_compressed) \ + && defined(__riscv_zicntr) \ + && defined(__riscv_zicsr) \ + && defined(__riscv_zifencei) \ + && defined(__riscv_zihpm) \ + && defined(__riscv_zfh) \ + && defined(__riscv_xtheadba) \ + && defined(__riscv_xtheadbb) \ + && defined(__riscv_xtheadbs) \ + && defined(__riscv_xtheadcmo) \ + && defined(__riscv_xtheadcondmov) \ + && defined(__riscv_xtheadfmemidx) \ + && defined(__riscv_xtheadmac) \ + && defined(__riscv_xtheadmemidx) \ + && defined(__riscv_xtheadmempair) \ + && defined(__riscv_xtheadsync) \ + && defined(__riscv_xtheadvector)) +#error "unexpected arch" +#endif + +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/mcpu-xt-c920v2.c b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c920v2.c new file mode 100644 index 0000000..36a6267 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/mcpu-xt-c920v2.c @@ -0,0 +1,56 @@ +/* { dg-do compile } */ +/* { dg-skip-if "-march given" { *-*-* } { "-march=*" } } */ +/* { dg-options "-mcpu=xt-c920v2" { target { rv64 } } } */ +/* XuanTie C920v2 => rv64imafdcv_zicbom_zicbop_zicboz_zicntr_zicond_zicsr_zifencei _zihintntl_zihintpause_zihpm_zawrs_zfa_zfbfmin_zfh_zca_zcb_zcd_zba_zbb_zbc_zbs_zvfbfmin_zvfbfwma_zvfh_sscofpmf_sstc_svinval_svnapot_svpbmt_xtheadba_xtheadbb_xtheadbs_xtheadcmo_xtheadcondmov_xtheadfmemidx_xtheadsync_xtheadvdot */ + +#if !((__riscv_xlen == 64) \ + && !defined(__riscv_32e) \ + && defined(__riscv_mul) \ + && defined(__riscv_atomic) \ + && (__riscv_flen == 64) \ + && defined(__riscv_compressed) \ + && defined(__riscv_v) \ + && defined(__riscv_zicbom) \ + && defined(__riscv_zicbop) \ + && defined(__riscv_zicboz) \ + && defined(__riscv_zicntr) \ + && defined(__riscv_zicond) \ + && defined(__riscv_zicsr) \ + && defined(__riscv_zifencei ) \ + && defined(__riscv_zihintntl) \ + && defined(__riscv_zihintpause) \ + && defined(__riscv_zihpm) \ + && defined(__riscv_zawrs) \ + && defined(__riscv_zfa) \ + && defined(__riscv_zfbfmin) \ + && defined(__riscv_zfh) \ + && defined(__riscv_zca) \ + && defined(__riscv_zcb) \ + && defined(__riscv_zcd) \ + && defined(__riscv_zba) \ + && defined(__riscv_zbb) \ + && defined(__riscv_zbc) \ + && defined(__riscv_zbs) \ + && defined(__riscv_zvfbfmin) \ + && defined(__riscv_zvfbfwma) \ + && defined(__riscv_zvfh) \ + && defined(__riscv_sscofpmf) \ + && defined(__riscv_sstc) \ + && defined(__riscv_svinval) \ + && defined(__riscv_svnapot) \ + && defined(__riscv_svpbmt) \ + && defined(__riscv_xtheadba) \ + && defined(__riscv_xtheadbb) \ + && defined(__riscv_xtheadbs) \ + && defined(__riscv_xtheadcmo) \ + && defined(__riscv_xtheadcondmov) \ + && defined(__riscv_xtheadfmemidx) \ + && defined(__riscv_xtheadsync) \ + && defined(__riscv_xtheadvdot)) +#error "unexpected arch" +#endif + +int main() +{ + return 0; +} diff --git a/gcc/testsuite/gcc.target/riscv/pr118410-1.c b/gcc/testsuite/gcc.target/riscv/pr118410-1.c new file mode 100644 index 0000000..4a8b847 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/pr118410-1.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ +/* { dg-skip-if "" { *-*-* } { "-O0" "-Og" } } */ +/* { dg-options "-march=rv64gcb -mabi=lp64d" { target { rv64} } } */ +/* { dg-options "-march=rv32gcb -mabi=ilp32" { target { rv32} } } */ + +long orlow(long x) { return x | ((1L << 24) - 1); } + +/* { dg-final { scan-assembler-times "orn\t" 1 } } */ +/* { dg-final { scan-assembler-not "addi\t" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/pr118410-2.c b/gcc/testsuite/gcc.target/riscv/pr118410-2.c new file mode 100644 index 0000000..b63a1d9 --- /dev/null +++ b/gcc/testsuite/gcc.target/riscv/pr118410-2.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ +/* { dg-skip-if "" { *-*-* } { "-O0" "-Og" } } */ +/* { dg-options "-march=rv64gcb -mabi=lp64d" { target { rv64} } } */ +/* { dg-options "-march=rv32gcb -mabi=ilp32" { target { rv32} } } */ + +long xorlow(long x) { return x ^ ((1L << 24) - 1); } + +/* { dg-final { scan-assembler-times "xnor\t" 1 } } */ +/* { dg-final { scan-assembler-not "addi\t" } } */ diff --git a/gcc/testsuite/gcc.target/sh/pr111814.c b/gcc/testsuite/gcc.target/sh/pr111814.c new file mode 100644 index 0000000..a88e5d7 --- /dev/null +++ b/gcc/testsuite/gcc.target/sh/pr111814.c @@ -0,0 +1,7 @@ +/* Verify that __builtin_nan("") produces a constant matches + architecture specification. */ +/* { dg-do compile } */ + +double d = __builtin_nan (""); + +/* { dg-final { scan-assembler "\t.long\t-1\n\t.long\t2146959359\n" } } */ diff --git a/gcc/testsuite/gdc.dg/gcov.exp b/gcc/testsuite/gdc.dg/gcov.exp index a65d000..3f0234e 100644 --- a/gcc/testsuite/gdc.dg/gcov.exp +++ b/gcc/testsuite/gdc.dg/gcov.exp @@ -21,12 +21,19 @@ load_lib gdc-dg.exp load_lib gcov.exp global GDC_UNDER_TEST +global GCOV_UNDER_TEST -# For now find gcov in the same directory as $GDC_UNDER_TEST. -if { ![is_remote host] && [string match "*/*" [lindex $GDC_UNDER_TEST 0]] } { - set GCOV [file dirname [lindex $GDC_UNDER_TEST 0]]/[gcc-transform-out-of-tree gcov] +# For now find gcov in the same directory as $GDC_UNDER_TEST, unless +# GCOV_UNDER_TEST is defined. + +if ![info exists GCOV_UNDER_TEST] { + if { ![is_remote host] && [string match "*/*" [lindex $GDC_UNDER_TEST 0]] } { + set GCOV [file dirname [lindex $GDC_UNDER_TEST 0]]/[gcc-transform-out-of-tree gcov] + } else { + set GCOV [gcc-transform-out-of-tree gcov] + } } else { - set GCOV [gcc-transform-out-of-tree gcov] + set GCOV $GCOV_UNDER_TEST } # Initialize harness. diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 index 29c2b3a..7fd2085 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 @@ -9,6 +9,7 @@ program pr98903 integer :: a[*] type(team_type) :: team + team = get_team() me = this_image() n = num_images() a = 42 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 new file mode 100644 index 0000000..c35ec10 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 @@ -0,0 +1,80 @@ +!{ dg-do run } + +! Check coindexes with team= or team_number= are working. + +program coindexed_5 + use, intrinsic :: iso_fortran_env + + type(team_type) :: parentteam, team, formed_team + integer :: t_num= 42, stat = 42, lhs + integer(kind=2) :: st_num=42 + integer :: caf(2)[*] + + parentteam = get_team() + + caf = [23, 32] + form team(t_num, team, new_index=1) + form team(t_num, formed_team) + + change team(team, cell[*] => caf(2)) + ! for get_from_remote + ! Checking against caf_single is very limitted. + if (cell[1, team_number=t_num] /= 32) stop 1 + if (cell[1, team_number=st_num] /= 32) stop 2 + if (cell[1, team=parentteam] /= 32) stop 3 + + ! Check that team_number is validated + lhs = cell[1, team_number=5, stat=stat] + if (stat /= 1) stop 4 + + ! Check that only access to active teams is valid + stat = 42 + lhs = cell[1, team=formed_team, stat=stat] + if (stat /= 1) stop 5 + + ! for send_to_remote + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = 45 + if (cell /= 45) stop 11 + cell[1, team_number=st_num] = 46 + if (cell /= 46) stop 12 + cell[1, team=parentteam] = 47 + if (cell /= 47) stop 13 + + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = 0 + if (stat /= 1) stop 14 + + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = -1 + if (stat /= 1) stop 15 + + ! for transfer_between_remotes + ! Checking against caf_single is very limitted. + cell[1, team_number=t_num] = caf(1)[1, team_number=-1] + if (cell /= 23) stop 21 + cell[1, team_number=st_num] = caf(2)[1, team_number=-1] + ! cell is an alias for caf(2) and has been overwritten by caf(1)! + if (cell /= 23) stop 22 + cell[1, team=parentteam] = caf(1)[1, team= team] + if (cell /= 23) stop 23 + + ! Check that team_number is validated + stat = -1 + cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1] + if (stat /= 1) stop 24 + stat = -1 + cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat] + if (stat /= 1) stop 25 + + ! Check that only access to active teams is valid + stat = 42 + cell[1, team=formed_team, stat=stat] = caf(1)[1] + if (stat /= 1) stop 26 + stat = 42 + cell[1] = caf(1)[1, team=formed_team, stat=stat] + if (stat /= 1) stop 27 + end team +end program coindexed_5 diff --git a/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90 b/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90 new file mode 100644 index 0000000..f37d1c7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/get_team_1.f90 @@ -0,0 +1,29 @@ +!{ dg-do compile } + +! PR 97210 +! Tests get_team syntax + + use iso_fortran_env + implicit none + type(team_type) :: team, ret + integer :: level + + ret = get_team() + ret = get_team('abc') !{ dg-error "must be INTEGER" } + ret = get_team(level, 'abc') !{ dg-error "Too many arguments" } + ret = get_team([1,2]) !{ dg-error "must be a scalar" } + ret = get_team(team) !{ dg-error "must be INTEGER" } + + ret = get_team(INITIAL_TEAM) + ret = get_team(CURRENT_TEAM) + ret = get_team(PARENT_TEAM) + ret = get_team(INITIAL_TEAM, CURRENT_TEAM) !{ dg-error "Too many arguments" } + + level = INITIAL_TEAM + ret = get_team(level) + ret = get_team(99) !{ dg-error "specify one of the INITIAL_TEAM, PARENT_TEAM" } + level = 99 + ret = get_team(level) + level = get_team() !{ dg-error "Cannot convert TYPE\\(team_type\\)" } +end + diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 index 098a2bb..b7ec5a6 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 @@ -18,7 +18,7 @@ program test_image_status_1 isv = image_status(k2) ! Ok isv = image_status(k4) ! Ok isv = image_status(k8) ! Ok - isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) not yet supported" } + isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" } isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90 index 53917b5..6f453d5 100644 --- a/gcc/testsuite/gfortran.dg/coarray_10.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_10.f90 @@ -21,7 +21,7 @@ subroutine this_image_check() integer,save :: z(4)[*], i j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" } - j = this_image(dim=3) ! { dg-error "DIM argument without COARRAY argument" } + j = this_image(dim=3) ! { dg-error "'dim' argument without 'coarray' argument" } i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" } i = image_index(z, 2) ! { dg-error "must be a rank one array" } end subroutine this_image_check diff --git a/gcc/testsuite/gfortran.dg/coarray_49.f90 b/gcc/testsuite/gfortran.dg/coarray_49.f90 index 370e3fd..fd8549b 100644 --- a/gcc/testsuite/gfortran.dg/coarray_49.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_49.f90 @@ -5,5 +5,5 @@ program p integer :: x[*] - print *, image_index (x, [1.0]) ! { dg-error "shall be INTEGER" } + print *, image_index (x, [1.0]) ! { dg-error "must be INTEGER" } end diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 index 299ea62..2d8a39a 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 @@ -20,6 +20,6 @@ program test call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3) end program test -! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 6\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., res, &stat3, errmesg3, 8\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 index 8419cf9..05a1350 100644 --- a/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_16.f90 @@ -33,6 +33,6 @@ contains end function hc end program test -! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0B, 0B\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, gz, 0, 4, &stat2, errmesg2, 0, 7\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., hc, 1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_critical_2.f90 b/gcc/testsuite/gfortran.dg/coarray_critical_2.f90 new file mode 100644 index 0000000..702611c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_critical_2.f90 @@ -0,0 +1,30 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! Test critical syntax errors with stat= and errmsg= specifiers + + implicit none + integer :: istat + character(len=30) :: err + integer(kind=1) :: too_small_stat + + critical (stat=err) !{ dg-error "must be a scalar INTEGER" } + continue + end critical + + critical (stat=istat, stat=istat) !{ dg-error "Duplicate STAT" } + continue + end critical !{ dg-error "Expecting END PROGRAM" } + + critical (stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER variable" } + continue + end critical + + critical (stat=istat, errmsg=err, errmsg=err) !{ dg-error "Duplicate ERRMSG" } + continue + end critical !{ dg-error "Expecting END PROGRAM" } + + critical (stat=too_small_stat) !{ dg-error "scalar INTEGER variable of at least kind 2" } + continue + end critical +end diff --git a/gcc/testsuite/gfortran.dg/coarray_critical_3.f90 b/gcc/testsuite/gfortran.dg/coarray_critical_3.f90 new file mode 100644 index 0000000..cd609bd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_critical_3.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Test critical construct with stat= and errmsg= specifiers +! + use, intrinsic :: iso_fortran_env, only: int16 + implicit none + integer :: istat = 42 + integer(kind=int16) :: istat16 = 42 + character(len=30) :: err = 'unchanged' + integer :: fail = 0 + + critical (stat=istat, errmsg=err) + if (istat /= 0) fail = 1 + if (trim(err) /= 'unchanged') fail = 2 + end critical + + if (fail /= 0) stop fail + + critical (stat=istat16, errmsg=err) + if (istat16 /= 0) fail = 3 + if (trim(err) /= 'unchanged') fail = 4 + end critical + + if (fail /= 0) stop fail +end + +! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0, 1, 0B, &istat, &err, 30\\);" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_lock \\(caf_token\\.\[0-9\]+, 0, 1, 0B, &stat\\.\[0-9\]+, &err, 30\\);" "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token\\.\[0-9\]+, 0, 1, &stat\\.\[0-9\]+, 0B, 0\\);" 2 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 index 63cca3e..7939a79 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_1.f90 @@ -19,8 +19,8 @@ end ! { dg-final { scan-tree-dump-times "bar \\(real\\(kind=4\\)\\\[2\\\] \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } } ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } } -! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0B, 0B\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(x, caf_token.., 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 index a27d740..31a7677 100644 --- a/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90 @@ -19,8 +19,8 @@ end ! { dg-final { scan-tree-dump-times "bar \\(struct array02_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } } ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } } -! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0B, 0B\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0B\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 index 1fe2318..5a609d8 100644 --- a/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_this_image_1.f90 @@ -1,19 +1,52 @@ -! { dg-do compile } -! { dg-options "-fdump-tree-original -fcoarray=single" } +!{ dg-do run } +!{ dg-options "-fdump-tree-original -fcoarray=single" } ! -j1 = this_image(distance=4) -j2 = this_image(5) + +use, intrinsic :: iso_fortran_env, only: team_type +integer :: caf[2,*] +integer, allocatable :: res(:) +type(team_type) :: team + +form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1) +j1 = this_image() +if (j1 /= 1) then + print *, me, ":", j1 + stop 1 +endif +res = this_image(caf) +if (any (res /= [1, 1])) then + print *, me, ":", res + stop 2 +endif +j2 = this_image(caf, 1) +if (j2 /= 1) then + print *, me, ":", j2 + stop 3 +endif +j3 = this_image(team) +if (j3 /= MOD(this_image() + 43, num_images()) +1) then + print *, me, ":", j3 + stop 4 +endif +res = this_image(caf, team) +if (any(res /= [1, 1])) then + print *, me, ":", res + stop 5 +endif +j4 = this_image(caf, 1, team) +if (j4 /= 1) then + print *, me, ":", j4 + stop 6 +endif +associate(me => this_image()) +end associate k1 = num_images() -k2 = num_images(6) -k3 = num_images(distance=7) -k4 = num_images(distance=8, failed=.true.) -k5 = num_images(failed=.false.) +k2 = num_images(team) +k3 = num_images(-1) end -! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "j2 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k1 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k2 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k3 = 1;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k4 = 0;" 1 "original" } } -! { dg-final { scan-tree-dump-times "k5 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j\[1-4\] = 1;" 4 "original" } } +! { dg-final { scan-tree-dump-times "A\\.\[0-9\]+\\\[2\\\] = \\\{1, 1\\\};" 4 "original" } } +! { dg-final { scan-tree-dump "k1 = 1;" "original" } } +! { dg-final { scan-tree-dump "k2 = 1;" "original" } } +! { dg-final { scan-tree-dump "k3 = 1;" "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 index 002c897..9713e3d 100644 --- a/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_this_image_2.f90 @@ -1,19 +1,57 @@ -! { dg-do compile } -! { dg-options "-fdump-tree-original -fcoarray=lib" } +!{ dg-do run } +!{ dg-additional-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } ! -j1 = this_image(distance=4) -j2 = this_image(5) + +use, intrinsic :: iso_fortran_env, only: team_type +integer :: caf[2,*] +integer, allocatable :: res(:) +type(team_type) :: team + +form team(1, team, new_index=MOD(this_image() + 43, num_images()) + 1) + +associate(me => this_image()) +j1 = this_image() +if (j1 /= 1) then + print *, me, ":", j1 + stop 1 +endif +res = this_image(caf) +if (any (res /= [1, 1])) then + print *, me, ":", res + stop 2 +endif +j2 = this_image(caf, 1) +if (j2 /= 1) then + print *, me, ":", j2 + stop 3 +endif +j3 = this_image(team) +if (j3 /= MOD(this_image() + 43, num_images()) +1) then + print *, me, ":", j3 + stop 4 +endif +res = this_image(caf, team) +if (any(res /= [1, 1])) then + print *, me, ":", res + stop 5 +endif +j4 = this_image(caf, 1, team) +if (j4 /= 1) then + print *, me, ":", j4 + stop 6 +endif +end associate k1 = num_images() -k2 = num_images(6) -k3 = num_images(distance=7) -k4 = num_images(distance=8, failed=.true.) -k5 = num_images(failed=.false.) +k2 = num_images(team) +k3 = num_images(-1) +k4 = num_images(1) end -! { dg-final { scan-tree-dump-times "j1 = _gfortran_caf_this_image \\(4\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "j2 = _gfortran_caf_this_image \\(5\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k1 = _gfortran_caf_num_images \\(0, -1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k2 = _gfortran_caf_num_images \\(6, -1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k3 = _gfortran_caf_num_images \\(7, -1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k4 = _gfortran_caf_num_images \\(8, 1\\);" 1 "original" } } -! { dg-final { scan-tree-dump-times "k5 = _gfortran_caf_num_images \\(0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump "j1 = _gfortran_caf_this_image \\(0B\\);" "original" } } +! { dg-final { scan-tree-dump "j3 = _gfortran_caf_this_image \\(team\\);" "original" } } +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(team\\) \\+ -1;" 2 "original" } } +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = _gfortran_caf_this_image \\(0B\\) \\+ -1;" 2 "original" } } +! { dg-final { scan-tree-dump "k1 = _gfortran_caf_num_images \\(0B, 0B\\);" "original" } } +! { dg-final { scan-tree-dump "k2 = _gfortran_caf_num_images \\(team, 0B\\);" "original" } } +! { dg-final { scan-tree-dump "k3 = _gfortran_caf_num_images \\(0B, &D\\.\[0-9\]+\\);" "original" } } +! { dg-final { scan-tree-dump "k4 = _gfortran_caf_num_images \\(0B, &D\\.\[0-9\]+\\);" "original" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 new file mode 100644 index 0000000..b8433b2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_this_image_3.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } + + +use, intrinsic :: iso_fortran_env, only: team_type +integer :: caf[*] +integer, allocatable :: res(:) +type(team_type) :: team + +j1 = this_image() ! ok +j1 = this_image('bar') !{ dg-error "First argument of 'this_image'" } +res = this_image(caf) ! ok +res = this_image(caf, caf) !{ dg-error "Second argument of 'this_image'" } +j2 = this_image(caf, 1) ! ok +j3 = this_image(caf, 'foo') !{ dg-error "Second argument of 'this_image'" } +j4 = this_image(caf, [1, 2]) !{ dg-error "Second argument of 'this_image'" } +j5 = this_image(team) ! ok +j6 = this_image(team, caf) !{ dg-error "Second argument of 'this_image'" } +res = this_image(caf, team) ! ok +res = this_image(caf, team, 'foo') !{ dg-error "shall be of type 'team_type'" } +j4 = this_image(caf, 1, team) ! ok +j5 = this_image(caf, 1, team, 'baz') !{ dg-error "Too many arguments in call" } +j6 = this_image(dim=1, team=team, coarray=caf) + +k1 = num_images() ! ok +k2 = num_images(team) ! ok +k3 = num_images(team, 2) !{ dg-error "Too many arguments in call to" } +k4 = num_images(1) ! ok +k5 = num_images('abc') !{ dg-error "'team/team_number' argument of 'num_images' intrinsic" } +k6 = num_images(1, team) !{ dg-error "Too many arguments in call to" } +end diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 index 0c8a6ad..a7fa7c3 100644 --- a/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 +++ b/gcc/testsuite/gfortran.dg/do_concurrent_all_clauses.f90 @@ -18,7 +18,7 @@ program do_concurrent_all_clauses squared = i * i arr(i) = temp2 + squared sum = sum + arr(i) - max_val = max(max_val, arr(i)) ! { dg-error "Reference to impure function" } + max_val = max(max_val, arr(i)) end block end do print *, arr, sum, max_val diff --git a/gcc/testsuite/gfortran.dg/move_alloc_11.f90 b/gcc/testsuite/gfortran.dg/move_alloc_11.f90 new file mode 100644 index 0000000..d33e0ce --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_11.f90 @@ -0,0 +1,23 @@ +!{ dg-do compile } + +! General error checking for move_alloc parameter list. + +integer, allocatable :: i, o +integer :: st, s2 +character(30) :: e, e2 + + call move_alloc(i, o, STAT=st) + call move_alloc(i, o, STAT=st, STAT=s2) !{ dg-error "Keyword 'stat' at \\(1\\) has already appeared in the current argument list" } + call move_alloc(i, o, STAT=e) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" } + call move_alloc(i, o, STAT=[st, s2]) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" } + call move_alloc(i, o, STAT=.TRUE.) !{ dg-error "STAT= argument at \\(1\\) must be a scalar INTEGER variable of at least kind 2" } + + call move_alloc(i, o, STAT=st, ERRMSG=e) + call move_alloc(i, o, ERRMSG=e) + call move_alloc(i, o, ERRMSG=e, ERRMSG=e2) !{ dg-error "Keyword 'errmsg' at \\(1\\) has already appeared in the current argument list" } + call move_alloc(i, o, ERRMSG=st) !{ dg-error "ERRMSG= argument at \\(1\\) must be a scalar CHARACTER variable of at least kind 1" } + call move_alloc(i, o, ERRMSG=.TRUE.) !{ dg-error "ERRMSG= argument at \\(1\\) must be a scalar CHARACTER variable of at least kind 1" } + + +end + diff --git a/gcc/testsuite/gfortran.dg/num_images_1.f90 b/gcc/testsuite/gfortran.dg/num_images_1.f90 index dac34ba..e03857c 100644 --- a/gcc/testsuite/gfortran.dg/num_images_1.f90 +++ b/gcc/testsuite/gfortran.dg/num_images_1.f90 @@ -5,5 +5,5 @@ program foo implicit none integer k5 - k5 = num_images(failed=.false.) ! { dg-error "argument to NUM_IMAGES" } + k5 = num_images(failed=.false.) ! { dg-error "Cannot find keyword named 'failed' in call to 'num_images'" } end program foo diff --git a/gcc/testsuite/gfortran.dg/pr102458.f90 b/gcc/testsuite/gfortran.dg/pr102458.f90 index 555e497..7c13084 100644 --- a/gcc/testsuite/gfortran.dg/pr102458.f90 +++ b/gcc/testsuite/gfortran.dg/pr102458.f90 @@ -9,7 +9,7 @@ end program p block - integer :: a(get_team()) = 1 ! { dg-error "Automatic array" } + integer :: a(get_team()) = 1 ! { dg-error "Automatic array | ISO_FORTRAN_ENV | must be of INTEGER" } print *, a end block end diff --git a/gcc/testsuite/gfortran.dg/pr119836_1.f90 b/gcc/testsuite/gfortran.dg/pr119836_1.f90 new file mode 100644 index 0000000..984e2d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_1.f90 @@ -0,0 +1,18 @@ +! +! { dg-do run } +! +! PR fortran/119836 +! +program p + implicit none + integer, parameter :: n = 4 + integer :: i + integer :: y(n), x(n) + do concurrent (i=1:n) + x(i) = shiftl (i,1) ! accepted + block + y(i) = shiftl (i,1) ! wrongly rejected + end block + end do + if (any(x /= y)) stop 1 +end program p diff --git a/gcc/testsuite/gfortran.dg/pr119836_2.f90 b/gcc/testsuite/gfortran.dg/pr119836_2.f90 new file mode 100644 index 0000000..5e2d0c9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_2.f90 @@ -0,0 +1,21 @@ +! +! { dg-do compile } +! +! PR fortran/119836 +! +! Although intrinsic functions contained within the Fortran standard +! are pure procedures, many of the additional intrinsic functions +! supplied in libgfortran are impure. RAND() is one such function. +! +program foo + implicit none + integer i + real x(4) + do concurrent (i=1:4) + x = rand() ! { dg-error "Reference to impure function" } + block + x = rand() ! { dg-error "Reference to impure function" } + end block + end do + print *, x +end program foo diff --git a/gcc/testsuite/gfortran.dg/pr119836_3.f90 b/gcc/testsuite/gfortran.dg/pr119836_3.f90 new file mode 100644 index 0000000..69a5fcf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_3.f90 @@ -0,0 +1,30 @@ +! +! { dg-do run } +! +! PR fortran/119836 +! +program p + implicit none + integer, parameter :: n = 4 + integer :: i + integer :: y(n), x(n) + x = [(i,i=1,n)] + do concurrent (i=1:n) + call bar(x, y) + end do + if (any(x /= y)) stop 1 + x = 2 * x + do concurrent (i=1:n) + block + call bar(x, y) + end block + end do + if (any(x /= y)) stop 1 + + contains + elemental subroutine bar(x, y) + integer, intent(in) :: x + integer, intent(out) :: y + y = x + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/pr119836_4.f90 b/gcc/testsuite/gfortran.dg/pr119836_4.f90 new file mode 100644 index 0000000..dc6f72b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr119836_4.f90 @@ -0,0 +1,30 @@ +! +! { dg-do compile } +! +! PR fortran/119836 +! +program p + implicit none + integer, parameter :: n = 4 + integer :: i + integer :: y(n), x(n) + x = [(i,i=1,n)] + do concurrent (i=1:n) + call bar(x, y) ! { dg-error "Subroutine call" } + end do + if (any(x /= y)) stop 1 + x = 2 * x + do concurrent (i=1:n) + block + call bar(x, y) ! { dg-error "Subroutine call" } + end block + end do + if (any(x /= y)) stop 1 + + contains + subroutine bar(x, y) + integer, intent(in) :: x(:) + integer, intent(out) :: y(:) + y = x + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/team_change_2.f90 b/gcc/testsuite/gfortran.dg/team_change_2.f90 new file mode 100644 index 0000000..66fe63c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_change_2.f90 @@ -0,0 +1,93 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Tests change team syntax + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat + character(len=30) :: err + integer :: caf[*], caf2[*] + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team !{ dg-error "Syntax error in CHANGE TEAM statement" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (err) !{ dg-error "must be a scalar expression of type TEAM_TYPE" } + continue + end team + + change team (team, stat=err) !{ dg-error "must be a scalar INTEGER" } + continue + end team + + change team (team, stat=istat, stat=istat) !{ dg-error "Duplicate STAT" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, stat=istat, errmsg=istat) !{ dg-error "must be a scalar CHARACTER variable" } + continue + end team + + change team (team, stat=istat, errmsg=str, errmsg=str) !{ dg-error "Duplicate ERRMSG" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + +1234 if (istat /= 0) stop 1 !{ dg-error "leaves CHANGE TEAM" } + + change team (team) + go to 1234 !{ dg-error "leaves CHANGE TEAM" } + end team + + call foo(team) + + ! F2018, C1113 + change team (team, caf[3,*] => caf) !{ dg-error "Codimension decl name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, c[3,*] => caf, c => caf2) !{ dg-error "Duplicate name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, c[3,*] => caf, caf => caf2) !{ dg-error "Codimension decl name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + change team (team, caf2[3,*] => caf, c => caf2) !{ dg-error "Codimension decl name" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + ! F2018, C1114 + change team (team, c => [caf, caf2]) !{ dg-error "a named coarray" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + ! F2018, C1115 + change team (team, c => caf, c2 => caf) !{ dg-error "duplicates selector at" } + continue + end team !{ dg-error "Expecting END PROGRAM statement" } + + t: change team(team) + exit t + end team t + + change team(team) + exit t !{ dg-error "EXIT statement at \\(1\\) is not within construct 't'" } + end team +contains + subroutine foo(team) + type(team_type) :: team + + change team (team) + return !{ dg-error "Image control statement" } + end team + end subroutine +end + diff --git a/gcc/testsuite/gfortran.dg/team_change_3.f90 b/gcc/testsuite/gfortran.dg/team_change_3.f90 new file mode 100644 index 0000000..bc30c40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_change_3.f90 @@ -0,0 +1,29 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Tests change team stat= and errmsg= specifiers + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat = 42 + character(len=30) :: err = 'unchanged' + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team (team, stat=istat) + if (istat /= 0) stop 1 + end team + + change team (team, stat=istat, errmsg=err) + if (trim(err) /= 'unchanged') stop 2 + end team + +end + +! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_change_team \\(team, &istat, &err, 30\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_end_2.f90 b/gcc/testsuite/gfortran.dg/team_end_2.f90 new file mode 100644 index 0000000..c27b59d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_end_2.f90 @@ -0,0 +1,42 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Tests change team syntax + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat + character(len=30) :: err + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team (team) + continue + end team (stat=err) ! { dg-error "must be a scalar INTEGER" } + + change team (team) + continue + end team (stat=istat, stat=istat) ! { dg-error "Duplicate STAT" } + + change team (team) + continue + end team (stat=istat, errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" } + + change team (team) + continue + end team (stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" } + + t: change team (team) + continue + end team (stat=istat) t ! ok + + t2: change team (team) + continue + end team ! { dg-error "Expected block name of 't2' in END TEAM" } + end team t2 ! close the team correctly to catch other errors +end + diff --git a/gcc/testsuite/gfortran.dg/team_end_3.f90 b/gcc/testsuite/gfortran.dg/team_end_3.f90 new file mode 100644 index 0000000..9cd7d4c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_end_3.f90 @@ -0,0 +1,41 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Tests end team stat= and errmsg= specifiers + + use iso_fortran_env, only : team_type + implicit none + type(team_type) :: team + integer :: new_team, istat = 42 + character(len=30) :: err = 'unchanged' + integer, allocatable :: sample(:)[:] + integer, allocatable :: scal_caf[:] + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + change team (team) + allocate(sample(5)[*], scal_caf[*]) + if (.NOT. allocated(sample)) stop 1 + if (.NOT. allocated(scal_caf)) stop 2 + end team (stat=istat) + if (istat /= 0) stop 3 + if (allocated(sample)) stop 4 + if (allocated(scal_caf)) stop 5 + + deallocate(sample, stat=istat) + if (istat == 0) stop 6 + + istat = 42 + t: change team (team) + continue + end team (stat=istat, errmsg=err) t + if (istat /= 0) stop 7 + if (trim(err) /= 'unchanged') stop 8 +end + +! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_end_team \\(&istat, &err, 30\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_form_2.f90 b/gcc/testsuite/gfortran.dg/team_form_2.f90 new file mode 100644 index 0000000..5c6d81f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_form_2.f90 @@ -0,0 +1,27 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Tests form team syntax errors + + use iso_fortran_env, only : team_type + implicit none + integer :: istat, new_team + character(len=30) :: err + type(team_type) :: team + + new_team = mod(this_image(),2)+1 + + form team ! { dg-error "Syntax error in FORM TEAM statement" } + form team (new_team) ! { dg-error "Syntax error in FORM TEAM statement" } + form team (new_team,err) ! { dg-error "must be a scalar expression of type TEAM_TYPE" } + form team (new_team,team,istat) ! { dg-error "Syntax error in FORM TEAM statement" } + form team (new_team,team,stat=istat,stat=istat) ! { dg-error "Duplicate STAT" } + form team (new_team,team,stat=istat,errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" } + form team (new_team,team,stat=istat,errmsg=err,errmsg=err) ! { dg-error "Duplicate ERRMSG" } + form team (new_team,team,new_index=1,new_index=1) ! { dg-error "Duplicate NEW_INDEX" } + form team (new_team,team,new_index=err) ! { dg-error "must be a scalar INTEGER" } + form team (new_team,team,new_index=1,new_index=1,stat=istat,errmsg=err) ! { dg-error "Duplicate NEW_INDEX" } + form team (new_team,team,new_index=1,stat=istat,errmsg=err,new_index=9) ! { dg-error "Duplicate NEW_INDEX" } + +end diff --git a/gcc/testsuite/gfortran.dg/team_form_3.f90 b/gcc/testsuite/gfortran.dg/team_form_3.f90 new file mode 100644 index 0000000..d9aae33 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_form_3.f90 @@ -0,0 +1,34 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Tests form team with stat= and errmsg= + + use iso_fortran_env, only : team_type + implicit none + integer :: istat = 42, new_team + character(len=30) :: err = "unchanged" + type(team_type) :: team + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + form team (new_team,team,stat=istat) + if (istat /= 0) stop 1 + form team (new_team,team,stat=istat, errmsg=err) + if (trim(err) /= 'unchanged') stop 2 + form team (new_team,team,new_index=1) + istat = 42 + form team (new_team,team,new_index=1,stat=istat) + if (istat /= 0) stop 3 + form team (new_team,team,new_index=1,stat=istat,errmsg=err) + if (trim(err) /= 'unchanged') stop 4 +end + +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, 0B, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, 0B, &istat, &err, 30\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, 0B, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_form_team \\(new_team, &team, &C\\.\[0-9\]+, &istat, &err, 30\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_get_1.f90 b/gcc/testsuite/gfortran.dg/team_get_1.f90 new file mode 100644 index 0000000..fe00ce8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_get_1.f90 @@ -0,0 +1,27 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original" } + +! PR 87939 +! Tests get_team + + use iso_fortran_env + implicit none + type(team_type) :: team, ret + integer :: new_team, level + + new_team = mod(this_image(),2)+1 + + form team (new_team,team) + + ret = get_team() + ret = get_team(INITIAL_TEAM) + ret = get_team(PARENT_TEAM) + ret = get_team(CURRENT_TEAM) + level = INITIAL_TEAM + ret = get_team(level) + +end + +! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(0B\\)" "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get_team \\(&C\.\[0-9\]+\\)" 3 "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_get_team \\(&level\\)" "original" } } diff --git a/gcc/testsuite/gfortran.dg/team_number_1.f90 b/gcc/testsuite/gfortran.dg/team_number_1.f90 index e44e17b..f0ee7d1 100644 --- a/gcc/testsuite/gfortran.dg/team_number_1.f90 +++ b/gcc/testsuite/gfortran.dg/team_number_1.f90 @@ -1,13 +1,13 @@ ! { dg-do run } ! { dg-options "-fcoarray=single" } ! -! Tests if team_number intrinsic fucntion works +! Tests if team_number intrinsic function works ! use iso_fortran_env, only : team_type implicit none - type(team_type) team + type(team_type) :: team integer, parameter :: standard_initial_value=-1 - integer new_team + integer :: new_team if (team_number()/=standard_initial_value) STOP 1 diff --git a/gcc/testsuite/gfortran.dg/team_sync_1.f90 b/gcc/testsuite/gfortran.dg/team_sync_1.f90 new file mode 100644 index 0000000..5b28651 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_sync_1.f90 @@ -0,0 +1,24 @@ +!{ dg-do compile } +!{ dg-additional-options "-fcoarray=lib" } + +! PR 87939 +! Test sync team syntax errors + + use iso_fortran_env, only : team_type + implicit none + integer :: istat + character(len=30) :: err + type(team_type) :: team + + form team (mod(this_image(),2)+1, team) + + change team (team) + sync team ! { dg-error "Syntax error in SYNC TEAM statement" } + sync team (err) ! { dg-error "must be a scalar expression of type TEAM_TYPE" } + sync team (team, istat) ! { dg-error "Syntax error in SYNC TEAM statement" } + sync team (team, stat=err) ! { dg-error "must be a scalar INTEGER" } + sync team (team, stat=istat, stat=istat) ! { dg-error "Duplicate STAT" } + sync team (team, stat=istat, errmsg=istat) ! { dg-error "must be a scalar CHARACTER variable" } + sync team (team, stat=istat, errmsg=err, errmsg=err) ! { dg-error "Duplicate ERRMSG" } + end team +end diff --git a/gcc/testsuite/gfortran.dg/team_sync_2.f90 b/gcc/testsuite/gfortran.dg/team_sync_2.f90 new file mode 100644 index 0000000..947f65d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/team_sync_2.f90 @@ -0,0 +1,27 @@ +!{ dg-do run } +!{ dg-additional-options "-fcoarray=lib -fdump-tree-original -lcaf_single" } +!{ dg-additional-options "-latomic" { target libatomic_available } } + +! PR 87939 +! Test sync team statement +! + use iso_fortran_env, only : team_type + implicit none + integer :: istat = 42 + type(team_type) :: team + character(len=30) :: err = "unchanged" + + form team (mod(this_image(),2)+1, team) + + change team (team) + sync team (team) + sync team (team, stat=istat) + if (istat /= 0) stop 1 + sync team (team, stat=istat, errmsg=err) + if (trim(err) /= 'unchanged') stop 2 + end team +end + +! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, 0B, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, 0B, 0\\)" "original" } } +! { dg-final { scan-tree-dump "_gfortran_caf_sync_team \\(team, &istat, &err, 30\\)" "original" } } diff --git a/gcc/testsuite/gnat.dg/gcov/gcov.exp b/gcc/testsuite/gnat.dg/gcov/gcov.exp index 4fa887d..031914a 100644 --- a/gcc/testsuite/gnat.dg/gcov/gcov.exp +++ b/gcc/testsuite/gnat.dg/gcov/gcov.exp @@ -21,12 +21,19 @@ load_lib gnat-dg.exp load_lib gcov.exp global GCC_UNDER_TEST +global GCOV_UNDER_TEST -# For now find gcov in the same directory as $GCC_UNDER_TEST. -if { ![is_remote host] && [string match "*/*" [lindex $GCC_UNDER_TEST 0]] } { - set GCOV [file dirname [lindex $GCC_UNDER_TEST 0]]/gcov +# For now find gcov in the same directory as $GCC_UNDER_TEST, unless +# GCOV_UNDER_TEST is defined. + +if ![info exists GCOV_UNDER_TEST] { + if { ![is_remote host] && [string match "*/*" [lindex $GCC_UNDER_TEST 0]] } { + set GCOV [file dirname [lindex $GCC_UNDER_TEST 0]]/gcov + } else { + set GCOV gcov + } } else { - set GCOV gcov + set GCOV $GCOV_UNDER_TEST } # Initialize harness. diff --git a/gcc/testsuite/lib/target-supports.exp b/gcc/testsuite/lib/target-supports.exp index a62f459..869d150 100644 --- a/gcc/testsuite/lib/target-supports.exp +++ b/gcc/testsuite/lib/target-supports.exp @@ -562,6 +562,16 @@ proc check_effective_target_elf { } { } } +# Returns 1 if the target uses the PE/COFF object format, 0 otherwise. + +proc check_effective_target_pe { } { + if { [gcc_target_object_format] == "pe" } { + return 1; + } else { + return 0; + } +} + # Returns 1 if the target toolchain supports ifunc, 0 otherwise. proc check_ifunc_available { } { diff --git a/gcc/testsuite/rust/compile/nr2/compile.exp b/gcc/testsuite/rust/compile/nr2/compile.exp index 4d91dd0..9e15cdd 100644 --- a/gcc/testsuite/rust/compile/nr2/compile.exp +++ b/gcc/testsuite/rust/compile/nr2/compile.exp @@ -19,6 +19,15 @@ # Load support procs. load_lib rust-dg.exp +# These tests don't run runtest_file_p consistently if it +# doesn't return the same values, so disable parallelization +# of this *.exp file. The first parallel runtest to reach +# this will run all the tests serially. +if ![gcc_parallel_test_run_p compile] { + return +} +gcc_parallel_test_enable 0 + # Initialize `dg'. dg-init @@ -136,3 +145,5 @@ namespace eval rust-nr2-ns { # All done. dg-finish + +gcc_parallel_test_enable 1 diff --git a/gcc/tree-vect-loop.cc b/gcc/tree-vect-loop.cc index 2d35fa1..1c9e9b0 100644 --- a/gcc/tree-vect-loop.cc +++ b/gcc/tree-vect-loop.cc @@ -10059,7 +10059,7 @@ vect_update_nonlinear_iv (gimple_seq* stmts, tree vectype, } -/* Function vectorizable_induction +/* Function vectorizable_nonlinear_induction Check if STMT_INFO performs an nonlinear induction computation that can be vectorized. If VEC_STMT is also passed, vectorize the induction PHI: create @@ -10408,6 +10408,7 @@ vectorizable_induction (loop_vec_info loop_vinfo, poly_uint64 vf = LOOP_VINFO_VECT_FACTOR (loop_vinfo); unsigned i; tree expr; + tree index_vectype = NULL_TREE; gimple_stmt_iterator si; enum vect_induction_op_type induction_type = STMT_VINFO_LOOP_PHI_EVOLUTION_TYPE (stmt_info); @@ -10519,12 +10520,29 @@ vectorizable_induction (loop_vec_info loop_vinfo, "supported.\n"); return false; } - tree step_vectype = get_same_sized_vectype (TREE_TYPE (step_expr), vectype); + tree stept = TREE_TYPE (step_expr); + tree step_vectype = get_same_sized_vectype (stept, vectype); - /* Check for backend support of PLUS/MINUS_EXPR. */ - if (!directly_supported_p (PLUS_EXPR, step_vectype) - || !directly_supported_p (MINUS_EXPR, step_vectype)) - return false; + /* Check for target support of the vectorized arithmetic used here. */ + if (!target_supports_op_p (step_vectype, PLUS_EXPR, optab_default) + || !target_supports_op_p (step_vectype, MINUS_EXPR, optab_default)) + return false; + if (!nunits.is_constant ()) + { + if (!target_supports_op_p (step_vectype, MULT_EXPR, optab_default)) + return false; + /* FLOAT_EXPR when computing VEC_INIT for float inductions. */ + if (SCALAR_FLOAT_TYPE_P (stept)) + { + tree index_type = build_nonstandard_integer_type + (GET_MODE_BITSIZE (SCALAR_TYPE_MODE (stept)), 1); + + index_vectype = build_vector_type (index_type, nunits); + if (!can_float_p (TYPE_MODE (step_vectype), + TYPE_MODE (index_vectype), 1)) + return false; + } + } if (!vec_stmt) /* transformation not required. */ { @@ -10643,7 +10661,6 @@ vectorizable_induction (loop_vec_info loop_vinfo, nivs = 1; } gimple_seq init_stmts = NULL; - tree stept = TREE_TYPE (step_vectype); tree lupdate_mul = NULL_TREE; if (!nested_in_vect_loop) { @@ -10795,7 +10812,9 @@ vectorizable_induction (loop_vec_info loop_vinfo, + (vectype) [0, 1, 2, ...] * [step, step, step, ...]. */ gcc_assert (SCALAR_FLOAT_TYPE_P (TREE_TYPE (steps[0]))); gcc_assert (flag_associative_math); - tree index = build_index_vector (step_vectype, 0, 1); + gcc_assert (index_vectype != NULL_TREE); + + tree index = build_index_vector (index_vectype, 0, 1); new_name = gimple_convert (&init_stmts, TREE_TYPE (steps[0]), inits[0]); tree base_vec = gimple_build_vector_from_val (&init_stmts, @@ -11070,7 +11089,9 @@ vectorizable_induction (loop_vec_info loop_vinfo, + (vectype) [0, 1, 2, ...] * [step, step, step, ...]. */ gcc_assert (SCALAR_FLOAT_TYPE_P (TREE_TYPE (step_expr))); gcc_assert (flag_associative_math); - tree index = build_index_vector (step_vectype, 0, 1); + gcc_assert (index_vectype != NULL_TREE); + + tree index = build_index_vector (index_vectype, 0, 1); tree base_vec = gimple_build_vector_from_val (&stmts, step_vectype, new_name); tree step_vec = gimple_build_vector_from_val (&stmts, step_vectype, @@ -2395,11 +2395,11 @@ public: array_slice (vec<OtherT, A, vl_embed> *v) : m_base (v ? v->address () : nullptr), m_size (v ? v->length () : 0) {} - iterator begin () { return m_base; } - iterator end () { return m_base + m_size; } + iterator begin () { gcc_checking_assert (is_valid ()); return m_base; } + iterator end () { gcc_checking_assert (is_valid ()); return m_base + m_size; } - const_iterator begin () const { return m_base; } - const_iterator end () const { return m_base + m_size; } + const_iterator begin () const { gcc_checking_assert (is_valid ()); return m_base; } + const_iterator end () const { gcc_checking_assert (is_valid ()); return m_base + m_size; } value_type &front (); value_type &back (); |