diff mbox series

[Ada] Unsynchronized concurrent access to a Boolean variable

Message ID 20210708135004.GA2465601@adacore.com
State New
Headers show
Series [Ada] Unsynchronized concurrent access to a Boolean variable | expand

Commit Message

Pierre-Marie de Rodat July 8, 2021, 1:50 p.m. UTC 
If an exception declaration occurs in a nonstatic scope (for example,
within the body of a task type),
System.Exception_Table.Register_Exception is to be called the first (and
*only* the first) time the declaration is elaborated.  A library-level
"this exception has been registered" Boolean flag was being used to
accomplish this, but this solution introduces potential problems with
concurrency. So instead of Boolean, use the type
System.Atomic_Operations.Test_And_Set.Test_And_Set_Flag if this option
is available and concurrent access via tasking is a possibility;
otherwise, stick with the old Boolean-based approach.

Tested on x86_64-pc-linux-gnu, committed on trunk

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 mbox series

Patch

diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
--- 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
--- 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
--- 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,