[Ada] New procedure Register_Global_Unhandled_Action

2020-06-04  Arnaud Charlet  <charlet@adacore.com>

gcc/ada/

	* libgnat/a-exextr.adb (Global_Unhandled_Action): New global
	variable.
	(Notify_Exception): Take into account Global_Unhandled_Action
	and fix latent race condition.
	(Exception_Action): Mark Favor_Top_Level so that variables can
	be atomic.
	(Global_Action): Mark atomic to remove the need for a lock.
	* libgnat/g-excact.ads, libgnat/g-excact.adb
	(Register_Global_Unhandled_Action): New procedure.
	(Register_Global_Action): Remove lock.
	* libgnat/s-stalib.ads (Raise_Action): Mark Favor_Top_Level to
	be compatible with Exception_Action.
	* sem_warn.adb (Warn_On_Unreferenced_Entity): Fix logic wrt
	Volatile entities and entities with an address clause: the code
	did not match the comment/intent.

diff --git a/gcc/ada/libgnat/a-exextr.adb b/gcc/ada/libgnat/a-exextr.adb
index 87890875e474160d573b3fce6f89ca9568e65c16..da66873d02dbd20fc29eff7f7437136c05291ee2 100644 (file)
--- a/gcc/ada/libgnat/a-exextr.adb
+++ b/gcc/ada/libgnat/a-exextr.adb
@@ -43,12 +43,23 @@ package body Exception_Traces is
    --  Convenient shortcut
 
    type Exception_Action is access procedure (E : Exception_Occurrence);
+   pragma Favor_Top_Level (Exception_Action);
+
    Global_Action : Exception_Action := null;
+   pragma Atomic (Global_Action);
    pragma Export
      (Ada, Global_Action, "__gnat_exception_actions_global_action");
    --  Global action, executed whenever an exception is raised.  Changing the
    --  export name must be coordinated with code in g-excact.adb.
 
+   Global_Unhandled_Action : Exception_Action := null;
+   pragma Atomic (Global_Unhandled_Action);
+   pragma Export
+     (Ada, Global_Unhandled_Action,
+      "__gnat_exception_actions_global_unhandled_action");
+   --  Global action, executed whenever an unhandled exception is raised.
+   --  Changing the export name must be coordinated with code in g-excact.adb.
+
    Raise_Hook_Initialized : Boolean := False;
    pragma Export
      (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
@@ -77,6 +88,11 @@ package body Exception_Traces is
    ----------------------
 
    procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is
+      --  Save actions locally to avoid any race condition that would
+      --  reset them to null.
+      Action           : constant Exception_Action := Global_Action;
+      Unhandled_Action : constant Exception_Action := Global_Unhandled_Action;
+
    begin
       --  Output the exception information required by the Exception_Trace
       --  configuration. Take care not to output information about internal
@@ -119,8 +135,12 @@ package body Exception_Traces is
          To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all);
       end if;
 
-      if Global_Action /= null then
-         Global_Action (Excep.all);
+      if Is_Unhandled and Unhandled_Action /= null then
+         Unhandled_Action (Excep.all);
+      end if;
+
+      if Action /= null then
+         Action (Excep.all);
       end if;
    end Notify_Exception;
 

diff --git a/gcc/ada/libgnat/g-excact.adb b/gcc/ada/libgnat/g-excact.adb
index 39eb5a5c518fb58395d4b1d741849eb260eae288..202d9e20ca114f3001c96fc27898749a22034a8e 100644 (file)
--- a/gcc/ada/libgnat/g-excact.adb
+++ b/gcc/ada/libgnat/g-excact.adb
@@ -38,9 +38,19 @@ with System.Exception_Table;  use System.Exception_Table;
 package body GNAT.Exception_Actions is
 
    Global_Action : Exception_Action;
-   pragma Import (C, Global_Action, "__gnat_exception_actions_global_action");
+   pragma Import
+     (Ada, Global_Action, "__gnat_exception_actions_global_action");
+   pragma Atomic (Global_Action);
    --  Imported from Ada.Exceptions. Any change in the external name needs to
-   --  be coordinated with a-except.adb
+   --  be coordinated with a-exextr.adb.
+
+   Global_Unhandled_Action : Exception_Action;
+   pragma Import
+     (Ada, Global_Unhandled_Action,
+      "__gnat_exception_actions_global_unhandled_action");
+   pragma Atomic (Global_Unhandled_Action);
+   --  Imported from Ada.Exceptions. Any change in the external name needs to
+   --  be coordinated with a-exextr.adb.
 
    Raise_Hook_Initialized : Boolean;
    pragma Import
@@ -61,11 +71,18 @@ package body GNAT.Exception_Actions is
 
    procedure Register_Global_Action (Action : Exception_Action) is
    begin
-      Lock_Task.all;
       Global_Action := Action;
-      Unlock_Task.all;
    end Register_Global_Action;
 
+   --------------------------------------
+   -- Register_Global_Unhandled_Action --
+   --------------------------------------
+
+   procedure Register_Global_Unhandled_Action (Action : Exception_Action) is
+   begin
+      Global_Unhandled_Action := Action;
+   end Register_Global_Unhandled_Action;
+
    ------------------------
    -- Register_Id_Action --
    ------------------------

diff --git a/gcc/ada/libgnat/g-excact.ads b/gcc/ada/libgnat/g-excact.ads
index 2aa0a7e8781c3935abb6fd1eccc455421a9fad71..c38f6a03761d15fad8cbec8fced5a5e21222ea13 100644 (file)
--- a/gcc/ada/libgnat/g-excact.ads
+++ b/gcc/ada/libgnat/g-excact.ads
@@ -57,6 +57,7 @@ package GNAT.Exception_Actions is
 
    type Exception_Action is access
      procedure (Occurrence : Exception_Occurrence);
+   pragma Favor_Top_Level (Exception_Action);
    --  General callback type whenever an exception is raised. The callback
    --  procedure must not propagate an exception (execution of the program
    --  is erroneous if such an exception is propagated).
@@ -69,6 +70,10 @@ package GNAT.Exception_Actions is
    --  Action is called before the exception is propagated to user's code.
    --  If Action is null, this will in effect cancel all exception actions.
 
+   procedure Register_Global_Unhandled_Action (Action : Exception_Action);
+   --  Similar to Register_Global_Action, called on unhandled exceptions
+   --  only.
+
    procedure Register_Id_Action
      (Id     : Exception_Id;
       Action : Exception_Action);

diff --git a/gcc/ada/libgnat/s-stalib.ads b/gcc/ada/libgnat/s-stalib.ads
index 0b38849361e6d7eeb3749e2933886d9092ea662f..5fbedae2e36ef690ad3294c188e48910e7f89a8a 100644 (file)
--- a/gcc/ada/libgnat/s-stalib.ads
+++ b/gcc/ada/libgnat/s-stalib.ads
@@ -81,6 +81,7 @@ package System.Standard_Library is
    -------------------------------------
 
    type Raise_Action is access procedure;
+   pragma Favor_Top_Level (Raise_Action);
    --  A pointer to a procedure used in the Raise_Hook field
 
    type Exception_Data;

diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 6f91dc14362411935531336f5ac81908532ed7d5..0158adcd320e2904a0478dcb1f1c141c54d3be61 100644 (file)
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -4330,11 +4330,10 @@ package body Sem_Warn is
                --  the message if the variable is volatile, has an address
                --  clause, is aliased, or is a renaming, or is imported.
 
-               if Referenced_As_LHS_Check_Spec (E)
-                 and then No (Address_Clause (E))
-                 and then not Is_Volatile (E)
-               then
+               if Referenced_As_LHS_Check_Spec (E) then
                   if Warn_On_Modified_Unread
+                    and then No (Address_Clause (E))
+                    and then not Is_Volatile (E)
                     and then not Is_Imported (E)
                     and then not Is_Aliased (E)
                     and then No (Renamed_Object (E))