[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.

4 files changed, 49 insertions, 6 deletions

diff --git a/gcc/ada/libgnat/a-exextr.adb b/gcc/ada/libgnat/a-exextr.adb
index 8789087..da66873 100644
--- 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 39eb5a5..202d9e2 100644
--- 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 2aa0a7e..c38f6a0 100644
--- 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 0b38849..5fbedae 100644
--- 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;