FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Unsynchronized concurrent access to a Boolean variable

Browse source 
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).
This commit is contained in:
Steve Baird 2021-05-24 14:38:07 -07:00 • committed by Pierre-Marie de Rodat
parent 076c1a9157
commit 5478d8a7ae
3 changed files with 81 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

83
gcc/ada/exp_ch11.adb
View file

@ -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);
Insert_After_And_Analyze (N,
Make_Implicit_If_Statement (N,
Condition => New_Occurrence_Of (Flag_Id, Loc),
Then_Statements => L));
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_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;

8
gcc/ada/rtsfind.adb
View file

@ -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;

11
gcc/ada/rtsfind.ads
View file

@ -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,