diff options
| author | Martin Liska <mliska@suse.cz> | 2022-11-07 09:55:28 +0100 |
|---|---|---|
| committer | Martin Liska <mliska@suse.cz> | 2022-11-07 09:55:28 +0100 |
| commit | 33f5dde0cd15df9cf89b29280d4ff5fcf7b30e66 (patch) | |
| tree | d7311de992568a7d952a4e9af8891041d34394c4 | |
| parent | 1b09b78ee61bd921ae78ebd0f7905b95b9e1c903 (diff) | |
| parent | a8fb90eb3949bfb101bd6f50f24a029e10119591 (diff) | |
| download | gcc-33f5dde0cd15df9cf89b29280d4ff5fcf7b30e66.zip gcc-33f5dde0cd15df9cf89b29280d4ff5fcf7b30e66.tar.gz gcc-33f5dde0cd15df9cf89b29280d4ff5fcf7b30e66.tar.bz2 | |
Merge branch 'master' into devel/sphinx
40 files changed, 655 insertions, 621 deletions
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 4e89918..e72cdf8 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -114,27 +114,23 @@ package body Bindgen is -- For CodePeer, introduce a wrapper subprogram which calls the -- user-defined main subprogram. - -- Names for local C-String variables + -- Name for local C-String variable Adainit_String_Obj_Name : constant String := "Adainit_Name_C_String"; - Adafinal_String_Obj_Name : constant String := "Adafinal_Name_C_String"; - -- Names and link_names for CUDA device adainit/adafinal procs. + -- Name and link_name for CUDA device initialization procedure - Device_Subp_Name_Prefix : constant String := "imported_device_"; + Device_Ada_Init_Subp_Name : constant String := "Device_Initialization"; Device_Link_Name_Prefix : constant String := "__device_"; - function Device_Ada_Final_Link_Name return String is - (Device_Link_Name_Prefix & Ada_Final_Name.all); + function Device_Link_Name (Suffix : String) return String is + (Device_Link_Name_Prefix & + (if CUDA_Device_Library_Name = null + then "ada" -- is this an error path? + else CUDA_Device_Library_Name.all) & Suffix); - function Device_Ada_Final_Subp_Name return String is - (Device_Subp_Name_Prefix & Ada_Final_Name.all); - - function Device_Ada_Init_Link_Name return String is - (Device_Link_Name_Prefix & Ada_Init_Name.all); - - function Device_Ada_Init_Subp_Name return String is - (Device_Subp_Name_Prefix & Ada_Init_Name.all); + function Device_Ada_Init_Link_Name return String + is (Device_Link_Name (Suffix => "init")); ---------------------------------- -- Interface_State Pragma Table -- @@ -523,12 +519,6 @@ package body Bindgen is WBI (" System.Standard_Library.Adafinal;"); end if; - -- perform device (as opposed to host) finalization - if Enable_CUDA_Expansion then - WBI (" pragma CUDA_Execute (" & - Device_Ada_Final_Subp_Name & ", 1, 1);"); - end if; - WBI (" end " & Ada_Final_Name.all & ";"); WBI (""); end Gen_Adafinal; @@ -1362,17 +1352,12 @@ package body Bindgen is end loop; WBI (" procedure " & Device_Ada_Init_Subp_Name & ";"); - WBI (" pragma Import (C, " & Device_Ada_Init_Subp_Name & + WBI (" pragma Export (C, " & Device_Ada_Init_Subp_Name & ", Link_Name => """ & Device_Ada_Init_Link_Name & """);"); - WBI (" procedure " & Device_Ada_Final_Subp_Name & ";"); - WBI (" pragma Import (C, " & Device_Ada_Final_Subp_Name & - ", Link_Name => """ & Device_Ada_Final_Link_Name & """);"); - -- C-string declarations for adainit and adafinal + -- C-string declaration for adainit WBI (" " & Adainit_String_Obj_Name & " : Interfaces.C.Strings.Chars_Ptr;"); - WBI (" " & Adafinal_String_Obj_Name - & " : Interfaces.C.Strings.Chars_Ptr;"); WBI (""); WBI (""); @@ -1455,15 +1440,11 @@ package body Bindgen is end; end loop; - -- Register device-side Adainit and Adafinal + -- Register device-side Adainit Gen_CUDA_Register_Function_Call (Kernel_Name => Device_Ada_Init_Link_Name, Kernel_String => Adainit_String_Obj_Name, Kernel_Proc => Device_Ada_Init_Subp_Name); - Gen_CUDA_Register_Function_Call - (Kernel_Name => Device_Ada_Final_Link_Name, - Kernel_String => Adafinal_String_Obj_Name, - Kernel_Proc => Device_Ada_Final_Subp_Name); WBI (" CUDA_Register_Fat_Binary_End (Fat_Binary_Handle);"); @@ -2685,7 +2666,8 @@ package body Bindgen is WBI (" procedure " & Ada_Init_Name.all & ";"); if Enable_CUDA_Device_Expansion then WBI (" pragma Export (C, " & Ada_Init_Name.all & - ", Link_Name => """ & Device_Ada_Init_Link_Name & """);"); + ", Link_Name => """ & Device_Link_Name_Prefix + & Ada_Init_Name.all & """);"); WBI (" pragma CUDA_Global (" & Ada_Init_Name.all & ");"); else WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ & @@ -2702,10 +2684,10 @@ package body Bindgen is if not Cumulative_Restrictions.Set (No_Finalization) then WBI (""); WBI (" procedure " & Ada_Final_Name.all & ";"); - if Enable_CUDA_Device_Expansion then WBI (" pragma Export (C, " & Ada_Final_Name.all & - ", Link_Name => """ & Device_Ada_Final_Link_Name & """);"); + ", Link_Name => """ & Device_Link_Name_Prefix & + Ada_Final_Name.all & """);"); WBI (" pragma CUDA_Global (" & Ada_Final_Name.all & ");"); else WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ & @@ -2935,6 +2917,13 @@ package body Bindgen is Gen_Adainit (Elab_Order); + if Enable_CUDA_Expansion then + WBI (" procedure " & Device_Ada_Init_Subp_Name & " is"); + WBI (" begin"); + WBI (" raise Program_Error;"); + WBI (" end " & Device_Ada_Init_Subp_Name & ";"); + end if; + if Bind_Main_Program then Gen_Main; end if; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 4741294..9687667 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -999,21 +999,26 @@ package body Checks is Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True); if VOK and then Tlo <= Vlo and then Vhi <= Thi then - Rewrite (Left_Opnd (N), - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), - Expression => Relocate_Node (Left_Opnd (N)))); - - Rewrite (Right_Opnd (N), - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), - Expression => Relocate_Node (Right_Opnd (N)))); - -- Rewrite the conversion operand so that the original -- node is retained, in order to avoid the warning for -- redundant conversions in Resolve_Type_Conversion. - Rewrite (N, Relocate_Node (N)); + declare + Op : constant Node_Id := New_Op_Node (Nkind (N), Loc); + begin + Set_Left_Opnd (Op, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Left_Opnd (N)))); + Set_Right_Opnd (Op, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Target_Type, Loc), + Expression => Relocate_Node (Right_Opnd (N)))); + + Rewrite (N, Op); + end; Set_Etype (N, Target_Type); @@ -8403,115 +8408,10 @@ package body Checks is Loc : constant Source_Ptr := Sloc (Parent (N)); Typ : constant Entity_Id := Etype (N); - function Safe_To_Capture_In_Parameter_Value return Boolean; - -- Determines if it is safe to capture Known_Non_Null status for an - -- the entity referenced by node N. The caller ensures that N is indeed - -- an entity name. It is safe to capture the non-null status for an IN - -- parameter when the reference occurs within a declaration that is sure - -- to be executed as part of the declarative region. - procedure Mark_Non_Null; -- After installation of check, if the node in question is an entity -- name, then mark this entity as non-null if possible. - function Safe_To_Capture_In_Parameter_Value return Boolean is - E : constant Entity_Id := Entity (N); - S : constant Entity_Id := Current_Scope; - S_Par : Node_Id; - - begin - if Ekind (E) /= E_In_Parameter then - return False; - end if; - - -- Two initial context checks. We must be inside a subprogram body - -- with declarations and reference must not appear in nested scopes. - - if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure) - or else Scope (E) /= S - then - return False; - end if; - - S_Par := Parent (Parent (S)); - - if Nkind (S_Par) /= N_Subprogram_Body - or else No (Declarations (S_Par)) - then - return False; - end if; - - declare - N_Decl : Node_Id; - P : Node_Id; - - begin - -- Retrieve the declaration node of N (if any). Note that N - -- may be a part of a complex initialization expression. - - P := Parent (N); - N_Decl := Empty; - while Present (P) loop - - -- If we have a short circuit form, and we are within the right - -- hand expression, we return false, since the right hand side - -- is not guaranteed to be elaborated. - - if Nkind (P) in N_Short_Circuit - and then N = Right_Opnd (P) - then - return False; - end if; - - -- Similarly, if we are in an if expression and not part of the - -- condition, then we return False, since neither the THEN or - -- ELSE dependent expressions will always be elaborated. - - if Nkind (P) = N_If_Expression - and then N /= First (Expressions (P)) - then - return False; - end if; - - -- If within a case expression, and not part of the expression, - -- then return False, since a particular dependent expression - -- may not always be elaborated - - if Nkind (P) = N_Case_Expression - and then N /= Expression (P) - then - return False; - end if; - - -- While traversing the parent chain, if node N belongs to a - -- statement, then it may never appear in a declarative region. - - if Nkind (P) in N_Statement_Other_Than_Procedure_Call - or else Nkind (P) = N_Procedure_Call_Statement - then - return False; - end if; - - -- If we are at a declaration, record it and exit - - if Nkind (P) in N_Declaration - and then Nkind (P) not in N_Subprogram_Specification - then - N_Decl := P; - exit; - end if; - - P := Parent (P); - end loop; - - if No (N_Decl) then - return False; - end if; - - return List_Containing (N_Decl) = Declarations (S_Par); - end; - end Safe_To_Capture_In_Parameter_Value; - ------------------- -- Mark_Non_Null -- ------------------- @@ -8527,19 +8427,10 @@ package body Checks is Set_Is_Known_Null (Entity (N), False); - -- We can mark the entity as known to be non-null if either it is - -- safe to capture the value, or in the case of an IN parameter, - -- which is a constant, if the check we just installed is in the - -- declarative region of the subprogram body. In this latter case, - -- a check is decisive for the rest of the body if the expression - -- is sure to be elaborated, since we know we have to elaborate - -- all declarations before executing the body. - - -- Couldn't this always be part of Safe_To_Capture_Value ??? + -- We can mark the entity as known to be non-null if it is safe to + -- capture the value. - if Safe_To_Capture_Value (N, Entity (N)) - or else Safe_To_Capture_In_Parameter_Value - then + if Safe_To_Capture_Value (N, Entity (N)) then Set_Is_Known_Non_Null (Entity (N)); end if; end if; diff --git a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst index 83bc50f..31e2e31 100644 --- a/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst +++ b/gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst @@ -2795,6 +2795,8 @@ of the pragma in the :title:`GNAT_Reference_manual`). * :switch:`-gnatw.q` (questionable layout of record types) + * :switch:`-gnatw_q` (ignored equality) + * :switch:`-gnatw_r` (out-of-order record representation clauses) * :switch:`-gnatw.s` (overridden size clause) @@ -3687,6 +3689,25 @@ of the pragma in the :title:`GNAT_Reference_manual`). a record type would very likely cause inefficiencies. +.. index:: -gnatw_q (gcc) + +:switch:`-gnatw_q` + *Activate warnings for ignored equality operators.* + + This switch activates warnings for a user-defined "=" function that does + not compose (i.e. is ignored for a predefined "=" for a composite type + containing a component whose type has the user-defined "=" as + primitive). Note that the user-defined "=" must be a primitive operator + in order to trigger the warning. + + The default is that these warnings are not given. + +.. index:: -gnatw_Q (gcc) + +:switch:`-gnatw_Q` + *Suppress warnings for ignored equality operators.* + + .. index:: -gnatwr (gcc) :switch:`-gnatwr` diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index e827d1f..c239c36 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -1252,8 +1252,8 @@ most often, and are therefore the most time-consuming. better handle Ada programs and multitasking. It is currently supported on the following platforms -* linux x86/x86_64 -* windows x86 +* Linux x86/x86_64 +* Windows x86/x86_64 (without PIE support) In order to profile a program using ``gprof``, several steps are needed: @@ -1291,6 +1291,10 @@ Note that only the objects that were compiled with the ``-pg`` switch will be profiled; if you need to profile your whole project, use the ``-f`` gnatmake switch to force full recompilation. +Note that on Windows, gprof does not support PIE. The ``-no-pie`` switch +should be added to the linker flags to disable this feature. + + .. _Program_execution: diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 78fe514..846a4a6 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -64,7 +64,7 @@ package Errout is -- sequences in error messages generate appropriate tags for the output -- error messages. If this switch is False, then these sequences are still -- recognized (for the purposes of implementing the pattern matching in - -- pragmas Warnings (Off,..) and Warning_As_Pragma(...) but do not result + -- pragmas Warnings (Off,..) and Warning_As_Error(...) but do not result -- in adding the error message tag. The -gnatw.d switch sets this flag -- True, -gnatw.D sets this flag False. @@ -314,10 +314,11 @@ package Errout is -- continuations, use this in each continuation message. -- Insertion character ?x? ?.x? ?_x? (warning with switch) - -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string + -- "x" is a (lower-case) warning switch character. + -- Like ??, but if the flag Warn_Doc_Switch is True, adds the string -- "[-gnatwx]", "[-gnatw.x]", or "[-gnatw_x]", at the end of the - -- warning message. x must be lower case. For continuations, use this - -- on each continuation message. + -- warning message. For continuations, use this on each continuation + -- message. -- Insertion character ?*? (restriction warning) -- Like ?, but if the flag Warn_Doc_Switch is True, adds the string diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 1ef3065..25f1627 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2002,8 +2002,8 @@ package body Exp_Attr is -- -- Skip check for output parameters of an Asm instruction (since their -- valuesare not set till after the attribute has been elaborated), - -- for the arguments of a 'Read or 'Input attribute reference (since - -- the scalar argument is an OUT scalar) and for the arguments of a + -- for the arguments of a 'Read attribute reference (since the + -- scalar argument is an OUT scalar) and for the arguments of a -- 'Has_Same_Storage or 'Overlaps_Storage attribute reference (which not -- considered to be reads of their prefixes and expressions, see Ada RM -- 13.3(73.10/3)). @@ -2011,7 +2011,6 @@ package body Exp_Attr is if Validity_Checks_On and then Validity_Check_Operands and then Id /= Attribute_Asm_Output and then Id /= Attribute_Read - and then Id /= Attribute_Input and then Id /= Attribute_Has_Same_Storage and then Id /= Attribute_Overlaps_Storage then diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0d82691..1e70b58 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4599,7 +4599,8 @@ package body Exp_Ch3 is end if; -- If not inherited and not user-defined, build body as for a type with - -- tagged components. + -- components of record type (i.e. a type for which "=" composes when + -- used as a component in an outer composite type). if Build_Eq then Decl := diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7a3a414..0a104cd 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -151,14 +151,17 @@ package body Exp_Ch4 is -- where we allow comparison of "out of range" values. function Expand_Composite_Equality - (Nod : Node_Id; - Typ : Entity_Id; - Lhs : Node_Id; - Rhs : Node_Id) return Node_Id; + (Outer_Type : Entity_Id; + Nod : Node_Id; + Comp_Type : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id) return Node_Id; -- Local recursive function used to expand equality for nested composite -- types. Used by Expand_Record/Array_Equality. Nod provides the Sloc value -- for generated code. Lhs and Rhs are the left and right sides for the - -- comparison, and Typ is the type of the objects to compare. + -- comparison, and Comp_Typ is the type of the objects to compare. + -- Outer_Type is the composite type containing a component of type + -- Comp_Type -- used for printing messages. procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); -- Routine to expand concatenation of a sequence of two or more operands @@ -1424,33 +1427,52 @@ package body Exp_Ch4 is Remove_Side_Effects (Op1, Name_Req => True); Remove_Side_Effects (Op2, Name_Req => True); - Rewrite (Op1, - Make_Function_Call (Sloc (Op1), - Name => New_Occurrence_Of (RTE (Comp), Loc), + declare + Comp_Call : constant Node_Id := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Comp), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op1), - Attribute_Name => Name_Address), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op1), + Attribute_Name => Name_Address), - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op2), - Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op2), + Attribute_Name => Name_Address), - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op1), - Attribute_Name => Name_Length), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op1), + Attribute_Name => Name_Length), - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Op2), - Attribute_Name => Name_Length)))); + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Op2), + Attribute_Name => Name_Length))); + + Zero : constant Node_Id := + Make_Integer_Literal (Loc, + Intval => Uint_0); - Rewrite (Op2, - Make_Integer_Literal (Sloc (Op2), - Intval => Uint_0)); + Comp_Op : Node_Id; + + begin + case Nkind (N) is + when N_Op_Lt => + Comp_Op := Make_Op_Lt (Loc, Comp_Call, Zero); + when N_Op_Le => + Comp_Op := Make_Op_Le (Loc, Comp_Call, Zero); + when N_Op_Gt => + Comp_Op := Make_Op_Gt (Loc, Comp_Call, Zero); + when N_Op_Ge => + Comp_Op := Make_Op_Ge (Loc, Comp_Call, Zero); + when others => + raise Program_Error; + end case; + + Rewrite (N, Comp_Op); + end; - Analyze_And_Resolve (Op1, Standard_Integer); - Analyze_And_Resolve (Op2, Standard_Integer); + Analyze_And_Resolve (N, Standard_Boolean); return; end if; end if; @@ -1702,7 +1724,9 @@ package body Exp_Ch4 is Prefix => Make_Identifier (Loc, Chars (B)), Expressions => Index_List2); - Test := Expand_Composite_Equality (Nod, Component_Type (Typ), L, R); + Test := Expand_Composite_Equality + (Outer_Type => Typ, Nod => Nod, Comp_Type => Component_Type (Typ), + Lhs => L, Rhs => R); -- If some (sub)component is an unchecked_union, the whole operation -- will raise program error. @@ -1934,7 +1958,6 @@ package body Exp_Ch4 is if Ltyp /= Rtyp then Ltyp := Base_Type (Ltyp); Rtyp := Base_Type (Rtyp); - pragma Assert (Ltyp = Rtyp); end if; -- If the array type is distinct from the type of the arguments, it @@ -1957,6 +1980,7 @@ package body Exp_Ch4 is New_Rhs := Rhs; end if; + pragma Assert (Ltyp = Rtyp); First_Idx := First_Index (Ltyp); -- If optimization is enabled and the array boils down to a couple of @@ -1964,7 +1988,6 @@ package body Exp_Ch4 is -- which should be easier to optimize by the code generator. if Optimization_Level > 0 - and then Ltyp = Rtyp and then Is_Constrained (Ltyp) and then Number_Dimensions (Ltyp) = 1 and then Compile_Time_Known_Bounds (Ltyp) @@ -1991,7 +2014,9 @@ package body Exp_Ch4 is Prefix => New_Copy_Tree (New_Rhs), Expressions => New_List (New_Copy_Tree (Low_B))); - TestL := Expand_Composite_Equality (Nod, Ctyp, L, R); + TestL := Expand_Composite_Equality + (Outer_Type => Ltyp, Nod => Nod, Comp_Type => Ctyp, + Lhs => L, Rhs => R); L := Make_Indexed_Component (Loc, @@ -2003,7 +2028,9 @@ package body Exp_Ch4 is Prefix => New_Rhs, Expressions => New_List (New_Copy_Tree (High_B))); - TestH := Expand_Composite_Equality (Nod, Ctyp, L, R); + TestH := Expand_Composite_Equality + (Outer_Type => Ltyp, Nod => Nod, Comp_Type => Ctyp, + Lhs => L, Rhs => R); return Make_And_Then (Loc, Left_Opnd => TestL, Right_Opnd => TestH); @@ -2416,20 +2443,21 @@ package body Exp_Ch4 is -- case because it is not possible to respect normal Ada visibility rules. function Expand_Composite_Equality - (Nod : Node_Id; - Typ : Entity_Id; - Lhs : Node_Id; - Rhs : Node_Id) return Node_Id + (Outer_Type : Entity_Id; + Nod : Node_Id; + Comp_Type : Entity_Id; + Lhs : Node_Id; + Rhs : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Nod); Full_Type : Entity_Id; Eq_Op : Entity_Id; begin - if Is_Private_Type (Typ) then - Full_Type := Underlying_Type (Typ); + if Is_Private_Type (Comp_Type) then + Full_Type := Underlying_Type (Comp_Type); else - Full_Type := Typ; + Full_Type := Comp_Type; end if; -- If the private type has no completion the context may be the @@ -2454,7 +2482,7 @@ package body Exp_Ch4 is -- Case of tagged record types if Is_Tagged_Type (Full_Type) then - Eq_Op := Find_Primitive_Eq (Typ); + Eq_Op := Find_Primitive_Eq (Comp_Type); pragma Assert (Present (Eq_Op)); return @@ -2616,18 +2644,20 @@ package body Exp_Ch4 is -- Equality composes in Ada 2012 for untagged record types. It also -- composes for bounded strings, because they are part of the - -- predefined environment. We could make it compose for bounded - -- strings by making them tagged, or by making sure all subcomponents - -- are set to the same value, even when not used. Instead, we have - -- this special case in the compiler, because it's more efficient. - - elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then + -- predefined environment (see 4.5.2(32.1/1)). We could make it + -- compose for bounded strings by making them tagged, or by making + -- sure all subcomponents are set to the same value, even when not + -- used. Instead, we have this special case in the compiler, because + -- it's more efficient. + elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Comp_Type) + then -- If no TSS has been created for the type, check whether there is -- a primitive equality declared for it. declare - Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs); + Op : constant Node_Id := + Build_Eq_Call (Comp_Type, Loc, Lhs, Rhs); begin -- Use user-defined primitive if it exists, otherwise use @@ -2647,6 +2677,33 @@ package body Exp_Ch4 is -- Case of non-record types (always use predefined equality) else + -- Print a warning if there is a user-defined "=", because it can be + -- surprising that the predefined "=" takes precedence over it. + + -- Suppress the warning if the "user-defined" one is in the + -- predefined library, because those are defined to compose + -- properly by RM-4.5.2(32.1/1). Intrinsics also compose. + + declare + Op : constant Entity_Id := Find_Primitive_Eq (Comp_Type); + begin + if Warn_On_Ignored_Equality + and then Present (Op) + and then not In_Predefined_Unit (Base_Type (Comp_Type)) + and then not Is_Intrinsic_Subprogram (Op) + then + pragma Assert + (Is_First_Subtype (Outer_Type) + or else Is_Generic_Actual_Type (Outer_Type)); + Error_Msg_Node_1 := Outer_Type; + Error_Msg_Node_2 := Comp_Type; + Error_Msg + ("?_q?""="" for type & uses predefined ""="" for }", Loc); + Error_Msg_Sloc := Sloc (Op); + Error_Msg ("\?_q?""="" # is ignored here", Loc); + end if; + end; + return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); end if; end Expand_Composite_Equality; @@ -4135,39 +4192,42 @@ package body Exp_Ch4 is Mod_Minus_Right : constant Uint := Modulus (Typ) - Intval (Right_Opnd (N)); - Exprs : constant List_Id := New_List; - Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); - Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); - Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, - Loc); + Cond_Expr : Node_Id; + Then_Expr : Node_Id; + Else_Expr : Node_Id; begin -- To prevent spurious visibility issues, convert all -- operands to Standard.Unsigned. - Set_Left_Opnd (Cond_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Cond_Expr, - Make_Integer_Literal (Loc, Mod_Minus_Right)); - Append_To (Exprs, Cond_Expr); - - Set_Left_Opnd (Then_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Then_Expr, - Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); - Append_To (Exprs, Then_Expr); - - Set_Left_Opnd (Else_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Else_Expr, - Make_Integer_Literal (Loc, Mod_Minus_Right)); - Append_To (Exprs, Else_Expr); + Cond_Expr := + Make_Op_Lt (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N))), + Right_Opnd => + Make_Integer_Literal (Loc, Mod_Minus_Right)); + + Then_Expr := + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N))), + Right_Opnd => + Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); + + Else_Expr := + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N))), + Right_Opnd => + Make_Integer_Literal (Loc, Mod_Minus_Right)); Rewrite (N, Unchecked_Convert_To (Typ, - Make_If_Expression (Loc, Expressions => Exprs))); + Make_If_Expression (Loc, + Expressions => + New_List (Cond_Expr, Then_Expr, Else_Expr)))); end; end if; end Expand_Modular_Addition; @@ -4183,7 +4243,7 @@ package body Exp_Ch4 is -- backend does not have to deal with nonbinary-modulus ops. Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc); - Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc); + Mod_Expr : Node_Id; Target_Type : Entity_Id; begin @@ -4278,10 +4338,10 @@ package body Exp_Ch4 is Force_Evaluation (Op_Expr, Mode => Strict); end if; - Set_Left_Opnd (Mod_Expr, Op_Expr); - - Set_Right_Opnd (Mod_Expr, - Make_Integer_Literal (Loc, Modulus (Typ))); + Mod_Expr := + Make_Op_Mod (Loc, + Left_Opnd => Op_Expr, + Right_Opnd => Make_Integer_Literal (Loc, Modulus (Typ))); Rewrite (N, Unchecked_Convert_To (Typ, Mod_Expr)); @@ -4312,37 +4372,40 @@ package body Exp_Ch4 is Mod_Minus_Right : constant Uint := Modulus (Typ) - Intval (Right_Opnd (N)); - Exprs : constant List_Id := New_List; - Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); - Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); - Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, - Loc); + Cond_Expr : Node_Id; + Then_Expr : Node_Id; + Else_Expr : Node_Id; begin - Set_Left_Opnd (Cond_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Cond_Expr, - Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); - Append_To (Exprs, Cond_Expr); - - Set_Left_Opnd (Then_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Then_Expr, - Make_Integer_Literal (Loc, Mod_Minus_Right)); - Append_To (Exprs, Then_Expr); - - Set_Left_Opnd (Else_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Left_Opnd (N)))); - Set_Right_Opnd (Else_Expr, - Unchecked_Convert_To (Standard_Unsigned, - New_Copy_Tree (Right_Opnd (N)))); - Append_To (Exprs, Else_Expr); + Cond_Expr := + Make_Op_Lt (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N))), + Right_Opnd => + Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); + + Then_Expr := + Make_Op_Add (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N))), + Right_Opnd => + Make_Integer_Literal (Loc, Mod_Minus_Right)); + + Else_Expr := + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N))), + Right_Opnd => + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Right_Opnd (N)))); Rewrite (N, Unchecked_Convert_To (Typ, - Make_If_Expression (Loc, Expressions => Exprs))); + Make_If_Expression (Loc, + Expressions => + New_List (Cond_Expr, Then_Expr, Else_Expr)))); end; end if; end Expand_Modular_Subtraction; @@ -9819,7 +9882,7 @@ package body Exp_Ch4 is -- avoids anomalies when the replacement is done in an instance and -- is epsilon more efficient. - Set_Entity (N, Standard_Entity (S_Op_Rem)); + pragma Assert (Entity (N) = Standard_Op_Rem); Set_Etype (N, Typ); Set_Do_Division_Check (N, DDC); Expand_N_Op_Rem (N); @@ -13322,15 +13385,16 @@ package body Exp_Ch4 is end if; Check := - Expand_Composite_Equality (Nod, Etype (C), - Lhs => - Make_Selected_Component (Loc, - Prefix => New_Lhs, - Selector_Name => New_Occurrence_Of (C, Loc)), - Rhs => - Make_Selected_Component (Loc, - Prefix => New_Rhs, - Selector_Name => New_Occurrence_Of (C, Loc))); + Expand_Composite_Equality + (Outer_Type => Typ, Nod => Nod, Comp_Type => Etype (C), + Lhs => + Make_Selected_Component (Loc, + Prefix => New_Lhs, + Selector_Name => New_Occurrence_Of (C, Loc)), + Rhs => + Make_Selected_Component (Loc, + Prefix => New_Rhs, + Selector_Name => New_Occurrence_Of (C, Loc))); -- If some (sub)component is an unchecked_union, the whole -- operation will raise program error. diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index eb9b506..7efd105 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -97,7 +97,7 @@ package Exp_Ch4 is -- individually to yield the required Boolean result. Loc is the -- location for the generated nodes. Typ is the type of the record, and -- Lhs, Rhs are the record expressions to be compared, these - -- expressions need not to be analyzed but have to be side-effect free. + -- expressions need not be analyzed but have to be side-effect free. -- Nod provides the Sloc value for generated code. procedure Expand_Set_Membership (N : Node_Id); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index cf64e82..0fa9768 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1806,7 +1806,7 @@ package body Exp_Ch6 is Expr := New_Occurrence_Of (Temp, Loc); end if; - Rewrite (Actual, New_Occurrence_Of (Temp, Loc)); + Rewrite (Actual, New_Occurrence_Of (Temp, Sloc (Actual))); Analyze (Actual); -- If the actual is a conversion of a packed reference, it may @@ -6240,7 +6240,7 @@ package body Exp_Ch6 is -- The object may be a component of some other data structure, in which -- case this must be handled as an inter-object call. - if not In_Open_Scopes (Scop) + if not Scope_Within_Or_Same (Inner => Current_Scope, Outer => Scop) or else Is_Entry_Wrapper (Current_Scope) or else not Is_Entity_Name (Name (N)) then diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 51f1195..f2043f5 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -938,12 +938,12 @@ package body Exp_Imgv is -- P3 : constant Natural := call_put_enumN (P1 + 1); declare - Add_Node : constant Node_Id := New_Op_Node (N_Op_Add, Loc); + Add_Node : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (P1_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_1)); begin - Set_Left_Opnd (Add_Node, New_Occurrence_Of (P1_Id, Loc)); - Set_Right_Opnd (Add_Node, Make_Integer_Literal (Loc, 1)); - Append_To (Ins_List, Make_Object_Declaration (Loc, Defining_Identifier => P3_Id, @@ -963,12 +963,12 @@ package body Exp_Imgv is -- P4 : String renames call_put_enumS (P2 .. P3 - 1); declare - Sub_Node : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc); + Sub_Node : constant Node_Id := + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (P3_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_1)); begin - Set_Left_Opnd (Sub_Node, New_Occurrence_Of (P3_Id, Loc)); - Set_Right_Opnd (Sub_Node, Make_Integer_Literal (Loc, 1)); - Append_To (Ins_List, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => P4_Id, @@ -988,12 +988,12 @@ package body Exp_Imgv is -- subtype S1 is String (1 .. P3 - P2); declare - HB : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc); + HB : constant Node_Id := + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (P3_Id, Loc), + Right_Opnd => New_Occurrence_Of (P2_Id, Loc)); begin - Set_Left_Opnd (HB, New_Occurrence_Of (P3_Id, Loc)); - Set_Right_Opnd (HB, New_Occurrence_Of (P2_Id, Loc)); - Append_To (Ins_List, Make_Subtype_Declaration (Loc, Defining_Identifier => S1_Id, diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb index 50e0569..c489ad4 100644 --- a/gcc/ada/exp_put_image.adb +++ b/gcc/ada/exp_put_image.adb @@ -1039,13 +1039,13 @@ package body Exp_Put_Image is end if; -- In Ada 2022, T'Image calls T'Put_Image if there is an explicit - -- aspect_specification for Put_Image, or if U_Type'Image is illegal - -- in pre-2022 versions of Ada. + -- (or inherited) aspect_specification for Put_Image, or if + -- U_Type'Image is illegal in pre-2022 versions of Ada. declare U_Type : constant Entity_Id := Underlying_Type (Entity (Prefix (N))); begin - if Present (TSS (U_Type, TSS_Put_Image)) then + if Present (Find_Aspect (U_Type, Aspect_Put_Image)) then return True; end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 888e2ec..1fdc9d0 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1718,11 +1718,16 @@ package body Freeze is end; end if; - New_Prag := New_Copy_Tree (A_Post); - Rewrite - (Expression (First (Pragma_Argument_Associations (New_Prag))), - Class_Post); - Append (New_Prag, Decls); + -- A_Post can be null here if the postcondition was inlined in the + -- called subprogram. + + if Present (A_Post) then + New_Prag := New_Copy_Tree (A_Post); + Rewrite + (Expression (First (Pragma_Argument_Associations (New_Prag))), + Class_Post); + Append (New_Prag, Decls); + end if; end if; end Build_Inherited_Condition_Pragmas; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 0f23d5b..385f1d3 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -10733,6 +10733,9 @@ switch are: @code{-gnatw.q} (questionable layout of record types) @item +@code{-gnatw_q} (ignored equality) + +@item @code{-gnatw_r} (out-of-order record representation clauses) @item @@ -11948,6 +11951,34 @@ This switch suppresses warnings for cases where the default layout of a record type would very likely cause inefficiencies. @end table +@geindex -gnatw_q (gcc) + + +@table @asis + +@item @code{-gnatw_q} + +`Activate warnings for ignored equality operators.' + +This switch activates warnings for a user-defined “=” function that does +not compose (i.e. is ignored for a predefined “=” for a composite type +containing a component whose type has the user-defined “=” as +primitive). Note that the user-defined “=” must be a primitive operator +in order to trigger the warning. + +The default is that these warnings are not given. +@end table + +@geindex -gnatw_Q (gcc) + + +@table @asis + +@item @code{-gnatw_Q} + +`Suppress warnings for ignored equality operators.' +@end table + @geindex -gnatwr (gcc) @@ -19521,10 +19552,10 @@ It is currently supported on the following platforms @itemize * @item -linux x86/x86_64 +Linux x86/x86_64 @item -windows x86 +Windows x86/x86_64 (without PIE support) @end itemize In order to profile a program using @code{gprof}, several steps are needed: @@ -19583,6 +19614,9 @@ Note that only the objects that were compiled with the @code{-pg} switch will be profiled; if you need to profile your whole project, use the @code{-f} gnatmake switch to force full recompilation. +Note that on Windows, gprof does not support PIE. The @code{-no-pie} switch +should be added to the linker flags to disable this feature. + @node Program execution,Running gprof,Compilation for profiling,Profiling an Ada Program with gprof @anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{175}@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{176} @subsubsection Program execution diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index e3f35da..a1ead98 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -3013,14 +3013,10 @@ package body Inline is Temp_Typ := Etype (A); end if; - -- If the actual is a simple name or a literal, no need to - -- create a temporary, object can be used directly. - - -- If the actual is a literal and the formal has its address taken, - -- we cannot pass the literal itself as an argument, so its value - -- must be captured in a temporary. Skip this optimization in - -- GNATprove mode, to make sure any check on a type conversion - -- will be issued. + -- If the actual is a simple name or a literal, no need to create a + -- temporary, object can be used directly. Skip this optimization in + -- GNATprove mode, to make sure any check on a type conversion will + -- be issued. if (Is_Entity_Name (A) and then @@ -3039,6 +3035,10 @@ package body Inline is and then Formal_Is_Used_Once (F) and then not GNATprove_Mode) + -- If the actual is a literal and the formal has its address taken, + -- we cannot pass the literal itself as an argument, so its value + -- must be captured in a temporary. + or else (Nkind (A) in N_Real_Literal | N_Integer_Literal | N_Character_Literal diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 043444c..5a1538e 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1271,10 +1271,10 @@ package body Lib.Xref is XE : Xref_Entry renames Xrefs.Table (F); type M is mod 2**32; - H : constant M := M (XE.Key.Ent) + 2 ** 7 * M (abs XE.Key.Loc); + H : constant M := 3 * M (XE.Key.Ent) + 5 * M (abs XE.Key.Loc); -- It would be more natural to write: -- - -- H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc); + -- H : constant M := 3 * M'Mod (XE.Key.Ent) + 5 * M'Mod (XE.Key.Loc); -- -- But we can't use M'Mod, because it prevents bootstrapping with older -- compilers. Loc can be negative, so we do "abs" before converting. diff --git a/gcc/ada/libgnarl/s-interr.adb b/gcc/ada/libgnarl/s-interr.adb index a3d28d6..2fbb140 100644 --- a/gcc/ada/libgnarl/s-interr.adb +++ b/gcc/ada/libgnarl/s-interr.adb @@ -54,27 +54,22 @@ with Ada.Exceptions; with Ada.Task_Identification; +with Ada.Unchecked_Conversion; -with System.Task_Primitives; with System.Interrupt_Management; - with System.Interrupt_Management.Operations; -pragma Elaborate_All (System.Interrupt_Management.Operations); - with System.IO; - +with System.Parameters; +with System.Task_Primitives; with System.Task_Primitives.Operations; with System.Task_Primitives.Interrupt_Operations; with System.Storage_Elements; +with System.Tasking.Initialization; with System.Tasking.Utilities; - with System.Tasking.Rendezvous; -pragma Elaborate_All (System.Tasking.Rendezvous); -with System.Tasking.Initialization; -with System.Parameters; - -with Ada.Unchecked_Conversion; +pragma Elaborate_All (System.Interrupt_Management.Operations); +pragma Elaborate_All (System.Tasking.Rendezvous); package body System.Interrupts is @@ -114,8 +109,8 @@ package body System.Interrupts is Static : Boolean); entry Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); + (Interrupt : Interrupt_ID; + Static : Boolean); entry Bind_Interrupt_To_Entry (T : Task_Id; @@ -179,15 +174,14 @@ package body System.Interrupts is pragma Atomic_Components (Ignored); -- True iff the corresponding interrupt is blocked in the process level - Last_Unblocker : - array (Interrupt_ID'Range) of Task_Id := [others => Null_Task]; + Last_Unblocker : array (Interrupt_ID'Range) of Task_Id := + [others => Null_Task]; pragma Atomic_Components (Last_Unblocker); -- Holds the ID of the last Task which Unblocked this Interrupt. It -- contains Null_Task if no tasks have ever requested the Unblocking -- operation or the Interrupt is currently Blocked. - Server_ID : array (Interrupt_ID'Range) of Task_Id := - [others => Null_Task]; + Server_ID : array (Interrupt_ID'Range) of Task_Id := [others => Null_Task]; pragma Atomic_Components (Server_ID); -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is -- needed to accomplish locking per Interrupt base. Also is needed to diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb index 2107994..88f8f96 100644 --- a/gcc/ada/mdll.adb +++ b/gcc/ada/mdll.adb @@ -448,57 +448,41 @@ package body MDLL is (Lib_Filename : String; Def_Filename : String) is - procedure Build_Import_Library (Lib_Filename : String); - -- Build an import library. This is to build only a .a library to link - -- against a DLL. + function Strip_Lib_Prefix (Filename : String) return String; + -- Return Filename without the lib prefix if present - -------------------------- - -- Build_Import_Library -- - -------------------------- - - procedure Build_Import_Library (Lib_Filename : String) is - - function No_Lib_Prefix (Filename : String) return String; - -- Return Filename without the lib prefix if present - - ------------------- - -- No_Lib_Prefix -- - ------------------- - - function No_Lib_Prefix (Filename : String) return String is - begin - if Filename (Filename'First .. Filename'First + 2) = "lib" then - return Filename (Filename'First + 3 .. Filename'Last); - else - return Filename; - end if; - end No_Lib_Prefix; - - -- Local variables - - Def_File : String renames Def_Filename; - Dll_File : constant String := Get_Dll_Name (Lib_Filename); - Base_Filename : constant String := - MDLL.Fil.Ext_To (No_Lib_Prefix (Lib_Filename)); - Lib_File : constant String := "lib" & Base_Filename & ".dll.a"; - - -- Start of processing for Build_Import_Library + ---------------------- + -- Strip_Lib_Prefix -- + ---------------------- + function Strip_Lib_Prefix (Filename : String) return String is begin - if not Quiet then - Text_IO.Put_Line ("Building import library..."); - Text_IO.Put_Line - ("make " & Lib_File & " to use dynamic library " & Dll_File); + if Filename (Filename'First .. Filename'First + 2) = "lib" then + return Filename (Filename'First + 3 .. Filename'Last); + else + return Filename; end if; + end Strip_Lib_Prefix; - Utl.Dlltool - (Def_File, Dll_File, Lib_File, Build_Import => True); - end Build_Import_Library; + -- Local variables + + Def_File : String renames Def_Filename; + Dll_File : constant String := Get_Dll_Name (Lib_Filename); + Base_Filename : constant String := + MDLL.Fil.Ext_To (Strip_Lib_Prefix (Lib_Filename)); + Lib_File : constant String := "lib" & Base_Filename & ".dll.a"; -- Start of processing for Build_Import_Library begin - Build_Import_Library (Lib_Filename); + if not Quiet then + Text_IO.Put_Line ("Building import library..."); + Text_IO.Put_Line + ("make " & Lib_File & " to use dynamic library " & Dll_File); + end if; + + Utl.Dlltool + (Def_File, Dll_File, Lib_File, Build_Import => True); end Build_Import_Library; ------------------ diff --git a/gcc/ada/mdll.ads b/gcc/ada/mdll.ads index 110eb31..9f080c0 100644 --- a/gcc/ada/mdll.ads +++ b/gcc/ada/mdll.ads @@ -74,7 +74,7 @@ package MDLL is procedure Build_Import_Library (Lib_Filename : String; Def_Filename : String); - -- Build an import library (.a) from a definition files. An import library - -- is needed to link against a DLL. + -- Build an import library (.a) from definition files. An import library is + -- needed to link against a DLL. end MDLL; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 9eb792e..6f3ced2 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -395,6 +395,10 @@ package Opt is -- Set to True (-C switch) to indicate that the compiler will be invoked -- with a mapping file (-gnatem compiler switch). + CUDA_Device_Library_Name : String_Ptr := null; + -- GNATBIND + -- Non-null only if Enable_CUDA_Expansion is True. + subtype Debug_Level_Value is Nat range 0 .. 3; Debugger_Level : Debug_Level_Value := 0; -- GNAT, GNATBIND @@ -549,9 +553,7 @@ package Opt is Enable_CUDA_Device_Expansion : Boolean := False; -- GNATBIND - -- Set to True to enable CUDA device (as opposed to host) expansion: - -- - Binder generates elaboration/finalization code that can be - -- invoked from corresponding binder-generated host-side code. + -- Set to True to enable CUDA device (as opposed to host) expansion. Error_Msg_Line_Length : Nat := 0; -- GNAT diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 87a8c1a..31ce9ca 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3531,7 +3531,18 @@ package body Sem_Aggr is Next (Choice); end loop; - Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); + -- For an array_delta_aggregate, the array_component_association + -- shall not use the box symbol <>; RM 4.3.4(11/5). + + pragma Assert + (Box_Present (Assoc) xor Present (Expression (Assoc))); + + if Box_Present (Assoc) then + Error_Msg_N + ("'<'> in array delta aggregate is not allowed", Assoc); + else + Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); + end if; end if; Next (Assoc); diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 66cbcfb..004aadb 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -279,7 +279,7 @@ package Sem_Aux is -- or subtype. This is true if Suppress_Initialization is set either for -- the subtype itself, or for the corresponding base type. - function Is_Body (N : Node_Id) return Boolean; + function Is_Body (N : Node_Id) return Boolean with Inline; -- Determine whether an arbitrary node denotes a body function Is_By_Copy_Type (Ent : Entity_Id) return Boolean; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index bb732b7..244e53f 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -192,8 +192,13 @@ package body Sem_Case is record Low, High : Uint; end record; + function "=" (X, Y : Discrete_Range_Info) return Boolean is abstract; + -- Here (and below), we don't use "=", which is a good thing, + -- because it wouldn't work, because the user-defined "=" on + -- Uint does not compose according to Ada rules. type Composite_Range_Info is array (Part_Id) of Discrete_Range_Info; + function "=" (X, Y : Composite_Range_Info) return Boolean is abstract; type Choice_Range_Info (Is_Others : Boolean := False) is record @@ -204,6 +209,7 @@ package body Sem_Case is null; end case; end record; + function "=" (X, Y : Choice_Range_Info) return Boolean is abstract; type Choices_Range_Info is array (Choice_Id) of Choice_Range_Info; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 0b7b7c9..2b7833d 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7023,7 +7023,7 @@ package body Sem_Ch12 is Astype := First_Subtype (E); end if; - Set_Size_Info (E, (Astype)); + Set_Size_Info (E, Astype); Copy_RM_Size (To => E, From => Astype); Set_First_Rep_Item (E, First_Rep_Item (Astype)); @@ -7054,12 +7054,10 @@ package body Sem_Ch12 is elsif Present (Associated_Formal_Package (E)) and then not Is_Generic_Formal (E) then - if Box_Present (Parent (Associated_Formal_Package (E))) then - Check_Generic_Actuals (Renamed_Entity (E), True); - - else - Check_Generic_Actuals (Renamed_Entity (E), False); - end if; + Check_Generic_Actuals + (Renamed_Entity (E), + Is_Formal_Box => + Box_Present (Parent (Associated_Formal_Package (E)))); Set_Is_Hidden (E, False); end if; @@ -15457,7 +15455,7 @@ package body Sem_Ch12 is end loop; end if; - Exchange_Declarations (Node (M)); + Exchange_Declarations (Typ); Next_Elmt (M); end loop; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2eb1a69..5507353 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9930,7 +9930,7 @@ package body Sem_Ch13 is if Opt.List_Inherited_Aspects and then not Is_Generic_Actual_Type (Typ) - and then Instantiation_Depth (Sloc (Typ)) = 0 + and then Instantiation_Location (Sloc (Typ)) = No_Location and then not Is_Internal_Name (Chars (T)) and then not Is_Internal_Name (Chars (Typ)) then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 90af320..76dc632 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16720,9 +16720,9 @@ package body Sem_Ch3 is (Is_Generic_Unit (Scope (Find_Dispatching_Type (Alias_Subp))) or else - Instantiation_Depth - (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0); - + Instantiation_Location + (Sloc (Find_Dispatching_Type (Alias_Subp))) + /= No_Location); declare Iface_Prim_Loc : constant Source_Ptr := Original_Location (Sloc (Alias_Subp)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 60ea681..2a3aca8 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -7315,22 +7315,16 @@ package body Sem_Prag is Parent_Node : Node_Id; begin - if not Is_List_Member (N) then - return False; - - else + if Is_List_Member (N) then Plist := List_Containing (N); Parent_Node := Parent (Plist); - if Parent_Node = Empty - or else Nkind (Parent_Node) /= N_Compilation_Unit - or else Context_Items (Parent_Node) /= Plist - then - return False; - end if; + return Present (Parent_Node) + and then Nkind (Parent_Node) = N_Compilation_Unit + and then Context_Items (Parent_Node) = Plist; end if; - return True; + return False; end Is_In_Context_Clause; --------------------------------- @@ -20502,10 +20496,16 @@ package body Sem_Prag is if No (Decl) then - -- First case: library level compilation unit declaration with + -- Case 0: library level compilation unit declaration with + -- the pragma preceding the declaration. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Pragma_Misplaced; + + -- Case 1: library level compilation unit declaration with -- the pragma immediately following the declaration. - if Nkind (Parent (N)) = N_Compilation_Unit_Aux then + elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then Set_Obsolescent (Defining_Entity (Unit (Parent (Parent (N))))); return; @@ -31719,43 +31719,45 @@ package body Sem_Prag is -- Start of processing for Non_Significant_Pragma_Reference begin - P := Parent (N); - - if Nkind (P) /= N_Pragma_Argument_Association then + -- Reference might appear either directly as expression of a pragma + -- argument association, e.g. pragma Export (...), or within an + -- aggregate with component associations, e.g. pragma Refined_State + -- ((... => ...)). - -- References within pragma Refined_State are not significant. They - -- can't be recognized using pragma argument number, because they - -- appear inside refinement clauses that rely on aggregate syntax. + P := Parent (N); + loop + case Nkind (P) is + when N_Pragma_Argument_Association => + exit; + when N_Aggregate | N_Component_Association => + P := Parent (P); + when others => + return False; + end case; + end loop; - if In_Pragma_Expression (N, Name_Refined_State) then - return True; - end if; + AN := Arg_No; + if AN = 0 then return False; + end if; - else - Id := Get_Pragma_Id (Parent (P)); - C := Sig_Flags (Id); - AN := Arg_No; + Id := Get_Pragma_Id (Parent (P)); + C := Sig_Flags (Id); - if AN = 0 then + case C is + when -1 => return False; - end if; - case C is - when -1 => - return False; - - when 0 => - return True; + when 0 => + return True; - when 92 .. 99 => - return AN < (C - 90); + when 92 .. 99 => + return AN < (C - 90); - when others => - return AN /= C; - end case; - end if; + when others => + return AN /= C; + end case; end Is_Non_Significant_Pragma_Reference; ------------------------------ diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 7675070..402da43 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -895,10 +895,6 @@ package body Sem_Res is ------------------------------ function Check_Infinite_Recursion (Call : Node_Id) return Boolean is - function Enclosing_Declaration_Or_Statement (N : Node_Id) return Node_Id; - -- Return the nearest enclosing declaration or statement that houses - -- arbitrary node N. - function Invoked_With_Different_Arguments (N : Node_Id) return Boolean; -- Determine whether call N invokes the related enclosing subprogram -- with actuals that differ from the subprogram's formals. @@ -934,33 +930,6 @@ package body Sem_Res is -- Determine whether arbitrary node N appears within a conditional -- construct. - ---------------------------------------- - -- Enclosing_Declaration_Or_Statement -- - ---------------------------------------- - - function Enclosing_Declaration_Or_Statement - (N : Node_Id) return Node_Id - is - Par : Node_Id; - - begin - Par := N; - while Present (Par) loop - if Is_Declaration (Par) or else Is_Statement (Par) then - return Par; - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Par) then - exit; - end if; - - Par := Parent (Par); - end loop; - - return N; - end Enclosing_Declaration_Or_Statement; - -------------------------------------- -- Invoked_With_Different_Arguments -- -------------------------------------- @@ -2370,8 +2339,6 @@ package body Sem_Res is ("prefix must statically denote a non-remote subprogram", N); end if; - From_Lib := Comes_From_Predefined_Lib_Unit (N); - -- If the context is a Remote_Access_To_Subprogram, access attributes -- must be resolved with the corresponding fat pointer. There is no need -- to check for the attribute name since the return type of an @@ -2505,6 +2472,8 @@ package body Sem_Res is -- is compatible with the context (i.e. the type passed to Resolve) else + From_Lib := Comes_From_Predefined_Lib_Unit (N); + -- Loop through possible interpretations Get_First_Interp (N, I, It); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5c49576..c00490c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -8271,6 +8271,33 @@ package body Sem_Util is return Decl; end Enclosing_Declaration; + ---------------------------------------- + -- Enclosing_Declaration_Or_Statement -- + ---------------------------------------- + + function Enclosing_Declaration_Or_Statement + (N : Node_Id) return Node_Id + is + Par : Node_Id; + + begin + Par := N; + while Present (Par) loop + if Is_Declaration (Par) or else Is_Statement (Par) then + return Par; + + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (Par) then + exit; + end if; + + Par := Parent (Par); + end loop; + + return N; + end Enclosing_Declaration_Or_Statement; + ---------------------------- -- Enclosing_Generic_Body -- ---------------------------- @@ -27885,7 +27912,10 @@ package body Sem_Util is P := Parent (N); while Present (P) loop - if Nkind (P) = N_If_Statement + if Is_Body (P) then + return True; + + elsif Nkind (P) = N_If_Statement or else Nkind (P) = N_Case_Statement or else (Nkind (P) in N_Short_Circuit and then Desc = Right_Opnd (P)) diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 88bfbfc..e651b20 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -809,6 +809,10 @@ package Sem_Util is -- Returns the declaration node enclosing N (including possibly N itself), -- if any, or Empty otherwise. + function Enclosing_Declaration_Or_Statement (N : Node_Id) return Node_Id; + -- Return the nearest enclosing declaration or statement that houses + -- arbitrary node N. + function Enclosing_Generic_Body (N : Node_Id) return Node_Id; -- Returns the Node_Id associated with the innermost enclosing generic -- body, if any. If none, then returns Empty. @@ -1877,12 +1881,13 @@ package Sem_Util is function Is_Attribute_Update (N : Node_Id) return Boolean; -- Determine whether node N denotes attribute 'Update - function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean; + function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean + with Inline; -- Determine whether node N denotes a body or a package declaration function Is_Bounded_String (T : Entity_Id) return Boolean; -- True if T is a bounded string type. Used to make sure "=" composes - -- properly for bounded string types. + -- properly for bounded string types (see 4.5.2(32.1/1)). function Is_By_Protected_Procedure (Id : Entity_Id) return Boolean; -- Determine whether entity Id denotes a procedure with synchronization diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 77d5821..0a46c66 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1460,31 +1460,6 @@ package body Sem_Warn is and then not Known_To_Have_Preelab_Init (Etype (E1)) then - -- For other than access type, go back to original node to - -- deal with case where original unset reference has been - -- rewritten during expansion. - - -- In some cases, the original node may be a type - -- conversion, a qualification or an attribute reference and - -- in this case we want the object entity inside. Same for - -- an expression with actions. - - UR := Original_Node (UR); - loop - if Nkind (UR) in N_Expression_With_Actions - | N_Qualified_Expression - | N_Type_Conversion - then - UR := Expression (UR); - - elsif Nkind (UR) = N_Attribute_Reference then - UR := Prefix (UR); - - else - exit; - end if; - end loop; - -- Don't issue warning if appearing inside Initial_Condition -- pragma or aspect, since that expression is not evaluated -- at the point where it occurs in the source. @@ -1745,7 +1720,6 @@ package body Sem_Warn is elsif Is_Generic_Subprogram (E1) and then not Is_Instantiated (E1) and then not Publicly_Referenceable (E1) - and then Instantiation_Depth (Sloc (E1)) = 0 and then Warn_On_Redundant_Constructs then if not Warnings_Off_E1 and then not Has_Junk_Name (E1) then @@ -2974,21 +2948,6 @@ package body Sem_Warn is begin return Traverse (N) = Abandon; - - -- If any exception occurs, then something has gone wrong, and this is - -- only a minor aesthetic issue anyway, so just say we did not find what - -- we are looking for, rather than blow up. - - exception - when others => - -- With debug flag K we will get an exception unless an error has - -- already occurred (useful for debugging). - - if Debug_Flag_K then - Check_Error_Detected; - end if; - - return False; end Operand_Has_Warnings_Suppressed; ----------------------------------------- @@ -2997,7 +2956,7 @@ package body Sem_Warn is procedure Output_Non_Modified_In_Out_Warnings is - function No_Warn_On_In_Out (E : Entity_Id) return Boolean; + function Warn_On_In_Out (E : Entity_Id) return Boolean; -- Given a formal parameter entity E, determines if there is a reason to -- suppress IN OUT warnings (not modified, could be IN) for formals of -- the subprogram. We suppress these warnings if Warnings Off is set, or @@ -3006,11 +2965,11 @@ package body Sem_Warn is -- context may force use of IN OUT, even if the parameter is not -- modified for this particular case). - ----------------------- - -- No_Warn_On_In_Out -- - ----------------------- + -------------------- + -- Warn_On_In_Out -- + -------------------- - function No_Warn_On_In_Out (E : Entity_Id) return Boolean is + function Warn_On_In_Out (E : Entity_Id) return Boolean is S : constant Entity_Id := Scope (E); SE : constant Entity_Id := Spec_Entity (E); @@ -3021,7 +2980,7 @@ package body Sem_Warn is if Address_Taken (S) or else (Present (SE) and then Address_Taken (Scope (SE))) then - return True; + return False; -- Do not warn if used as a generic actual, since the generic may be -- what is forcing the use of an "unnecessary" IN OUT. @@ -3029,19 +2988,19 @@ package body Sem_Warn is elsif Used_As_Generic_Actual (S) or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE))) then - return True; + return False; - -- Else test warnings off + -- Else test warnings off on the subprogram - elsif Warnings_Off_Check_Spec (S) then - return True; + elsif Warnings_Off (S) then + return False; -- All tests for suppressing warning failed else - return False; + return True; end if; - end No_Warn_On_In_Out; + end Warn_On_In_Out; -- Start of processing for Output_Non_Modified_In_Out_Warnings @@ -3054,16 +3013,9 @@ package body Sem_Warn is begin -- Suppress warning in specific cases (see details in comments for - -- No_Warn_On_In_Out), or if there is a pragma Unmodified. - - if Has_Pragma_Unmodified_Check_Spec (E1) - or else No_Warn_On_In_Out (E1) - then - null; - - -- Here we generate the warning + -- No_Warn_On_In_Out). - else + if Warn_On_In_Out (E1) then -- If -gnatwk is set then output message that it could be IN if not Is_Trivial_Subprogram (Scope (E1)) then @@ -3146,7 +3098,7 @@ package body Sem_Warn is ("?j?with of obsolescent procedure& declared#", N, E); else Error_Msg_NE - ("??with of obsolescent function& declared#", N, E); + ("?j?with of obsolescent function& declared#", N, E); end if; -- If we do not have a with clause, then ignore any reference to an @@ -3412,11 +3364,10 @@ package body Sem_Warn is -- determined, and Test_Result is set True/False accordingly. Otherwise -- False is returned, and Test_Result is unchanged. - procedure Track (N : Node_Id; Loc : Node_Id); + procedure Track (N : Node_Id); -- Adds continuation warning(s) pointing to reason (assignment or test) -- for the operand of the conditional having a known value (or at least - -- enough is known about the value to issue the warning). N is the node - -- which is judged to have a known value. Loc is the warning location. + -- enough is known about the value to issue the warning). --------------------- -- Is_Known_Branch -- @@ -3450,36 +3401,45 @@ package body Sem_Warn is -- Track -- ----------- - procedure Track (N : Node_Id; Loc : Node_Id) is - Nod : constant Node_Id := Original_Node (N); + procedure Track (N : Node_Id) is - begin - if Nkind (Nod) in N_Op_Compare then - Track (Left_Opnd (Nod), Loc); - Track (Right_Opnd (Nod), Loc); + procedure Rec (Sub_N : Node_Id); + -- Recursive helper to do the work of Track, so we can refer to N's + -- Sloc in error messages. Sub_N is initially N, and a proper subnode + -- when recursively walking comparison operations. - elsif Is_Entity_Name (Nod) and then Is_Object (Entity (Nod)) then - declare - CV : constant Node_Id := Current_Value (Entity (Nod)); + procedure Rec (Sub_N : Node_Id) is + Orig : constant Node_Id := Original_Node (Sub_N); + begin + if Nkind (Orig) in N_Op_Compare then + Rec (Left_Opnd (Orig)); + Rec (Right_Opnd (Orig)); - begin - if Present (CV) then - Error_Msg_Sloc := Sloc (CV); + elsif Is_Entity_Name (Orig) and then Is_Object (Entity (Orig)) then + declare + CV : constant Node_Id := Current_Value (Entity (Orig)); + begin + if Present (CV) then + Error_Msg_Sloc := Sloc (CV); - if Nkind (CV) not in N_Subexpr then - Error_Msg_N ("\\??(see test #)", Loc); + if Nkind (CV) not in N_Subexpr then + Error_Msg_N ("\\??(see test #)", N); - elsif Nkind (Parent (CV)) = - N_Case_Statement_Alternative - then - Error_Msg_N ("\\??(see case alternative #)", Loc); + elsif Nkind (Parent (CV)) = + N_Case_Statement_Alternative + then + Error_Msg_N ("\\??(see case alternative #)", N); - else - Error_Msg_N ("\\??(see assignment #)", Loc); + else + Error_Msg_N ("\\??(see assignment #)", N); + end if; end if; - end if; - end; - end if; + end; + end if; + end Rec; + + begin + Rec (N); end Track; -- Local variables @@ -3497,11 +3457,8 @@ package body Sem_Warn is and then Is_Known_Branch then declare - Atrue : Boolean; - + Atrue : Boolean := Test_Result; begin - Atrue := Test_Result; - if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then Atrue := not Atrue; end if; @@ -3583,7 +3540,6 @@ package body Sem_Warn is declare True_Branch : Boolean := Test_Result; Cond : Node_Id := C; - begin if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not @@ -3592,37 +3548,27 @@ package body Sem_Warn is Cond := Parent (C); end if; - -- Condition always True - - if True_Branch then - if Is_Entity_Name (Original_Node (C)) - and then Nkind (Cond) /= N_Op_Not - then - Error_Msg_NE - ("object & is always True at this point?c?", - Cond, Original_Node (C)); - Track (Original_Node (C), Cond); + -- Suppress warning if this is True/False of a derived boolean + -- type with Nonzero_Is_True, which gets rewritten as Boolean + -- True/False. - else - Error_Msg_N ("condition is always True?c?", Cond); - Track (Cond, Cond); - end if; + if Is_Entity_Name (Original_Node (C)) + and then Ekind (Entity (Original_Node (C))) + = E_Enumeration_Literal + and then Nonzero_Is_True (Etype (Original_Node (C))) + then + null; - -- Condition always False + -- Give warning for nontrivial always True/False case else - if Is_Entity_Name (Original_Node (C)) - and then Nkind (Cond) /= N_Op_Not - then - Error_Msg_NE - ("object & is always False at this point?c?", - Cond, Original_Node (C)); - Track (Original_Node (C), Cond); - + if True_Branch then + Error_Msg_N ("condition is always True?c?", Cond); else Error_Msg_N ("condition is always False?c?", Cond); - Track (Cond, Cond); end if; + + Track (Cond); end if; end; end if; diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb index 8e80213..c96049b 100644 --- a/gcc/ada/sinput.adb +++ b/gcc/ada/sinput.adb @@ -620,7 +620,6 @@ package body Sinput is ------------------------- function Instantiation_Depth (S : Source_Ptr) return Nat is - Sind : Source_File_Index; Sval : Source_Ptr; Depth : Nat; @@ -629,8 +628,7 @@ package body Sinput is Depth := 0; loop - Sind := Get_Source_File_Index (Sval); - Sval := Instantiation (Sind); + Sval := Instantiation_Location (Sval); exit when Sval = No_Location; Depth := Depth + 1; end loop; diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb index c40cb97..7a732ae 100644 --- a/gcc/ada/switch-b.adb +++ b/gcc/ada/switch-b.adb @@ -168,6 +168,15 @@ package body Switch.B is if Enable_CUDA_Expansion and Enable_CUDA_Device_Expansion then Bad_Switch (Switch_Chars); + elsif C = 'c' then + -- specify device library name + if Ptr >= Max or else Switch_Chars (Ptr + 1) /= '=' then + Bad_Switch (Switch_Chars); + else + CUDA_Device_Library_Name := + new String'(Switch_Chars (Ptr + 2 .. Max)); + Ptr := Max; + end if; end if; Underscore := False; diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb index 4a7dcc3..733c962 100644 --- a/gcc/ada/warnsw.adb +++ b/gcc/ada/warnsw.adb @@ -80,6 +80,7 @@ package body Warnsw is Warn_On_Questionable_Layout := Setting; Warn_On_Questionable_Missing_Parens := Setting; Warn_On_Record_Holes := Setting; + Warn_On_Ignored_Equality := Setting; Warn_On_Component_Order := Setting; Warn_On_Redundant_Constructs := Setting; Warn_On_Reverse_Bit_Order := Setting; @@ -181,6 +182,8 @@ package body Warnsw is W.Warn_On_Questionable_Missing_Parens; Warn_On_Record_Holes := W.Warn_On_Record_Holes; + Warn_On_Ignored_Equality := + W.Warn_On_Ignored_Equality; Warn_On_Component_Order := W.Warn_On_Component_Order; Warn_On_Redundant_Constructs := @@ -295,6 +298,8 @@ package body Warnsw is Warn_On_Questionable_Missing_Parens; W.Warn_On_Record_Holes := Warn_On_Record_Holes; + W.Warn_On_Ignored_Equality := + Warn_On_Ignored_Equality; W.Warn_On_Component_Order := Warn_On_Component_Order; W.Warn_On_Redundant_Constructs := @@ -516,6 +521,12 @@ package body Warnsw is when 'P' => Warn_On_Pedantic_Checks := False; + when 'q' => + Warn_On_Ignored_Equality := True; + + when 'Q' => + Warn_On_Ignored_Equality := False; + when 'r' => Warn_On_Component_Order := True; diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads index 8fe5ef7..9edd6be 100644 --- a/gcc/ada/warnsw.ads +++ b/gcc/ada/warnsw.ads @@ -77,6 +77,12 @@ package Warnsw is -- Warn when explicit record component clauses leave uncovered holes (gaps) -- in a record layout. Off by default, set by -gnatw.h (but not -gnatwa). + Warn_On_Ignored_Equality : Boolean := False; + -- Warn when a user-defined "=" function does not compose (i.e. is ignored + -- for a predefined "=" for a composite type containing a component of + -- whose type has the user-defined "=" as primitive). Off by default, and + -- set by -gnatw_q (but not -gnatwa). + Warn_On_Component_Order : Boolean := False; -- Warn when record component clauses are out of order with respect to the -- component declarations, or if the memory layout is out of order with @@ -140,6 +146,7 @@ package Warnsw is Warn_On_Questionable_Layout : Boolean; Warn_On_Questionable_Missing_Parens : Boolean; Warn_On_Record_Holes : Boolean; + Warn_On_Ignored_Equality : Boolean; Warn_On_Component_Order : Boolean; Warn_On_Redundant_Constructs : Boolean; Warn_On_Reverse_Bit_Order : Boolean; @@ -156,7 +163,7 @@ package Warnsw is end record; function Save_Warnings return Warning_Record; - -- Returns current settingh of warnings + -- Returns current settings of warnings procedure Restore_Warnings (W : Warning_Record); -- Restores current settings of warning flags from W diff --git a/gcc/doc/invoke.texi b/gcc/doc/invoke.texi index b9a5640..b2083ec 100644 --- a/gcc/doc/invoke.texi +++ b/gcc/doc/invoke.texi @@ -16464,9 +16464,10 @@ by this option. @end table -Note the enabled sanitizer options tend to increase a false-positive rate -of selected warnings, most notably @option{-Wmaybe-uninitialized}. -And thus we recommend to disable @option{-Werror}. +Note that sanitizers tend to increase the rate of false positive +warnings, most notably those around @option{-Wmaybe-uninitialized}. +We recommend against combining @option{-Werror} and [the use of] +sanitizers. While @option{-ftrapv} causes traps for signed overflows to be emitted, @option{-fsanitize=undefined} gives a diagnostic message. diff --git a/gcc/gimple-fold.cc b/gcc/gimple-fold.cc index 9055cd8..410544c 100644 --- a/gcc/gimple-fold.cc +++ b/gcc/gimple-fold.cc @@ -5370,19 +5370,39 @@ arith_overflowed_p (enum tree_code code, const_tree type, return wi::min_precision (wres, sign) > TYPE_PRECISION (type); } -/* If IFN_MASK_LOAD/STORE call CALL is unconditional, return a MEM_REF +/* If IFN_{MASK,LEN}_LOAD/STORE call CALL is unconditional, return a MEM_REF for the memory it references, otherwise return null. VECTYPE is the - type of the memory vector. */ + type of the memory vector. MASK_P indicates it's for MASK if true, + otherwise it's for LEN. */ static tree -gimple_fold_mask_load_store_mem_ref (gcall *call, tree vectype) +gimple_fold_partial_load_store_mem_ref (gcall *call, tree vectype, bool mask_p) { tree ptr = gimple_call_arg (call, 0); tree alias_align = gimple_call_arg (call, 1); - tree mask = gimple_call_arg (call, 2); - if (!tree_fits_uhwi_p (alias_align) || !integer_all_onesp (mask)) + if (!tree_fits_uhwi_p (alias_align)) return NULL_TREE; + if (mask_p) + { + tree mask = gimple_call_arg (call, 2); + if (!integer_all_onesp (mask)) + return NULL_TREE; + } else { + tree basic_len = gimple_call_arg (call, 2); + if (!tree_fits_uhwi_p (basic_len)) + return NULL_TREE; + unsigned int nargs = gimple_call_num_args (call); + tree bias = gimple_call_arg (call, nargs - 1); + gcc_assert (tree_fits_uhwi_p (bias)); + tree biased_len = int_const_binop (MINUS_EXPR, basic_len, bias); + unsigned int len = tree_to_uhwi (biased_len); + unsigned int vect_len + = GET_MODE_SIZE (TYPE_MODE (vectype)).to_constant (); + if (vect_len != len) + return NULL_TREE; + } + unsigned HOST_WIDE_INT align = tree_to_uhwi (alias_align); if (TYPE_ALIGN (vectype) != align) vectype = build_aligned_type (vectype, align); @@ -5390,16 +5410,18 @@ gimple_fold_mask_load_store_mem_ref (gcall *call, tree vectype) return fold_build2 (MEM_REF, vectype, ptr, offset); } -/* Try to fold IFN_MASK_LOAD call CALL. Return true on success. */ +/* Try to fold IFN_{MASK,LEN}_LOAD call CALL. Return true on success. + MASK_P indicates it's for MASK if true, otherwise it's for LEN. */ static bool -gimple_fold_mask_load (gimple_stmt_iterator *gsi, gcall *call) +gimple_fold_partial_load (gimple_stmt_iterator *gsi, gcall *call, bool mask_p) { tree lhs = gimple_call_lhs (call); if (!lhs) return false; - if (tree rhs = gimple_fold_mask_load_store_mem_ref (call, TREE_TYPE (lhs))) + if (tree rhs + = gimple_fold_partial_load_store_mem_ref (call, TREE_TYPE (lhs), mask_p)) { gassign *new_stmt = gimple_build_assign (lhs, rhs); gimple_set_location (new_stmt, gimple_location (call)); @@ -5410,13 +5432,16 @@ gimple_fold_mask_load (gimple_stmt_iterator *gsi, gcall *call) return false; } -/* Try to fold IFN_MASK_STORE call CALL. Return true on success. */ +/* Try to fold IFN_{MASK,LEN}_STORE call CALL. Return true on success. + MASK_P indicates it's for MASK if true, otherwise it's for LEN. */ static bool -gimple_fold_mask_store (gimple_stmt_iterator *gsi, gcall *call) +gimple_fold_partial_store (gimple_stmt_iterator *gsi, gcall *call, + bool mask_p) { tree rhs = gimple_call_arg (call, 3); - if (tree lhs = gimple_fold_mask_load_store_mem_ref (call, TREE_TYPE (rhs))) + if (tree lhs + = gimple_fold_partial_load_store_mem_ref (call, TREE_TYPE (rhs), mask_p)) { gassign *new_stmt = gimple_build_assign (lhs, rhs); gimple_set_location (new_stmt, gimple_location (call)); @@ -5635,10 +5660,16 @@ gimple_fold_call (gimple_stmt_iterator *gsi, bool inplace) cplx_result = true; break; case IFN_MASK_LOAD: - changed |= gimple_fold_mask_load (gsi, stmt); + changed |= gimple_fold_partial_load (gsi, stmt, true); break; case IFN_MASK_STORE: - changed |= gimple_fold_mask_store (gsi, stmt); + changed |= gimple_fold_partial_store (gsi, stmt, true); + break; + case IFN_LEN_LOAD: + changed |= gimple_fold_partial_load (gsi, stmt, false); + break; + case IFN_LEN_STORE: + changed |= gimple_fold_partial_store (gsi, stmt, false); break; default: break; diff --git a/gcc/range-op.cc b/gcc/range-op.cc index 25c004d..5e94c3d 100644 --- a/gcc/range-op.cc +++ b/gcc/range-op.cc @@ -1753,17 +1753,18 @@ public: const wide_int &lh_lb, const wide_int &lh_ub, const wide_int &rh_lb, - const wide_int &rh_ub) const; + const wide_int &rh_ub) const final override; virtual bool wi_op_overflows (wide_int &res, tree type, - const wide_int &w0, const wide_int &w1) const; + const wide_int &w0, const wide_int &w1) + const final override; virtual bool op1_range (irange &r, tree type, const irange &lhs, const irange &op2, - relation_trio) const; + relation_trio) const final override; virtual bool op2_range (irange &r, tree type, const irange &lhs, const irange &op1, - relation_trio) const; + relation_trio) const final override; } op_mult; bool @@ -1929,9 +1930,10 @@ public: const wide_int &lh_lb, const wide_int &lh_ub, const wide_int &rh_lb, - const wide_int &rh_ub) const; + const wide_int &rh_ub) const final override; virtual bool wi_op_overflows (wide_int &res, tree type, - const wide_int &, const wide_int &) const; + const wide_int &, const wide_int &) + const final override; virtual bool fold_range (irange &r, tree type, const irange &lh, const irange &rh, relation_trio trio) const final override; diff --git a/gcc/testsuite/gcc.target/powerpc/p9-vec-length-epil-8.c b/gcc/testsuite/gcc.target/powerpc/p9-vec-length-epil-8.c index 961df0d..8b9c910 100644 --- a/gcc/testsuite/gcc.target/powerpc/p9-vec-length-epil-8.c +++ b/gcc/testsuite/gcc.target/powerpc/p9-vec-length-epil-8.c @@ -8,5 +8,5 @@ #include "p9-vec-length-8.h" -/* { dg-final { scan-assembler-times {\mlxvl\M} 21 } } */ +/* { dg-final { scan-assembler-times {\mlxvl\M} 16 } } */ /* { dg-final { scan-assembler-times {\mstxvl\M} 7 } } */ diff --git a/gcc/testsuite/gcc.target/powerpc/pr107412.c b/gcc/testsuite/gcc.target/powerpc/pr107412.c new file mode 100644 index 0000000..4526ea8 --- /dev/null +++ b/gcc/testsuite/gcc.target/powerpc/pr107412.c @@ -0,0 +1,19 @@ +/* { dg-require-effective-target powerpc_p9vector_ok } */ +/* { dg-require-effective-target lp64 } */ +/* { dg-options "-mdejagnu-cpu=power9 -O2 -ftree-vectorize -fno-vect-cost-model -funroll-loops -fno-tree-loop-distribute-patterns --param vect-partial-vector-usage=2 -fdump-tree-optimized" } */ + +/* Verify there is only one IFN call LEN_LOAD and IFN_STORE separately. */ + +#define N 16 +int src[N]; +int dest[N]; + +void +foo () +{ + for (int i = 0; i < (N - 1); i++) + dest[i] = src[i]; +} + +/* { dg-final { scan-tree-dump-times {\mLEN_LOAD\M} 1 "optimized" } } */ +/* { dg-final { scan-tree-dump-times {\mLEN_STORE\M} 1 "optimized" } } */ |