diff options
Diffstat (limited to 'gcc')
110 files changed, 3657 insertions, 970 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 59f447c..e4f3f94 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,103 @@ +2025-06-06 Tobias Burnus <tburnus@baylibre.com> + + Backported from master: + 2025-06-05 Tobias Burnus <tburnus@baylibre.com> + + * config.gcc (--with-{arch,tune}): Use .def file to validate gcn + processor names. + * doc/install.texi (amdgcn*-*-*): Update list of devices supported + by --with-arch/--with-tune. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-31 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120357 + * tree-vect-loop.cc (vect_create_epilog_for_reduction): Create + the conditional reduction induction IV increment before the + main IV exit. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-30 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120341 + * tree-ssa-loop-im.cc (can_sm_ref_p): STRING_CSTs are readonly. + * tree-ssa-phiopt.cc (cond_store_replacement): Likewise. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-09 Richard Biener <rguenther@suse.de> + + PR rtl-optimization/120182 + * dse.cc (canon_address): Constant addresses have no + separate store group. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-04-30 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120003 + * tree-ssa-threadbackward.cc (back_threader::find_paths_to_names): + Allow block re-use but do not enlarge the path beyond such a + re-use. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-09 Richard Biener <rguenther@suse.de> + + PR tree-optimization/119960 + * tree-vect-slp.cc (vect_slp_can_convert_to_external): + Handle cases where defs from multiple BBs are ordered + by their dominance relation. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-08 Richard Biener <rguenther@suse.de> + + PR tree-optimization/116352 + * tree-vect-slp.cc (vect_build_slp_tree_2): When compressing + operands from a two-operator node make sure the resulting + operation does not mix defs from different basic-blocks. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-04-30 Richard Biener <rguenther@suse.de> + + PR tree-optimization/119960 + * tree-vect-slp.cc (vect_schedule_slp_node): Sanity + check dominance check on operand defs. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-04-30 Richard Biener <rguenther@suse.de> + + * tree-vectorizer.h (get_later_stmt): Robustify against + stmts in different BBs, assert when they are unordered. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-15 Richard Biener <rguenther@suse.de> + + * config/i386/i386.cc (ix86_vector_costs::finish_cost): + Do not suggest a first epilogue mode for AVX512 sized + main loops with X86_TUNE_AVX512_TWO_EPILOGUES as that + interferes with using a masked epilogue. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * tree-vect-data-refs.cc (vect_can_force_dr_alignment_p): Return + false if the variable has no symtab node. + 2025-05-29 Yuta Mukai <mukai.yuta@fujitsu.com> Backported from master: diff --git a/gcc/ChangeLog.omp b/gcc/ChangeLog.omp index b832b2a..9934978 100644 --- a/gcc/ChangeLog.omp +++ b/gcc/ChangeLog.omp @@ -1,3 +1,59 @@ +2025-06-10 Tobias Burnus <tburnus@baylibre.com> + + Backported from master: + 2025-06-10 Tobias Burnus <tburnus@baylibre.com> + + * config/gcn/gcn-devices.def: Add gfx942, gfx950 and gfx9-4-generic. + * config/gcn/gcn-opts.h (TARGET_CDNA3, TARGET_CDNA3_PLUS, + TARGET_GLC_NAME, TARGET_TARGET_SC_CACHE): Define. + (TARGET_ARCHITECTED_FLAT_SCRATCH): Use also for CDNA3. + * config/gcn/gcn.h (gcn_isa): Add ISA_CDNA3 to the enum. + * config/gcn/gcn.cc (print_operand): Update 'g' to use + TARGET_GLC_NAME; add 'G' to print TARGET_GLC_NAME unconditionally. + * config/gcn/gcn-valu.md (scatter, gather): Use TARGET_GLC_NAME. + * config/gcn/gcn.md: Use %G<num> instead of glc; use 'buffer_inv sc1' + for TARGET_TARGET_SC_CACHE. + * doc/invoke.texi (march): Add gfx942, gfx950 and gfx9-4-generic. + * doc/install.texi (amdgcn*-*-*): Add gfx942, gfx950 and gfx9-4-generic. + * config/gcn/gcn-tables.opt: Regenerate. + +2025-06-06 Tobias Burnus <tburnus@baylibre.com> + + Backported from master: + 2025-06-06 Tobias Burnus <tburnus@baylibre.com> + Sandra Loosemore <sloosemore@baylibre.com> + + * gimple-fold.cc (gimple_fold_builtin_omp_get_initial_device, + gimple_fold_builtin_omp_get_num_devices): New. + (gimple_fold_builtin): Call them. + * omp-builtins.def (BUILT_IN_OMP_GET_INITIAL_DEVICE): Add + (BUILT_IN_OMP_GET_NUM_DEVICES): Make uservisible + pure. + +2025-06-06 Tobias Burnus <tburnus@baylibre.com> + + Backported from master: + 2025-06-06 Tobias Burnus <tburnus@baylibre.com> + + * builtins.def (DEF_GOACC_BUILTIN_COMPILER, DEF_GOMP_BUILTIN_COMPILER): + Set NONANSI_P = false to enable those also with -fno-nonansi-builtins. + +2025-06-05 Sandra Loosemore <sloosemore@baylibre.com> + + Backported from master: + 2025-06-04 Sandra Loosemore <sloosemore@baylibre.com> + + PR c++/120518 + * omp-general.cc (omp_device_num_check): Look inside a + CLEANUP_POINT_EXPR when trying to optimize special cases. + +2025-06-04 Thomas Schwinge <tschwinge@baylibre.com> + + Backported from master: + 2025-06-04 Thomas Schwinge <tschwinge@baylibre.com> + + * config/nvptx/mkoffload.cc (process): Use an 'auto_vec' for + 'file_idx'. + 2025-05-30 Thomas Schwinge <tschwinge@baylibre.com> Backported from master: diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 5646e6e..52988ae 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20250602 +20250610 diff --git a/gcc/DATESTAMP.omp b/gcc/DATESTAMP.omp index ac27433..52988ae 100644 --- a/gcc/DATESTAMP.omp +++ b/gcc/DATESTAMP.omp @@ -1 +1 @@ -20250530 +20250610 diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 89cb7d4..b275a5c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,203 @@ +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Constrain_Index): In the case of a fixed-lower-bound index, + set Etype of the newly created itype's Scalar_Range from the index's Etype. + * sem_ch12.adb (Validate_Array_Type_Instance): If the actual subtype is + a fixed-lower-bound type, then check again the Etype of its Scalar_Range. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Fix conditions for legality checks on + formal type declarations. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): If pragmas apply to a formal array + type, then set the flags on the base type. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Expand_Container_Aggregate): Use the Base_Type of the + subtype provided by the context as the subtype of the temporary object + initialized by the aggregate. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): When expanding attribute + Valid, use signedness from the validated view, not from its base type. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * contracts.adb (Inherit_Condition): Remove Assoc_List and its uses + along with function Check_Condition, since mapping of formals will + effectively be done in Build_Class_Wide_Expression (by Replace_Entity). + * exp_util.adb (Replace_Entity): Only rewrite entity references in + function calls that qualify according to the result of calling the + new function Call_To_Parent_Dispatching_Op_Must_Be_Mapped. + (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): New function that + determines whether a function call to a primitive of Par_Subp + associated tagged type needs to be mapped (according to whether + it has any actuals that reference controlling formals of the + primitive). + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Insert_Conditional_Object_Declaration): Remove Decl + formal parameter, add Typ and Const formal parameters. + (Expand_N_Case_Expression): Fix pasto in comment. Adjust call to + Insert_Conditional_Object_Declaration and tidy up surrounding code. + (Expand_N_If_Expression): Adjust couple of calls to + Insert_Conditional_Object_Declaration. + +2025-06-06 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb (Constant_Indexing_OK): Add missing support for + RM 4.1.6(13/3), and improve performance to avoid climbing more + than needed. Add documentation. + (Try_Indexing_Function): New subprogram. + (Expr_Matches_In_Formal): Added new formals. + (Handle_Selected_Component): New subprogram. + (Has_IN_Mode): New subprogram. + (Try_Container_Indexing): Add documentation, code reorganization + and extend its functionality to improve its support for prefixed + notation calls. + +2025-06-06 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch10.adb (Install_Siblings.In_Context): Add missing guard. + +2025-06-06 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Insert_Conditional_Object_Declaration): Make sure the + object is allocated properly by the code generator at library level. + +2025-06-06 Steve Baird <baird@adacore.com> + + * sem_ch4.adb + (Find_Unary_Types): Because we reanalyze names in an instance, + we sometimes have to take steps to filter out extraneous name + resolution candidates that happen to be visible at the point of the + instance declaration. Remove some code that appears to have been + written with this in mind. This is done for two reasons. First, the + code sometimes doesn't work (possibly because the In_Instance test + is not specific enough - it probably should be testing to see whether + we are in an instance of the particular generic in which the result + of calling Corresponding_Generic_Type was declared) and causes correct + code to be rejected. Second, the code seems to no longer be necessary + (possibly because of subsequent fixes in this area which are not + specific to unary operators). + +2025-06-06 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Expand_Record_Aggregate): Use the named form for the + second actual parameter in the call to Duplicate_Subexpr. + * exp_attr.adb (Expand_Size_Attribute): Likewise. + * exp_ch5.adb (Expand_Assign_Array): Likewise. + (Expand_Assign_Array_Bitfield): Likewise. + (Expand_Assign_Array_Bitfield_Fast): Likewise. + * exp_util.ads (Duplicate_Subexpr): Add New_Scope formal parameter. + (Duplicate_Subexpr_No_Checks): Likewise. + (Duplicate_Subexpr_Move_Checks): Likewise. + * exp_util.adb (Build_Allocate_Deallocate_Proc): Pass Proc_Id as the + actual for New_Scope in the calls to Duplicate_Subexpr_No_Checks. + (Duplicate_Subexpr): Add New_Scope formal parameter and forward it + in the call to New_Copy_Tree. + (Duplicate_Subexpr_No_Checks): Likewise. + (Duplicate_Subexpr_Move_Checks): Likewise. + +2025-06-06 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Insert_Valid_Check): Set flag Assignment_OK in the object + declaration inserted for the validity checks. + +2025-06-05 Javier Miranda <miranda@adacore.com> + + * exp_ch7.adb (Process_Object_Declaration): Avoid generating + duplicate names for master nodes. + +2025-06-05 Steve Baird <baird@adacore.com> + + * sem_util.adb + (Side_Effect_Free_Statements): Return False if the statement list + includes an explicit (i.e. Comes_From_Source) raise statement. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * exp_ch4.adb (Tagged_Membership): Fix for protected types. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * exp_attr.adb (Interunit_Ref_OK): Tweak categorization of compilation + units. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Two_Pass_Aggr_Code): New function containing + most of the code initially present in Two_Pass_Aggregate_Expansion. + (Two_Pass_Aggregate_Expansion): Remove redundant N parameter. + Implement built-in-place expansion for (static) object declarations + and allocators, using Build_Two_Pass_Aggr_Code for the main work. + (Expand_Array_Aggregate): Adjust Two_Pass_Aggregate_Expansion call. + Replace Etype (N) by Typ in a couple of places. + * exp_ch3.adb (Expand_Freeze_Array_Type): Remove special case for + two-pass array aggregates. + (Expand_N_Object_Declaration): Do not adjust the object when it is + initialized by a two-pass array aggregate. + * exp_ch4.adb (Expand_Allocator_Expression): Apply the processing + used for container aggregates to two-pass array aggregates. + * exp_ch6.adb (Validate_Subprogram_Calls): Skip calls present in + initialization expressions of N_Object_Declaration nodes that have + No_Initialization set. + * sem_ch3.adb (Analyze_Object_Declaration): Detect the cases of an + array originally initialized by an aggregate consistently. + +2025-06-05 Viljar Indus <indus@adacore.com> + + * doc/gnat_rm/implementation_defined_attributes.rst: Update the + documentation for Valid_Value. + * sem_attr.adb (Analyze_Attribute): Reject types where + the root type originates from Standard. + * gnat_rm.texi: Regenerate. + +2025-06-05 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Two_Pass_Aggregate_Expansion): Change call to Make_Assignment + for the indexed aggregate object to call Change_Make_OK_Assignment instead. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Remove obsolete comment. + (Make_Build_In_Place_Call_In_Anonymous_Context): Always use a proper + object declaration initialized with the function call in the cases + where a temporary is needed, with Assignment_OK set on it. + * sem_util.adb (Entity_Of): Deal with rewritten function call first. + +2025-06-05 Steve Baird <baird@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): When accessing the + maps declared in package Cached_Attribute_Ops, the key value + passed to Get or to Set should never be the entity node for a + subtype. Use the entity of the corresponding type declaration + instead. + +2025-06-05 Steve Baird <baird@adacore.com> + + * sem_res.adb + (Set_Mixed_Mode_Operand): If we are about to call Resolve + passing in Any_Fixed as the expected type, then instead pass in + the fixed point type of the other operand (i.e., B_Typ). + +2025-06-05 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Check_Function_Writable_Actuals): Add handling for + N_Iterated_Component_Association and N_Iterated_Element_Association. + Fix a typo in an RM reference (6.4.1(20/3) => 6.4.1(6.20/3)). + (Collect_Expression_Ids): New procedure factoring code for collecting + identifiers from expressions of aggregate associations. + (Handle_Association_Choices): New procedure factoring code for handling + id collection for expressions of aggregate associations with multiple + choices. Removed redundant test of Box_Present from original code. + 2025-05-05 Eric Botcazou <ebotcazou@adacore.com> PR ada/120104 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index dcfcaa3..6a98292 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -8163,6 +8163,7 @@ package body Checks is end if; declare + Decl : Node_Id; CE : Node_Id; PV : Node_Id; Var_Id : Entity_Id; @@ -8215,12 +8216,20 @@ package body Checks is Mutate_Ekind (Var_Id, E_Variable); Set_Etype (Var_Id, Typ); - Insert_Action (Exp, + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Var_Id, Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => New_Copy_Tree (Exp)), - Suppress => Validity_Check); + Expression => New_Copy_Tree (Exp)); + + -- We might be validity-checking object whose type is declared as + -- limited but completion is a scalar type. We need to explicitly + -- flag its assignment as OK, as otherwise it would be rejected by + -- the language rules. + + Set_Assignment_OK (Decl); + + Insert_Action (Exp, Decl, Suppress => Validity_Check); Set_Validated_Object (Var_Id, New_Copy_Tree (Exp)); diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 8b94a67..e0eb26e 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4389,10 +4389,10 @@ package body Contracts is Seen : Subprogram_List (Subps'Range) := (others => Empty); function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id; - -- Inherit the class-wide condition from Par_Subp to Subp and adjust - -- all the references to formals in the inherited condition. + (Par_Subp : Entity_Id) return Node_Id; + -- Inherit the class-wide condition from Par_Subp. Simply makes + -- a copy of the condition in preparation for later mapping of + -- referenced formals and functions by Build_Class_Wide_Expression. procedure Merge_Conditions (From : Node_Id; Into : Node_Id); -- Merge two class-wide preconditions or postconditions (the former @@ -4407,92 +4407,11 @@ package body Contracts is ----------------------- function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id - is - function Check_Condition (Expr : Node_Id) return Boolean; - -- Used in assertion to check that Expr has no reference to the - -- formals of Par_Subp. - - --------------------- - -- Check_Condition -- - --------------------- - - function Check_Condition (Expr : Node_Id) return Boolean is - Par_Formal_Id : Entity_Id; - - function Check_Entity (N : Node_Id) return Traverse_Result; - -- Check occurrence of Par_Formal_Id - - ------------------ - -- Check_Entity -- - ------------------ - - function Check_Entity (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Identifier - and then Present (Entity (N)) - and then Entity (N) = Par_Formal_Id - then - return Abandon; - end if; - - return OK; - end Check_Entity; - - function Check_Expression is new Traverse_Func (Check_Entity); - - -- Start of processing for Check_Condition - - begin - Par_Formal_Id := First_Formal (Par_Subp); - - while Present (Par_Formal_Id) loop - if Check_Expression (Expr) = Abandon then - return False; - end if; - - Next_Formal (Par_Formal_Id); - end loop; - - return True; - end Check_Condition; - - -- Local variables - - Assoc_List : constant Elist_Id := New_Elmt_List; - Par_Formal_Id : Entity_Id := First_Formal (Par_Subp); - Subp_Formal_Id : Entity_Id := First_Formal (Subp); - New_Condition : Node_Id; - + (Par_Subp : Entity_Id) return Node_Id is begin - while Present (Par_Formal_Id) loop - Append_Elmt (Par_Formal_Id, Assoc_List); - Append_Elmt (Subp_Formal_Id, Assoc_List); - - Next_Formal (Par_Formal_Id); - Next_Formal (Subp_Formal_Id); - end loop; - - -- Check that Parent field of all the nodes have their correct - -- decoration; required because otherwise mapped nodes with - -- wrong Parent field are left unmodified in the copied tree - -- and cause reporting wrong errors at later stages. - - pragma Assert - (Check_Parents (Class_Condition (Kind, Par_Subp), Assoc_List)); - - New_Condition := + return New_Copy_Tree - (Source => Class_Condition (Kind, Par_Subp), - Map => Assoc_List); - - -- Ensure that the inherited condition has no reference to the - -- formals of the parent subprogram. - - pragma Assert (Check_Condition (New_Condition)); - - return New_Condition; + (Source => Class_Condition (Kind, Par_Subp)); end Inherit_Condition; ---------------------- @@ -4606,9 +4525,7 @@ package body Contracts is Par_Prim := Subp_Id; Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim); - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); if Present (Class_Cond) then Merge_Conditions (Cond, Class_Cond); @@ -4652,9 +4569,7 @@ package body Contracts is then Seen (Index) := Subp_Id; - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); Check_Class_Condition (Cond => Cond, diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index f051810..86d2a81 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -1629,9 +1629,9 @@ Attribute Valid_Value .. index:: Valid_Value The ``'Valid_Value`` attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. ``T'Valid_Value (S)`` returns True -if and only if ``T'Value (S)`` would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. ``T'Valid_Value (S)`` +returns True if and only if ``T'Value (S)`` would not raise Constraint_Error. Attribute Valid_Scalars ======================= diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index f154e7f..7c05e53 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1623,7 +1623,7 @@ package Einfo is -- Has_Dynamic_Predicate_Aspect -- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect --- was explicitly applied to the type. Generally we treat predicates as +-- was applied to the type or subtype. Generally we treat predicates as -- static if possible, regardless of whether they are specified using -- Predicate, Static_Predicate, or Dynamic_Predicate. And if a predicate -- can be treated as static (i.e. its expression is predicate-static), diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7cb26ce..b6c1605 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4956,6 +4956,14 @@ package body Exp_Aggr is -- type using the computable sizes of the aggregate and its sub- -- aggregates. + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id; + -- The aggregate consists only of iterated associations and Lhs is an + -- expression containing the location of the anonymous object, which + -- may be built in place. Returns the dynamic subtype of the aggregate + -- in Aggr_Typ and the list of statements needed to build it. + procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id); -- Checks that the bounds of Aggr_Bounds are within the bounds defined -- by Index_Bounds. For null array aggregate (Ada 2022) check that the @@ -4983,7 +4991,7 @@ package body Exp_Aggr is -- built directly into the target of an assignment, the target must -- be free of side effects. N is the target of the assignment. - procedure Two_Pass_Aggregate_Expansion (N : Node_Id); + procedure Two_Pass_Aggregate_Expansion; -- If the aggregate consists only of iterated associations then the -- aggregate is constructed in two steps: -- a) Build an expression to compute the number of elements @@ -5053,6 +5061,221 @@ package body Exp_Aggr is Freeze_Itype (Agg_Type, N); end Build_Constrained_Type; + ------------------------------ + -- Build_Two_Pass_Aggr_Code -- + ------------------------------ + + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id + is + Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + Index_Base : constant Entity_Id := Base_Type (Index_Type); + Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Size_Type : constant Entity_Id := + Integer_Type_For + (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); + + Assoc : Node_Id; + Incr : Node_Id; + Iter : Node_Id; + New_Comp : Node_Id; + One_Loop : Node_Id; + Iter_Id : Entity_Id; + + Aggr_Code : List_Id; + Size_Expr_Code : List_Id; + + begin + Size_Expr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Size_Id, + Object_Definition => New_Occurrence_Of (Size_Type, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + -- First pass: execute the iterators to count the number of elements + -- that will be generated. + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Size_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over the + -- original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (Incr)); + + Append (One_Loop, Size_Expr_Code); + Next (Assoc); + end loop; + + Insert_Actions (N, Size_Expr_Code); + + -- Build a constrained subtype with the bounds deduced from + -- the size computed above and declare the aggregate object. + -- The index type is some discrete type, so the bounds of the + -- constrained subtype are computed as T'Val (integer bounds). + + declare + -- Pos_Lo := Index_Type'Pos (Index_Type'First) + + Pos_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First))); + + -- Corresponding index value, i.e. Index_Type'First + + Aggr_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First); + + -- Pos_Hi := Pos_Lo + Size - 1 + + Pos_Hi : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => Pos_Lo, + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Corresponding index value + + Aggr_Hi : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (Pos_Hi)); + + begin + Aggr_Typ := Make_Temporary (Loc, 'T'); + + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Aggr_Typ, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => + New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi)))))); + end; + + -- Second pass: use the iterators to generate the elements of the + -- aggregate. We assume that the second evaluation of each iterator + -- generates the same number of elements as the first pass, and thus + -- consider that the execution is erroneous (even if the RM does not + -- state this explicitly) if the number of elements generated differs + -- between first and second pass. + + Assoc := First (Component_Associations (N)); + + -- Initialize insertion position to first array component + + Aggr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Index_Id, + Object_Definition => + New_Occurrence_Of (Index_Type, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Lhs), + Attribute_Name => Name_First))); + + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + New_Comp := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc))), + Expression => Copy_Separate_Tree (Expression (Assoc))); + + -- Arrange for the component to be adjusted if need be (the call + -- will be generated by Make_Tag_Ctrl_Assignment). + + if Needs_Finalization (Ctyp) + and then not Is_Inherently_Limited_Type (Ctyp) + then + Set_No_Finalize_Actions (New_Comp); + else + Set_No_Ctrl_Actions (New_Comp); + end if; + + -- Advance index position for insertion + + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Index_Id, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Succ, + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc)))); + + -- Add guard to skip last increment when upper bound is reached + + Incr := + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Index_Id, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Last)), + Then_Statements => New_List (Incr)); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over + -- the original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (New_Comp, Incr)); + + Append (One_Loop, Aggr_Code); + Next (Assoc); + end loop; + + return Aggr_Code; + end Build_Two_Pass_Aggr_Code; + ------------------ -- Check_Bounds -- ------------------ @@ -5596,214 +5819,98 @@ package body Exp_Aggr is -- Two_Pass_Aggregate_Expansion -- ---------------------------------- - procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Comp_Type : constant Entity_Id := Etype (N); - Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Index_Type : constant Entity_Id := Etype (First_Index (Etype (N))); - Index_Base : constant Entity_Id := Base_Type (Index_Type); - Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Size_Type : constant Entity_Id := - Integer_Type_For - (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); - TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); - - Assoc : Node_Id := First (Component_Associations (N)); - Incr : Node_Id; - Iter : Node_Id; - New_Comp : Node_Id; - One_Loop : Node_Id; - Iter_Id : Entity_Id; - - Size_Expr_Code : List_Id; - Insertion_Code : List_Id := New_List; + procedure Two_Pass_Aggregate_Expansion is + Aggr_Code : List_Id; + Aggr_Typ : Entity_Id; + Lhs : Node_Id; + Obj_Id : Entity_Id; + Par : Node_Id; begin - Size_Expr_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Size_Id, - Object_Definition => New_Occurrence_Of (Size_Type, Loc), - Expression => Make_Integer_Literal (Loc, 0))); - - -- First pass: execute the iterators to count the number of elements - -- that will be generated. - - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Size_Id, Loc), - Expression => - Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. - - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (Incr)); - - Append (One_Loop, Size_Expr_Code); - Next (Assoc); + Par := Parent (N); + while Nkind (Par) = N_Qualified_Expression loop + Par := Parent (Par); end loop; - Insert_Actions (N, Size_Expr_Code); - - -- Build a constrained subtype with the bounds deduced from - -- the size computed above and declare the aggregate object. - -- The index type is some discrete type, so the bounds of the - -- constrained subtype are computed as T'Val (integer bounds). - - declare - -- Pos_Lo := Index_Type'Pos (Index_Type'First) - - Pos_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Pos, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); - - -- Corresponding index value, i.e. Index_Type'First - - Aggr_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First); - - -- Pos_Hi := Pos_Lo + Size - 1 - - Pos_Hi : constant Node_Id := - Make_Op_Add (Loc, - Left_Opnd => Pos_Lo, - Right_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Corresponding index value - - Aggr_Hi : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Val, - Expressions => New_List (Pos_Hi)); + -- If the aggregate is the initialization expression of an object + -- declaration, we always build the aggregate in place, although + -- this is required only for immutably limited types and types + -- that need finalization, see RM 7.6(17.2/3-17.3/3). - SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); - SubD : constant Node_Id := - Make_Subtype_Declaration (Loc, - Defining_Identifier => SubE, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Comp_Type), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint - (Loc, - Constraints => - New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi))))); - - -- Create a temporary array of the above subtype which - -- will be used to capture the aggregate assignments. - - TmpD : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => TmpE, - Object_Definition => New_Occurrence_Of (SubE, Loc)); - - begin - Insert_Actions (N, New_List (SubD, TmpD)); - end; - - -- Second pass: use the iterators to generate the elements of the - -- aggregate. Insertion index starts at Index_Type'First. We - -- assume that the second evaluation of each iterator generates - -- the same number of elements as the first pass, and consider - -- that the execution is erroneous (even if the RM does not state - -- this explicitly) if the number of elements generated differs - -- between first and second pass. - - Assoc := First (Component_Associations (N)); + if Nkind (Par) = N_Object_Declaration then + Obj_Id := Defining_Identifier (Par); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Initialize insertion position to first array component. + -- Save the last assignment statement associated with the + -- aggregate when building a controlled object. This last + -- assignment is used by the finalization machinery when + -- marking an object as successfully initialized. - Insertion_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Index_Id, - Object_Definition => - New_Occurrence_Of (Index_Type, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); + if Needs_Finalization (Typ) then + Mutate_Ekind (Obj_Id, E_Variable); + Set_Last_Aggregate_Assignment (Obj_Id, Last (Aggr_Code)); + end if; - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - New_Comp := Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (TmpE, Loc), - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc))), - Expression => Copy_Separate_Tree (Expression (Assoc))); + -- If a transient scope has been created around the declaration, + -- we need to attach the code to it so that finalization actions + -- of the declaration will be inserted after it; otherwise, we + -- directly insert it after the declaration. In both cases, the + -- code will be analyzed after the declaration is processed, i.e. + -- once the actual subtype of the object is established. - -- Advance index position for insertion. + if Scope_Is_Transient and then Par = Node_To_Be_Wrapped then + Store_After_Actions_In_Scope_Without_Analysis (Aggr_Code); + else + Insert_List_After (Par, Aggr_Code); + end if; - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Index_Id, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Succ, - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc)))); + Set_Etype (N, Aggr_Typ); + Set_No_Initialization (Par); - -- Add guard to skip last increment when upper bound is reached. + -- Likewise if it is the qualified expression of an allocator but, + -- in this case, we wait until after Expand_Allocator_Expression + -- rewrites the allocator as the initialization expression of an + -- object declaration, so that we have the left-hand side. - Incr := Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Index_Id, Loc), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Last)), - Then_Statements => New_List (Incr)); + elsif Nkind (Par) = N_Allocator then + if Nkind (Parent (Par)) = N_Object_Declaration + and then + not Comes_From_Source (Defining_Identifier (Parent (Par))) + then + Obj_Id := Defining_Identifier (Parent (Par)); + Lhs := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc)); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. + Insert_Actions_After (Parent (Par), Aggr_Code); - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (New_Comp, Incr)); + Set_Expression (Par, New_Occurrence_Of (Aggr_Typ, Loc)); + Set_No_Initialization (Par); + end if; - Append (One_Loop, Insertion_Code); - Next (Assoc); - end loop; + -- Otherwise we create a temporary for the anonymous object and + -- replace the aggregate with the temporary. - Insert_Actions (N, Insertion_Code); + else + Obj_Id := Make_Temporary (Loc, 'A', N); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); - -- Depending on context this may not work for build-in-place - -- arrays ??? + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); + Prepend_To (Aggr_Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => New_Occurrence_Of (Aggr_Typ, Loc))); - Rewrite (N, New_Occurrence_Of (TmpE, Loc)); + Insert_Actions (N, Aggr_Code); + Rewrite (N, Lhs); + Analyze_And_Resolve (N, Aggr_Typ); + end if; end Two_Pass_Aggregate_Expansion; -- Local variables @@ -5829,7 +5936,7 @@ package body Exp_Aggr is -- Aggregates that require a two-pass expansion are handled separately elsif Is_Two_Pass_Aggregate (N) then - Two_Pass_Aggregate_Expansion (N); + Two_Pass_Aggregate_Expansion; return; -- Do not attempt expansion if error already detected. We may reach this @@ -6002,12 +6109,11 @@ package body Exp_Aggr is -- static type imposed by the context. declare - Itype : constant Entity_Id := Etype (N); Index : Node_Id; Needs_Type : Boolean := False; begin - Index := First_Index (Itype); + Index := First_Index (Typ); while Present (Index) loop if not Is_OK_Static_Subtype (Etype (Index)) then Needs_Type := True; @@ -6019,7 +6125,7 @@ package body Exp_Aggr is if Needs_Type then Build_Constrained_Type (Positional => True); - Rewrite (N, Unchecked_Convert_To (Itype, N)); + Rewrite (N, Unchecked_Convert_To (Typ, N)); Analyze (N); end if; end; @@ -6147,7 +6253,7 @@ package body Exp_Aggr is then Tmp := Name (Parent_Node); - if Etype (Tmp) /= Etype (N) then + if Etype (Tmp) /= Typ then Apply_Length_Check (N, Etype (Tmp)); if Nkind (N) = N_Raise_Constraint_Error then @@ -6904,7 +7010,7 @@ package body Exp_Aggr is begin return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal then Intval (Expr) - else Enumeration_Pos (Expr))); + else Enumeration_Pos (Entity (Expr)))); end To_Int; -- Local variables @@ -7362,7 +7468,7 @@ package body Exp_Aggr is -- Likewise if the aggregate is the qualified expression of an allocator -- but, in this case, we wait until after Expand_Allocator_Expression -- rewrites the allocator as the initialization expression of an object - -- declaration to have the left hand side. + -- declaration, so that we have the left-hand side. elsif Nkind (Par) = N_Allocator then if Nkind (Parent (Par)) = N_Object_Declaration @@ -7390,10 +7496,19 @@ package body Exp_Aggr is Set_Assignment_OK (Lhs); Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init); + + -- Use the unconstrained base subtype of the subtype provided by + -- the context for declaring the temporary object (which may come + -- from a constrained assignment target), to ensure that the + -- aggregate can be successfully expanded and assigned to the + -- temporary without exceeding its capacity. (Later assignment + -- of the temporary to a target object may result in failing + -- a discriminant check.) + Prepend_To (Aggr_Code, Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, - Object_Definition => New_Occurrence_Of (Typ, Loc), + Object_Definition => New_Occurrence_Of (Base_Type (Typ), Loc), Expression => Init)); Insert_Actions (N, Aggr_Code); @@ -7971,7 +8086,8 @@ package body Exp_Aggr is Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Typ, - Duplicate_Subexpr (Parent_Expr, True)), + Duplicate_Subexpr + (Parent_Expr, Name_Req => True)), Selector_Name => New_Occurrence_Of (Comp, Loc)); Append_To (Comps, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b896228..18179d3 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -88,8 +88,10 @@ package body Exp_Attr is function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is (Header_Num (Id mod Map_Size)); - -- Cache used to avoid building duplicate subprograms for a single - -- type/streaming-attribute pair. + -- Caches used to avoid building duplicate subprograms for a single + -- type/attribute pair (where the attribute is either Put_Image or + -- one of the four streaming attributes). The type used as a key in + -- in accessing these maps should not be the entity of a subtype. package Read_Map is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -282,8 +284,8 @@ package body Exp_Attr is (In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit) -- If subp declared in unit body, then we don't want to refer -- to it from within unit spec so return False in that case. - and then not (Body_Required (Attr_Ref_Unit) - and not Body_Required (Subp_Unit))); + and then not (not Is_Body (Unit (Attr_Ref_Unit)) + and Is_Body (Unit (Subp_Unit)))); -- Returns True if it is ok to refer to a cached subprogram declared in -- Subp_Unit from the point of an attribute reference occurring in -- Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes, @@ -4669,7 +4671,7 @@ package body Exp_Attr is end if; if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Input_Map.Set (P_Type, Fname); + Cached_Attribute_Ops.Input_Map.Set (U_Type, Fname); end if; end Input; @@ -5750,7 +5752,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Output_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Output_Map.Set (U_Type, Pname); end if; end Output; @@ -6669,7 +6671,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Read_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname); end if; end Read; @@ -7870,9 +7872,8 @@ package body Exp_Attr is else declare Uns : constant Boolean := - Is_Unsigned_Type (Ptyp) - or else (Is_Private_Type (Ptyp) - and then Is_Unsigned_Type (PBtyp)); + Is_Unsigned_Type (Validated_View (Ptyp)); + Size : Uint; P : Node_Id := Pref; @@ -8349,7 +8350,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Write_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Write_Map.Set (U_Type, Pname); end if; end Write; @@ -8600,10 +8601,10 @@ package body Exp_Attr is Rewrite (N, Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Pref, True), + Prefix => Duplicate_Subexpr (Pref, Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Pref, True), + Prefix => Duplicate_Subexpr (Pref, Name_Req => True), Attribute_Name => Name_Component_Size))); Analyze_And_Resolve (N, Typ); end if; @@ -8951,15 +8952,22 @@ package body Exp_Attr is return Empty; end if; - if Nam = TSS_Stream_Read then - Ent := Cached_Attribute_Ops.Read_Map.Get (Typ); - elsif Nam = TSS_Stream_Write then - Ent := Cached_Attribute_Ops.Write_Map.Get (Typ); - elsif Nam = TSS_Stream_Input then - Ent := Cached_Attribute_Ops.Input_Map.Get (Typ); - elsif Nam = TSS_Stream_Output then - Ent := Cached_Attribute_Ops.Output_Map.Get (Typ); - end if; + declare + function U_Base return Entity_Id is + (Underlying_Type (Base_Type (Typ))); + -- Return the right type node for use in a C_A_O map lookup. + -- In particular, we do not want the entity for a subtype. + begin + if Nam = TSS_Stream_Read then + Ent := Cached_Attribute_Ops.Read_Map.Get (U_Base); + elsif Nam = TSS_Stream_Write then + Ent := Cached_Attribute_Ops.Write_Map.Get (U_Base); + elsif Nam = TSS_Stream_Input then + Ent := Cached_Attribute_Ops.Input_Map.Get (U_Base); + elsif Nam = TSS_Stream_Output then + Ent := Cached_Attribute_Ops.Output_Map.Get (U_Base); + end if; + end; Cached_Attribute_Ops.Validate_Cached_Candidate (Subp => Ent, Attr_Ref => Attr_Ref); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bc46fd3..fa87149 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5423,18 +5423,12 @@ package body Exp_Ch3 is -- with an initial value, its Init_Proc will never be called. The -- initial value itself may have been expanded into assignments, -- in which case the declaration has the No_Initialization flag. - -- The exception is when the initial value is a 2-pass aggregate, - -- because the special expansion used for it creates a temporary - -- that needs a fully-fledged initialization. if Is_Itype (Base) and then Nkind (Associated_Node_For_Itype (Base)) = N_Object_Declaration and then - ((Present (Expression (Associated_Node_For_Itype (Base))) - and then not - Is_Two_Pass_Aggregate - (Expression (Associated_Node_For_Itype (Base)))) + (Present (Expression (Associated_Node_For_Itype (Base))) or else No_Initialization (Associated_Node_For_Itype (Base))) then null; @@ -8293,12 +8287,15 @@ package body Exp_Ch3 is -- where the object has been initialized by a call to a function -- returning on the primary stack (see Expand_Ctrl_Function_Call) -- since no copy occurred, given that the type is by-reference. + -- Likewise if it is initialized by a 2-pass aggregate, since the + -- actual initialization will only occur during the second pass. -- Similarly, no adjustment is needed if we are going to rewrite -- the object declaration into a renaming declaration. if Needs_Finalization (Typ) and then not Is_Inherently_Limited_Type (Typ) and then Nkind (Expr_Q) /= N_Function_Call + and then not Is_Two_Pass_Aggregate (Expr_Q) and then not Rewrite_As_Renaming then Adj_Call := diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 82978c7..0cf605c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -193,12 +193,12 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id); - -- Expr is the dependent expression of a conditional expression and Decl - -- is the declaration of an object whose initialization expression is the - -- conditional expression. Insert in the actions of Expr the declaration - -- of Obj_Id modeled on Decl and with Expr as initialization expression. + Const : Boolean); + -- Expr is the dependent expression of a conditional expression. Insert in + -- the actions of Expr the declaration of Obj_Id with type Typ and Expr as + -- initialization expression. Const is True when Obj_Id is a constant. procedure Insert_Dereference_Action (N : Node_Id); -- N is an expression whose type is an access. When the type of the @@ -769,7 +769,6 @@ package body Exp_Ch4 is -- Local variables Aggr_In_Place : Boolean; - Container_Aggr : Boolean; Delayed_Cond_Expr : Boolean; TagT : Entity_Id := Empty; @@ -865,13 +864,15 @@ package body Exp_Ch4 is Aggr_In_Place := Is_Delayed_Aggregate (Exp); Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp); - Container_Aggr := Nkind (Exp) = N_Aggregate - and then Has_Aspect (T, Aspect_Aggregate); - -- An allocator with a container aggregate as qualified expression must - -- be rewritten into the form expected by Expand_Container_Aggregate. + -- An allocator with a container aggregate, resp. a 2-pass aggregate, + -- as qualified expression must be rewritten into the form expected by + -- Expand_Container_Aggregate, resp. Two_Pass_Aggregate_Expansion. - if Container_Aggr then + if Nkind (Exp) = N_Aggregate + and then (Has_Aspect (T, Aspect_Aggregate) + or else Is_Two_Pass_Aggregate (Exp)) + then Temp := Make_Temporary (Loc, 'P', N); Set_Analyzed (Exp, False); Insert_Action (N, @@ -5303,7 +5304,7 @@ package body Exp_Ch4 is -- 'Unrestricted_Access. -- Generate: - -- type Ptr_Typ is not null access all [constant] Typ; + -- type Target_Typ is not null access all [constant] Typ; else Target_Typ := Make_Temporary (Loc, 'P'); @@ -5401,20 +5402,16 @@ package body Exp_Ch4 is elsif Optimize_Object_Decl then Obj := Make_Temporary (Loc, 'C', Alt_Expr); - Insert_Conditional_Object_Declaration (Obj, Alt_Expr, Par); - - Alt_Expr := - Make_Attribute_Reference (Alt_Loc, - Prefix => New_Occurrence_Of (Obj, Alt_Loc), - Attribute_Name => Name_Unrestricted_Access); - - LHS := New_Occurrence_Of (Target, Loc); - Set_Assignment_OK (LHS); + Insert_Conditional_Object_Declaration + (Obj, Typ, Alt_Expr, Const => Constant_Present (Par)); Stmts := New_List ( Make_Assignment_Statement (Alt_Loc, - Name => LHS, - Expression => Alt_Expr)); + Name => New_Occurrence_Of (Target, Loc), + Expression => + Make_Attribute_Reference (Alt_Loc, + Prefix => New_Occurrence_Of (Obj, Alt_Loc), + Attribute_Name => Name_Unrestricted_Access))); -- Take the unrestricted access of the expression value for non- -- scalar types. This approach avoids big copies and covers the @@ -6012,8 +6009,10 @@ package body Exp_Ch4 is Target : constant Entity_Id := Make_Temporary (Loc, 'C', N); begin - Insert_Conditional_Object_Declaration (Then_Obj, Thenx, Par); - Insert_Conditional_Object_Declaration (Else_Obj, Elsex, Par); + Insert_Conditional_Object_Declaration + (Then_Obj, Typ, Thenx, Const => Constant_Present (Par)); + Insert_Conditional_Object_Declaration + (Else_Obj, Typ, Elsex, Const => Constant_Present (Par)); -- Generate: -- type Ptr_Typ is not null access all [constant] Typ; @@ -13284,17 +13283,20 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id) + Const : Boolean) is Loc : constant Source_Ptr := Sloc (Expr); Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, - Aliased_Present => Aliased_Present (Decl), - Constant_Present => Constant_Present (Decl), - Object_Definition => New_Copy_Tree (Object_Definition (Decl)), + Aliased_Present => True, + Constant_Present => Const, + Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Expr)); + -- We make the object unconditionally aliased to avoid dangling bound + -- issues when its nominal subtype is an unconstrained array type. Master_Node_Decl : Node_Id; Master_Node_Id : Entity_Id; @@ -13309,6 +13311,21 @@ package body Exp_Ch4 is Insert_Action (Expr, Obj_Decl); + -- The object can never be local to an elaboration routine at library + -- level since we will take 'Unrestricted_Access of it. Beware that + -- Is_Library_Level_Entity always returns False when called from within + -- a transient scope, but the associated block will not be materialized + -- when the transient scope is finally closed in the case of an object + -- declaration (see Exp.Ch7.Wrap_Transient_Declaration). + + if Scope (Obj_Id) = Current_Scope and then Scope_Is_Transient then + Set_Is_Statically_Allocated + (Obj_Id, Is_Library_Level_Entity (Scope (Obj_Id))); + else + Set_Is_Statically_Allocated + (Obj_Id, Is_Library_Level_Entity (Obj_Id)); + end if; + -- If the object needs finalization, we need to insert its Master_Node -- manually because 1) the machinery in Exp_Ch7 will not pick it since -- it will be declared in the arm of a conditional statement and 2) we @@ -15035,10 +15052,11 @@ package body Exp_Ch4 is -- Handle entities from the limited view - Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right)); + Orig_Right_Type : constant Entity_Id := + Base_Type (Available_View (Etype (Right))); Full_R_Typ : Entity_Id; - Left_Type : Entity_Id := Available_View (Etype (Left)); + Left_Type : Entity_Id := Base_Type (Available_View (Etype (Left))); Right_Type : Entity_Id := Orig_Right_Type; Obj_Tag : Node_Id; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 06616ea..3d8a542 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1039,7 +1039,8 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr_Move_Checks (Larray, True), + Duplicate_Subexpr_Move_Checks + (Larray, Name_Req => True), Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => @@ -1054,7 +1055,8 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr_Move_Checks (Rarray, True), + Duplicate_Subexpr_Move_Checks + (Rarray, Name_Req => True), Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => @@ -1396,7 +1398,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Left_Lo))), Attribute_Name => Name_Address); @@ -1405,7 +1407,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Left_Lo))), Attribute_Name => Name_Bit); @@ -1414,7 +1416,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Rarray, True), + Duplicate_Subexpr (Rarray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Right_Lo))), Attribute_Name => Name_Address); @@ -1423,7 +1425,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Rarray, True), + Duplicate_Subexpr (Rarray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Right_Lo))), Attribute_Name => Name_Bit); @@ -1439,11 +1441,11 @@ package body Exp_Ch5 is Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Component_Size)); begin @@ -1527,11 +1529,11 @@ package body Exp_Ch5 is Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Attribute_Name => Name_Component_Size)); L_Arg, R_Arg, Call : Node_Id; @@ -1582,7 +1584,7 @@ package body Exp_Ch5 is end if; return Make_Assignment_Statement (Loc, - Name => Duplicate_Subexpr (Larray, True), + Name => Duplicate_Subexpr (Larray, Name_Req => True), Expression => Unchecked_Convert_To (L_Typ, Call)); end Expand_Assign_Array_Bitfield_Fast; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7e46454..f85d977 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2470,11 +2470,6 @@ package body Exp_Ch6 is -- (and ensure that we have an activation chain defined for tasks -- and a Master variable). - -- Currently we limit such functions to those with inherently - -- limited result subtypes, but eventually we plan to expand the - -- functions that are treated as build-in-place to include other - -- composite result types. - -- But do not do it here for intrinsic subprograms since this will -- be done properly after the subprogram is expanded. @@ -8562,12 +8557,10 @@ package body Exp_Ch6 is procedure Make_Build_In_Place_Call_In_Anonymous_Context (Function_Call : Node_Id) is - Loc : constant Source_Ptr := Sloc (Function_Call); - Func_Call : constant Node_Id := Unqual_Conv (Function_Call); - Function_Id : Entity_Id; - Result_Subt : Entity_Id; - Return_Obj_Id : Entity_Id; - Return_Obj_Decl : Entity_Id; + Loc : constant Source_Ptr := Sloc (Function_Call); + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); + Function_Id : Entity_Id; + Result_Subt : Entity_Id; begin -- If the call has already been processed to add build-in-place actuals @@ -8580,10 +8573,6 @@ package body Exp_Ch6 is return; end if; - -- Mark the call as processed as a build-in-place call - - Set_Is_Expanded_Build_In_Place_Call (Func_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -8601,8 +8590,13 @@ package body Exp_Ch6 is -- If the build-in-place function returns a controlled object, then the -- object needs to be finalized immediately after the context. Since -- this case produces a transient scope, the servicing finalizer needs - -- to name the returned object. Create a temporary which is initialized - -- with the function call: + -- to name the returned object. + + -- If the build-in-place function returns a definite subtype, then an + -- object also needs to be created and an access value designating it + -- passed as an actual. + + -- Create a temporary which is initialized with the function call: -- -- Temp_Id : Func_Type := BIP_Func_Call; -- @@ -8610,75 +8604,25 @@ package body Exp_Ch6 is -- the expander using the appropriate mechanism in Make_Build_In_Place_ -- Call_In_Object_Declaration. - if Needs_Finalization (Result_Subt) then + if Needs_Finalization (Result_Subt) + or else Caller_Known_Size (Func_Call, Result_Subt) + then declare Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); - Temp_Decl : Node_Id; - - begin - -- Reset the guard on the function call since the following does - -- not perform actual call expansion. - - Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); - - Temp_Decl := + Temp_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, - Object_Definition => - New_Occurrence_Of (Result_Subt, Loc), - Expression => - New_Copy_Tree (Function_Call)); + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Result_Subt, Loc), + Expression => Relocate_Node (Function_Call)); + begin + Set_Assignment_OK (Temp_Decl); Insert_Action (Function_Call, Temp_Decl); - Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); Analyze (Function_Call); end; - -- When the result subtype is definite, an object of the subtype is - -- declared and an access value designating it is passed as an actual. - - elsif Caller_Known_Size (Func_Call, Result_Subt) then - - -- Create a temporary object to hold the function result - - Return_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Return_Obj_Id, Result_Subt); - - Return_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Result_Subt, Loc)); - - Set_No_Initialization (Return_Obj_Decl); - - Insert_Action (Func_Call, Return_Obj_Decl); - - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. - - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - - Add_Collection_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id); - - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); - - -- Add an implicit actual to the function call that provides access - -- to the caller's return object. - - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc)); - - pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); - pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); - -- When the result subtype is unconstrained, the function must allocate -- the return object in the secondary stack, so appropriate implicit -- parameters are added to the call to indicate that. A transient @@ -8703,6 +8647,10 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Empty); + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); end if; @@ -9909,6 +9857,13 @@ package body Exp_Ch6 is return Skip; end if; + -- Skip calls placed in unexpanded initialization expressions + + when N_Object_Declaration => + if No_Initialization (Nod) then + return Skip; + end if; + -- Skip calls placed in subprogram specifications since function -- calls initializing default parameter values will be processed -- when the call to the subprogram is found (if the default actual diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 67af1d7..905094c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2783,16 +2783,31 @@ package body Exp_Ch7 is Master_Node_Id := Make_Defining_Identifier (Master_Node_Loc, Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN")); + Master_Node_Decl := Make_Master_Node_Declaration (Master_Node_Loc, Master_Node_Id, Obj_Id); Push_Scope (Scope (Obj_Id)); + + -- Avoid generating duplicate names for master nodes + + if Ekind (Obj_Id) = E_Loop_Parameter + and then + Present (Current_Entity_In_Scope (Chars (Master_Node_Id))) + then + Set_Chars (Master_Node_Id, + New_External_Name (Chars (Obj_Id), + Suffix => "MN", + Suffix_Index => -1)); + end if; + if not Has_Strict_Ctrl_Objs or else Count = 1 then Prepend_To (Decls, Master_Node_Decl); else Insert_Before (Decl, Master_Node_Decl); end if; + Analyze (Master_Node_Decl); Pop_Scope; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b8c6a9f..44e26d1 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1081,10 +1081,12 @@ package body Exp_Util is Make_Attribute_Reference (Loc, Prefix => (if Is_Allocate then - Duplicate_Subexpr_No_Checks (Expression (Alloc_Expr)) + Duplicate_Subexpr_No_Checks + (Expression (Alloc_Expr), New_Scope => Proc_Id) else Make_Explicit_Dereference (Loc, - Duplicate_Subexpr_No_Checks (Expr))), + Duplicate_Subexpr_No_Checks + (Expr, New_Scope => Proc_Id))), Attribute_Name => Name_Alignment))); end if; @@ -1137,7 +1139,9 @@ package body Exp_Util is if Is_RTE (Etype (Temp), RE_Tag_Ptr) then Param := Make_Explicit_Dereference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Temp)); + Prefix => + Duplicate_Subexpr_No_Checks + (Temp, New_Scope => Proc_Id)); -- In the default case, obtain the tag of the object about -- to be allocated / deallocated. Generate: @@ -1157,7 +1161,9 @@ package body Exp_Util is Param := Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Temp), + Prefix => + Duplicate_Subexpr_No_Checks + (Temp, New_Scope => Proc_Id), Attribute_Name => Name_Tag); end if; @@ -1517,7 +1523,118 @@ package body Exp_Util is New_E := Type_Map.Get (Entity (N)); if Present (New_E) then - Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + declare + + Ctrl_Type : constant Entity_Id + := Find_Dispatching_Type (Par_Subp); + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean; + -- If Call_Node is a call to a primitive function F of the + -- tagged type T associated with Par_Subp that either has + -- any actuals that are controlling formals of Par_Subp, + -- or else the call to F is an actual parameter of an + -- enclosing call to a primitive of T that has any actuals + -- that are controlling formals of Par_Subp (and recursively + -- up the tree of enclosing function calls), returns True; + -- otherwise returns False. Returning True implies that the + -- call to F must be mapped to a call that instead targets + -- the corresponding function F of the tagged type for which + -- Subp is a primitive function. + + -------------------------------------------------- + -- Call_To_Parent_Dispatching_Op_Must_Be_Mapped -- + -------------------------------------------------- + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean + is + pragma Assert (Nkind (Call_Node) = N_Function_Call); + + Actual : Node_Id := First_Actual (Call_Node); + Actual_Type : Entity_Id; + Actual_Or_Prefix : Node_Id; + + begin + if Is_Entity_Name (Name (Call_Node)) + and then Is_Dispatching_Operation + (Entity (Name (Call_Node))) + and then + Is_Ancestor + (Ctrl_Type, + Find_Dispatching_Type + (Entity (Name (Call_Node)))) + then + while Present (Actual) loop + + -- Account for 'Old and explicit dereferences, + -- picking up the prefix object in those cases. + + if (Nkind (Actual) = N_Attribute_Reference + and then Attribute_Name (Actual) = Name_Old) + or else Nkind (Actual) = N_Explicit_Dereference + then + Actual_Or_Prefix := Prefix (Actual); + else + Actual_Or_Prefix := Actual; + end if; + + Actual_Type := Etype (Actual); + + if Is_Anonymous_Access_Type (Actual_Type) then + Actual_Type := Designated_Type (Actual_Type); + end if; + + if Nkind (Actual_Or_Prefix) + in N_Identifier + | N_Expanded_Name + | N_Operator_Symbol + + and then Is_Formal (Entity (Actual_Or_Prefix)) + + and then Covers (Ctrl_Type, Actual_Type) + then + -- At least one actual is a formal parameter of + -- Par_Subp with type Ctrl_Type. + + return True; + end if; + + Next_Actual (Actual); + end loop; + + if Nkind (Parent (Call_Node)) = N_Function_Call then + return + Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Parent (Call_Node)); + end if; + + return False; + + else + return False; + end if; + end Call_To_Parent_Dispatching_Op_Must_Be_Mapped; + + begin + -- If N's entity is in the map, then the entity is either + -- a formal of the parent subprogram that should necessarily + -- be mapped, or it's a function call's target entity that + -- that should be mapped if the call involves any actuals + -- that reference formals of the parent subprogram (or the + -- function call is part of an enclosing call that similarly + -- qualifies for mapping). Rewrite a node that references + -- any such qualified entity to a new node referencing the + -- corresponding entity associated with the derived type. + + if not Is_Subprogram (Entity (N)) + or else Nkind (Parent (N)) /= N_Function_Call + or else + Call_To_Parent_Dispatching_Op_Must_Be_Mapped (Parent (N)) + then + Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + end if; + end; end if; -- Update type of function call node, which should be the same as @@ -5062,12 +5179,13 @@ package body Exp_Util is function Duplicate_Subexpr (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is begin Remove_Side_Effects (Exp, Name_Req, Renaming_Req); - return New_Copy_Tree (Exp); + return New_Copy_Tree (Exp, New_Scope => New_Scope); end Duplicate_Subexpr; --------------------------------- @@ -5076,8 +5194,9 @@ package body Exp_Util is function Duplicate_Subexpr_No_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; @@ -5087,7 +5206,7 @@ package body Exp_Util is Name_Req => Name_Req, Renaming_Req => Renaming_Req); - New_Exp := New_Copy_Tree (Exp); + New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope); Remove_Checks (New_Exp); return New_Exp; end Duplicate_Subexpr_No_Checks; @@ -5098,14 +5217,15 @@ package body Exp_Util is function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; begin Remove_Side_Effects (Exp, Name_Req, Renaming_Req); - New_Exp := New_Copy_Tree (Exp); + New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope); Remove_Checks (Exp); return New_Exp; end Duplicate_Subexpr_Move_Checks; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 6178767..1306f5e 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -479,8 +479,9 @@ package Exp_Util is function Duplicate_Subexpr (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Given the node for a subexpression, this function makes a logical copy -- of the subexpression, and returns it. This is intended for use when the -- expansion of an expression needs to repeat part of it. For example, @@ -494,6 +495,9 @@ package Exp_Util is -- the caller is responsible for analyzing the returned copy after it is -- attached to the tree. -- + -- The New_Scope entity may be used to specify a new scope for all copied + -- entities and itypes. + -- -- The Name_Req flag is set to ensure that the result is suitable for use -- in a context requiring a name (for example, the prefix of an attribute -- reference). @@ -509,8 +513,9 @@ package Exp_Util is function Duplicate_Subexpr_No_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on the result, so that the duplicated expression does not include -- checks. This is appropriate for use when Exp, the original expression is @@ -519,8 +524,9 @@ package Exp_Util is function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on Exp after the duplication is complete, so that the original -- expression does not include checks. In this case the result returned diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 54b6202..eb751e1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6869,9 +6869,10 @@ package body Freeze is end if; end if; - -- Static objects require special handling + -- Statically allocated objects require special handling if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then No (Renamed_Object (E)) and then Is_Statically_Allocated (E) then Freeze_Static_Object (E); @@ -10230,11 +10231,17 @@ package body Freeze is -- issue an error message saying that this object cannot be imported -- or exported. If it has an address clause it is an overlay in the -- current partition and the static requirement is not relevant. - -- Do not issue any error message when ignoring rep clauses. + -- Do not issue any error message when ignoring rep clauses or for + -- compiler-generated entities. if Ignore_Rep_Clauses then null; + elsif not Comes_From_Source (E) then + pragma + Assert (Nkind (Parent (Declaration_Node (E))) in N_Case_Statement + | N_If_Statement); + elsif Is_Imported (E) then if No (Address_Clause (E)) then Error_Msg_N diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 97469d7..54830b8 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -12360,9 +12360,9 @@ which changes element (1,2) to 20 and (3,4) to 30. @geindex Valid_Value The @code{'Valid_Value} attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. @code{T'Valid_Value (S)} returns True -if and only if @code{T'Value (S)} would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. @code{T'Valid_Value (S)} +returns True if and only if @code{T'Value (S)} would not raise Constraint_Error. @node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Value,Implementation Defined Attributes @anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1c5} diff --git a/gcc/ada/libgnarl/s-stusta.adb b/gcc/ada/libgnarl/s-stusta.adb index 5aca435..c9848a0 100644 --- a/gcc/ada/libgnarl/s-stusta.adb +++ b/gcc/ada/libgnarl/s-stusta.adb @@ -32,6 +32,7 @@ -- This is why this package is part of GNARL: with System.Tasking.Debug; +with System.Tasking.Stages; with System.Task_Primitives.Operations; with System.IO; @@ -103,7 +104,9 @@ package body System.Stack_Usage.Tasking is -- Calculate the task usage for a given task - Report_For_Task (Id); + if not System.Tasking.Stages.Terminated (Id) then + Report_For_Task (Id); + end if; end loop; end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index af08fdb..08da29a 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7511,13 +7511,14 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); Validate_Non_Static_Attribute_Function_Call; - if P_Type in Standard_Boolean + if Root_Type (P_Type) in Standard_Boolean | Standard_Character | Standard_Wide_Character | Standard_Wide_Wide_Character then Error_Attr_P - ("prefix of % attribute must not be a type in Standard"); + ("prefix of % attribute must not be a type originating from " & + "Standard"); end if; if Discard_Names (First_Subtype (P_Type)) then diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 3399a41..c81b563 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -3684,13 +3684,15 @@ package body Sem_Case is -- Use of nonstatic predicate is an error if not Is_Discrete_Type (E) - or else not Has_Static_Predicate (E) + or else (not Has_Static_Predicate (E) + and then + not Has_Static_Predicate_Aspect (E)) or else Has_Dynamic_Predicate_Aspect (E) or else Has_Ghost_Predicate_Aspect (E) then Bad_Predicated_Subtype_Use - ("cannot use subtype& with non-static " - & "predicate as case alternative", + ("cannot use subtype& with nonstatic " + & "predicate as choice in case alternative", Choice, E, Suggest_Static => True); -- Static predicate case. The bounds are those of diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index de5a8c8..e3d9925 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -4932,6 +4932,8 @@ package body Sem_Ch10 is if Entity (Name (Clause)) = Id or else (Nkind (Name (Clause)) = N_Expanded_Name + and then + Is_Entity_Name (Prefix (Name (Clause))) and then Entity (Prefix (Name (Clause))) = Id) then return True; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5768e28e..02c7c36 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -9340,9 +9340,6 @@ package body Sem_Ch12 is and then Nkind (Ancestor_Type (N)) in N_Entity then declare - Root_Typ : constant Entity_Id := - Root_Type (Ancestor_Type (N)); - Typ : Entity_Id := Ancestor_Type (N); begin @@ -9351,7 +9348,7 @@ package body Sem_Ch12 is Switch_View (Typ); end if; - exit when Typ = Root_Typ; + exit when Etype (Typ) = Typ; Typ := Etype (Typ); end loop; @@ -14132,6 +14129,16 @@ package body Sem_Ch12 is T2 := Etype (I2); end if; + -- In the case of a fixed-lower-bound subtype, we want to check + -- against the index type's range rather than the range of the + -- subtype (which will be seen as unconstrained, and whose bounds + -- won't generally match those of the formal unconstrained array + -- type's corresponding index type). + + if Is_Fixed_Lower_Bound_Index_Subtype (T2) then + T2 := Etype (Scalar_Range (T2)); + end if; + if not Subtypes_Match (Find_Actual_Type (Etype (I1), A_Gen_T), T2) then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 74eac9c..9a25ff7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4991,7 +4991,7 @@ package body Sem_Ch3 is if Is_Array_Type (T) and then No_Initialization (N) - and then Nkind (Original_Node (E)) = N_Aggregate + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then Act_T := Etype (E); @@ -5137,10 +5137,7 @@ package body Sem_Ch3 is elsif Is_Array_Type (T) and then No_Initialization (N) - and then (Nkind (Original_Node (E)) = N_Aggregate - or else (Nkind (Original_Node (E)) = N_Qualified_Expression - and then Nkind (Original_Node (Expression - (Original_Node (E)))) = N_Aggregate)) + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then if not Is_Entity_Name (Object_Definition (N)) then Act_T := Etype (E); @@ -6633,8 +6630,6 @@ package body Sem_Ch3 is end; end if; - -- Constrained array case - if No (T) then -- We might be creating more than one itype with the same Related_Id, -- e.g. for an array object definition and its initial value. Give @@ -6644,6 +6639,8 @@ package body Sem_Ch3 is T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); end if; + -- Constrained array case + if Nkind (Def) = N_Constrained_Array_Definition then Index := First (Discrete_Subtype_Definitions (Def)); @@ -15095,7 +15092,8 @@ package body Sem_Ch3 is -- If this is a range for a fixed-lower-bound subtype, then set the -- index itype's low bound to the FLB and the index itype's upper bound -- to the high bound of the parent array type's index subtype. Also, - -- mark the itype as an FLB index subtype. + -- set the Etype of the new scalar range and mark the itype as an FLB + -- index subtype. if Nkind (S) = N_Range and then Is_FLB_Index then Set_Scalar_Range @@ -15103,6 +15101,7 @@ package body Sem_Ch3 is Make_Range (Sloc (S), Low_Bound => Low_Bound (S), High_Bound => Type_High_Bound (T))); + Set_Etype (Scalar_Range (Def_Id), Etype (Index)); Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id); else diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 4069839..8be9647 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -308,8 +308,12 @@ package body Sem_Ch4 is (N : Node_Id; Prefix : Node_Id; Exprs : List_Id) return Boolean; - -- AI05-0139: Generalized indexing to support iterators over containers - -- ??? Need to provide a more detailed spec of what this function does + -- AI05-0139: Generalized indexing to support iterators over containers. + -- Given the N_Indexed_Component node N, with the given prefix and + -- expressions list, check if the generalized indexing is applicable; + -- if applicable then build its indexing function, link it to N through + -- attribute Generalized_Indexing, and return True; otherwise return + -- False. function Try_Indexed_Call (N : Node_Id; @@ -7642,35 +7646,14 @@ package body Sem_Ch4 is begin if not Is_Overloaded (R) then if Is_Numeric_Type (Etype (R)) then - - -- In an instance a generic actual may be a numeric type even if - -- the formal in the generic unit was not. In that case, the - -- predefined operator was not a possible interpretation in the - -- generic, and cannot be one in the instance, unless the operator - -- is an actual of an instance. - - if In_Instance - and then - not Is_Numeric_Type (Corresponding_Generic_Type (Etype (R))) - then - null; - else - Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); - end if; + Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); end if; else Get_First_Interp (R, Index, It); while Present (It.Typ) loop if Is_Numeric_Type (It.Typ) then - if In_Instance - and then - not Is_Numeric_Type - (Corresponding_Generic_Type (Etype (It.Typ))) - then - null; - - elsif Is_Effectively_Visible_Operator (N, Base_Type (It.Typ)) + if Is_Effectively_Visible_Operator (N, Base_Type (It.Typ)) then Add_One_Interp (N, Op_Id, Base_Type (It.Typ)); end if; @@ -8533,21 +8516,29 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is - Pref_Typ : Entity_Id := Etype (Prefix); + Heuristic : Boolean := False; + Pref_Typ : Entity_Id := Etype (Prefix); function Constant_Indexing_OK return Boolean; - -- Constant_Indexing is legal if there is no Variable_Indexing defined - -- for the type, or else node not a target of assignment, or an actual - -- for an IN OUT or OUT formal (RM 4.1.6 (11)). - - function Expr_Matches_In_Formal - (Subp : Entity_Id; - Par : Node_Id) return Boolean; - -- Find formal corresponding to given indexed component that is an - -- actual in a call. Note that the enclosing subprogram call has not - -- been analyzed yet, and the parameter list is not normalized, so - -- that if the argument is a parameter association we must match it - -- by name and not by position. + -- Determines whether the Constant_Indexing aspect has been specified + -- for the type of the prefix and can be interpreted as constant + -- indexing; that is, there is no Variable_Indexing defined for the + -- type, or else the node is not a target of an assignment, or an + -- actual for an IN OUT or OUT formal, or the name in an object + -- renaming (RM 4.1.6 (12/3..15/3)). + -- + -- Given that prefix notation calls have not yet been resolved, if the + -- type of the prefix has both aspects present (Constant_Indexing and + -- Variable_Indexing), and context analysis performed by this routine + -- identifies a potential prefix notation call (i.e., an N_Selected_ + -- Component node), this function may rely on heuristics to decide + -- between constant or variable indexing. In such cases, if the + -- decision is later found to be incorrect, Try_Container_Indexing + -- will retry using the alternative indexing aspect. + + -- When heuristics are used to compute the result of this function + -- the behavior of Try_Container_Indexing might not be strictly + -- following the rules of the RM. function Indexing_Interpretations (T : Entity_Id; @@ -8555,59 +8546,429 @@ package body Sem_Ch4 is -- Return a set of interpretations reflecting all of the functions -- associated with an indexing aspect of type T of the given kind. + function Try_Indexing_Function + (Func_Name : Node_Id; + Assoc : List_Id) return Entity_Id; + -- Build a call to the given indexing function name with the given + -- parameter associations; if there are several indexing functions + -- the call is analyzed for each of the interpretation; if there are + -- several successfull candidates, resolution is handled by result. + -- Return the Etype of the built function call. + -------------------------- -- Constant_Indexing_OK -- -------------------------- function Constant_Indexing_OK return Boolean is - Par : Node_Id; + + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Subp_Call : Node_Id; + Param : Node_Id; + Skip_Controlling_Formal : Boolean := False) return Boolean; + -- Find formal corresponding to given indexed component that is an + -- actual in a call. Note that the enclosing subprogram call has not + -- been analyzed yet, and the parameter list is not normalized, so + -- that if the argument is a parameter association we must match it + -- by name and not by position. In the traversal up the tree done by + -- Constant_Indexing_OK, the previous node in the traversal (that is, + -- the actual parameter used to ascend to the subprogram call node), + -- is passed to this function in formal Param, and it is used to + -- determine wether the argument is passed by name or by position. + -- Skip_Controlling_Formal is set to True to skip the first formal + -- of Subp. + + procedure Handle_Selected_Component + (Current_Node : Node_Id; + Sel_Comp : Node_Id; + Candidate : out Entity_Id; + Is_Constant_Idx : out Boolean); + -- Current_Node is the current node climbing up the tree. Determine + -- if Sel_Comp is a candidate for a prefixed call using constant + -- indexing; if no candidate is found Candidate is returned Empty + -- and Is_Constant_Idx is returned False. + + function Has_IN_Mode (Formal : Node_Id) return Boolean is + (Ekind (Formal) = E_In_Parameter); + -- Return True if the given formal has mode IN + + ---------------------------- + -- Expr_Matches_In_Formal -- + ---------------------------- + + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Subp_Call : Node_Id; + Param : Node_Id; + Skip_Controlling_Formal : Boolean := False) return Boolean + is + pragma Assert (Nkind (Subp_Call) in N_Subprogram_Call); + + Actual : Node_Id := First (Parameter_Associations (Subp_Call)); + Formal : Node_Id := First_Formal (Subp); + + begin + if Skip_Controlling_Formal then + Next_Formal (Formal); + end if; + + -- Match by position + + if Nkind (Param) /= N_Parameter_Association then + while Present (Actual) and then Present (Formal) loop + exit when Actual = Param; + Next (Actual); + + if Present (Formal) then + Next_Formal (Formal); + + -- Otherwise this is a parameter mismatch, the error is + -- reported elsewhere, or else variable indexing is implied. + + else + return False; + end if; + end loop; + + -- Match by name + + else + while Present (Formal) loop + exit when Chars (Formal) = Chars (Selector_Name (Param)); + Next_Formal (Formal); + + if No (Formal) then + return False; + end if; + end loop; + end if; + + return Present (Formal) and then Has_IN_Mode (Formal); + end Expr_Matches_In_Formal; + + ------------------------------- + -- Handle_Selected_Component -- + ------------------------------- + + procedure Handle_Selected_Component + (Current_Node : Node_Id; + Sel_Comp : Node_Id; + Candidate : out Entity_Id; + Is_Constant_Idx : out Boolean) + is + procedure Search_Constant_Interpretation + (Call : Node_Id; + Target_Name : Node_Id; + Candidate : out Entity_Id; + Is_Unique : out Boolean; + Unique_Mode : out Boolean); + -- Given a subprogram call, search in the homonyms chain for + -- visible (or potentially visible) dispatching primitives that + -- have at least one formal. Candidate is the entity of the first + -- found candidate; Is_Unique is returned True when the mode of + -- the first formal of all the candidates match. If no candidate + -- is found the out parameter Candidate is returned Empty, and + -- Is_Unique is returned False. + + procedure Search_Enclosing_Call + (Call_Node : out Node_Id; + Prev_Node : out Node_Id); + -- Climb up to the tree looking for an enclosing subprogram call + -- of a prefixed notation call. If found then the Call_Node and + -- its Prev_Node in such traversal are returned; otherwise + -- Call_Node and Prev_Node are returned Empty. + + ------------------------------------ + -- Search_Constant_Interpretation -- + ------------------------------------ + + procedure Search_Constant_Interpretation + (Call : Node_Id; + Target_Name : Node_Id; + Candidate : out Entity_Id; + Is_Unique : out Boolean; + Unique_Mode : out Boolean) + is + Constant_Idx : Boolean; + In_Proc_Call : constant Boolean := + Present (Call) + and then + Nkind (Call) = N_Procedure_Call_Statement; + Kind : constant Entity_Kind := + (if In_Proc_Call then E_Procedure + else E_Function); + Target_Subp : constant Entity_Id := + Current_Entity (Target_Name); + begin + Candidate := Empty; + Is_Unique := False; + Unique_Mode := False; + + if Present (Target_Subp) then + declare + Hom : Entity_Id := Target_Subp; + + begin + while Present (Hom) loop + if Is_Overloadable (Hom) + and then Is_Dispatching_Operation (Hom) + and then + (Is_Immediately_Visible (Scope (Hom)) + or else + Is_Potentially_Use_Visible (Scope (Hom))) + and then Ekind (Hom) = Kind + and then Present (First_Formal (Hom)) + then + if No (Candidate) then + Candidate := Hom; + Is_Unique := True; + Unique_Mode := True; + Constant_Idx := + Has_IN_Mode (First_Formal (Candidate)); + + else + Is_Unique := False; + + if Ekind (First_Formal (Hom)) + /= Ekind (First_Formal (Candidate)) + or else Has_IN_Mode (First_Formal (Hom)) + /= Constant_Idx + then + Unique_Mode := False; + exit; + end if; + end if; + end if; + + Hom := Homonym (Hom); + end loop; + end; + end if; + end Search_Constant_Interpretation; + + --------------------------- + -- Search_Enclosing_Call -- + --------------------------- + + procedure Search_Enclosing_Call + (Call_Node : out Node_Id; + Prev_Node : out Node_Id) + is + Prev : Node_Id := Current_Node; + Par : Node_Id := Parent (N); + + begin + while Present (Par) + and then Nkind (Par) not in N_Subprogram_Call + | N_Handled_Sequence_Of_Statements + | N_Assignment_Statement + | N_Iterator_Specification + | N_Object_Declaration + | N_Case_Statement + | N_Declaration + | N_Elsif_Part + | N_If_Statement + | N_Simple_Return_Statement + loop + Prev := Par; + Par := Parent (Par); + end loop; + + if Present (Par) + and then Nkind (Par) in N_Subprogram_Call + and then Nkind (Name (Par)) = N_Selected_Component + then + Call_Node := Par; + Prev_Node := Prev; + else + Call_Node := Empty; + Prev_Node := Empty; + end if; + end Search_Enclosing_Call; + + -- Local variables + + Is_Unique : Boolean; + Unique_Mode : Boolean; + Call_Node : Node_Id; + Prev_Node : Node_Id; + + -- Start of processing for Handle_Selected_Component + + begin + pragma Assert (Nkind (Sel_Comp) = N_Selected_Component); + + -- Climb up the tree starting from Current_Node searching for the + -- enclosing subprogram call of a prefixed notation call. + + Search_Enclosing_Call (Call_Node, Prev_Node); + + -- Search for a candidate visible (or potentially visible) + -- dispatching primitive that has at least one formal, and may + -- be called using the prefix notation. This must be done even + -- if we did not found an enclosing call since the prefix notation + -- call has not been transformed yet into a subprogram call. The + -- found Call_Node (if any) is passed now to help identifying if + -- the prefix notation call corresponds with a procedure call or + -- a function call. + + Search_Constant_Interpretation + (Call => Call_Node, + Target_Name => Selector_Name (Sel_Comp), + Candidate => Candidate, + Is_Unique => Is_Unique, + Unique_Mode => Unique_Mode); + + -- If there is no candidate to interpret this node as a prefixed + -- call to a subprogram we return no candidate, and the caller + -- will continue ascending in the tree. + + if No (Candidate) then + Is_Constant_Idx := False; + + -- If we found an unique candidate and also found the enclosing + -- call node, we differentiate two cases: either we climbed up + -- the tree through the first actual parameter of the call (that + -- is, the name of the selected component), or we climbed up the + -- tree though another actual parameter of the prefixed call and + -- we must skip the controlling formal of the call. + + elsif Is_Unique + and then Present (Call_Node) + then + -- First actual parameter + + if Name (Call_Node) = Prev_Node + and then Nkind (Prev_Node) = N_Selected_Component + and then Nkind (Selector_Name (Prev_Node)) in N_Has_Chars + and then Chars (Selector_Name (Prev_Node)) = Chars (Candidate) + then + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + + -- Any other actual parameter + + else + Is_Constant_Idx := + Expr_Matches_In_Formal (Candidate, + Subp_Call => Call_Node, + Param => Prev_Node, + Skip_Controlling_Formal => True); + end if; + + -- The mode of the first formal of all the candidates match but, + -- given that we have several candidates, we cannot check if + -- indexing is used in the first actual parameter of the call + -- or in another actual parameter. Heuristically assume here + -- that indexing is used in the prefix of a call. + + elsif Unique_Mode then + Heuristic := True; + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + + -- The target candidate subprogram has several possible + -- interpretations; we don't know what to do with an + -- N_Selected_Component node for a prefixed notation call + -- to AA.BB that has several candidate targets and it has + -- not yet been resolved. For now we maintain the + -- behavior that we have had so far; to be improved??? + + else + Heuristic := True; + + if Nkind (Call_Node) = N_Procedure_Call_Statement then + Is_Constant_Idx := False; + + -- For function calls we rely on the mode of the + -- first formal of the first found candidate??? + + else + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + end if; + end if; + end Handle_Selected_Component; + + -- Local variables + + Asp_Constant : constant Node_Id := + Find_Value_Of_Aspect (Pref_Typ, + Aspect_Constant_Indexing); + Asp_Variable : constant Node_Id := + Find_Value_Of_Aspect (Pref_Typ, + Aspect_Variable_Indexing); + Par : Node_Id; + + -- Start of processing for Constant_Indexing_OK begin - if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then + if No (Asp_Constant) then + return False; + + -- It is interpreted as constant indexing when the prefix has the + -- Constant_Indexing aspect and the Variable_Indexing aspect is not + -- specified for the type of the prefix. + + elsif No (Asp_Variable) then return True; + -- It is interpreted as constant indexing when the prefix denotes + -- a constant. + elsif not Is_Variable (Prefix) then return True; end if; + -- Both aspects are present + + pragma Assert (Present (Asp_Constant) and Present (Asp_Variable)); + + -- The prefix must be interpreted as a constant indexing when it + -- is used within a primary where a name denoting a constant is + -- permitted. + Par := N; while Present (Par) loop - if Nkind (Parent (Par)) = N_Assignment_Statement - and then Par = Name (Parent (Par)) + + -- Avoid climbing more than needed + + exit when Nkind (Parent (Par)) in N_Iterator_Specification + | N_Handled_Sequence_Of_Statements; + + if Nkind (Parent (Par)) in N_Case_Statement + | N_Declaration + | N_Elsif_Part + | N_If_Statement + | N_Simple_Return_Statement then - return False; + return True; + + -- It is not interpreted as constant indexing for the variable + -- name in the LHS of an assignment. + + elsif Nkind (Parent (Par)) = N_Assignment_Statement then + return Par /= Name (Parent (Par)); -- The call may be overloaded, in which case we assume that its -- resolution does not depend on the type of the parameter that - -- includes the indexing operation. + -- includes the indexing operation because we cannot invoke + -- Preanalyze_And_Resolve (since it would cause a never-ending + -- loop). elsif Nkind (Parent (Par)) in N_Subprogram_Call then - if not Is_Entity_Name (Name (Parent (Par))) then - - -- ??? We don't know what to do with an N_Selected_Component - -- node for a prefixed-notation call to AA.BB where AA's - -- type is known, but BB has not yet been resolved. In that - -- case, the preceding Is_Entity_Name call returns False. - -- Incorrectly returning False here will usually work - -- better than incorrectly returning True, so that's what - -- we do for now. + -- Regular subprogram call - return False; - end if; - - declare - Proc : Entity_Id; + -- It is not interpreted as constant indexing for the name + -- used for an OUT or IN OUT parameter. - begin - -- We should look for an interpretation with the proper - -- number of formals, and determine whether it is an - -- In_Parameter, but for now we examine the formal that - -- corresponds to the indexing, and assume that variable - -- indexing is required if some interpretation has an - -- assignable formal at that position. Still does not - -- cover the most complex cases ??? + -- We should look for an interpretation with the proper + -- number of formals, and determine whether it is an + -- In_Parameter, but for now we examine the formal that + -- corresponds to the indexing, and assume that variable + -- indexing is required if some interpretation has an + -- assignable formal at that position. Still does not + -- cover the most complex cases ??? + if Is_Entity_Name (Name (Parent (Par))) then if Is_Overloaded (Name (Parent (Par))) then declare Proc : constant Node_Id := Name (Parent (Par)); @@ -8617,57 +8978,103 @@ package body Sem_Ch4 is begin Get_First_Interp (Proc, I, It); while Present (It.Nam) loop - if not Expr_Matches_In_Formal (It.Nam, Par) then + if not Expr_Matches_In_Formal + (Subp => It.Nam, + Subp_Call => Parent (Par), + Param => Par) + then return False; end if; Get_Next_Interp (I, It); end loop; - end; - -- All interpretations have a matching in-mode formal + -- All interpretations have a matching in-mode formal - return True; + return True; + end; else - Proc := Entity (Name (Parent (Par))); + declare + Proc : Entity_Id := Entity (Name (Parent (Par))); - -- If this is an indirect call, get formals from - -- designated type. + begin + -- If this is an indirect call, get formals from + -- designated type. - if Is_Access_Subprogram_Type (Etype (Proc)) then - Proc := Designated_Type (Etype (Proc)); - end if; + if Is_Access_Subprogram_Type (Etype (Proc)) then + Proc := Designated_Type (Etype (Proc)); + end if; + + return Expr_Matches_In_Formal + (Subp => Proc, + Subp_Call => Parent (Par), + Param => Par); + end; end if; - return Expr_Matches_In_Formal (Proc, Par); - end; + -- Continue climbing + + elsif Nkind (Name (Parent (Par))) = N_Explicit_Dereference then + null; + + -- Not a regular call; we know that we are in a subprogram + -- call, we also know that the name of the call may be a + -- prefixed call, and we know the name of the target + -- subprogram. Search for an unique target candidate in the + -- homonym chain. + + elsif Nkind (Name (Parent (Par))) = N_Selected_Component then + declare + Candidate : Entity_Id; + Is_Constant_Idx : Boolean; + + begin + Handle_Selected_Component + (Current_Node => Par, + Sel_Comp => Name (Parent (Par)), + Candidate => Candidate, + Is_Constant_Idx => Is_Constant_Idx); + + if Present (Candidate) then + return Is_Constant_Idx; + + -- Continue climbing + + else + null; + end if; + end; + end if; + + -- It is not interpreted as constant indexing for the name in + -- an object renaming. elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then return False; - -- If the indexed component is a prefix it may be the first actual - -- of a prefixed call. Retrieve the called entity, if any, and - -- check its first formal. Determine if the context is a procedure - -- or function call. + -- If the indexed component is a prefix it may be an actual of + -- of a prefixed call. elsif Nkind (Parent (Par)) = N_Selected_Component then declare - Sel : constant Node_Id := Selector_Name (Parent (Par)); - Nam : constant Entity_Id := Current_Entity (Sel); + Candidate : Entity_Id; + Is_Constant_Idx : Boolean; begin - if Present (Nam) and then Is_Overloadable (Nam) then - if Nkind (Parent (Parent (Par))) = - N_Procedure_Call_Statement - then - return False; + Handle_Selected_Component + (Current_Node => Par, + Sel_Comp => Parent (Par), + Candidate => Candidate, + Is_Constant_Idx => Is_Constant_Idx); - elsif Ekind (Nam) = E_Function - and then Present (First_Formal (Nam)) - then - return Ekind (First_Formal (Nam)) = E_In_Parameter; - end if; + if Present (Candidate) then + return Is_Constant_Idx; + + -- Continue climbing + + else + null; end if; end; @@ -8678,61 +9085,12 @@ package body Sem_Ch4 is Par := Parent (Par); end loop; - -- In all other cases, constant indexing is legal + -- It is not interpreted as constant indexing when both aspects + -- are present (RM 4.1.6(13/3)). - return True; + return False; end Constant_Indexing_OK; - ---------------------------- - -- Expr_Matches_In_Formal -- - ---------------------------- - - function Expr_Matches_In_Formal - (Subp : Entity_Id; - Par : Node_Id) return Boolean - is - Actual : Node_Id; - Formal : Node_Id; - - begin - Formal := First_Formal (Subp); - Actual := First (Parameter_Associations ((Parent (Par)))); - - if Nkind (Par) /= N_Parameter_Association then - - -- Match by position - - while Present (Actual) and then Present (Formal) loop - exit when Actual = Par; - Next (Actual); - - if Present (Formal) then - Next_Formal (Formal); - - -- Otherwise this is a parameter mismatch, the error is - -- reported elsewhere, or else variable indexing is implied. - - else - return False; - end if; - end loop; - - else - -- Match by name - - while Present (Formal) loop - exit when Chars (Formal) = Chars (Selector_Name (Par)); - Next_Formal (Formal); - - if No (Formal) then - return False; - end if; - end loop; - end if; - - return Present (Formal) and then Ekind (Formal) = E_In_Parameter; - end Expr_Matches_In_Formal; - ------------------------------ -- Indexing_Interpretations -- ------------------------------ @@ -8782,14 +9140,127 @@ package body Sem_Ch4 is return Indexing_Func; end Indexing_Interpretations; + --------------------------- + -- Try_Indexing_Function -- + --------------------------- + + function Try_Indexing_Function + (Func_Name : Node_Id; + Assoc : List_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + Func : Entity_Id; + Indexing : Node_Id; + + begin + if not Is_Overloaded (Func_Name) then + Func := Entity (Func_Name); + + Indexing := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Func, Loc), + Parameter_Associations => Assoc); + + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); + Analyze (Indexing); + Set_Etype (N, Etype (Indexing)); + + -- If the return type of the indexing function is a reference + -- type, add the dereference as a possible interpretation. Note + -- that the indexing aspect may be a function that returns the + -- element type with no intervening implicit dereference, and + -- that the reference discriminant is not the first discriminant. + + if Has_Discriminants (Etype (Func)) then + Check_Implicit_Dereference (N, Etype (Func)); + end if; + + else + -- If there are multiple indexing functions, build a function + -- call and analyze it for each of the possible interpretations. + + Indexing := + Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, Chars (Func_Name)), + Parameter_Associations => Assoc); + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); + Set_Etype (N, Any_Type); + Set_Etype (Name (Indexing), Any_Type); + + declare + I : Interp_Index; + It : Interp; + Success : Boolean; + + begin + Get_First_Interp (Func_Name, I, It); + Set_Etype (Indexing, Any_Type); + + -- Analyze each candidate function with the given actuals + + while Present (It.Nam) loop + Analyze_One_Call (Indexing, It.Nam, False, Success); + Get_Next_Interp (I, It); + end loop; + + -- If there are several successful candidates, resolution will + -- be by result. Mark the interpretations of the function name + -- itself. + + if Is_Overloaded (Indexing) then + Get_First_Interp (Indexing, I, It); + + while Present (It.Nam) loop + Add_One_Interp (Name (Indexing), It.Nam, It.Typ); + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (Name (Indexing), Etype (Indexing)); + end if; + + -- Now add the candidate interpretations to the indexing node + -- itself, to be replaced later by the function call. + + if Is_Overloaded (Name (Indexing)) then + Get_First_Interp (Name (Indexing), I, It); + + while Present (It.Nam) loop + Add_One_Interp (N, It.Nam, It.Typ); + + -- Add dereference interpretation if the result type has + -- implicit reference discriminants. + + if Has_Discriminants (Etype (It.Nam)) then + Check_Implicit_Dereference (N, Etype (It.Nam)); + end if; + + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (N, Etype (Name (Indexing))); + + if Has_Discriminants (Etype (N)) then + Check_Implicit_Dereference (N, Etype (N)); + end if; + end if; + end; + end if; + + return Etype (Indexing); + end Try_Indexing_Function; + -- Local variables Loc : constant Source_Ptr := Sloc (N); Assoc : List_Id; C_Type : Entity_Id; - Func : Entity_Id; Func_Name : Node_Id; - Indexing : Node_Id; + Idx_Type : Entity_Id; -- Start of processing for Try_Container_Indexing @@ -8799,6 +9270,13 @@ package body Sem_Ch4 is if Present (Generalized_Indexing (N)) then return True; + + -- Old language version or unknown type require no action + + elsif Ada_Version < Ada_2012 + or else Pref_Typ = Any_Type + then + return False; end if; -- An explicit dereference needs to be created in the case of a prefix @@ -8833,8 +9311,8 @@ package body Sem_Ch4 is Func_Name := Empty; - -- The context is suitable for constant indexing, so obtain the name of - -- the indexing functions from aspect Constant_Indexing. + -- The context is suitable for constant indexing, so obtain the name + -- of the indexing functions from aspect Constant_Indexing. if Constant_Indexing_OK then Func_Name := @@ -8867,6 +9345,11 @@ package body Sem_Ch4 is else return False; end if; + + -- Handle cascaded errors + + elsif No (Entity (Func_Name)) then + return False; end if; Assoc := New_List (Relocate_Node (Prefix)); @@ -8907,110 +9390,54 @@ package body Sem_Ch4 is end loop; end; - if not Is_Overloaded (Func_Name) then - Func := Entity (Func_Name); - - -- Can happen in case of e.g. cascaded errors - - if No (Func) then - return False; - end if; - - Indexing := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Func, Loc), - Parameter_Associations => Assoc); - - Set_Parent (Indexing, Parent (N)); - Set_Generalized_Indexing (N, Indexing); - Analyze (Indexing); - Set_Etype (N, Etype (Indexing)); - - -- If the return type of the indexing function is a reference type, - -- add the dereference as a possible interpretation. Note that the - -- indexing aspect may be a function that returns the element type - -- with no intervening implicit dereference, and that the reference - -- discriminant is not the first discriminant. - - if Has_Discriminants (Etype (Func)) then - Check_Implicit_Dereference (N, Etype (Func)); - end if; - - else - -- If there are multiple indexing functions, build a function call - -- and analyze it for each of the possible interpretations. - - Indexing := - Make_Function_Call (Loc, - Name => - Make_Identifier (Loc, Chars (Func_Name)), - Parameter_Associations => Assoc); - Set_Parent (Indexing, Parent (N)); - Set_Generalized_Indexing (N, Indexing); - Set_Etype (N, Any_Type); - Set_Etype (Name (Indexing), Any_Type); - + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); + + -- Last chance handling for heuristics: Given that prefix notation + -- calls have not yet been resolved, when the type of the prefix has + -- both operational aspects present (Constant_Indexing and Variable_ + -- Indexing), and the analysis of the context identified a potential + -- prefix notation call (i.e. an N_Selected_Component node), the + -- evaluation of Constant_Indexing_OK is based on heuristics; in such + -- case, if the chosen indexing approach is noticed now to be wrong + -- we retry with the other alternative before leaving. + + -- Retrying means that the heuristic decision taken when analyzing + -- the context failed in this case, and therefore we should adjust + -- the code of Handle_Selected_Component to improve identification + -- of prefix notation calls. This last chance handling handler is + -- left here for the purpose of improving such routine because it + -- proved to be usefull for identified such cases when the function + -- Handle_Selected_Component was added. + + if Idx_Type = Any_Type and then Heuristic then declare - I : Interp_Index; - It : Interp; - Success : Boolean; + Tried_Func_Name : constant Node_Id := Func_Name; begin - Get_First_Interp (Func_Name, I, It); - Set_Etype (Indexing, Any_Type); - - -- Analyze each candidate function with the given actuals + Func_Name := + Indexing_Interpretations (C_Type, + Aspect_Constant_Indexing); - while Present (It.Nam) loop - Analyze_One_Call (Indexing, It.Nam, False, Success); - Get_Next_Interp (I, It); - end loop; - - -- If there are several successful candidates, resolution will - -- be by result. Mark the interpretations of the function name - -- itself. - - if Is_Overloaded (Indexing) then - Get_First_Interp (Indexing, I, It); - - while Present (It.Nam) loop - Add_One_Interp (Name (Indexing), It.Nam, It.Typ); - Get_Next_Interp (I, It); - end loop; + if Present (Func_Name) + and then Func_Name /= Tried_Func_Name + then + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); else - Set_Etype (Name (Indexing), Etype (Indexing)); - end if; - - -- Now add the candidate interpretations to the indexing node - -- itself, to be replaced later by the function call. - - if Is_Overloaded (Name (Indexing)) then - Get_First_Interp (Name (Indexing), I, It); - - while Present (It.Nam) loop - Add_One_Interp (N, It.Nam, It.Typ); - - -- Add dereference interpretation if the result type has - -- implicit reference discriminants. + Func_Name := + Indexing_Interpretations (C_Type, + Aspect_Variable_Indexing); - if Has_Discriminants (Etype (It.Nam)) then - Check_Implicit_Dereference (N, Etype (It.Nam)); - end if; - - Get_Next_Interp (I, It); - end loop; - - else - Set_Etype (N, Etype (Name (Indexing))); - if Has_Discriminants (Etype (N)) then - Check_Implicit_Dereference (N, Etype (N)); + if Present (Func_Name) + and then Func_Name /= Tried_Func_Name + then + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); end if; end if; end; end if; - if Etype (Indexing) = Any_Type then + if Idx_Type = Any_Type then Error_Msg_NE ("container cannot be indexed with&", N, Etype (First (Exprs))); Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 621edc7..19e72ab 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14696,19 +14696,18 @@ package body Sem_Prag is D := Declaration_Node (E); - if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E)) + if (Nkind (D) in N_Full_Type_Declaration + | N_Formal_Type_Declaration + and then Is_Array_Type (E)) or else (Nkind (D) = N_Object_Declaration and then Ekind (E) in E_Constant | E_Variable and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition) - or else - (Ada_Version >= Ada_2022 - and then Nkind (D) = N_Formal_Type_Declaration) then -- The flag is set on the base type, or on the object - if Nkind (D) = N_Full_Type_Declaration then + if Is_Array_Type (E) then E := Base_Type (E); end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b73b947..0df6c27 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6101,6 +6101,8 @@ package body Sem_Res is elsif Is_Fixed_Point_Type (It.Typ) then if Analyzed (N) then Error_Msg_N ("ambiguous operand in fixed operation", N); + elsif It.Typ = Any_Fixed then + Resolve (N, B_Typ); else Resolve (N, It.Typ); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0e1505b..7757e04 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3025,7 +3025,7 @@ package body Sem_Util is -- For an array aggregate, a discrete_choice_list that has -- a nonstatic range is considered as two or more separate - -- occurrences of the expression (RM 6.4.1(20/3)). + -- occurrences of the expression (RM 6.4.1(6.20/3)). elsif Is_Array_Type (Etype (N)) and then Nkind (N) = N_Aggregate @@ -3110,48 +3110,105 @@ package body Sem_Util is end loop; end if; - -- Handle discrete associations + -- Handle named associations if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop - if not Box_Present (Assoc) then - Choice := First (Choices (Assoc)); - while Present (Choice) loop + Handle_Association : declare - -- For now we skip discriminants since it requires - -- performing the analysis in two phases: first one - -- analyzing discriminants and second one analyzing - -- the rest of components since discriminants are - -- evaluated prior to components: too much extra - -- work to detect a corner case??? + procedure Collect_Expression_Ids (Expr : Node_Id); + -- Collect identifiers in association expression Expr - if Nkind (Choice) in N_Has_Entity - and then Present (Entity (Choice)) - and then Ekind (Entity (Choice)) = E_Discriminant - then - null; + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id); + -- Collect identifiers in an association expression + -- Expr for each choice in Choices. - elsif Box_Present (Assoc) then - null; + ---------------------------- + -- Collect_Expression_Ids -- + ---------------------------- + procedure Collect_Expression_Ids (Expr : Node_Id) is + Comp_Expr : Node_Id; + + begin + if not Analyzed (Expr) then + Comp_Expr := New_Copy_Tree (Expr); + Set_Parent (Comp_Expr, Parent (N)); + Preanalyze_Without_Errors (Comp_Expr); else - if not Analyzed (Expression (Assoc)) then - Comp_Expr := - New_Copy_Tree (Expression (Assoc)); - Set_Parent (Comp_Expr, Parent (N)); - Preanalyze_Without_Errors (Comp_Expr); + Comp_Expr := Expr; + end if; + + Collect_Identifiers (Comp_Expr); + end Collect_Expression_Ids; + + -------------------------------- + -- Handle_Association_Choices -- + -------------------------------- + + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id) + is + Choice : Node_Id := First (Choices); + + begin + while Present (Choice) loop + + -- For now skip discriminants since it requires + -- performing analysis in two phases: first one + -- analyzing discriminants and second analyzing + -- the rest of components since discriminants + -- are evaluated prior to components: too much + -- extra work to detect a corner case??? + + if Nkind (Choice) in N_Has_Entity + and then Present (Entity (Choice)) + and then + Ekind (Entity (Choice)) = E_Discriminant + then + null; + else - Comp_Expr := Expression (Assoc); + Collect_Expression_Ids (Expr); end if; - Collect_Identifiers (Comp_Expr); - end if; + Next (Choice); + end loop; + end Handle_Association_Choices; - Next (Choice); - end loop; - end if; + begin + if not Box_Present (Assoc) then + if Nkind (Assoc) = N_Component_Association then + Handle_Association_Choices + (Choices (Assoc), Expression (Assoc)); + + elsif + Nkind (Assoc) = N_Iterated_Component_Association + and then Present (Defining_Identifier (Assoc)) + then + Handle_Association_Choices + (Discrete_Choices (Assoc), Expression (Assoc)); + + -- Nkind (Assoc) = N_Iterated_Component_Association + -- with iterator_specification, or + -- Nkind (Assoc) = N_Iterated_Element_Association + -- with loop_parameter_specification + -- or iterator_specification + -- + -- It seems that we might also need to deal with + -- iterable/iterator_names and iterator_filters + -- within iterator_specifications, and range bounds + -- within loop_parameter_specifications, but the + -- utility of doing that seems very low. ??? + + else + Collect_Expression_Ids (Expression (Assoc)); + end if; + end if; + end Handle_Association; Next (Assoc); end loop; @@ -8063,12 +8120,20 @@ package body Sem_Util is loop Ren := Renamed_Object (Id); + -- The reference renames a function result. Check the original + -- node in case expansion relocates the function call. + + -- Ren : ... renames Func_Call; + + if Nkind (Original_Node (Ren)) = N_Function_Call then + exit; + -- The reference renames an abstract state or a whole object -- Obj : ...; -- Ren : ... renames Obj; - if Is_Entity_Name (Ren) then + elsif Is_Entity_Name (Ren) then -- Do not follow a renaming that goes through a generic formal, -- because these entities are hidden and must not be referenced @@ -8081,14 +8146,6 @@ package body Sem_Util is Id := Entity (Ren); end if; - -- The reference renames a function result. Check the original - -- node in case expansion relocates the function call. - - -- Ren : ... renames Func_Call; - - elsif Nkind (Original_Node (Ren)) = N_Function_Call then - exit; - -- Otherwise the reference renames something which does not yield -- an abstract state or a whole object. Treat the reference as not -- having a proper entity for SPARK legality purposes. @@ -12368,9 +12425,14 @@ package body Sem_Util is while Present (Node) loop case Nkind (Node) is - when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => + when N_Null_Statement | N_Call_Marker => null; + when N_Raise_xxx_Error => + if Comes_From_Source (Node) then + return False; + end if; + when N_Object_Declaration => if Present (Expression (Node)) and then not Side_Effect_Free (Expression (Node)) diff --git a/gcc/builtins.def b/gcc/builtins.def index ff47005..6794109 100644 --- a/gcc/builtins.def +++ b/gcc/builtins.def @@ -217,6 +217,8 @@ along with GCC; see the file COPYING3. If not see DEF_BUILTIN (ENUM, "__builtin_" NAME, BUILT_IN_NORMAL, TYPE, TYPE, \ false, true, true, ATTRS, false, \ flag_openacc) +/* Set NONANSI_P = false to enable the builtins also with -fno-nonansi-builtins, + esp. as -std=c++../c.. imply that flag and -fopenacc should be othogonal. */ #undef DEF_GOACC_BUILTIN_COMPILER #define DEF_GOACC_BUILTIN_COMPILER(ENUM, NAME, TYPE, ATTRS) \ DEF_BUILTIN (ENUM, "__builtin_" NAME, BUILT_IN_NORMAL, TYPE, TYPE, \ @@ -232,10 +234,12 @@ along with GCC; see the file COPYING3. If not see (flag_openacc \ || flag_openmp \ || flag_tree_parallelize_loops > 1)) +/* Set NONANSI_P = false to enable the builtins also with -fno-nonansi-builtins, + esp. as -std=c++../c.. imply that flag and -fopenmp should be othogonal. */ #undef DEF_GOMP_BUILTIN_COMPILER #define DEF_GOMP_BUILTIN_COMPILER(ENUM, NAME, TYPE, ATTRS) \ DEF_BUILTIN (ENUM, "__builtin_" NAME, BUILT_IN_NORMAL, TYPE, TYPE, \ - flag_openmp, true, true, ATTRS, false, flag_openmp) + flag_openmp, true, false, ATTRS, false, flag_openmp) /* Builtin used by the implementation of GNU TM. These functions are mapped to the actual implementation of the STM library. */ diff --git a/gcc/c/ChangeLog.omp b/gcc/c/ChangeLog.omp index ff881b5..d3e1d0e 100644 --- a/gcc/c/ChangeLog.omp +++ b/gcc/c/ChangeLog.omp @@ -1,3 +1,12 @@ +2025-06-05 Sandra Loosemore <sloosemore@baylibre.com> + + Backported from master: + 2025-06-02 Sandra Loosemore <sloosemore@baylibre.com> + + * c-parser.cc (c_parser_omp_context_selector): Call + convert_lvalue_to_rvalue and c_objc_common_truthvalue_conversion + on the expression for OMP_TRAIT_PROPERTY_BOOL_EXPR. + 2025-05-15 waffl3x <waffl3x@baylibre.com> PR c++/119659 diff --git a/gcc/c/c-parser.cc b/gcc/c/c-parser.cc index d132704..368caf8 100644 --- a/gcc/c/c-parser.cc +++ b/gcc/c/c-parser.cc @@ -28425,17 +28425,30 @@ c_parser_omp_context_selector (c_parser *parser, enum omp_tss_code set, break; case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR: case OMP_TRAIT_PROPERTY_BOOL_EXPR: - t = c_parser_expr_no_commas (parser, NULL).value; + { + c_expr texpr = c_parser_expr_no_commas (parser, NULL); + texpr = convert_lvalue_to_rvalue (token->location, texpr, + true, true); + t = texpr.value; + } if (t == error_mark_node) return error_mark_node; mark_exp_read (t); - t = c_fully_fold (t, false, NULL); - if (!INTEGRAL_TYPE_P (TREE_TYPE (t))) + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + { + t = c_objc_common_truthvalue_conversion (token->location, + t, + boolean_type_node); + if (t == error_mark_node) + return error_mark_node; + } + else if (!INTEGRAL_TYPE_P (TREE_TYPE (t))) { error_at (token->location, "property must be integer expression"); return error_mark_node; } + t = c_fully_fold (t, false, NULL); properties = make_trait_property (NULL_TREE, t, properties); break; case OMP_TRAIT_PROPERTY_CLAUSE_LIST: diff --git a/gcc/config.gcc b/gcc/config.gcc index 40b50dc..5725704 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -4598,15 +4598,13 @@ case "${target}" in for which in arch tune; do eval "val=\$with_$which" - case ${val} in - "" | gfx900 | gfx906 | gfx908 | gfx90a | gfx90c | gfx1030 | gfx1036 | gfx1100 | gfx1103) - # OK - ;; - *) + if test x"$val" != x \ + && ! grep -q "GCN_DEVICE($val," \ + "${srcdir}/config/gcn/gcn-devices.def"; + then echo "Unknown cpu used in --with-$which=$val." 1>&2 exit 1 - ;; - esac + fi done [ "x$with_arch" = x ] && with_arch=gfx900 diff --git a/gcc/config/gcn/gcn-devices.def b/gcc/config/gcn/gcn-devices.def index af14203..426acf0 100644 --- a/gcc/config/gcn/gcn-devices.def +++ b/gcc/config/gcn/gcn-devices.def @@ -171,6 +171,28 @@ GCN_DEVICE(gfx90c, GFX90C, 0x32, ISA_GCN5, /* Generic Name */ GFX9_GENERIC ) +GCN_DEVICE(gfx942, GFX942, 0x4c, ISA_CDNA3, + /* XNACK default */ HSACO_ATTR_ANY, + /* SRAM_ECC default */ HSACO_ATTR_ANY, + /* WAVE64 mode */ HSACO_ATTR_UNSUPPORTED, + /* CU mode */ HSACO_ATTR_UNSUPPORTED, + /* Max ISA VGPRs */ 512, + /* Generic code obj version */ 0, /* non-generic */ + /* Architecture Family */ GFX9, + /* Generic Name */ NONE + ) + +GCN_DEVICE(gfx950, GFX950, 0x4f, ISA_CDNA3, + /* XNACK default */ HSACO_ATTR_ANY, + /* SRAM_ECC default */ HSACO_ATTR_ANY, + /* WAVE64 mode */ HSACO_ATTR_UNSUPPORTED, + /* CU mode */ HSACO_ATTR_UNSUPPORTED, + /* Max ISA VGPRs */ 512, + /* Generic code obj version */ 0, /* non-generic */ + /* Architecture Family */ GFX9, + /* Generic Name */ NONE + ) + GCN_DEVICE(gfx9-generic, GFX9_GENERIC, 0x051, ISA_GCN5, /* XNACK default */ HSACO_ATTR_ANY, /* SRAM_ECC default */ HSACO_ATTR_UNSUPPORTED, @@ -182,6 +204,17 @@ GCN_DEVICE(gfx9-generic, GFX9_GENERIC, 0x051, ISA_GCN5, /* Generic Name */ NONE ) +GCN_DEVICE(gfx9-4-generic, GFX9_4_GENERIC, 0x05f, ISA_CDNA3, + /* XNACK default */ HSACO_ATTR_ANY, + /* SRAM_ECC default */ HSACO_ATTR_UNSUPPORTED, + /* WAVE64 mode */ HSACO_ATTR_UNSUPPORTED, + /* CU mode */ HSACO_ATTR_UNSUPPORTED, + /* Max ISA VGPRs */ 256, + /* Generic code obj version */ 1, + /* Architecture Family */ GFX9, + /* Generic Name */ NONE + ) + /* GCN GFX10.3 (RDNA 2) */ GCN_DEVICE(gfx1030, GFX1030, 0x36, ISA_RDNA2, diff --git a/gcc/config/gcn/gcn-opts.h b/gcc/config/gcn/gcn-opts.h index 88f562d..bcea14f 100644 --- a/gcc/config/gcn/gcn-opts.h +++ b/gcc/config/gcn/gcn-opts.h @@ -33,7 +33,8 @@ extern enum gcn_isa { ISA_RDNA2, ISA_RDNA3, ISA_CDNA1, - ISA_CDNA2 + ISA_CDNA2, + ISA_CDNA3 } gcn_isa; #define TARGET_GCN5 (gcn_isa == ISA_GCN5) @@ -41,6 +42,8 @@ extern enum gcn_isa { #define TARGET_CDNA1_PLUS (gcn_isa >= ISA_CDNA1) #define TARGET_CDNA2 (gcn_isa == ISA_CDNA2) #define TARGET_CDNA2_PLUS (gcn_isa >= ISA_CDNA2) +#define TARGET_CDNA3 (gcn_isa == ISA_CDNA3) +#define TARGET_CDNA3_PLUS (gcn_isa >= ISA_CDNA3) #define TARGET_RDNA2 (gcn_isa == ISA_RDNA2) #define TARGET_RDNA2_PLUS (gcn_isa >= ISA_RDNA2 && gcn_isa < ISA_CDNA1) #define TARGET_RDNA3 (gcn_isa == ISA_RDNA3) @@ -81,18 +84,22 @@ enum hsaco_attr_type #define TARGET_DPP8 TARGET_RDNA2_PLUS /* Device requires CDNA1-style manually inserted wait states for AVGPRs. */ #define TARGET_AVGPR_CDNA1_NOPS TARGET_CDNA1 +/* Whether to use the 'globally coherent' (glc) or the 'scope' (sc0, sc1) flag + for scalar memory operations. The string starts on purpose with a space. */ +#define TARGET_GLC_NAME (TARGET_CDNA3 ? " sc0" : " glc") /* The metadata on different devices need different granularity. */ #define TARGET_VGPR_GRANULARITY \ (TARGET_RDNA3 ? 12 \ : TARGET_RDNA2_PLUS || TARGET_CDNA2_PLUS ? 8 \ : 4) /* This mostly affects the metadata. */ -#define TARGET_ARCHITECTED_FLAT_SCRATCH TARGET_RDNA3 +#define TARGET_ARCHITECTED_FLAT_SCRATCH (TARGET_RDNA3 || TARGET_CDNA3) /* Device has Sub-DWord Addressing instrucions. */ #define TARGET_SDWA (!TARGET_RDNA3) /* Different devices uses different cache control instructions. */ -#define TARGET_WBINVL1_CACHE (!TARGET_RDNA2_PLUS) +#define TARGET_WBINVL1_CACHE (!TARGET_RDNA2_PLUS && !TARGET_CDNA3) #define TARGET_GLn_CACHE TARGET_RDNA2_PLUS +#define TARGET_TARGET_SC_CACHE TARGET_CDNA3 /* Some devices have TGSPLIT, which needs at least metadata. */ #define TARGET_TGSPLIT TARGET_CDNA2_PLUS diff --git a/gcc/config/gcn/gcn-tables.opt b/gcc/config/gcn/gcn-tables.opt index 96ce9bd..4a381b3 100644 --- a/gcc/config/gcn/gcn-tables.opt +++ b/gcc/config/gcn/gcn-tables.opt @@ -49,9 +49,18 @@ EnumValue Enum(gpu_type) String(gfx90c) Value(PROCESSOR_GFX90C) EnumValue +Enum(gpu_type) String(gfx942) Value(PROCESSOR_GFX942) + +EnumValue +Enum(gpu_type) String(gfx950) Value(PROCESSOR_GFX950) + +EnumValue Enum(gpu_type) String(gfx9-generic) Value(PROCESSOR_GFX9_GENERIC) EnumValue +Enum(gpu_type) String(gfx9-4-generic) Value(PROCESSOR_GFX9_4_GENERIC) + +EnumValue Enum(gpu_type) String(gfx1030) Value(PROCESSOR_GFX1030) EnumValue diff --git a/gcc/config/gcn/gcn-valu.md b/gcc/config/gcn/gcn-valu.md index 977ad88..4b21302 100644 --- a/gcc/config/gcn/gcn-valu.md +++ b/gcc/config/gcn/gcn-valu.md @@ -1161,7 +1161,7 @@ && (((unsigned HOST_WIDE_INT)INTVAL(operands[2]) + 0x1000) < 0x2000))" { addr_space_t as = INTVAL (operands[3]); - const char *glc = INTVAL (operands[4]) ? " glc" : ""; + const char *glc = INTVAL (operands[4]) ? TARGET_GLC_NAME : ""; static char buf[200]; if (AS_FLAT_P (as)) @@ -1221,7 +1221,7 @@ && (((unsigned HOST_WIDE_INT)INTVAL(operands[3]) + 0x1000) < 0x2000))" { addr_space_t as = INTVAL (operands[4]); - const char *glc = INTVAL (operands[5]) ? " glc" : ""; + const char *glc = INTVAL (operands[5]) ? TARGET_GLC_NAME : ""; static char buf[200]; if (AS_GLOBAL_P (as)) @@ -1288,7 +1288,7 @@ && (((unsigned HOST_WIDE_INT)INTVAL(operands[1]) + 0x1000) < 0x2000))" { addr_space_t as = INTVAL (operands[3]); - const char *glc = INTVAL (operands[4]) ? " glc" : ""; + const char *glc = INTVAL (operands[4]) ? TARGET_GLC_NAME : ""; static char buf[200]; if (AS_FLAT_P (as)) @@ -1345,7 +1345,7 @@ && (((unsigned HOST_WIDE_INT)INTVAL(operands[2]) + 0x1000) < 0x2000))" { addr_space_t as = INTVAL (operands[4]); - const char *glc = INTVAL (operands[5]) ? " glc" : ""; + const char *glc = INTVAL (operands[5]) ? TARGET_GLC_NAME : ""; static char buf[200]; if (AS_GLOBAL_P (as)) diff --git a/gcc/config/gcn/gcn.cc b/gcc/config/gcn/gcn.cc index 91ce801..9b882d9 100644 --- a/gcc/config/gcn/gcn.cc +++ b/gcc/config/gcn/gcn.cc @@ -7108,7 +7108,8 @@ print_operand_address (FILE *file, rtx mem) E - print conditional code for v_cmp (eq_u64/ne_u64...) A - print address in formatting suitable for given address space. O - print offset:n for data share operations. - g - print "glc", if appropriate for given MEM + G - print "glc" (or for gfx94x: sc0) unconditionally [+ indep. of regnum] + g - print "glc" (or for gfx94x: sc0), if appropriate for given MEM L - print low-part of a multi-reg value H - print second part of a multi-reg value (high-part of 2-reg value) J - print third part of a multi-reg value @@ -7724,10 +7725,13 @@ print_operand (FILE *file, rtx x, int code) else output_addr_const (file, x); return; + case 'G': + fputs (TARGET_GLC_NAME, file); + return; case 'g': gcc_assert (xcode == MEM); if (MEM_VOLATILE_P (x)) - fputs (" glc", file); + fputs (TARGET_GLC_NAME, file); return; default: output_operand_lossage ("invalid %%xn code"); diff --git a/gcc/config/gcn/gcn.h b/gcc/config/gcn/gcn.h index 5198fbc..3d42de3 100644 --- a/gcc/config/gcn/gcn.h +++ b/gcc/config/gcn/gcn.h @@ -43,6 +43,8 @@ extern const struct gcn_device_def { builtin_define ("__CDNA1__"); \ else if (TARGET_CDNA2) \ builtin_define ("__CDNA2__"); \ + else if (TARGET_CDNA3) \ + builtin_define ("__CDNA3__"); \ else if (TARGET_RDNA2) \ builtin_define ("__RDNA2__"); \ else if (TARGET_RDNA3) \ diff --git a/gcc/config/gcn/gcn.md b/gcc/config/gcn/gcn.md index e0fb735..1998931 100644 --- a/gcc/config/gcn/gcn.md +++ b/gcc/config/gcn/gcn.md @@ -206,7 +206,7 @@ ; vdata: vgpr0-255 ; srsrc: sgpr0-102 ; soffset: sgpr0-102 -; flags: offen, idxen, glc, lds, slc, tfe +; flags: offen, idxen, %G, lds, slc, tfe ; ; mtbuf - Typed memory buffer operation. Two words ; offset: 12-bit constant @@ -216,10 +216,10 @@ ; vdata: vgpr0-255 ; srsrc: sgpr0-102 ; soffset: sgpr0-102 -; flags: offen, idxen, glc, lds, slc, tfe +; flags: offen, idxen, %G, lds, slc, tfe ; ; flat - flat or global memory operations -; flags: glc, slc +; flags: %G, slc ; addr: vgpr0-255 ; data: vgpr0-255 ; vdst: vgpr0-255 @@ -1964,6 +1964,14 @@ [(set_attr "type" "mult") (set_attr "length" "8")]) +(define_insn "*memory_barrier" + [(set (match_operand:BLK 0) + (unspec:BLK [(match_dup 0)] UNSPEC_MEMORY_BARRIER))] + "TARGET_TARGET_SC_CACHE" + "buffer_inv sc1" + [(set_attr "type" "mubuf") + (set_attr "length" "4")]) + ; FIXME: These patterns have been disabled as they do not seem to work ; reliably - they can cause hangs or incorrect results. ; TODO: flush caches according to memory model @@ -1979,9 +1987,9 @@ (use (match_operand 3 "const_int_operand"))] "0 /* Disabled. */" "@ - s_atomic_<bare_mnemonic><X>\t%0, %1, %2 glc\;s_waitcnt\tlgkmcnt(0) - flat_atomic_<bare_mnemonic><X>\t%0, %1, %2 glc\;s_waitcnt\t0 - global_atomic_<bare_mnemonic><X>\t%0, %A1, %2%O1 glc\;s_waitcnt\tvmcnt(0)" + s_atomic_<bare_mnemonic><X>\t%0, %1, %2 %G2\;s_waitcnt\tlgkmcnt(0) + flat_atomic_<bare_mnemonic><X>\t%0, %1, %2 %G2\;s_waitcnt\t0 + global_atomic_<bare_mnemonic><X>\t%0, %A1, %2%O1 %G2\;s_waitcnt\tvmcnt(0)" [(set_attr "type" "smem,flat,flat") (set_attr "length" "12")]) @@ -2046,9 +2054,9 @@ UNSPECV_ATOMIC))] "" "@ - s_atomic_cmpswap<X>\t%0, %1, %2 glc\;s_waitcnt\tlgkmcnt(0) - flat_atomic_cmpswap<X>\t%0, %1, %2 glc\;s_waitcnt\t0 - global_atomic_cmpswap<X>\t%0, %A1, %2%O1 glc\;s_waitcnt\tvmcnt(0)" + s_atomic_cmpswap<X>\t%0, %1, %2 %G2\;s_waitcnt\tlgkmcnt(0) + flat_atomic_cmpswap<X>\t%0, %1, %2 %G2\;s_waitcnt\t0 + global_atomic_cmpswap<X>\t%0, %A1, %2%O1 %G2\;s_waitcnt\tvmcnt(0)" [(set_attr "type" "smem,flat,flat") (set_attr "length" "12") (set_attr "delayeduse" "*,yes,yes")]) @@ -2088,15 +2096,15 @@ switch (which_alternative) { case 0: - return "s_load%o0\t%0, %A1 glc\;s_waitcnt\tlgkmcnt(0)"; + return "s_load%o0\t%0, %A1 %G1\;s_waitcnt\tlgkmcnt(0)"; case 1: return (TARGET_RDNA2 /* Not GFX11. */ - ? "flat_load%o0\t%0, %A1%O1 glc dlc\;s_waitcnt\t0" - : "flat_load%o0\t%0, %A1%O1 glc\;s_waitcnt\t0"); + ? "flat_load%o0\t%0, %A1%O1 %G1 dlc\;s_waitcnt\t0" + : "flat_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\t0"); case 2: return (TARGET_RDNA2 /* Not GFX11. */ - ? "global_load%o0\t%0, %A1%O1 glc dlc\;s_waitcnt\tvmcnt(0)" - : "global_load%o0\t%0, %A1%O1 glc\;s_waitcnt\tvmcnt(0)"); + ? "global_load%o0\t%0, %A1%O1 %G1 dlc\;s_waitcnt\tvmcnt(0)" + : "global_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\tvmcnt(0)"); } break; case MEMMODEL_CONSUME: @@ -2105,25 +2113,31 @@ switch (which_alternative) { case 0: - return "s_load%o0\t%0, %A1 glc\;s_waitcnt\tlgkmcnt(0)\;" + return "s_load%o0\t%0, %A1 %G1\;s_waitcnt\tlgkmcnt(0)\;" "s_dcache_wb_vol"; case 1: return (TARGET_RDNA2 - ? "flat_load%o0\t%0, %A1%O1 glc dlc\;s_waitcnt\t0\;" + ? "flat_load%o0\t%0, %A1%O1 %G1 dlc\;s_waitcnt\t0\;" "buffer_gl1_inv\;buffer_gl0_inv" : TARGET_RDNA3 - ? "flat_load%o0\t%0, %A1%O1 glc\;s_waitcnt\t0\;" + ? "flat_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\t0\;" "buffer_gl1_inv\;buffer_gl0_inv" - : "flat_load%o0\t%0, %A1%O1 glc\;s_waitcnt\t0\;" + : TARGET_TARGET_SC_CACHE + ? "flat_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\t0\;" + "buffer_inv sc1" + : "flat_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\t0\;" "buffer_wbinvl1_vol"); case 2: return (TARGET_RDNA2 - ? "global_load%o0\t%0, %A1%O1 glc dlc\;s_waitcnt\tvmcnt(0)\;" + ? "global_load%o0\t%0, %A1%O1 %G1 dlc\;s_waitcnt\tvmcnt(0)\;" "buffer_gl1_inv\;buffer_gl0_inv" : TARGET_RDNA3 - ? "global_load%o0\t%0, %A1%O1 glc\;s_waitcnt\tvmcnt(0)\;" + ? "global_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\tvmcnt(0)\;" "buffer_gl1_inv\;buffer_gl0_inv" - : "global_load%o0\t%0, %A1%O1 glc\;s_waitcnt\tvmcnt(0)\;" + : TARGET_TARGET_SC_CACHE + ? "global_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\tvmcnt(0)\;" + "buffer_inv sc1" + : "global_load%o0\t%0, %A1%O1 %G1\;s_waitcnt\tvmcnt(0)\;" "buffer_wbinvl1_vol"); } break; @@ -2133,25 +2147,31 @@ switch (which_alternative) { case 0: - return "s_dcache_wb_vol\;s_load%o0\t%0, %A1 glc\;" + return "s_dcache_wb_vol\;s_load%o0\t%0, %A1 %G1\;" "s_waitcnt\tlgkmcnt(0)\;s_dcache_inv_vol"; case 1: return (TARGET_RDNA2 - ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_load%o0\t%0, %A1%O1 glc dlc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_load%o0\t%0, %A1%O1 %G1 dlc\;" "s_waitcnt\t0\;buffer_gl1_inv\;buffer_gl0_inv" : TARGET_RDNA3 - ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_load%o0\t%0, %A1%O1 glc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_load%o0\t%0, %A1%O1 %G1\;" "s_waitcnt\t0\;buffer_gl1_inv\;buffer_gl0_inv" - : "buffer_wbinvl1_vol\;flat_load%o0\t%0, %A1%O1 glc\;" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;flat_load%o0\t%0, %A1%O1 %G1\;" + "s_waitcnt\t0\;buffer_inv sc1" + : "buffer_wbinvl1_vol\;flat_load%o0\t%0, %A1%O1 %G1\;" "s_waitcnt\t0\;buffer_wbinvl1_vol"); case 2: return (TARGET_RDNA2 - ? "buffer_gl1_inv\;buffer_gl0_inv\;global_load%o0\t%0, %A1%O1 glc dlc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;global_load%o0\t%0, %A1%O1 %G1 dlc\;" "s_waitcnt\tvmcnt(0)\;buffer_gl1_inv\;buffer_gl0_inv" : TARGET_RDNA3 - ? "buffer_gl1_inv\;buffer_gl0_inv\;global_load%o0\t%0, %A1%O1 glc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;global_load%o0\t%0, %A1%O1 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_gl1_inv\;buffer_gl0_inv" - : "buffer_wbinvl1_vol\;global_load%o0\t%0, %A1%O1 glc\;" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;global_load%o0\t%0, %A1%O1 %G1\;" + "s_waitcnt\tvmcnt(0)\;buffer_inv sc1" + : "buffer_wbinvl1_vol\;global_load%o0\t%0, %A1%O1 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_wbinvl1_vol"); } break; @@ -2176,11 +2196,11 @@ switch (which_alternative) { case 0: - return "s_store%o1\t%1, %A0 glc\;s_waitcnt\tlgkmcnt(0)"; + return "s_store%o1\t%1, %A0 %G1\;s_waitcnt\tlgkmcnt(0)"; case 1: - return "flat_store%o1\t%A0, %1%O0 glc\;s_waitcnt\t0"; + return "flat_store%o1\t%A0, %1%O0 %G1\;s_waitcnt\t0"; case 2: - return "global_store%o1\t%A0, %1%O0 glc\;s_waitcnt\tvmcnt(0)"; + return "global_store%o1\t%A0, %1%O0 %G1\;s_waitcnt\tvmcnt(0)"; } break; case MEMMODEL_RELEASE: @@ -2188,18 +2208,22 @@ switch (which_alternative) { case 0: - return "s_dcache_wb_vol\;s_store%o1\t%1, %A0 glc"; + return "s_dcache_wb_vol\;s_store%o1\t%1, %A0 %G1"; case 1: return (TARGET_GLn_CACHE - ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_store%o1\t%A0, %1%O0 glc" + ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_store%o1\t%A0, %1%O0 %G1" : TARGET_WBINVL1_CACHE - ? "buffer_wbinvl1_vol\;flat_store%o1\t%A0, %1%O0 glc" + ? "buffer_wbinvl1_vol\;flat_store%o1\t%A0, %1%O0 %G1" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;flat_store%o1\t%A0, %1%O0 %G1" : "error: cache architectire unspecified"); case 2: return (TARGET_GLn_CACHE - ? "buffer_gl1_inv\;buffer_gl0_inv\;global_store%o1\t%A0, %1%O0 glc" + ? "buffer_gl1_inv\;buffer_gl0_inv\;global_store%o1\t%A0, %1%O0 %G1" : TARGET_WBINVL1_CACHE - ? "buffer_wbinvl1_vol\;global_store%o1\t%A0, %1%O0 glc" + ? "buffer_wbinvl1_vol\;global_store%o1\t%A0, %1%O0 %G1" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;global_store%o1\t%A0, %1%O0 %G1" : "error: cache architecture unspecified"); } break; @@ -2209,23 +2233,29 @@ switch (which_alternative) { case 0: - return "s_dcache_wb_vol\;s_store%o1\t%1, %A0 glc\;" + return "s_dcache_wb_vol\;s_store%o1\t%1, %A0 %G1\;" "s_waitcnt\tlgkmcnt(0)\;s_dcache_inv_vol"; case 1: return (TARGET_GLn_CACHE - ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_store%o1\t%A0, %1%O0 glc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_store%o1\t%A0, %1%O0 %G1\;" "s_waitcnt\t0\;buffer_gl1_inv\;buffer_gl0_inv" : TARGET_WBINVL1_CACHE - ? "buffer_wbinvl1_vol\;flat_store%o1\t%A0, %1%O0 glc\;" + ? "buffer_wbinvl1_vol\;flat_store%o1\t%A0, %1%O0 %G1\;" "s_waitcnt\t0\;buffer_wbinvl1_vol" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;flat_store%o1\t%A0, %1%O0 %G1\;" + "s_waitcnt\t0\;buffer_inv sc1" : "error: cache architecture unspecified"); case 2: return (TARGET_GLn_CACHE - ? "buffer_gl1_inv\;buffer_gl0_inv\;global_store%o1\t%A0, %1%O0 glc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;global_store%o1\t%A0, %1%O0 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_gl1_inv\;buffer_gl0_inv" : TARGET_WBINVL1_CACHE - ? "buffer_wbinvl1_vol\;global_store%o1\t%A0, %1%O0 glc\;" + ? "buffer_wbinvl1_vol\;global_store%o1\t%A0, %1%O0 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_wbinvl1_vol" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;global_store%o1\t%A0, %1%O0 %G1\;" + "s_waitcnt\tvmcnt(0)\;buffer_inv sc1" : "error: cache architecture unspecified"); } break; @@ -2252,11 +2282,11 @@ switch (which_alternative) { case 0: - return "s_atomic_swap<X>\t%0, %1, %2 glc\;s_waitcnt\tlgkmcnt(0)"; + return "s_atomic_swap<X>\t%0, %1, %2 %G1\;s_waitcnt\tlgkmcnt(0)"; case 1: - return "flat_atomic_swap<X>\t%0, %1, %2 glc\;s_waitcnt\t0"; + return "flat_atomic_swap<X>\t%0, %1, %2 %G1\;s_waitcnt\t0"; case 2: - return "global_atomic_swap<X>\t%0, %A1, %2%O1 glc\;" + return "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" "s_waitcnt\tvmcnt(0)"; } break; @@ -2266,23 +2296,29 @@ switch (which_alternative) { case 0: - return "s_atomic_swap<X>\t%0, %1, %2 glc\;s_waitcnt\tlgkmcnt(0)\;" + return "s_atomic_swap<X>\t%0, %1, %2 %G1\;s_waitcnt\tlgkmcnt(0)\;" "s_dcache_wb_vol\;s_dcache_inv_vol"; case 1: return (TARGET_GLn_CACHE - ? "flat_atomic_swap<X>\t%0, %1, %2 glc\;s_waitcnt\t0\;" + ? "flat_atomic_swap<X>\t%0, %1, %2 %G1\;s_waitcnt\t0\;" "buffer_gl1_inv\;buffer_gl0_inv" : TARGET_WBINVL1_CACHE - ? "flat_atomic_swap<X>\t%0, %1, %2 glc\;s_waitcnt\t0\;" + ? "flat_atomic_swap<X>\t%0, %1, %2 %G1\;s_waitcnt\t0\;" "buffer_wbinvl1_vol" + : TARGET_TARGET_SC_CACHE + ? "flat_atomic_swap<X>\t%0, %1, %2 %G1\;s_waitcnt\t0\;" + "buffer_inv sc1" : "error: cache architecture unspecified"); case 2: return (TARGET_GLn_CACHE - ? "global_atomic_swap<X>\t%0, %A1, %2%O1 glc\;" + ? "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_gl1_inv\;buffer_gl0_inv" : TARGET_WBINVL1_CACHE - ? "global_atomic_swap<X>\t%0, %A1, %2%O1 glc\;" + ? "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_wbinvl1_vol" + : TARGET_TARGET_SC_CACHE + ? "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" + "s_waitcnt\tvmcnt(0)\;buffer_inv sc1" : "error: cache architecture unspecified"); } break; @@ -2291,24 +2327,31 @@ switch (which_alternative) { case 0: - return "s_dcache_wb_vol\;s_atomic_swap<X>\t%0, %1, %2 glc\;" + return "s_dcache_wb_vol\;s_atomic_swap<X>\t%0, %1, %2 %G1\;" "s_waitcnt\tlgkmcnt(0)"; case 1: return (TARGET_GLn_CACHE - ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_atomic_swap<X>\t%0, %1, %2 glc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_atomic_swap<X>\t%0, %1, %2 %G1\;" "s_waitcnt\t0" : TARGET_WBINVL1_CACHE - ? "buffer_wbinvl1_vol\;flat_atomic_swap<X>\t%0, %1, %2 glc\;" + ? "buffer_wbinvl1_vol\;flat_atomic_swap<X>\t%0, %1, %2 %G1\;" + "s_waitcnt\t0" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;flat_atomic_swap<X>\t%0, %1, %2 %G1\;" "s_waitcnt\t0" : "error: cache architecture unspecified"); case 2: return (TARGET_GLn_CACHE ? "buffer_gl1_inv\;buffer_gl0_inv\;" - "global_atomic_swap<X>\t%0, %A1, %2%O1 glc\;" + "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" "s_waitcnt\tvmcnt(0)" : TARGET_WBINVL1_CACHE ? "buffer_wbinvl1_vol\;" - "global_atomic_swap<X>\t%0, %A1, %2%O1 glc\;" + "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" + "s_waitcnt\tvmcnt(0)" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;" + "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" "s_waitcnt\tvmcnt(0)" : "error: cache architecture unspecified"); } @@ -2319,25 +2362,32 @@ switch (which_alternative) { case 0: - return "s_dcache_wb_vol\;s_atomic_swap<X>\t%0, %1, %2 glc\;" + return "s_dcache_wb_vol\;s_atomic_swap<X>\t%0, %1, %2 %G1\;" "s_waitcnt\tlgkmcnt(0)\;s_dcache_inv_vol"; case 1: return (TARGET_GLn_CACHE - ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_atomic_swap<X>\t%0, %1, %2 glc\;" + ? "buffer_gl1_inv\;buffer_gl0_inv\;flat_atomic_swap<X>\t%0, %1, %2 %G1\;" "s_waitcnt\t0\;buffer_gl1_inv\;buffer_gl0_inv" : TARGET_WBINVL1_CACHE - ? "buffer_wbinvl1_vol\;flat_atomic_swap<X>\t%0, %1, %2 glc\;" + ? "buffer_wbinvl1_vol\;flat_atomic_swap<X>\t%0, %1, %2 %G1\;" "s_waitcnt\t0\;buffer_wbinvl1_vol" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;flat_atomic_swap<X>\t%0, %1, %2 %G1\;" + "s_waitcnt\t0\;buffer_inv sc1" : "error: cache architecture unspecified"); case 2: return (TARGET_GLn_CACHE ? "buffer_gl1_inv\;buffer_gl0_inv\;" - "global_atomic_swap<X>\t%0, %A1, %2%O1 glc\;" + "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_gl1_inv\;buffer_gl0_inv" : TARGET_WBINVL1_CACHE ? "buffer_wbinvl1_vol\;" - "global_atomic_swap<X>\t%0, %A1, %2%O1 glc\;" + "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" "s_waitcnt\tvmcnt(0)\;buffer_wbinvl1_vol" + : TARGET_TARGET_SC_CACHE + ? "buffer_inv sc1\;" + "global_atomic_swap<X>\t%0, %A1, %2%O1 %G1\;" + "s_waitcnt\tvmcnt(0)\;buffer_inv sc1" : "error: cache architecture unspecified"); } break; diff --git a/gcc/config/i386/i386.cc b/gcc/config/i386/i386.cc index 38df84f..a6f0a58 100644 --- a/gcc/config/i386/i386.cc +++ b/gcc/config/i386/i386.cc @@ -25545,14 +25545,10 @@ ix86_vector_costs::finish_cost (const vector_costs *scalar_costs) /* When X86_TUNE_AVX512_TWO_EPILOGUES is enabled arrange for both a AVX2 and a SSE epilogue for AVX512 vectorized loops. */ if (loop_vinfo + && LOOP_VINFO_EPILOGUE_P (loop_vinfo) + && GET_MODE_SIZE (loop_vinfo->vector_mode) == 32 && ix86_tune_features[X86_TUNE_AVX512_TWO_EPILOGUES]) - { - if (GET_MODE_SIZE (loop_vinfo->vector_mode) == 64) - m_suggested_epilogue_mode = V32QImode; - else if (LOOP_VINFO_EPILOGUE_P (loop_vinfo) - && GET_MODE_SIZE (loop_vinfo->vector_mode) == 32) - m_suggested_epilogue_mode = V16QImode; - } + m_suggested_epilogue_mode = V16QImode; /* When a 128bit SSE vectorized epilogue still has a VF of 16 or larger enable a 64bit SSE epilogue. */ if (loop_vinfo diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index 8983abf..db696c1 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,25 @@ +2025-06-09 Jason Merrill <jason@redhat.com> + + Backported from master: + 2025-06-06 Jason Merrill <jason@redhat.com> + + PR c++/120555 + * decl2.cc (fn_being_defined, fn_template_being_defined): New. + (mark_used): Check fn_template_being_defined. + +2025-06-09 Jason Merrill <jason@redhat.com> + + PR c++/120502 + * cp-gimplify.cc (cp_fold_r) [TARGET_EXPR]: Do constexpr evaluation + before genericize. + * constexpr.cc (cxx_eval_store_expression): Add comment. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/120123 + * lambda.cc (nonlambda_method_basetype): Look through lambdas + even when current_class_ref is null. + 2025-05-30 Sandra Loosemore <sloosemore@baylibre.com> Backported from master: diff --git a/gcc/cp/ChangeLog.omp b/gcc/cp/ChangeLog.omp index 3f2574a..c9026b4 100644 --- a/gcc/cp/ChangeLog.omp +++ b/gcc/cp/ChangeLog.omp @@ -1,3 +1,15 @@ +2025-06-05 Sandra Loosemore <sloosemore@baylibre.com> + + Backported from master: + 2025-06-02 Sandra Loosemore <sloosemore@baylibre.com> + + * cp-tree.h (maybe_convert_cond): Declare. + * parser.cc (cp_parser_omp_context_selector): Call + maybe_convert_cond and fold_build_cleanup_point_expr on the + expression for OMP_TRAIT_PROPERTY_BOOL_EXPR. + * pt.cc (tsubst_omp_context_selector): Likewise. + * semantics.cc (maybe_convert_cond): Remove static declaration. + 2025-05-15 Sandra Loosemore <sloosemore@baylibre.com> Tobias Burnus <tburnus@baylibre.com> diff --git a/gcc/cp/constexpr.cc b/gcc/cp/constexpr.cc index 48327fb..5c98208 100644 --- a/gcc/cp/constexpr.cc +++ b/gcc/cp/constexpr.cc @@ -6424,7 +6424,8 @@ cxx_eval_store_expression (const constexpr_ctx *ctx, tree t, if (TREE_CLOBBER_P (init) && CLOBBER_KIND (init) < CLOBBER_OBJECT_END) - /* Only handle clobbers ending the lifetime of objects. */ + /* Only handle clobbers ending the lifetime of objects. + ??? We should probably set CONSTRUCTOR_NO_CLEARING. */ return void_node; /* First we figure out where we're storing to. */ diff --git a/gcc/cp/cp-gimplify.cc b/gcc/cp/cp-gimplify.cc index a4f3eaa..9144239 100644 --- a/gcc/cp/cp-gimplify.cc +++ b/gcc/cp/cp-gimplify.cc @@ -1473,6 +1473,19 @@ cp_fold_r (tree *stmt_p, int *walk_subtrees, void *data_) break; case TARGET_EXPR: + if (!flag_no_inline) + if (tree &init = TARGET_EXPR_INITIAL (stmt)) + { + tree folded = maybe_constant_init (init, TARGET_EXPR_SLOT (stmt), + (data->flags & ff_mce_false + ? mce_false : mce_unknown)); + if (folded != init && TREE_CONSTANT (folded)) + init = folded; + } + + /* This needs to happen between the constexpr evaluation (which wants + pre-generic trees) and fold (which wants the cp_genericize_init + transformations). */ if (data->flags & ff_genericize) cp_genericize_target_expr (stmt_p); @@ -1481,14 +1494,6 @@ cp_fold_r (tree *stmt_p, int *walk_subtrees, void *data_) cp_walk_tree (&init, cp_fold_r, data, NULL); cp_walk_tree (&TARGET_EXPR_CLEANUP (stmt), cp_fold_r, data, NULL); *walk_subtrees = 0; - if (!flag_no_inline) - { - tree folded = maybe_constant_init (init, TARGET_EXPR_SLOT (stmt), - (data->flags & ff_mce_false - ? mce_false : mce_unknown)); - if (folded != init && TREE_CONSTANT (folded)) - init = folded; - } /* Folding might replace e.g. a COND_EXPR with a TARGET_EXPR; in that case, strip it in favor of this one. */ if (TREE_CODE (init) == TARGET_EXPR) diff --git a/gcc/cp/cp-tree.h b/gcc/cp/cp-tree.h index f984940..e512c72 100644 --- a/gcc/cp/cp-tree.h +++ b/gcc/cp/cp-tree.h @@ -7951,6 +7951,7 @@ extern bool perform_deferred_access_checks (tsubst_flags_t); extern bool perform_or_defer_access_check (tree, tree, tree, tsubst_flags_t, access_failure_info *afi = NULL); +extern tree maybe_convert_cond (tree); /* RAII sentinel to ensures that deferred access checks are popped before a function returns. */ diff --git a/gcc/cp/decl2.cc b/gcc/cp/decl2.cc index 4195c08..fb2801c 100644 --- a/gcc/cp/decl2.cc +++ b/gcc/cp/decl2.cc @@ -6272,6 +6272,33 @@ mark_single_function (tree expr, tsubst_flags_t complain) return true; } +/* True iff we have started, but not finished, defining FUNCTION_DECL DECL. */ + +bool +fn_being_defined (tree decl) +{ + /* DECL_INITIAL is set to error_mark_node in grokfndecl for a definition, and + changed to BLOCK by poplevel at the end of the function. */ + return (TREE_CODE (decl) == FUNCTION_DECL + && DECL_INITIAL (decl) == error_mark_node); +} + +/* True if DECL is an instantiation of a function template currently being + defined. */ + +bool +fn_template_being_defined (tree decl) +{ + if (TREE_CODE (decl) != FUNCTION_DECL + || !DECL_LANG_SPECIFIC (decl) + || !DECL_TEMPLOID_INSTANTIATION (decl) + || DECL_TEMPLATE_INSTANTIATED (decl)) + return false; + tree tinfo = DECL_TEMPLATE_INFO (decl); + tree pattern = DECL_TEMPLATE_RESULT (TI_TEMPLATE (tinfo)); + return fn_being_defined (pattern); +} + /* Mark DECL (either a _DECL or a BASELINK) as "used" in the program. If DECL is a specialization or implicitly declared class member, generate the actual definition. Return false if something goes @@ -6425,6 +6452,9 @@ mark_used (tree decl, tsubst_flags_t complain /* = tf_warning_or_error */) maybe_instantiate_decl (decl); if (!decl_dependent_p (decl) + /* Don't require this yet for an instantiation of a function template + we're currently defining (c++/120555). */ + && !fn_template_being_defined (decl) && !require_deduced_type (decl, complain)) return false; @@ -6439,9 +6469,6 @@ mark_used (tree decl, tsubst_flags_t complain /* = tf_warning_or_error */) && uses_template_parms (DECL_TI_ARGS (decl))) return true; - if (!require_deduced_type (decl, complain)) - return false; - if (builtin_pack_fn_p (decl)) { error ("use of built-in parameter pack %qD outside of a template", diff --git a/gcc/cp/lambda.cc b/gcc/cp/lambda.cc index b2e0ecd..352e1b9 100644 --- a/gcc/cp/lambda.cc +++ b/gcc/cp/lambda.cc @@ -1033,12 +1033,9 @@ current_nonlambda_function (void) tree nonlambda_method_basetype (void) { - if (!current_class_ref) - return NULL_TREE; - tree type = current_class_type; if (!type || !LAMBDA_TYPE_P (type)) - return type; + return current_class_ref ? type : NULL_TREE; while (true) { diff --git a/gcc/cp/parser.cc b/gcc/cp/parser.cc index 9c1d976..4e1a491 100644 --- a/gcc/cp/parser.cc +++ b/gcc/cp/parser.cc @@ -51717,12 +51717,25 @@ cp_parser_omp_context_selector (cp_parser *parser, enum omp_tss_code set, && !value_dependent_expression_p (t)) { t = fold_non_dependent_expr (t); - if (!INTEGRAL_TYPE_P (TREE_TYPE (t))) + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) { - error_at (token->location, - "property must be integer expression"); - return error_mark_node; + t = maybe_convert_cond (t); + if (t == error_mark_node) + return error_mark_node; + } + else + { + t = convert_from_reference (t); + if (!INTEGRAL_TYPE_P (TREE_TYPE (t))) + { + error_at (token->location, + "property must be integer expression"); + return error_mark_node; + } } + if (!processing_template_decl + && TREE_CODE (t) != CLEANUP_POINT_EXPR) + t = fold_build_cleanup_point_expr (TREE_TYPE (t), t); } properties = make_trait_property (NULL_TREE, t, properties); break; diff --git a/gcc/cp/pt.cc b/gcc/cp/pt.cc index fc2b31f..2747126 100644 --- a/gcc/cp/pt.cc +++ b/gcc/cp/pt.cc @@ -18415,7 +18415,9 @@ tsubst_omp_context_selector (tree ctx, tree args, tsubst_flags_t complain, } } - switch (omp_ts_map[OMP_TS_CODE (sel)].tp_type) + enum omp_tp_type property_kind + = omp_ts_map[OMP_TS_CODE (sel)].tp_type; + switch (property_kind) { case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR: case OMP_TRAIT_PROPERTY_BOOL_EXPR: @@ -18423,12 +18425,26 @@ tsubst_omp_context_selector (tree ctx, tree args, tsubst_flags_t complain, args, complain, in_decl); t = fold_non_dependent_expr (t); if (!value_dependent_expression_p (t) - && !type_dependent_expression_p (t) - && !INTEGRAL_TYPE_P (TREE_TYPE (t))) - error_at (cp_expr_loc_or_input_loc (t), - "property must be integer expression"); - else - properties = make_trait_property (NULL_TREE, t, NULL_TREE); + && !type_dependent_expression_p (t)) + { + if (property_kind == OMP_TRAIT_PROPERTY_BOOL_EXPR) + t = maybe_convert_cond (t); + else + { + t = convert_from_reference (t); + if (!INTEGRAL_TYPE_P (TREE_TYPE (t))) + { + error_at (cp_expr_loc_or_input_loc (t), + "property must be integer expression"); + t = error_mark_node; + } + } + } + if (t != error_mark_node + && !processing_template_decl + && TREE_CODE (t) != CLEANUP_POINT_EXPR) + t = fold_build_cleanup_point_expr (TREE_TYPE (t), t); + properties = make_trait_property (NULL_TREE, t, NULL_TREE); break; case OMP_TRAIT_PROPERTY_CLAUSE_LIST: if (OMP_TS_CODE (sel) == OMP_TRAIT_CONSTRUCT_SIMD) diff --git a/gcc/cp/semantics.cc b/gcc/cp/semantics.cc index f1523ed..0029080 100644 --- a/gcc/cp/semantics.cc +++ b/gcc/cp/semantics.cc @@ -52,7 +52,6 @@ along with GCC; see the file COPYING3. If not see during template instantiation, which may be regarded as a degenerate form of parsing. */ -static tree maybe_convert_cond (tree); static tree finalize_nrv_r (tree *, int *, void *); /* Used for OpenMP non-static data member privatization. */ @@ -1117,7 +1116,7 @@ annotate_saver::restore (tree new_inner) statement. Convert it to a boolean value, if appropriate. In addition, verify sequence points if -Wsequence-point is enabled. */ -static tree +tree maybe_convert_cond (tree cond) { /* Empty conditions remain empty. */ diff --git a/gcc/doc/install.texi b/gcc/doc/install.texi index 1af0082..9d72f79 100644 --- a/gcc/doc/install.texi +++ b/gcc/doc/install.texi @@ -1342,9 +1342,13 @@ default set of libraries is selected based on the value of @item amdgcn*-*-* @var{list} is a comma separated list of ISA names (allowed values: -@code{gfx900}, @code{gfx906}, @code{gfx908}, @code{gfx90a}, @code{gfx90c}, -@code{gfx1030}, @code{gfx1036}, @code{gfx1100}, @code{gfx1103}). -It ought not include the name of the default +@code{gfx900}, @code{gfx902}, @code{gfx904}, @code{gfx906}, @code{gfx908}, +@code{gfx909}, @code{gfx90a}, @code{gfx90c}, @code{gfx942}, @code{gfx950}, +@code{gfx9-generic}, @code{gfx9-4-generic}, @code{gfx1030}, @code{gfx1031}, +@code{gfx1032}, @code{gfx1033}, @code{gfx1034}, @code{gfx1035}, @code{gfx1036}, +@code{gfx10-3-generic}, @code{gfx1100}, @code{gfx1101}, @code{gfx1102}, +@code{gfx1103}, @code{gfx1150}, @code{gfx1151}, @code{gfx1152}, @code{gfx1153}, +@code{gfx11-generic}). It ought not include the name of the default ISA, specified via @option{--with-arch}. If @var{list} is empty, then there will be no multilibs and only the default run-time library will be built. If @var{list} is @code{default} or @option{--with-multilib-list=} is not @@ -4053,9 +4057,10 @@ By default, multilib support is built for @code{gfx900}, @code{gfx906}, requires LLVM 15 or newer. LLVM 13.0.1 or LLVM 14 can be used by specifying a @code{--with-multilib-list=} that does not list any GFX 11 device nor @code{gfx1036}. At least LLVM 16 is required for @code{gfx1150} and -@code{gfx1151}, LLVM 19 for the generic @code{gfx9-generic}, -@code{gfx10-3-generic}, and @code{gfx11-generic} targets and for -@code{gfx1152}, while LLVM 20 is required for @code{gfx1153}. +@code{gfx1151}, LLVM 18 for @code{gfx942}, LLVM 19 for the generic +@code{gfx9-generic}, @code{gfx9-4-generic}, @code{gfx10-3-generic}, and +@code{gfx11-generic} targets and for @code{gfx1152}, while LLVM 20 is required +for @code{gfx950} and @code{gfx1153}. The supported ISA architectures are listed in the GCC manual. The generic ISA targets @code{gfx9-generic}, @code{gfx10-3-generic}, and diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index 3135821..c122724 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -22614,10 +22614,20 @@ Compile for CDNA2 Instinct MI200 series devices (gfx90a). @item gfx90c Compile for GCN5 Vega 7 devices (gfx90c). +@item gfx942 +Compile for CDNA3 Instinct MI300 series devices (gfx942). (Experimental) + +@item gfx950 +Compile for the CDNA3 gfx950 devices. (Experimental) + @item gfx9-generic Compile generic code for Vega devices, executable on the following subset of GFX9 devices: gfx900, gfx902, gfx904, gfx906, gfx909 and gfx90c. (Experimental) +@item gfx9-4-generic +Compile generic code for CDNA3 devices, executable on the following subset of +GFX9 devices: gfx942 and gfx950. (Experimental) + @item gfx1030 Compile for RDNA2 gfx1030 devices (GFX10 series). @@ -1190,7 +1190,10 @@ canon_address (rtx mem, address = strip_offset_and_add (address, offset); if (ADDR_SPACE_GENERIC_P (MEM_ADDR_SPACE (mem)) - && const_or_frame_p (address)) + && const_or_frame_p (address) + /* Literal addresses can alias any base, avoid creating a + group for them. */ + && ! CONST_SCALAR_INT_P (address)) { group_info *group = get_group_info (address); diff --git a/gcc/ext-dce.cc b/gcc/ext-dce.cc index a034395..aa80c04 100644 --- a/gcc/ext-dce.cc +++ b/gcc/ext-dce.cc @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "print-rtl.h" #include "dbgcnt.h" #include "diagnostic-core.h" +#include "target.h" /* These should probably move into a C++ class. */ static vec<bitmap_head> livein; @@ -764,13 +765,25 @@ ext_dce_process_uses (rtx_insn *insn, rtx obj, We don't want to mark those bits live unnecessarily as that inhibits extension elimination in important cases such as those in Coremark. So we need that - outer code. */ + outer code. + + But if !TRULY_NOOP_TRUNCATION_MODES_P, the mode + change performed by Y would normally need to be a + TRUNCATE rather than a SUBREG. It is probably the + guarantee provided by SUBREG_PROMOTED_VAR_P that + allows the SUBREG in Y as an exception. We must + therefore preserve that guarantee and treat the + upper bits of the inner register as live + regardless of the outer code. See PR 120050. */ if (!REG_P (SUBREG_REG (y)) || (SUBREG_PROMOTED_VAR_P (y) && ((GET_CODE (SET_SRC (x)) == SIGN_EXTEND && SUBREG_PROMOTED_SIGNED_P (y)) || (GET_CODE (SET_SRC (x)) == ZERO_EXTEND - && SUBREG_PROMOTED_UNSIGNED_P (y))))) + && SUBREG_PROMOTED_UNSIGNED_P (y)) + || !TRULY_NOOP_TRUNCATION_MODES_P ( + GET_MODE (y), + GET_MODE (SUBREG_REG (y)))))) break; bit = subreg_lsb (y).to_constant (); diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2f9f5c9..c470df3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,74 @@ +2025-06-04 Harald Anlauf <anlauf@gmx.de> + + Backported from master: + 2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * data.cc (gfc_assign_data_value): For a new initializer use the + location from the constructor as fallback. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + Backported from master: + 2025-05-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102599 + PR fortran/114022 + * expr.cc (simplify_complex_array_inquiry_ref): Helper function for + simplification of inquiry references (%re/%im) of constant complex + arrays. + (find_inquiry_ref): Use it for handling %re/%im inquiry references + of complex arrays. + (scalarize_intrinsic_call): Fix frontend memleak. + * primary.cc (gfc_match_varspec): When the reference is NULL, the + previous simplification has succeeded in evaluating inquiry + references also of arrays. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + Backported from master: + 2025-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101735 + * primary.cc (gfc_match_varspec): Correct order of logic. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + Backported from master: + 2025-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101735 + * expr.cc (find_inquiry_ref): If an inquiry reference applies to + a substring, use that, and calculate substring length if needed. + * primary.cc (extend_ref): Also handle attaching to end of + reference chain for appending. + (gfc_match_varspec): Discrimate between arrays of character and + substrings of them. If a substring is taken from a character + component of a derived type, get the proper typespec so that + inquiry references work correctly. + (gfc_match_rvalue): Handle corner case where we hit a seemingly + dangling '%' and missed an inquiry reference. Try another match. + +2025-06-02 Jakub Jelinek <jakub@redhat.com> + + Backported from master: + 2025-05-10 Jakub Jelinek <jakub@redhat.com> + + PR fortran/120193 + * trans-types.cc (gfc_init_types): For flag_unsigned use + build_distinct_type_copy or build_variant_type_copy from + gfc_character_types[index_char] if index_char > -1 instead of + gfc_character_types[index_char] or + gfc_build_unsigned_type (&gfc_unsigned_kinds[index]). + +2025-06-02 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + Backported from master: + 2025-05-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/119856 + * io.cc: Set missing comma error checks to STD_STD_LEGACY. + 2025-05-31 Jerry DeLisle <jvdelisle@gcc.gnu.org> Backported from master: diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp index 05c8e3f..7c5eee2 100644 --- a/gcc/fortran/ChangeLog.omp +++ b/gcc/fortran/ChangeLog.omp @@ -1,3 +1,16 @@ +2025-06-06 Tobias Burnus <tburnus@baylibre.com> + + Backported from master: + 2025-06-06 Tobias Burnus <tburnus@baylibre.com> + Sandra Loosemore <sloosemore@baylibre.com> + + * f95-lang.cc (ATTR_PURE_NOTHROW_LIST): Define. + * trans-expr.cc (get_builtin_fn): Handle omp_get_num_devices + and omp_get_intrinsic_device. + * gfortran.h (gfc_option_t): Add disable_omp_... for them. + * options.cc (gfc_handle_option): Handle them with + -fno-builtin-. + 2025-05-15 Sandra Loosemore <sloosemore@baylibre.com> Tobias Burnus <tburnus@baylibre.com> diff --git a/gcc/fortran/data.cc b/gcc/fortran/data.cc index 5c83f69..a438c26 100644 --- a/gcc/fortran/data.cc +++ b/gcc/fortran/data.cc @@ -593,7 +593,13 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, { /* Point the container at the new expression. */ if (last_con == NULL) - symbol->value = expr; + { + symbol->value = expr; + /* For a new initializer use the location from the + constructor as fallback. */ + if (!GFC_LOCUS_IS_SET(expr->where) && con != NULL) + symbol->value->where = con->where; + } else last_con->expr = expr; } diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 827e199..95ea055 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -1838,6 +1838,55 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) } +/* Simplify inquiry references (%re/%im) of constant complex arrays. + Used by find_inquiry_ref. */ + +static gfc_expr * +simplify_complex_array_inquiry_ref (gfc_expr *p, inquiry_type inquiry) +{ + gfc_expr *e, *r, *result; + gfc_constructor_base base; + gfc_constructor *c; + + if ((inquiry != INQUIRY_RE && inquiry != INQUIRY_IM) + || p->expr_type != EXPR_ARRAY + || p->ts.type != BT_COMPLEX + || p->rank <= 0 + || p->value.constructor == NULL + || !gfc_is_constant_array_expr (p)) + return NULL; + + /* Simplify array sections. */ + gfc_simplify_expr (p, 0); + + result = gfc_get_array_expr (BT_REAL, p->ts.kind, &p->where); + result->rank = p->rank; + result->shape = gfc_copy_shape (p->shape, p->rank); + + base = p->value.constructor; + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) + { + e = c->expr; + if (e->expr_type != EXPR_CONSTANT) + goto fail; + + r = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where); + if (inquiry == INQUIRY_RE) + mpfr_set (r->value.real, mpc_realref (e->value.complex), GFC_RND_MODE); + else + mpfr_set (r->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE); + + gfc_constructor_append_expr (&result->value.constructor, r, &e->where); + } + + return result; + +fail: + gfc_free_expr (result); + return NULL; +} + + /* Pull an inquiry result out of an expression. */ static bool @@ -1846,7 +1895,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) gfc_ref *ref; gfc_ref *inquiry = NULL; gfc_ref *inquiry_head; + gfc_ref *ref_ss = NULL; gfc_expr *tmp; + bool nofail = false; tmp = gfc_copy_expr (p); @@ -1862,6 +1913,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) { inquiry = ref->next; ref->next = NULL; + if (ref->type == REF_SUBSTRING) + ref_ss = ref; + break; } } @@ -1891,6 +1945,28 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C")) goto cleanup; + /* Inquire length of substring? */ + if (ref_ss) + { + if (ref_ss->u.ss.start->expr_type == EXPR_CONSTANT + && ref_ss->u.ss.end->expr_type == EXPR_CONSTANT) + { + HOST_WIDE_INT istart, iend, length; + istart = gfc_mpz_get_hwi (ref_ss->u.ss.start->value.integer); + iend = gfc_mpz_get_hwi (ref_ss->u.ss.end->value.integer); + + if (istart <= iend) + length = iend - istart + 1; + else + length = 0; + *newp = gfc_get_int_expr (gfc_default_integer_kind, + NULL, length); + break; + } + else + goto cleanup; + } + if (tmp->ts.u.cl->length && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT) *newp = gfc_copy_expr (tmp->ts.u.cl->length); @@ -1921,24 +1997,50 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) break; case INQUIRY_RE: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "RE part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_RE); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_realref (tmp->value.complex), GFC_RND_MODE); break; case INQUIRY_IM: - if (tmp->ts.type != BT_COMPLEX || tmp->expr_type != EXPR_CONSTANT) + if (tmp->ts.type != BT_COMPLEX) goto cleanup; if (!gfc_notify_std (GFC_STD_F2008, "IM part_ref at %C")) goto cleanup; + if (tmp->expr_type == EXPR_ARRAY) + { + *newp = simplify_complex_array_inquiry_ref (tmp, INQUIRY_IM); + if (*newp != NULL) + { + nofail = true; + break; + } + } + + if (tmp->expr_type != EXPR_CONSTANT) + goto cleanup; + *newp = gfc_get_constant_expr (BT_REAL, tmp->ts.kind, &tmp->where); mpfr_set ((*newp)->value.real, mpc_imagref (tmp->value.complex), GFC_RND_MODE); @@ -1951,7 +2053,7 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp) if (!(*newp)) goto cleanup; - else if ((*newp)->expr_type != EXPR_CONSTANT) + else if ((*newp)->expr_type != EXPR_CONSTANT && !nofail) { gfc_free_expr (*newp); goto cleanup; @@ -2523,7 +2625,7 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag) rank[n] = a->expr->rank; else rank[n] = 1; - ctor = gfc_constructor_copy (a->expr->value.constructor); + ctor = a->expr->value.constructor; args[n] = gfc_constructor_first (ctor); } else diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 3808fed..3b6610e 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -571,7 +571,7 @@ gfc_builtin_function (tree decl) return decl; } -/* So far we need just these 10 attribute types. */ +/* So far we need just these 12 attribute types. */ #define ATTR_NULL 0 #define ATTR_LEAF_LIST (ECF_LEAF) #define ATTR_NOTHROW_LEAF_LIST (ECF_NOTHROW | ECF_LEAF) @@ -587,6 +587,7 @@ gfc_builtin_function (tree decl) #define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ (ECF_COLD | ECF_NORETURN | \ ECF_NOTHROW | ECF_LEAF) +#define ATTR_PURE_NOTHROW_LIST (ECF_PURE | ECF_NOTHROW) static void gfc_define_builtin (const char *name, tree type, enum built_in_function code, diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 903712a..aa44571 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3338,8 +3338,10 @@ typedef struct int flag_init_logical; int flag_init_character; char flag_init_character_value; - bool disable_omp_is_initial_device; - bool disable_acc_on_device; + bool disable_omp_is_initial_device:1; + bool disable_omp_get_initial_device:1; + bool disable_omp_get_num_devices:1; + bool disable_acc_on_device:1; int fpe; int fpe_summary; diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index ddddc1c..d3c9066 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -883,6 +883,10 @@ gfc_handle_option (size_t scode, const char *arg, HOST_WIDE_INT value, return false; /* Not supported. */ if (!strcmp ("omp_is_initial_device", arg)) gfc_option.disable_omp_is_initial_device = true; + else if (!strcmp ("omp_get_initial_device", arg)) + gfc_option.disable_omp_get_initial_device = true; + else if (!strcmp ("omp_get_num_devices", arg)) + gfc_option.disable_omp_get_num_devices = true; else if (!strcmp ("acc_on_device", arg)) gfc_option.disable_acc_on_device = true; else diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 72ecc7c..b5dddde 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2102,10 +2102,18 @@ extend_ref (gfc_expr *primary, gfc_ref *tail) { if (primary->ref == NULL) primary->ref = tail = gfc_get_ref (); + else if (tail == NULL) + { + /* Set tail to end of reference chain. */ + for (gfc_ref *ref = primary->ref; ref; ref = ref->next) + if (ref->next == NULL) + { + tail = ref; + break; + } + } else { - if (tail == NULL) - gfc_internal_error ("extend_ref(): Bad tail"); tail->next = gfc_get_ref (); tail = tail->next; } @@ -2302,9 +2310,22 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, gfc_array_spec *as; bool coarray_only = sym->attr.codimension && !sym->attr.dimension && sym->ts.type == BT_CHARACTER; + gfc_ref *ref, *strarr = NULL; tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; + if (sym->ts.type == BT_CHARACTER && tail->type == REF_SUBSTRING) + { + gcc_assert (sym->attr.dimension); + /* Find array reference for substrings of character arrays. */ + for (ref = primary->ref; ref && ref->next; ref = ref->next) + if (ref->type == REF_ARRAY && ref->next->type == REF_SUBSTRING) + { + strarr = ref; + break; + } + } + else + tail->type = REF_ARRAY; /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character @@ -2317,7 +2338,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, else as = sym->as; - m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, as ? as->corank : 0, + ref = strarr ? strarr : tail; + m = gfc_match_array_ref (&ref->u.ar, as, equiv_flag, as ? as->corank : 0, coarray_only); if (m != MATCH_YES) return m; @@ -2483,6 +2505,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, { bool t; gfc_symtree *tbp; + gfc_typespec *ts = &primary->ts; m = gfc_match_name (name); if (m == MATCH_NO) @@ -2490,8 +2513,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (m != MATCH_YES) return MATCH_ERROR; + /* For derived type components find typespec of ultimate component. */ + if (ts->type == BT_DERIVED && primary->ref) + { + for (gfc_ref *ref = primary->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT && ref->u.c.component) + ts = &ref->u.c.component->ts; + } + } + intrinsic = false; - if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED) + if (ts->type != BT_CLASS && ts->type != BT_DERIVED) { inquiry = is_inquiry_ref (name, &tmp); if (inquiry) @@ -2564,7 +2597,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, return MATCH_ERROR; } else if (tmp->u.i == INQUIRY_LEN - && primary->ts.type != BT_CHARACTER) + && ts->type != BT_CHARACTER) { gfc_error ("The LEN part_ref at %C must be applied " "to a CHARACTER expression"); @@ -2659,6 +2692,11 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, primary->ref = tmp; else { + /* Find end of reference chain if inquiry reference and tail not + set. */ + if (tail == NULL && inquiry && tmp) + tail = extend_ref (primary, tail); + /* Set by the for loop below for the last component ref. */ gcc_assert (tail != NULL); tail->next = tmp; @@ -2678,6 +2716,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (primary->expr_type == EXPR_CONSTANT) goto check_done; + if (primary->ref == NULL) + goto check_done; + switch (tmp->u.i) { case INQUIRY_RE: @@ -2828,6 +2869,7 @@ check_substring: if (substring) primary->ts.u.cl = NULL; + gfc_gobble_whitespace (); if (gfc_peek_ascii_char () == '(') { gfc_error_now ("Unexpected array/substring ref at %C"); @@ -4271,6 +4313,16 @@ gfc_match_rvalue (gfc_expr **result) return MATCH_ERROR; } + /* Scan for possible inquiry references. */ + if (m == MATCH_YES + && e->expr_type == EXPR_VARIABLE + && gfc_peek_ascii_char () == '%') + { + m = gfc_match_varspec (e, 0, false, false); + if (m == MATCH_NO) + m = MATCH_YES; + } + if (m == MATCH_YES) { e->where = where; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 7031a829..d72545e 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -4627,6 +4627,16 @@ get_builtin_fn (gfc_symbol * sym) && !strcmp (sym->name, "omp_is_initial_device")) return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE); + if (!gfc_option.disable_omp_get_initial_device + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_initial_device")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE); + + if (!gfc_option.disable_omp_get_num_devices + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_num_devices")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES); + if (!gfc_option.disable_acc_on_device && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL && !strcmp (sym->name, "acc_on_device_h")) diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 3374778..f898075 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1140,11 +1140,6 @@ gfc_init_types (void) } gfc_character1_type_node = gfc_character_types[0]; - /* The middle end only recognizes a single unsigned type. For - compatibility of existing test cases, let's just use the - character type. The reader of tree dumps is expected to be able - to deal with this. */ - if (flag_unsigned) { for (index = 0; gfc_unsigned_kinds[index].kind != 0;++index) @@ -1159,18 +1154,26 @@ gfc_init_types (void) break; } } - if (index_char > 0) + if (index_char > -1) { - gfc_unsigned_types[index] = gfc_character_types[index_char]; + type = gfc_character_types[index_char]; + if (TYPE_STRING_FLAG (type)) + { + type = build_distinct_type_copy (type); + TYPE_CANONICAL (type) + = TYPE_CANONICAL (gfc_character_types[index_char]); + } + else + type = build_variant_type_copy (type); + TYPE_NAME (type) = NULL_TREE; + TYPE_STRING_FLAG (type) = 0; } else - { - type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]); - gfc_unsigned_types[index] = type; - snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)", - gfc_integer_kinds[index].kind); - PUSH_TYPE (name_buf, type); - } + type = gfc_build_unsigned_type (&gfc_unsigned_kinds[index]); + gfc_unsigned_types[index] = type; + snprintf (name_buf, sizeof(name_buf), "unsigned(kind=%d)", + gfc_integer_kinds[index].kind); + PUSH_TYPE (name_buf, type); } } diff --git a/gcc/gimple-fold.cc b/gcc/gimple-fold.cc index a64922a..b867d66 100644 --- a/gcc/gimple-fold.cc +++ b/gcc/gimple-fold.cc @@ -4224,6 +4224,40 @@ gimple_fold_builtin_omp_is_initial_device (gimple_stmt_iterator *gsi) return false; } +/* omp_get_initial_device was in OpenMP 5.0/5.1 explicitly and in + 5.0 implicitly the same as omp_get_num_devices; since 6.0 it is + unspecified whether -1 or omp_get_num_devices() is returned. For + better backward compatibility, use omp_get_num_devices() on the + host - and -1 on the device (where the result is unspecified). */ + +static bool +gimple_fold_builtin_omp_get_initial_device (gimple_stmt_iterator *gsi) +{ +#if ACCEL_COMPILER + replace_call_with_value (gsi, build_int_cst (integer_type_node, -1)); +#else + if (!ENABLE_OFFLOADING) + replace_call_with_value (gsi, integer_zero_node); + else + { + tree fn = builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES); + gcall *repl = gimple_build_call (fn, 0); + replace_call_with_call_and_fold (gsi, repl); + } +#endif + return true; +} + +static bool +gimple_fold_builtin_omp_get_num_devices (gimple_stmt_iterator *gsi) +{ + if (!ENABLE_OFFLOADING) + { + replace_call_with_value (gsi, integer_zero_node); + return true; + } + return false; +} /* Fold a call to __builtin_acc_on_device. */ @@ -5468,6 +5502,12 @@ gimple_fold_builtin (gimple_stmt_iterator *gsi) case BUILT_IN_OMP_IS_INITIAL_DEVICE: return gimple_fold_builtin_omp_is_initial_device (gsi); + case BUILT_IN_OMP_GET_INITIAL_DEVICE: + return gimple_fold_builtin_omp_get_initial_device (gsi); + + case BUILT_IN_OMP_GET_NUM_DEVICES: + return gimple_fold_builtin_omp_get_num_devices (gsi); + case BUILT_IN_REALLOC: return gimple_fold_builtin_realloc (gsi); diff --git a/gcc/omp-builtins.def b/gcc/omp-builtins.def index 97e8b6a..cfc2fd8 100644 --- a/gcc/omp-builtins.def +++ b/gcc/omp-builtins.def @@ -71,7 +71,12 @@ DEF_GOACC_BUILTIN_ONLY (BUILT_IN_GOACC_SINGLE_COPY_END, "GOACC_single_copy_end", DEF_GOMP_BUILTIN_COMPILER (BUILT_IN_OMP_IS_INITIAL_DEVICE, "omp_is_initial_device", BT_FN_INT, - ATTR_CONST_NOTHROW_LEAF_LIST) + ATTR_CONST_NOTHROW_LIST) +DEF_GOMP_BUILTIN_COMPILER (BUILT_IN_OMP_GET_INITIAL_DEVICE, + "omp_get_initial_device", BT_FN_INT, + ATTR_PURE_NOTHROW_LIST) +DEF_GOMP_BUILTIN_COMPILER (BUILT_IN_OMP_GET_NUM_DEVICES, "omp_get_num_devices", + BT_FN_INT, ATTR_PURE_NOTHROW_LIST) DEF_GOMP_BUILTIN (BUILT_IN_OMP_GET_THREAD_NUM, "omp_get_thread_num", BT_FN_INT, ATTR_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_OMP_GET_NUM_THREADS, "omp_get_num_threads", @@ -88,8 +93,6 @@ DEF_GOMP_BUILTIN (BUILT_IN_OMP_SET_DEFAULT_DEVICE, "omp_set_default_device", BT_FN_INT, ATTR_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_OMP_GET_INTEROP_INT, "omp_get_interop_int", BT_FN_PTRMODE_PTR_INT_PTR, ATTR_NOTHROW_LEAF_LIST) -DEF_GOMP_BUILTIN (BUILT_IN_OMP_GET_NUM_DEVICES, "omp_get_num_devices", - BT_FN_INT, ATTR_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_OMP_INIT_ALLOCATOR, "omp_init_allocator", BT_FN_PTRMODE_PTRMODE_INT_PTR, ATTR_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_OMP_DESTROY_ALLOCATOR, "omp_destroy_allocator", diff --git a/gcc/omp-general.cc b/gcc/omp-general.cc index 0eaa431..6580a5f 100644 --- a/gcc/omp-general.cc +++ b/gcc/omp-general.cc @@ -2759,10 +2759,16 @@ omp_selector_is_dynamic (tree ctx) static tree omp_device_num_check (tree *device_num, bool *is_host) { + /* C++ may wrap the device_num expr in a CLEANUP_POINT_EXPR; we want + to look inside of it for the special cases. */ + tree t = *device_num; + if (TREE_CODE (t) == CLEANUP_POINT_EXPR) + t = TREE_OPERAND (t, 0); + /* First check for some constant values we can treat specially. */ - if (tree_fits_shwi_p (*device_num)) + if (tree_fits_shwi_p (t)) { - HOST_WIDE_INT num = tree_to_shwi (*device_num); + HOST_WIDE_INT num = tree_to_shwi (t); if (num < -1) return integer_zero_node; /* Initial device? */ @@ -2781,9 +2787,9 @@ omp_device_num_check (tree *device_num, bool *is_host) /* Also test for direct calls to OpenMP routines that return valid device numbers. */ - if (TREE_CODE (*device_num) == CALL_EXPR) + if (TREE_CODE (t) == CALL_EXPR) { - tree fndecl = get_callee_fndecl (*device_num); + tree fndecl = get_callee_fndecl (t); if (fndecl && omp_runtime_api_call (fndecl)) { const char *fnname = IDENTIFIER_POINTER (DECL_NAME (fndecl)); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5b94c72..4008287 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,141 @@ +2025-06-09 Jason Merrill <jason@redhat.com> + + Backported from master: + 2025-06-06 Jason Merrill <jason@redhat.com> + + PR c++/120555 + * g++.dg/cpp1z/constexpr-if39.C: New test. + +2025-06-09 Jason Merrill <jason@redhat.com> + + PR c++/120502 + * g++.dg/cpp2a/constexpr-prvalue2.C: New test. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-31 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120357 + * gcc.dg/vect/vect-early-break_136-pr120357.c: New testcase. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-30 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120341 + * gcc.dg/torture/pr120341-1.c: New testcase. + * gcc.dg/torture/pr120341-2.c: Likewise. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-09 Richard Biener <rguenther@suse.de> + + PR rtl-optimization/120182 + * gcc.dg/torture/pr120182.c: New testcase. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-01 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120003 + * gcc.dg/tree-ssa/ssa-dom-thread-7.c: Adjust aarch64 expected + thread2 number of threads. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-04-30 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120003 + * gcc.dg/tree-ssa/ssa-thread-23.c: New testcase. + * gcc.dg/tree-ssa/ssa-dom-thread-7.c: Adjust. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-09 Richard Biener <rguenther@suse.de> + + PR tree-optimization/119960 + * gcc.dg/vect/bb-slp-pr119960-1.c: New testcase. + +2025-06-06 Richard Biener <rguenther@suse.de> + + Backported from master: + 2025-05-15 Richard Biener <rguenther@suse.de> + + * gcc.target/i386/vect-epilogues-1.c: New testcase. + * gcc.target/i386/vect-epilogues-2.c: Likewise. + * gcc.target/i386/vect-epilogues-3.c: Likewise. + * gcc.target/i386/vect-epilogues-4.c: Likewise. + * gcc.target/i386/vect-epilogues-5.c: Likewise. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/specs/opt7.ads: New test. + * gnat.dg/specs/opt7_pkg.ads: New helper. + * gnat.dg/specs/opt7_pkg.adb: Likewise. + +2025-06-04 Harald Anlauf <anlauf@gmx.de> + + Backported from master: + 2025-06-03 Harald Anlauf <anlauf@gmx.de> + + PR fortran/99838 + * gfortran.dg/coarray_data_2.f90: New test. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + Backported from master: + 2025-05-30 Harald Anlauf <anlauf@gmx.de> + + PR fortran/102599 + PR fortran/114022 + * gfortran.dg/inquiry_type_ref_8.f90: New test. + +2025-06-03 Harald Anlauf <anlauf@gmx.de> + + Backported from master: + 2025-05-27 Harald Anlauf <anlauf@gmx.de> + + PR fortran/101735 + * gfortran.dg/inquiry_type_ref_7.f90: New test. + +2025-06-02 Jason Merrill <jason@redhat.com> + + PR c++/120123 + * g++.dg/cpp2a/concepts-lambda24.C: New test. + +2025-06-02 Jakub Jelinek <jakub@redhat.com> + + Backported from master: + 2025-05-10 Jakub Jelinek <jakub@redhat.com> + + PR fortran/120193 + * gfortran.dg/guality/pr120193.f90: New test. + +2025-06-02 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + Backported from master: + 2025-06-01 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libfortran/119856 + * gfortran.dg/pr119856.f90: New test. + +2025-06-02 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + Backported from master: + 2025-05-28 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR fortran/119856 + * gfortran.dg/comma_format_extension_1.f: Update dg-options to + "-std=legacy". + * gfortran.dg/comma_format_extension_3.f: Likewise. + * gfortran.dg/continuation_13.f90: Likewise. + 2025-05-31 Jerry DeLisle <jvdelisle@gcc.gnu.org> Backported from master: diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp index 621a45d..1684f7a 100644 --- a/gcc/testsuite/ChangeLog.omp +++ b/gcc/testsuite/ChangeLog.omp @@ -1,3 +1,27 @@ +2025-06-06 Tobias Burnus <tburnus@baylibre.com> + + Backported from master: + 2025-06-06 Tobias Burnus <tburnus@baylibre.com> + Sandra Loosemore <sloosemore@baylibre.com> + + * c-c++-common/gomp/omp_get_num_devices_initial_device-2.c: New test. + * c-c++-common/gomp/omp_get_num_devices_initial_device.c: New test. + * gfortran.dg/gomp/omp_get_num_devices_initial_device-2.f90: New test. + * gfortran.dg/gomp/omp_get_num_devices_initial_device.f90: New test. + +2025-06-05 Sandra Loosemore <sloosemore@baylibre.com> + + Backported from master: + 2025-06-02 Sandra Loosemore <sloosemore@baylibre.com> + + * c-c++-common/gomp/declare-variant-2.c: Update expected output. + * c-c++-common/gomp/metadirective-condition-constexpr.c: New. + * c-c++-common/gomp/metadirective-condition.c: New. + * c-c++-common/gomp/metadirective-error-recovery.c: Update expected + output. + * g++.dg/gomp/metadirective-condition-class.C: New. + * g++.dg/gomp/metadirective-condition-template.C: New. + 2025-05-22 Thomas Schwinge <tschwinge@baylibre.com> Backported from master: diff --git a/gcc/testsuite/c-c++-common/gomp/declare-variant-2.c b/gcc/testsuite/c-c++-common/gomp/declare-variant-2.c index f8f5143..83e1bb1 100644 --- a/gcc/testsuite/c-c++-common/gomp/declare-variant-2.c +++ b/gcc/testsuite/c-c++-common/gomp/declare-variant-2.c @@ -38,7 +38,7 @@ void f18 (void); void f19 (void); #pragma omp declare variant (f1) match(user={condition()}) /* { dg-error "expected \[^\n\r]*expression before '\\)' token" } */ void f20 (void); -#pragma omp declare variant (f1) match(user={condition(f1)}) /* { dg-error "property must be integer expression" } */ +#pragma omp declare variant (f1) match(user={condition(f1)}) void f21 (void); #pragma omp declare variant (f1) match(user={condition(1, 2, 3)}) /* { dg-error "expected '\\)' before ',' token" } */ void f22 (void); diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-condition-constexpr.c b/gcc/testsuite/c-c++-common/gomp/metadirective-condition-constexpr.c new file mode 100644 index 0000000..3484478 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-condition-constexpr.c @@ -0,0 +1,13 @@ +/* { dg-do compile { target { c || c++11 } } } */ +/* { dg-additional-options "-std=c23" { target c } } */ +/* { dg-additional-options "-fdump-tree-original" } */ + +constexpr int flag = 1; + +void f() { +#pragma omp metadirective when(user={condition(flag)} : nothing) \ + otherwise(error at(execution)) +} + +/* { dg-final { scan-tree-dump-not "__builtin_GOMP_error" "original" } } */ + diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-condition.c b/gcc/testsuite/c-c++-common/gomp/metadirective-condition.c new file mode 100644 index 0000000..099ad9d --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-condition.c @@ -0,0 +1,25 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-original" } */ + +static int arr[10]; +static int g (int a) { return -a; } + +void f (int *ptr, float x) { + + /* Implicit conversion float -> bool */ + #pragma omp metadirective when(user={condition(x)} : nothing) otherwise(nothing) + + /* Implicit conversion pointer -> bool */ + #pragma omp metadirective when(user={condition(ptr)} : nothing) otherwise(nothing) + + /* Array expression undergoes array->pointer conversion, OK but test is + always optimized away. */ + #pragma omp metadirective when(user={condition(arr)} : nothing) otherwise(nothing) + + /* Function reference has pointer-to-function type, OK but test is + always optimized away. */ + #pragma omp metadirective when(user={condition(g)} : nothing) otherwise(nothing) +} + +/* { dg-final { scan-tree-dump "x != 0.0" "original" } } */ +/* { dg-final { scan-tree-dump "ptr != 0B" "original" } } */ diff --git a/gcc/testsuite/c-c++-common/gomp/metadirective-error-recovery.c b/gcc/testsuite/c-c++-common/gomp/metadirective-error-recovery.c index 3242281..92995a2 100644 --- a/gcc/testsuite/c-c++-common/gomp/metadirective-error-recovery.c +++ b/gcc/testsuite/c-c++-common/gomp/metadirective-error-recovery.c @@ -15,6 +15,11 @@ void f (int aa, int bb) s2.b = bb + 1; /* A struct is not a valid argument for the condition selector. */ - #pragma omp metadirective when(user={condition(s1)} : nothing) otherwise(nothing) /* { dg-error "property must be integer expression" } */ - #pragma omp metadirective when(user={condition(s2)} : nothing) otherwise(nothing) /* { dg-error "property must be integer expression" } */ + #pragma omp metadirective when(user={condition(s1)} : nothing) otherwise(nothing) + /* { dg-error "used struct type value where scalar is required" "" { target c } .-1 } */ + /* { dg-error "could not convert .s1. from .s. to .bool." "" { target c++ } .-2 } */ + #pragma omp metadirective when(user={condition(s2)} : nothing) otherwise(nothing) + /* { dg-error "used struct type value where scalar is required" "" { target c } .-1 } */ + /* { dg-error "could not convert .s2. from .s. to .bool." "" { target c++ } .-2 } */ + } diff --git a/gcc/testsuite/c-c++-common/gomp/omp_get_num_devices_initial_device-2.c b/gcc/testsuite/c-c++-common/gomp/omp_get_num_devices_initial_device-2.c new file mode 100644 index 0000000..891f5cf --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/omp_get_num_devices_initial_device-2.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-O1 -fdump-tree-optimized -fno-builtin-omp_get_num_devices -fno-builtin-omp_get_initial_device" } */ + +#ifdef __cplusplus +extern "C" { +#endif +extern int omp_get_initial_device (); +extern int omp_get_num_devices (); +#ifdef __cplusplus +} +#endif + +int f() +{ +/* The following assumes that omp_get_initial_device () will not return + omp_initial_device (== -1), which is also permitted since OpenMP 6.0. */ + if (omp_get_initial_device () != omp_get_num_devices ()) __builtin_abort (); + + if (omp_get_num_devices () != omp_get_num_devices ()) __builtin_abort (); + + if (omp_get_initial_device () != omp_get_initial_device ()) __builtin_abort (); + + return omp_get_num_devices (); +} + +/* { dg-final { scan-tree-dump-times "abort" 3 "optimized" } } */ + +/* { dg-final { scan-tree-dump-times "omp_get_num_devices" 4 "optimized" } } */ +/* { dg-final { scan-tree-dump-times "omp_get_initial_device" 3 "optimized" } } */ diff --git a/gcc/testsuite/c-c++-common/gomp/omp_get_num_devices_initial_device.c b/gcc/testsuite/c-c++-common/gomp/omp_get_num_devices_initial_device.c new file mode 100644 index 0000000..4b17143 --- /dev/null +++ b/gcc/testsuite/c-c++-common/gomp/omp_get_num_devices_initial_device.c @@ -0,0 +1,32 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-O1 -fdump-tree-optimized" } */ + +#ifdef __cplusplus +extern "C" { +#endif +extern int omp_get_initial_device (); +extern int omp_get_num_devices (); +#ifdef __cplusplus +} +#endif + +int f() +{ +/* The following assumes that omp_get_initial_device () will not return + omp_initial_device (== -1), which is also permitted since OpenMP 6.0. */ + if (omp_get_initial_device () != omp_get_num_devices ()) __builtin_abort (); + + if (omp_get_num_devices () != omp_get_num_devices ()) __builtin_abort (); + + if (omp_get_initial_device () != omp_get_initial_device ()) __builtin_abort (); + + return omp_get_num_devices (); +} + +/* { dg-final { scan-tree-dump-not "abort" "optimized" } } */ + +/* { dg-final { scan-tree-dump-not "omp_get_num_devices;" "optimized" { target { ! offloading_enabled } } } } */ +/* { dg-final { scan-tree-dump "return 0;" "optimized" { target { ! offloading_enabled } } } } */ + +/* { dg-final { scan-tree-dump-times "omp_get_num_devices;" 1 "optimized" { target offloading_enabled } } } */ +/* { dg-final { scan-tree-dump "_1 = __builtin_omp_get_num_devices \\(\\);\[\\r\\n\]+\[ \]+return _1;" "optimized" { target offloading_enabled } } } */ diff --git a/gcc/testsuite/g++.dg/cpp1z/constexpr-if39.C b/gcc/testsuite/g++.dg/cpp1z/constexpr-if39.C new file mode 100644 index 0000000..38ae7a0 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp1z/constexpr-if39.C @@ -0,0 +1,30 @@ +// PR c++/120555 +// { dg-do compile { target c++17 } } + +struct A { int m; }; + +template<class T> +constexpr auto f() { + if constexpr (sizeof(T) == sizeof(int)) + return 1; + else + return A{f<int>()}; +} + +static_assert(f<bool>().m == 1); +static_assert(f<int>() == 1); + +template <class T> constexpr auto g(); + +template<class T> +constexpr auto f2() { + if constexpr (sizeof(T) == sizeof(int)) + return 1; + else + return A{g<int>()}; // { dg-error "auto" } +} + +template <class T> constexpr auto g() { return A{1}; } + +static_assert(f2<bool>().m == 1); +static_assert(f2<int>() == 1); diff --git a/gcc/testsuite/g++.dg/cpp2a/concepts-lambda24.C b/gcc/testsuite/g++.dg/cpp2a/concepts-lambda24.C new file mode 100644 index 0000000..28f56ca --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/concepts-lambda24.C @@ -0,0 +1,13 @@ +// PR c++/120123 +// { dg-do compile { target c++20 } } + +struct H { + void member(int) {} + void call() { + [this]() { + [this](const auto& v) + requires requires { /*this->*/member(v); } + { return member(v); }(0); + }; + } +}; diff --git a/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C b/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C new file mode 100644 index 0000000..c2dc7cd --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp2a/constexpr-prvalue2.C @@ -0,0 +1,26 @@ +// PR c++/120502 +// { dg-do compile { target c++20 } } +// { dg-additional-options -O } + +struct non_trivial_if { + constexpr non_trivial_if() {} +}; +struct allocator : non_trivial_if {}; +struct padding {}; +struct __short { + [[no_unique_address]] padding p; +}; +struct basic_string { + union { + __short s; + int l; + }; + [[no_unique_address]] allocator a; + constexpr basic_string() {} + ~basic_string() {} +}; +struct time_zone { + basic_string __abbrev; + long __offset; +}; +time_zone convert_to_time_zone() { return {}; } diff --git a/gcc/testsuite/g++.dg/gomp/metadirective-condition-class.C b/gcc/testsuite/g++.dg/gomp/metadirective-condition-class.C new file mode 100644 index 0000000..6403611 --- /dev/null +++ b/gcc/testsuite/g++.dg/gomp/metadirective-condition-class.C @@ -0,0 +1,43 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-original" } */ + +class c +{ + public: + int x; + c (int xx) { x = xx; } + operator bool() { return x != 0; } +}; + +void f (c &objref) +{ + #pragma omp metadirective when(user={condition(objref)} : nothing) otherwise(nothing) +} + + +template <typename T> class d +{ + public: + T x; + d (T xx) { x = xx; } + operator bool() { return x != 0; } +}; + +template <typename T> +void g (d<T> &objref) +{ + #pragma omp metadirective when(user={condition(objref)} : nothing) otherwise(nothing) +} + +int main (void) +{ + c obj1 (42); + d<int> obj2 (69); + + f (obj1); + g (obj2); +} + +/* { dg-final { scan-tree-dump "c::operator bool \\(\\(struct c .\\) objref\\)" "original" } } */ + +/* { dg-final { scan-tree-dump "d<int>::operator bool \\(\\(struct d .\\) objref\\)" "original" } } */ diff --git a/gcc/testsuite/g++.dg/gomp/metadirective-condition-template.C b/gcc/testsuite/g++.dg/gomp/metadirective-condition-template.C new file mode 100644 index 0000000..30783d9 --- /dev/null +++ b/gcc/testsuite/g++.dg/gomp/metadirective-condition-template.C @@ -0,0 +1,41 @@ +/* { dg-do compile } */ +/* { dg-additional-options "-fdump-tree-original" } */ + +template<typename T, typename T2> +void f (T x, T2 y) +{ + #pragma omp metadirective when(user={condition(x)}, \ + target_device={device_num(y)} : flush) +} + +class c +{ + public: + int x; + c (int xx) { x = xx; } + operator bool() { return x != 0; } +}; + +template <typename T> class d +{ + public: + T x; + d (T xx) { x = xx; } + operator bool() { return x != 0; } +}; + +int main (void) +{ + c obj1 (42); + d<int> obj2 (69); + + f (42, 0); + f (&obj1, 0); + f (obj1, 0); + f (obj2, 0); +} + +/* { dg-final { scan-tree-dump-times "if \\(x != 0 &&" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "if \\(x != 0B &&" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "if \\(<<cleanup_point c::operator bool \\(&x\\)>> &&" 1 "original" } } */ +/* { dg-final { scan-tree-dump-times "if \\(<<cleanup_point d<int>::operator bool \\(&x\\)>> &&" 1 "original" } } */ diff --git a/gcc/testsuite/gcc.dg/torture/pr120182.c b/gcc/testsuite/gcc.dg/torture/pr120182.c new file mode 100644 index 0000000..5e2d171 --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr120182.c @@ -0,0 +1,42 @@ +/* { dg-do run { target { { *-*-linux* *-*-gnu* *-*-uclinux* } && mmap } } } */ + +#include <unistd.h> +#include <stdlib.h> +#include <sys/mman.h> + +struct S +{ + struct S *next; +}; + +static void __attribute__((noipa)) +allocate(void *addr, unsigned long long size) +{ + void *ptr = mmap((void *)addr, size, + PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED_NOREPLACE, + -1, 0); + if(ptr != addr) + exit(0); +} + +int main (void) +{ + int size = 0x8000; + char *ptr = (char *)0x288000ull; + allocate((void *)ptr, size); + + struct S *s1 = (struct S *)ptr; + struct S *s2 = (struct S *)256; + for (int i = 0; i < 3; i++) + { + for(char *addr = (char *)s1; addr < (char *)s1 + sizeof(*s1); ++addr) + *addr = 0; + + if(s1->next) + s1->next = s1->next->next = s2; + else + s1->next = s2; + } + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/pr120341-1.c b/gcc/testsuite/gcc.dg/torture/pr120341-1.c new file mode 100644 index 0000000..e23185b --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr120341-1.c @@ -0,0 +1,11 @@ +/* { dg-do run } */ +/* { dg-additional-options "-fallow-store-data-races" } */ + +char a, *b; +int main() +{ + b = "0"; + if (a) + b[0]++; + return 0; +} diff --git a/gcc/testsuite/gcc.dg/torture/pr120341-2.c b/gcc/testsuite/gcc.dg/torture/pr120341-2.c new file mode 100644 index 0000000..7bcc96f --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr120341-2.c @@ -0,0 +1,13 @@ +/* { dg-do run } */ +/* { dg-additional-options "-fallow-store-data-races" } */ + +char a, *b; +int main() +{ + while (a) + { + b = "0"; + b[0]++; + } + return 0; +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c index d84acee..59891f2 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-dom-thread-7.c @@ -11,7 +11,7 @@ to change decisions in switch expansion which in turn can expose new jump threading opportunities. Skip the later tests on aarch64. */ /* { dg-final { scan-tree-dump-not "Jumps threaded" "dom3" { target { ! aarch64*-*-* } } } } */ -/* { dg-final { scan-tree-dump "Jumps threaded: 9" "thread2" { target { ! aarch64*-*-* } } } } */ +/* { dg-final { scan-tree-dump "Jumps threaded: 10" "thread2" { target { ! aarch64*-*-* } } } } */ /* { dg-final { scan-tree-dump "Jumps threaded: 17" "thread2" { target { aarch64*-*-* } } } } */ enum STATE { diff --git a/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-23.c b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-23.c new file mode 100644 index 0000000..930360a --- /dev/null +++ b/gcc/testsuite/gcc.dg/tree-ssa/ssa-thread-23.c @@ -0,0 +1,19 @@ +/* PR120003 */ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-cddce3-details" } */ + +extern _Bool g(int); + +_Bool f() +{ + _Bool retval = 0; + for(int i=0; i<1000000; ++i) + retval = retval || g(i); + return retval; +} + +/* Jump threading after loop optimization should get the counting loop + separated from the loop until retval is true and CD-DCE elide it. + It's difficult to check for the fact that a true retval terminates + the loop so check CD-DCE eliminates one loop instead. */ +/* { dg-final { scan-tree-dump "fix_loop_structure: removing loop" "cddce3" } } */ diff --git a/gcc/testsuite/gcc.dg/vect/bb-slp-pr119960-1.c b/gcc/testsuite/gcc.dg/vect/bb-slp-pr119960-1.c new file mode 100644 index 0000000..955fc7e --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/bb-slp-pr119960-1.c @@ -0,0 +1,15 @@ +/* { dg-do compile } */ +/* { dg-require-effective-target vect_double } */ + +double foo (double *dst, double *src, int b) +{ + double y = src[1]; + if (b) + { + dst[0] = src[0]; + dst[1] = y; + } + return y; +} + +/* { dg-final { scan-tree-dump "optimized: basic block part vectorized" "slp2" { target vect_double } } } */ diff --git a/gcc/testsuite/gcc.dg/vect/vect-early-break_136-pr120357.c b/gcc/testsuite/gcc.dg/vect/vect-early-break_136-pr120357.c new file mode 100644 index 0000000..8a51cfc --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-early-break_136-pr120357.c @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-add-options vect_early_break } */ +/* { dg-additional-options "-O3" } */ + +char a; +unsigned long long t[2][22]; +int u[22]; +void f(void) +{ + for (int v = 0; v < 22; v++) + for (_Bool w = 0; w < (u[v] < 0) + 1; w = 1) + a *= 0 != t[w][v]; +} diff --git a/gcc/testsuite/gcc.target/i386/vect-epilogues-1.c b/gcc/testsuite/gcc.target/i386/vect-epilogues-1.c new file mode 100644 index 0000000..a7f5f12 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/vect-epilogues-1.c @@ -0,0 +1,14 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -mavx2 -mno-avx512f -mtune=generic -fdump-tree-vect-optimized" } */ + +int test (signed char *data, int n) +{ + int sum = 0; + for (int i = 0; i < n; ++i) + sum += data[i]; + return sum; +} + +/* { dg-final { scan-tree-dump "loop vectorized using 32 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump "loop vectorized using 16 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump "loop vectorized using 8 byte vectors" "vect" { target { ! ia32 } } } } */ diff --git a/gcc/testsuite/gcc.target/i386/vect-epilogues-2.c b/gcc/testsuite/gcc.target/i386/vect-epilogues-2.c new file mode 100644 index 0000000..d6c06ed --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/vect-epilogues-2.c @@ -0,0 +1,15 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -mavx512bw -mtune=generic -fdump-tree-vect-optimized" } */ + +int test (signed char *data, int n) +{ + int sum = 0; + for (int i = 0; i < n; ++i) + sum += data[i]; + return sum; +} + +/* { dg-final { scan-tree-dump "loop vectorized using 64 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump "loop vectorized using 32 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump-not "loop vectorized using 16 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump-not "loop vectorized using 8 byte vectors" "vect" } } */ diff --git a/gcc/testsuite/gcc.target/i386/vect-epilogues-3.c b/gcc/testsuite/gcc.target/i386/vect-epilogues-3.c new file mode 100644 index 0000000..0ee610f --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/vect-epilogues-3.c @@ -0,0 +1,15 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -mavx512bw -mtune=znver4 -fdump-tree-vect-optimized" } */ + +int test (signed char *data, int n) +{ + int sum = 0; + for (int i = 0; i < n; ++i) + sum += data[i]; + return sum; +} + +/* { dg-final { scan-tree-dump "loop vectorized using 64 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump "loop vectorized using 32 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump "loop vectorized using 16 byte vectors" "vect" } } */ +/* { dg-final { scan-tree-dump "loop vectorized using 8 byte vectors" "vect" { target { ! ia32 } } } } */ diff --git a/gcc/testsuite/gcc.target/i386/vect-epilogues-4.c b/gcc/testsuite/gcc.target/i386/vect-epilogues-4.c new file mode 100644 index 0000000..498db6b --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/vect-epilogues-4.c @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -mavx512bw -mtune=generic --param vect-partial-vector-usage=1 -fdump-tree-vect-optimized" } */ + +int test (signed char *data, int n) +{ + int sum = 0; + for (int i = 0; i < n; ++i) + sum += data[i]; + return sum; +} + +/* { dg-final { scan-tree-dump-times "loop vectorized using 64 byte vectors" 2 "vect" } } */ +/* { dg-final { scan-tree-dump-not "loop vectorized using 32 byte vectors" "vect" } } */ diff --git a/gcc/testsuite/gcc.target/i386/vect-epilogues-5.c b/gcc/testsuite/gcc.target/i386/vect-epilogues-5.c new file mode 100644 index 0000000..6772cab --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/vect-epilogues-5.c @@ -0,0 +1,13 @@ +/* { dg-do compile } */ +/* { dg-options "-O3 -mavx512bw -mtune=znver4 --param vect-partial-vector-usage=1 -fdump-tree-vect-optimized" } */ + +int test (signed char *data, int n) +{ + int sum = 0; + for (int i = 0; i < n; ++i) + sum += data[i]; + return sum; +} + +/* { dg-final { scan-tree-dump-times "loop vectorized using 64 byte vectors" 2 "vect" } } */ +/* { dg-final { scan-tree-dump-not "loop vectorized using 32 byte vectors" "vect" } } */ diff --git a/gcc/testsuite/gfortran.dg/coarray_data_2.f90 b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 new file mode 100644 index 0000000..bda57f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_data_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=lib -Warray-temporaries" } +! +! PR fortran/99838 - ICE due to missing locus with data statement for coarray +! +! Contributed by Gerhard Steinmetz + +program p + type t + integer :: a + end type + type(t) :: x(3)[*] + data x%a /1, 2, 3/ ! { dg-warning "Creating array temporary" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device-2.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device-2.f90 new file mode 100644 index 0000000..18613d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device-2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-O1 -fdump-tree-optimized -fno-builtin-omp_get_num_devices -fno-builtin-omp_get_initial_device" } +integer function f() result(ret) + interface + integer function omp_get_initial_device (); end + integer function omp_get_num_devices (); end + end interface + + if (omp_get_initial_device () /= omp_get_num_devices ()) error stop + + if (omp_get_num_devices () /= omp_get_num_devices ()) error stop + + if (omp_get_initial_device () /= omp_get_initial_device ()) error stop + + ret = omp_get_num_devices () +end + +! { dg-final { scan-tree-dump-times "error_stop" 3 "optimized" } } + +! { dg-final { scan-tree-dump-times "omp_get_num_devices" 4 "optimized" } } +! { dg-final { scan-tree-dump-times "omp_get_initial_device" 3 "optimized" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device.f90 b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device.f90 new file mode 100644 index 0000000..5409f12 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/omp_get_num_devices_initial_device.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-O1 -fdump-tree-optimized" } +integer function f() result(ret) + interface + integer function omp_get_initial_device (); end + integer function omp_get_num_devices (); end + end interface + + if (omp_get_initial_device () /= omp_get_num_devices ()) error stop + + if (omp_get_num_devices () /= omp_get_num_devices ()) error stop + + if (omp_get_initial_device () /= omp_get_initial_device ()) error stop + + ret = omp_get_num_devices () +end + +! { dg-final { scan-tree-dump-not "error_stop" "optimized" } } + +! { dg-final { scan-tree-dump-not "omp_get_num_devices;" "optimized" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump "return 0;" "optimized" { target { ! offloading_enabled } } } } + +! { dg-final { scan-tree-dump-times "omp_get_num_devices;" 1 "optimized" { target offloading_enabled } } } +! { dg-final { scan-tree-dump "_1 = __builtin_omp_get_num_devices \\(\\);\[\\r\\n\]+\[ \]+return _1;" "optimized" { target offloading_enabled } } } diff --git a/gcc/testsuite/gfortran.dg/guality/pr120193.f90 b/gcc/testsuite/gfortran.dg/guality/pr120193.f90 new file mode 100644 index 0000000..e65febf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/guality/pr120193.f90 @@ -0,0 +1,26 @@ +! PR fortran/120193 +! { dg-do run } +! { dg-options "-g -funsigned" } +! { dg-skip-if "" { *-*-* } { "*" } { "-O0" } } + +program foo + unsigned(kind=1) :: a(2), e + unsigned(kind=2) :: b(2), f + unsigned(kind=4) :: c(2), g + unsigned(kind=8) :: d(2), h + character(kind=1, len=1) :: i(2), j + character(kind=4, len=1) :: k(2), l + a = 97u_1 ! { dg-final { gdb-test 24 "a" "d" } } + b = 97u_2 ! { dg-final { gdb-test 24 "b" "c" } } + c = 97u_4 ! { dg-final { gdb-test 24 "c" "b" } } + d = 97u_8 ! { dg-final { gdb-test 24 "d" "a" } } + e = 97u_1 ! { dg-final { gdb-test 24 "e" "97" } } + f = 97u_2 ! { dg-final { gdb-test 24 "f" "97" } } + g = 97u_4 ! { dg-final { gdb-test 24 "g" "97" } } + h = 97u_8 ! { dg-final { gdb-test 24 "h" "97" } } + i = 'a' ! { dg-final { gdb-test 24 "i" "('a', 'a')" } } + j = 'b' ! { dg-final { gdb-test 24 "j" "'b'" } } + k = 'c' + l = 'd' + print *, a +end program diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 new file mode 100644 index 0000000..534225a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/101735 - substrings and parsing of type parameter inquiries + +program p + implicit none + integer, parameter :: ck = 4 + character(len=5) :: str = "" + character(len=5) :: str2(4) + character(len=5,kind=ck) :: str4 = ck_"" + type t + character(len=5) :: str(4) + end type t + type(t) :: var + integer :: x, y + + integer, parameter :: i1 = kind (str(1:3)) + integer, parameter :: j1 = str (1:3) % kind + integer, parameter :: k1 = (str(1:3) % kind) + integer, parameter :: kk = str (1:3) % kind % kind + + integer, parameter :: i4 = kind (str4(1:3)) + integer, parameter :: j4 = str4 (1:3) % kind + integer, parameter :: ll = str4 (1:3) % len + + integer, parameter :: i2 = len (str(1:3)) + integer, parameter :: j2 = str (1:3) % len + integer, parameter :: k2 = (str(1:3) % len) + integer, parameter :: lk = str (1:3) % len % kind + + integer, parameter :: l4 = str2 (:) (2:3) % len + integer, parameter :: l5 = var % str (:) (2:4) % len + integer, parameter :: k4 = str2 (:) (2:3) % kind + integer, parameter :: k5 = var % str (:) (2:4) % kind + integer, parameter :: k6 = str2 (:) (2:3) % len % kind + integer, parameter :: k7 = var % str (:) (2:4) % len % kind + + if (i1 /= 1) stop 1 + if (j1 /= 1) stop 2 + if (k1 /= 1) stop 3 + + if (i4 /= ck) stop 4 + if (j4 /= ck) stop 5 + if (ll /= 3) stop 6 + + if (kk /= 4) stop 7 + if (lk /= 4) stop 8 + + if (i2 /= 3) stop 9 + if (j2 /= 3) stop 10 + if (k2 /= 3) stop 11 + + if (l4 /= 2) stop 12 + if (l5 /= 3) stop 13 + if (k4 /= 1) stop 14 + if (k5 /= 1) stop 15 + if (k6 /= 4) stop 16 + if (k7 /= 4) stop 17 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_8.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_8.f90 new file mode 100644 index 0000000..70ef621 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_8.f90 @@ -0,0 +1,214 @@ +! { dg-do compile } +! { dg-additional-options "-O0 -fdump-tree-original -std=f2018" } +! +! PR fortran/102599 - type parameter inquiries and constant complex arrays +! PR fortran/114022 - likewise +! +! Everything below shall be simplified at compile time. + +module mod + implicit none + public :: wp, c0, z0, y, test1 + private + + integer :: j + integer, parameter :: n = 5 + integer, parameter :: wp = 8 + type :: cx + real(wp) :: re + real(wp) :: im + end type cx + type(cx), parameter :: c0(*) = [(cx (j,-j), j=1,n)] + complex(wp), parameter :: z0(*) = [(cmplx(j,-j,wp),j=1,n)] + + type :: my_type + complex(wp) :: z(n) = z0 + type(cx) :: c(n) = c0 + end type my_type + type(my_type), parameter :: y = my_type() + +contains + + ! Check simplification for inquiries of host-associated variables + subroutine test1 () + ! Inquiries and full arrays + real(wp), parameter :: r0(*) = real (z0) + real(wp), parameter :: i0(*) = aimag (z0) + real(wp), parameter :: r1(*) = c0 % re + real(wp), parameter :: i1(*) = c0 % im + real(wp), parameter :: r2(*) = z0 % re + real(wp), parameter :: i2(*) = z0 % im + real(wp), parameter :: r3(*) = y % c % re + real(wp), parameter :: i3(*) = y % c % im + real(wp), parameter :: r4(*) = y % z % re + real(wp), parameter :: i4(*) = y % z % im + + logical, parameter :: l1 = all (r1 == r0) + logical, parameter :: l2 = all (i1 == i0) + logical, parameter :: l3 = all (r1 == r2) + logical, parameter :: l4 = all (i1 == i2) + logical, parameter :: l5 = all (r3 == r4) + logical, parameter :: l6 = all (i3 == i4) + logical, parameter :: l7 = all (r1 == r3) + logical, parameter :: l8 = all (i1 == i3) + + ! Inquiries and array sections + real(wp), parameter :: p0(*) = real (z0(::2)) + real(wp), parameter :: q0(*) = aimag (z0(::2)) + real(wp), parameter :: p1(*) = c0(::2) % re + real(wp), parameter :: q1(*) = c0(::2) % im + real(wp), parameter :: p2(*) = z0(::2) % re + real(wp), parameter :: q2(*) = z0(::2) % im + real(wp), parameter :: p3(*) = y % c(::2) % re + real(wp), parameter :: q3(*) = y % c(::2) % im + real(wp), parameter :: p4(*) = y % z(::2) % re + real(wp), parameter :: q4(*) = y % z(::2) % im + + logical, parameter :: m1 = all (p1 == p0) + logical, parameter :: m2 = all (q1 == q0) + logical, parameter :: m3 = all (p1 == p2) + logical, parameter :: m4 = all (q1 == q2) + logical, parameter :: m5 = all (p3 == p4) + logical, parameter :: m6 = all (q3 == q4) + logical, parameter :: m7 = all (p1 == p3) + logical, parameter :: m8 = all (q1 == q3) + + ! Inquiries and vector subscripts + real(wp), parameter :: v0(*) = real (z0([3,2])) + real(wp), parameter :: w0(*) = aimag (z0([3,2])) + real(wp), parameter :: v1(*) = c0([3,2]) % re + real(wp), parameter :: w1(*) = c0([3,2]) % im + real(wp), parameter :: v2(*) = z0([3,2]) % re + real(wp), parameter :: w2(*) = z0([3,2]) % im + real(wp), parameter :: v3(*) = y % c([3,2]) % re + real(wp), parameter :: w3(*) = y % c([3,2]) % im + real(wp), parameter :: v4(*) = y % z([3,2]) % re + real(wp), parameter :: w4(*) = y % z([3,2]) % im + + logical, parameter :: o1 = all (v1 == v0) + logical, parameter :: o2 = all (w1 == w0) + logical, parameter :: o3 = all (v1 == v2) + logical, parameter :: o4 = all (w1 == w2) + logical, parameter :: o5 = all (v3 == v4) + logical, parameter :: o6 = all (w3 == w4) + logical, parameter :: o7 = all (v1 == v3) + logical, parameter :: o8 = all (w1 == w3) + + ! Miscellaneous + complex(wp), parameter :: x(-1:*) = cmplx (r1,i1,kind=wp) + real(x%re%kind), parameter :: r(*) = x % re + real(x%im%kind), parameter :: i(*) = x % im + real(x%re%kind), parameter :: s(*) = [ x(:) % re ] + real(x%im%kind), parameter :: t(*) = [ x(:) % im ] + + integer, parameter :: kr = x % re % kind + integer, parameter :: ki = x % im % kind + integer, parameter :: kx = x % kind + + if (kr /= wp .or. ki /= wp .or. kx /= wp) stop 1 + if (any (r /= r1)) stop 2 + if (any (i /= i1)) stop 3 + if (any (s /= r1)) stop 4 + if (any (t /= i1)) stop 5 + + if (.not. all ([l1,l2,l3,l4,l5,l6,l7,l8])) stop 6 + if (.not. all ([m1,m2,m3,m4,m5,m6,m7,m8])) stop 7 + if (.not. all ([o1,o2,o3,o4,o5,o6,o7,o8])) stop 8 + end subroutine test1 +end + +program p + use mod, only: wp, c0, z0, y, test1 + implicit none + call test1 () + call test2 () +contains + ! Check simplification for inquiries of use-associated variables + subroutine test2 () + ! Inquiries and full arrays + real(wp), parameter :: r0(*) = real (z0) + real(wp), parameter :: i0(*) = aimag (z0) + real(wp), parameter :: r1(*) = c0 % re + real(wp), parameter :: i1(*) = c0 % im + real(wp), parameter :: r2(*) = z0 % re + real(wp), parameter :: i2(*) = z0 % im + real(wp), parameter :: r3(*) = y % c % re + real(wp), parameter :: i3(*) = y % c % im + real(wp), parameter :: r4(*) = y % z % re + real(wp), parameter :: i4(*) = y % z % im + + logical, parameter :: l1 = all (r1 == r0) + logical, parameter :: l2 = all (i1 == i0) + logical, parameter :: l3 = all (r1 == r2) + logical, parameter :: l4 = all (i1 == i2) + logical, parameter :: l5 = all (r3 == r4) + logical, parameter :: l6 = all (i3 == i4) + logical, parameter :: l7 = all (r1 == r3) + logical, parameter :: l8 = all (i1 == i3) + + ! Inquiries and array sections + real(wp), parameter :: p0(*) = real (z0(::2)) + real(wp), parameter :: q0(*) = aimag (z0(::2)) + real(wp), parameter :: p1(*) = c0(::2) % re + real(wp), parameter :: q1(*) = c0(::2) % im + real(wp), parameter :: p2(*) = z0(::2) % re + real(wp), parameter :: q2(*) = z0(::2) % im + real(wp), parameter :: p3(*) = y % c(::2) % re + real(wp), parameter :: q3(*) = y % c(::2) % im + real(wp), parameter :: p4(*) = y % z(::2) % re + real(wp), parameter :: q4(*) = y % z(::2) % im + + logical, parameter :: m1 = all (p1 == p0) + logical, parameter :: m2 = all (q1 == q0) + logical, parameter :: m3 = all (p1 == p2) + logical, parameter :: m4 = all (q1 == q2) + logical, parameter :: m5 = all (p3 == p4) + logical, parameter :: m6 = all (q3 == q4) + logical, parameter :: m7 = all (p1 == p3) + logical, parameter :: m8 = all (q1 == q3) + + ! Inquiries and vector subscripts + real(wp), parameter :: v0(*) = real (z0([3,2])) + real(wp), parameter :: w0(*) = aimag (z0([3,2])) + real(wp), parameter :: v1(*) = c0([3,2]) % re + real(wp), parameter :: w1(*) = c0([3,2]) % im + real(wp), parameter :: v2(*) = z0([3,2]) % re + real(wp), parameter :: w2(*) = z0([3,2]) % im + real(wp), parameter :: v3(*) = y % c([3,2]) % re + real(wp), parameter :: w3(*) = y % c([3,2]) % im + real(wp), parameter :: v4(*) = y % z([3,2]) % re + real(wp), parameter :: w4(*) = y % z([3,2]) % im + + logical, parameter :: o1 = all (v1 == v0) + logical, parameter :: o2 = all (w1 == w0) + logical, parameter :: o3 = all (v1 == v2) + logical, parameter :: o4 = all (w1 == w2) + logical, parameter :: o5 = all (v3 == v4) + logical, parameter :: o6 = all (w3 == w4) + logical, parameter :: o7 = all (v1 == v3) + logical, parameter :: o8 = all (w1 == w3) + + ! Miscellaneous + complex(wp), parameter :: x(-1:*) = cmplx (r1,i1,kind=wp) + real(x%re%kind), parameter :: r(*) = x % re + real(x%im%kind), parameter :: i(*) = x % im + real(x%re%kind), parameter :: s(*) = [ x(:) % re ] + real(x%im%kind), parameter :: t(*) = [ x(:) % im ] + + integer, parameter :: kr = x % re % kind + integer, parameter :: ki = x % im % kind + integer, parameter :: kx = x % kind + + if (kr /= wp .or. ki /= wp .or. kx /= wp) stop 11 + if (any (r /= r1)) stop 12 + if (any (i /= i1)) stop 13 + if (any (s /= r1)) stop 14 + if (any (t /= i1)) stop 15 + + if (.not. all ([l1,l2,l3,l4,l5,l6,l7,l8])) stop 16 + if (.not. all ([m1,m2,m3,m4,m5,m6,m7,m8])) stop 17 + if (.not. all ([o1,o2,o3,o4,o5,o6,o7,o8])) stop 18 + end subroutine test2 +end + +! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } } diff --git a/gcc/testsuite/gnat.dg/specs/opt7.ads b/gcc/testsuite/gnat.dg/specs/opt7.ads new file mode 100644 index 0000000..ee151f0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7.ads @@ -0,0 +1,15 @@ +-- { dg-do compile } +-- { dg-options "-O2 -gnatn" } + +with Opt7_Pkg; use Opt7_Pkg; + +package Opt7 is + + type Rec is record + E : Enum; + end record; + + function Image (R : Rec) return String is + (if R.E = A then Image (R.E) else ""); + +end Opt7; diff --git a/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb b/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb new file mode 100644 index 0000000..1c9d79b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7_pkg.adb @@ -0,0 +1,15 @@ +package body Opt7_Pkg is + + type Constant_String_Access is access constant String; + + type Enum_Name is array (Enum) of Constant_String_Access; + + Enum_Name_Table : constant Enum_Name := + (A => new String'("A"), B => new String'("B")); + + function Image (E : Enum) return String is + begin + return Enum_Name_Table (E).all; + end Image; + +end Opt7_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads b/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads new file mode 100644 index 0000000..2dd271b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/opt7_pkg.ads @@ -0,0 +1,9 @@ +-- { dg-excess-errors "no code generated" } + +package Opt7_Pkg is + + type Enum is (A, B); + + function Image (E : Enum) return String with Inline; + +end Opt7_Pkg; diff --git a/gcc/tree-ssa-loop-im.cc b/gcc/tree-ssa-loop-im.cc index 225964c..71a46f7 100644 --- a/gcc/tree-ssa-loop-im.cc +++ b/gcc/tree-ssa-loop-im.cc @@ -3293,7 +3293,8 @@ can_sm_ref_p (class loop *loop, im_mem_ref *ref) explicitly. */ base = get_base_address (ref->mem.ref); if ((tree_could_trap_p (ref->mem.ref) - || (DECL_P (base) && TREE_READONLY (base))) + || (DECL_P (base) && TREE_READONLY (base)) + || TREE_CODE (base) == STRING_CST) /* ??? We can at least use false here, allowing loads? We are forcing conditional stores if the ref is not always stored to later anyway. So this would only guard diff --git a/gcc/tree-ssa-phiopt.cc b/gcc/tree-ssa-phiopt.cc index 7f3390b..aaebae6 100644 --- a/gcc/tree-ssa-phiopt.cc +++ b/gcc/tree-ssa-phiopt.cc @@ -3565,8 +3565,9 @@ cond_store_replacement (basic_block middle_bb, basic_block join_bb, /* tree_could_trap_p is a predicate for rvalues, so check for readonly memory explicitly. */ || ((base = get_base_address (lhs)) - && DECL_P (base) - && TREE_READONLY (base))) + && ((DECL_P (base) + && TREE_READONLY (base)) + || TREE_CODE (base) == STRING_CST))) return false; } diff --git a/gcc/tree-ssa-threadbackward.cc b/gcc/tree-ssa-threadbackward.cc index d0b74b2..3adb83e 100644 --- a/gcc/tree-ssa-threadbackward.cc +++ b/gcc/tree-ssa-threadbackward.cc @@ -349,9 +349,6 @@ back_threader::find_paths_to_names (basic_block bb, bitmap interesting, unsigned overall_paths, back_threader_profitability &profit) { - if (m_visited_bbs.add (bb)) - return; - m_path.safe_push (bb); // Try to resolve the path without looking back. Avoid resolving paths @@ -377,7 +374,8 @@ back_threader::find_paths_to_names (basic_block bb, bitmap interesting, // Continue looking for ways to extend the path but limit the // search space along a branch else if ((overall_paths = overall_paths * EDGE_COUNT (bb->preds)) - <= (unsigned)param_max_jump_thread_paths) + <= (unsigned)param_max_jump_thread_paths + && !m_visited_bbs.add (bb)) { // For further greedy searching we want to remove interesting // names defined in BB but add ones on the PHI edges for the @@ -489,6 +487,7 @@ back_threader::find_paths_to_names (basic_block bb, bitmap interesting, backtracking we have to restore it. */ for (int j : new_imports) bitmap_clear_bit (m_imports, j); + m_visited_bbs.remove (bb); } else if (dump_file && (dump_flags & TDF_DETAILS)) fprintf (dump_file, " FAIL: Search space limit %d reached.\n", @@ -496,7 +495,6 @@ back_threader::find_paths_to_names (basic_block bb, bitmap interesting, // Reset things to their original state. m_path.pop (); - m_visited_bbs.remove (bb); } // Search backwards from BB looking for paths where the final diff --git a/gcc/tree-vect-data-refs.cc b/gcc/tree-vect-data-refs.cc index d6cd93a..aaeb522 100644 --- a/gcc/tree-vect-data-refs.cc +++ b/gcc/tree-vect-data-refs.cc @@ -7165,7 +7165,8 @@ vect_can_force_dr_alignment_p (const_tree decl, poly_uint64 alignment) return false; if (decl_in_symtab_p (decl) - && !symtab_node::get (decl)->can_increase_alignment_p ()) + && (!symtab_node::get (decl) + || !symtab_node::get (decl)->can_increase_alignment_p ())) return false; if (TREE_STATIC (decl)) diff --git a/gcc/tree-vect-loop.cc b/gcc/tree-vect-loop.cc index 2d35fa1..c824b5a 100644 --- a/gcc/tree-vect-loop.cc +++ b/gcc/tree-vect-loop.cc @@ -6189,7 +6189,8 @@ vect_create_epilog_for_reduction (loop_vec_info loop_vinfo, /* Create an induction variable. */ gimple_stmt_iterator incr_gsi; bool insert_after; - vect_iv_increment_position (loop_exit, &incr_gsi, &insert_after); + vect_iv_increment_position (LOOP_VINFO_IV_EXIT (loop_vinfo), + &incr_gsi, &insert_after); create_iv (series_vect, PLUS_EXPR, vec_step, NULL_TREE, loop, &incr_gsi, insert_after, &indx_before_incr, &indx_after_incr); diff --git a/gcc/tree-vect-slp.cc b/gcc/tree-vect-slp.cc index 958f000..f5286e6 100644 --- a/gcc/tree-vect-slp.cc +++ b/gcc/tree-vect-slp.cc @@ -2616,13 +2616,14 @@ out: if (oprnds_info[0]->def_stmts[0] && is_a<gassign *> (oprnds_info[0]->def_stmts[0]->stmt)) code = gimple_assign_rhs_code (oprnds_info[0]->def_stmts[0]->stmt); + basic_block bb = nullptr; for (unsigned j = 0; j < group_size; ++j) { FOR_EACH_VEC_ELT (oprnds_info, i, oprnd_info) { stmt_vec_info stmt_info = oprnd_info->def_stmts[j]; - if (!stmt_info || !stmt_info->stmt + if (!stmt_info || !is_a<gassign *> (stmt_info->stmt) || gimple_assign_rhs_code (stmt_info->stmt) != code || skip_args[i]) @@ -2630,6 +2631,14 @@ out: success = false; break; } + /* Avoid mixing lanes with defs in different basic-blocks. */ + if (!bb) + bb = gimple_bb (vect_orig_stmt (stmt_info)->stmt); + else if (gimple_bb (vect_orig_stmt (stmt_info)->stmt) != bb) + { + success = false; + break; + } bool exists; unsigned &stmt_idx @@ -7833,21 +7842,70 @@ vect_slp_analyze_node_operations_1 (vec_info *vinfo, slp_tree node, node, node_instance, cost_vec); } +static int +sort_ints (const void *a_, const void *b_) +{ + int a = *(const int *)a_; + int b = *(const int *)b_; + return a - b; +} + /* Verify if we can externalize a set of internal defs. */ static bool vect_slp_can_convert_to_external (const vec<stmt_vec_info> &stmts) { + /* Constant generation uses get_later_stmt which can only handle + defs from the same BB or a set of defs that can be ordered + with a dominance query. */ basic_block bb = NULL; + bool all_same = true; + auto_vec<int> bbs; + bbs.reserve_exact (stmts.length ()); for (stmt_vec_info stmt : stmts) - if (!stmt) - return false; - /* Constant generation uses get_later_stmt which can only handle - defs from the same BB. */ - else if (!bb) - bb = gimple_bb (stmt->stmt); - else if (gimple_bb (stmt->stmt) != bb) + { + if (!stmt) + return false; + else if (!bb) + bb = gimple_bb (stmt->stmt); + else if (gimple_bb (stmt->stmt) != bb) + all_same = false; + bbs.quick_push (gimple_bb (stmt->stmt)->index); + } + if (all_same) + return true; + + /* Produce a vector of unique BB indexes for the defs. */ + bbs.qsort (sort_ints); + unsigned i, j; + for (i = 1, j = 1; i < bbs.length (); ++i) + if (bbs[i] != bbs[j-1]) + bbs[j++] = bbs[i]; + gcc_assert (j >= 2); + bbs.truncate (j); + + if (bbs.length () == 2) + return (dominated_by_p (CDI_DOMINATORS, + BASIC_BLOCK_FOR_FN (cfun, bbs[0]), + BASIC_BLOCK_FOR_FN (cfun, bbs[1])) + || dominated_by_p (CDI_DOMINATORS, + BASIC_BLOCK_FOR_FN (cfun, bbs[1]), + BASIC_BLOCK_FOR_FN (cfun, bbs[0]))); + + /* ??? For more than two BBs we can sort the vector and verify the + result is a total order. But we can't use vec::qsort with a + compare function using a dominance query since there's no way to + signal failure and any fallback for an unordered pair would + fail qsort_chk later. + For now simply hope that ordering after BB index provides the + best candidate total order. If required we can implement our + own mergesort or export an entry without checking. */ + for (unsigned i = 1; i < bbs.length (); ++i) + if (!dominated_by_p (CDI_DOMINATORS, + BASIC_BLOCK_FOR_FN (cfun, bbs[i]), + BASIC_BLOCK_FOR_FN (cfun, bbs[i-1]))) return false; + return true; } @@ -11162,9 +11220,14 @@ vect_schedule_slp_node (vec_info *vinfo, == cycle_phi_info_type); gphi *phi = as_a <gphi *> (vect_find_last_scalar_stmt_in_slp (child)->stmt); - if (!last_stmt - || vect_stmt_dominates_stmt_p (last_stmt, phi)) + if (!last_stmt) last_stmt = phi; + else if (vect_stmt_dominates_stmt_p (last_stmt, phi)) + last_stmt = phi; + else if (vect_stmt_dominates_stmt_p (phi, last_stmt)) + ; + else + gcc_unreachable (); } /* We are emitting all vectorized stmts in the same place and the last one is the last. @@ -11175,9 +11238,14 @@ vect_schedule_slp_node (vec_info *vinfo, FOR_EACH_VEC_ELT (SLP_TREE_VEC_DEFS (child), j, vdef) { gimple *vstmt = SSA_NAME_DEF_STMT (vdef); - if (!last_stmt - || vect_stmt_dominates_stmt_p (last_stmt, vstmt)) + if (!last_stmt) + last_stmt = vstmt; + else if (vect_stmt_dominates_stmt_p (last_stmt, vstmt)) last_stmt = vstmt; + else if (vect_stmt_dominates_stmt_p (vstmt, last_stmt)) + ; + else + gcc_unreachable (); } } else if (!SLP_TREE_VECTYPE (child)) @@ -11190,9 +11258,14 @@ vect_schedule_slp_node (vec_info *vinfo, && !SSA_NAME_IS_DEFAULT_DEF (def)) { gimple *stmt = SSA_NAME_DEF_STMT (def); - if (!last_stmt - || vect_stmt_dominates_stmt_p (last_stmt, stmt)) + if (!last_stmt) + last_stmt = stmt; + else if (vect_stmt_dominates_stmt_p (last_stmt, stmt)) last_stmt = stmt; + else if (vect_stmt_dominates_stmt_p (stmt, last_stmt)) + ; + else + gcc_unreachable (); } } else @@ -11213,9 +11286,14 @@ vect_schedule_slp_node (vec_info *vinfo, && !SSA_NAME_IS_DEFAULT_DEF (vdef)) { gimple *vstmt = SSA_NAME_DEF_STMT (vdef); - if (!last_stmt - || vect_stmt_dominates_stmt_p (last_stmt, vstmt)) + if (!last_stmt) last_stmt = vstmt; + else if (vect_stmt_dominates_stmt_p (last_stmt, vstmt)) + last_stmt = vstmt; + else if (vect_stmt_dominates_stmt_p (vstmt, last_stmt)) + ; + else + gcc_unreachable (); } } } diff --git a/gcc/tree-vectorizer.h b/gcc/tree-vectorizer.h index 01d19c7..63991c3 100644 --- a/gcc/tree-vectorizer.h +++ b/gcc/tree-vectorizer.h @@ -30,6 +30,7 @@ typedef struct _slp_tree *slp_tree; #include "internal-fn.h" #include "tree-ssa-operands.h" #include "gimple-match.h" +#include "dominance.h" /* Used for naming of new temporaries. */ enum vect_var_kind { @@ -1870,11 +1871,25 @@ vect_orig_stmt (stmt_vec_info stmt_info) inline stmt_vec_info get_later_stmt (stmt_vec_info stmt1_info, stmt_vec_info stmt2_info) { - if (gimple_uid (vect_orig_stmt (stmt1_info)->stmt) - > gimple_uid (vect_orig_stmt (stmt2_info)->stmt)) + gimple *stmt1 = vect_orig_stmt (stmt1_info)->stmt; + gimple *stmt2 = vect_orig_stmt (stmt2_info)->stmt; + if (gimple_bb (stmt1) == gimple_bb (stmt2)) + { + if (gimple_uid (stmt1) > gimple_uid (stmt2)) + return stmt1_info; + else + return stmt2_info; + } + /* ??? We should be really calling this function only with stmts + in the same BB but we can recover if there's a domination + relationship between them. */ + else if (dominated_by_p (CDI_DOMINATORS, + gimple_bb (stmt1), gimple_bb (stmt2))) return stmt1_info; - else + else if (dominated_by_p (CDI_DOMINATORS, + gimple_bb (stmt2), gimple_bb (stmt1))) return stmt2_info; + gcc_unreachable (); } /* If STMT_INFO has been replaced by a pattern statement, return the |