Provided to enhance the GNAT.Exception_Actions API and allowing
registration of an action on unhandled exceptions (e.g. Core_Dump).
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-04 Arnaud Charlet <char...@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.--- gcc/ada/libgnat/a-exextr.adb
+++ 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;
--- gcc/ada/libgnat/g-excact.adb
+++ 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 --
------------------------
--- gcc/ada/libgnat/g-excact.ads
+++ 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);
--- gcc/ada/libgnat/s-stalib.ads
+++ 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;
--- gcc/ada/sem_warn.adb
+++ 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))
