From: Steve Baird Date: Mon, 24 May 2021 21:38:07 +0000 (-0700) Subject: [Ada] Unsynchronized concurrent access to a Boolean variable X-Git-Tag: basepoints/gcc-13~6166 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=5478d8a7aefbec4d93d32237fb29b9fdb8347b6b;p=thirdparty%2Fgcc.git [Ada] Unsynchronized concurrent access to a Boolean variable gcc/ada/ * rtsfind.ads, rtsfind.adb: Add support for finding the packages System.Atomic_Operations and System.Atomic_Operations.Test_And_Set and the declarations within that latter package of the type Test_And_Set_Flag and the function Atomic_Test_And_Set. * exp_ch11.adb (Expand_N_Exception_Declaration): If an exception is declared other than at library level, then we need to call Register_Exception the first time (and only the first time) the declaration is elaborated. In order to decide whether to perform this call for a given elaboration of the declaration, we used to unconditionally use a (library-level) Boolean variable. Now we instead use a variable of type System.Atomic_Operations.Test_And_Set.Test_And_Set_Flag unless either that type is unavailable or a No_Tasking restriction is in effect (in which case we use a Boolean variable as before). --- diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 605882600cdf..40288e47c966 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1088,10 +1088,19 @@ package body Exp_Ch11 is -- (protecting test only needed if not at library level) - -- exceptF : Boolean := True -- static data + -- exceptF : aliased System.Atomic_Operations.Test_And_Set. + -- .Test_And_Set_Flag := 0; -- static data + -- if not Atomic_Test_And_Set (exceptF) then + -- Register_Exception (except'Unrestricted_Access); + -- end if; + + -- If a No_Tasking restriction is in effect, or if Test_And_Set_Flag + -- is unavailable, then use Boolean instead. In that case, we generate: + -- + -- exceptF : Boolean := True; -- static data -- if exceptF then - -- exceptF := False; - -- Register_Exception (except'Unchecked_Access); + -- ExceptF := False; + -- Register_Exception (except'Unrestricted_Access); -- end if; procedure Expand_N_Exception_Declaration (N : Node_Id) is @@ -1275,7 +1284,7 @@ package body Exp_Ch11 is Force_Static_Allocation_Of_Referenced_Objects (Expression (N)); - -- Register_Exception (except'Unchecked_Access); + -- Register_Exception (except'Unrestricted_Access); if not No_Exception_Handlers_Set and then not Restriction_Active (No_Exception_Registration) @@ -1296,27 +1305,59 @@ package body Exp_Ch11 is Flag_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Id), 'F')); - - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Flag_Id, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc), - Expression => - New_Occurrence_Of (Standard_True, Loc))); - Set_Is_Statically_Allocated (Flag_Id); - Append_To (L, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Flag_Id, Loc), - Expression => New_Occurrence_Of (Standard_False, Loc))); + declare + Use_Test_And_Set_Flag : constant Boolean := + (not Global_No_Tasking) + and then RTE_Available (RE_Test_And_Set_Flag); + + Flag_Decl : Node_Id; + Condition : Node_Id; + begin + if Use_Test_And_Set_Flag then + Flag_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Test_And_Set_Flag), Loc), + Expression => + Make_Integer_Literal (Loc, 0)); + else + Flag_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (Standard_True, Loc)); + end if; - Insert_After_And_Analyze (N, - Make_Implicit_If_Statement (N, - Condition => New_Occurrence_Of (Flag_Id, Loc), - Then_Statements => L)); + Insert_Action (N, Flag_Decl); + + if Use_Test_And_Set_Flag then + Condition := + Make_Op_Not (Loc, + Make_Function_Call (Loc, + Name => New_Occurrence_Of + (RTE (RE_Atomic_Test_And_Set), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Flag_Id, Loc)))); + else + Condition := New_Occurrence_Of (Flag_Id, Loc); + + Append_To (L, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Flag_Id, Loc), + Expression => New_Occurrence_Of (Standard_False, Loc))); + end if; + Insert_After_And_Analyze (N, + Make_Implicit_If_Statement (N, + Condition => Condition, + Then_Statements => L)); + end; else Insert_List_After_And_Analyze (N, L); end if; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 6fe6f8567ac2..5a89076dfb16 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -602,6 +602,10 @@ package body Rtsfind is subtype System_Descendant is RTU_Id range System_Address_Image .. System_Tasking_Stages; + subtype System_Atomic_Operations_Descendant is System_Descendant + range System_Atomic_Operations_Test_And_Set .. + System_Atomic_Operations_Test_And_Set; + subtype System_Dim_Descendant is System_Descendant range System_Dim_Float_IO .. System_Dim_Integer_IO; @@ -689,6 +693,10 @@ package body Rtsfind is elsif U_Id in System_Descendant then Name_Buffer (7) := '.'; + if U_Id in System_Atomic_Operations_Descendant then + Name_Buffer (25) := '.'; + end if; + if U_Id in System_Dim_Descendant then Name_Buffer (11) := '.'; end if; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 6bec611c8087..99f870ad9ea3 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -195,6 +195,7 @@ package Rtsfind is System_Arith_128, System_AST_Handling, System_Assertions, + System_Atomic_Operations, System_Atomic_Primitives, System_Aux_DEC, System_Bignums, @@ -468,6 +469,10 @@ package Rtsfind is System_WWd_Enum, System_WWd_Wchar, + -- Children of System.Atomic_Operations + + System_Atomic_Operations_Test_And_Set, + -- Children of System.Dim System_Dim_Float_IO, @@ -800,6 +805,9 @@ package Rtsfind is RE_Uint32, -- System.Atomic_Primitives RE_Uint64, -- System.Atomic_Primitives + RE_Test_And_Set_Flag, -- System.Atomic_Operations.Test_And_Set + RE_Atomic_Test_And_Set, -- System.Atomic_Operations.Test_And_Set + RE_AST_Handler, -- System.Aux_DEC RE_Import_Address, -- System.Aux_DEC RE_Import_Value, -- System.Aux_DEC @@ -2482,6 +2490,9 @@ package Rtsfind is RE_Uint32 => System_Atomic_Primitives, RE_Uint64 => System_Atomic_Primitives, + RE_Test_And_Set_Flag => System_Atomic_Operations_Test_And_Set, + RE_Atomic_Test_And_Set => System_Atomic_Operations_Test_And_Set, + RE_AST_Handler => System_Aux_DEC, RE_Import_Address => System_Aux_DEC, RE_Import_Value => System_Aux_DEC,