From: Arnaud Charlet Date: Wed, 22 Jan 2020 11:43:54 +0000 (-0500) Subject: [Ada] New procedure Register_Global_Unhandled_Action X-Git-Tag: basepoints/gcc-12~7352 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=528576de0bd3bf7154952d9b5e7ced2b4ed7f038;p=thirdparty%2Fgcc.git [Ada] New procedure Register_Global_Unhandled_Action 2020-06-04 Arnaud Charlet 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 87890875e474..da66873d02db 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 39eb5a5c518f..202d9e20ca11 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 2aa0a7e8781c..c38f6a03761d 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 0b38849361e6..5fbedae2e36e 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; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 6f91dc143624..0158adcd320e 100644 --- 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))