From 0c9849e18b134711873df3bccd93d6b6faa93c6f Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Wed, 23 May 2018 10:22:52 +0000 Subject: [PATCH] [Ada] Suspension and elaboration warnings/checks This patch modifies the static elaboration model to stop the inspection of a task body when it contains a synchronous suspension call and restriction No_Entry_Calls_In_Elaboration_Code or switch -gnatd_s is in effect. ------------ -- Source -- ------------ -- suspension.ads package Suspension is procedure ABE; task type Barrier_Task_1; task type Barrier_Task_2; task type Object_Task_1; task type Object_Task_2; end Suspension; -- suspension.adb with Ada.Synchronous_Barriers; use Ada.Synchronous_Barriers; with Ada.Synchronous_Task_Control; use Ada.Synchronous_Task_Control; package body Suspension is Bar : Synchronous_Barrier (Barrier_Limit'Last); Obj : Suspension_Object; task body Barrier_Task_1 is OK : Boolean; begin Wait_For_Release (Bar, OK); ABE; end Barrier_Task_1; task body Barrier_Task_2 is procedure Block is OK : Boolean; begin Wait_For_Release (Bar, OK); end Block; begin Block; ABE; end Barrier_Task_2; task body Object_Task_1 is begin Suspend_Until_True (Obj); ABE; end Object_Task_1; task body Object_Task_2 is procedure Block is begin Suspend_Until_True (Obj); end Block; begin Block; ABE; end Object_Task_2; function Elaborator return Boolean is BT_1 : Barrier_Task_1; BT_2 : Barrier_Task_2; OT_1 : Object_Task_1; OT_2 : Object_Task_2; begin return True; end Elaborator; Elab : constant Boolean := Elaborator; procedure ABE is begin null; end ABE; end Suspension; -- main.adb with Suspension; procedure Main is begin null; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnatd_s main.adb suspension.adb:23:07: warning: cannot call "ABE" before body seen suspension.adb:23:07: warning: Program_Error may be raised at run time suspension.adb:23:07: warning: body of unit "Suspension" elaborated suspension.adb:23:07: warning: function "Elaborator" called at line 51 suspension.adb:23:07: warning: local tasks of "Elaborator" activated suspension.adb:23:07: warning: procedure "ABE" called at line 23 suspension.adb:39:07: warning: cannot call "ABE" before body seen suspension.adb:39:07: warning: Program_Error may be raised at run time suspension.adb:39:07: warning: body of unit "Suspension" elaborated suspension.adb:39:07: warning: function "Elaborator" called at line 51 suspension.adb:39:07: warning: local tasks of "Elaborator" activated suspension.adb:39:07: warning: procedure "ABE" called at line 39 2018-05-23 Hristian Kirtchev gcc/ada/ * debug.adb: Switch -gnatd_s is now used to stop elaboration checks on synchronized suspension. * rtsfind.ads: Add entries for units Ada.Synchronous_Barriers and Ada.Synchronous_Task_Control and routines Suspend_Until_True and Wait_For_Release. * sem_elab.adb: Document switch -gnatd_s. (In_Task_Body): New routine. (Is_Potential_Scenario): Code cleanup. Stop the traversal of a task body when the current construct denotes a synchronous suspension call, and restriction No_Entry_Calls_In_Elaboration_Code or switch -gnatd_s is in effect. (Is_Synchronous_Suspension_Call): New routine. * switch-c.adb (Scan_Front_End_Switches): Switch -gnatJ now sets switch -gnatd_s. From-SVN: r260585 --- gcc/ada/ChangeLog | 17 ++++++ gcc/ada/debug.adb | 6 +- gcc/ada/rtsfind.ads | 10 +++ gcc/ada/sem_elab.adb | 141 ++++++++++++++++++++++++++++++++++++++----- gcc/ada/switch-c.adb | 3 + 5 files changed, 160 insertions(+), 17 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index abc289c419b..f24eda6a112 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2018-05-23 Hristian Kirtchev + + * debug.adb: Switch -gnatd_s is now used to stop elaboration checks on + synchronized suspension. + * rtsfind.ads: Add entries for units Ada.Synchronous_Barriers and + Ada.Synchronous_Task_Control and routines Suspend_Until_True and + Wait_For_Release. + * sem_elab.adb: Document switch -gnatd_s. + (In_Task_Body): New routine. + (Is_Potential_Scenario): Code cleanup. Stop the traversal of a task + body when the current construct denotes a synchronous suspension call, + and restriction No_Entry_Calls_In_Elaboration_Code or switch -gnatd_s + is in effect. + (Is_Synchronous_Suspension_Call): New routine. + * switch-c.adb (Scan_Front_End_Switches): Switch -gnatJ now sets switch + -gnatd_s. + 2018-05-23 Javier Miranda * exp_disp.adb (Make_DT): Restrict the initialization of diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index c9b4aad476b..032443309b8 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -163,7 +163,7 @@ package body Debug is -- d_p Ignore assertion pragmas for elaboration -- d_q -- d_r - -- d_s + -- d_s Stop elaboration checks on synchronous suspension -- d_t -- d_u -- d_v @@ -839,6 +839,10 @@ package body Debug is -- semantics of invariants and postconditions in both the static and -- dynamic elaboration models. + -- d_s The compiler stops the examination of a task body once it reaches + -- a call to routine Ada.Synchronous_Task_Control.Suspend_Until_True + -- or Ada.Synchronous_Barriers.Wait_For_Release. + -- d_L Output trace information on elaboration checking. This debug switch -- causes output to be generated showing each call or instantiation as -- it is checked, and the progress of the recursive trace through diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index b7d07660f1c..53852584c3e 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -131,6 +131,8 @@ package Rtsfind is Ada_Real_Time, Ada_Streams, Ada_Strings, + Ada_Synchronous_Barriers, + Ada_Synchronous_Task_Control, Ada_Tags, Ada_Task_Identification, Ada_Task_Termination, @@ -609,6 +611,10 @@ package Rtsfind is RE_Unbounded_String, -- Ada.Strings.Unbounded + RE_Wait_For_Release, -- Ada.Synchronous_Barriers + + RE_Suspend_Until_True, -- Ada.Synchronous_Task_Control + RE_Access_Level, -- Ada.Tags RE_Alignment, -- Ada.Tags RE_Address_Array, -- Ada.Tags @@ -1847,6 +1853,10 @@ package Rtsfind is RE_Unbounded_String => Ada_Strings_Unbounded, + RE_Wait_For_Release => Ada_Synchronous_Barriers, + + RE_Suspend_Until_True => Ada_Synchronous_Task_Control, + RE_Access_Level => Ada_Tags, RE_Alignment => Ada_Tags, RE_Address_Array => Ada_Tags, diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 72d80f81663..0b369ea91f6 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -500,6 +500,14 @@ package body Sem_Elab is -- As a result, the assertion expressions of the pragmas are not -- processed. -- + -- -gnatd_s stop elaboration checks on synchronous suspension + -- + -- The ABE mechanism stops the traversal of a task body when it + -- encounters a call to one of the following routines: + -- + -- Ada.Synchronous_Barriers.Wait_For_Release + -- Ada.Synchronous_Task_Control.Suspend_Until_True + -- -- -gnatd.U ignore indirect calls for static elaboration -- -- The ABE mechanism does not consider '[Unrestricted_]Access of @@ -554,6 +562,7 @@ package body Sem_Elab is -- -gnatd_i -- -gnatdL -- -gnatd_p + -- -gnatd_s -- -gnatd.U -- -gnatd.y -- @@ -1339,6 +1348,10 @@ package body Sem_Elab is -- context ignoring enclosing library levels. Nested_OK should be set when -- the context of N1 can enclose that of N2. + function In_Task_Body (N : Node_Id) return Boolean; + pragma Inline (In_Task_Body); + -- Determine whether arbitrary node N appears within a task body + procedure Info_Call (Call : Node_Id; Target_Id : Entity_Id; @@ -1592,6 +1605,14 @@ package body Sem_Elab is -- Determine whether arbitrary node N is a suitable variable reference for -- ABE processing. + function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean; + pragma Inline (Is_Synchronous_Suspension_Call); + -- Determine whether arbitrary node N denotes a call to one the following + -- routines: + -- + -- Ada.Synchronous_Barriers.Wait_For_Release + -- Ada.Synchronous_Task_Control.Suspend_Until_True + function Is_Task_Entry (Id : Entity_Id) return Boolean; pragma Inline (Is_Task_Entry); -- Determine whether arbitrary entity Id denotes a task entry @@ -6170,6 +6191,39 @@ package body Sem_Elab is return False; end In_Same_Context; + ------------------ + -- In_Task_Body -- + ------------------ + + function In_Task_Body (N : Node_Id) return Boolean is + Par : Node_Id; + + begin + -- Climb the parent chain looking for a task body [procedure] + + Par := N; + while Present (Par) loop + if Nkind (Par) = N_Task_Body then + return True; + + elsif Nkind (Par) = N_Subprogram_Body + and then Is_Task_Body_Procedure (Par) + then + return True; + + -- Prevent the search from going too far. Note that this predicate + -- shares nodes with the two cases above, and must come last. + + elsif Is_Body_Or_Package_Declaration (Par) then + return False; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Task_Body; + ---------------- -- Initialize -- ---------------- @@ -7553,6 +7607,33 @@ package body Sem_Elab is return Nkind (N) = N_Variable_Reference_Marker; end Is_Suitable_Variable_Reference; + ------------------------------------ + -- Is_Synchronous_Suspension_Call -- + ------------------------------------ + + function Is_Synchronous_Suspension_Call (N : Node_Id) return Boolean is + Call_Attrs : Call_Attributes; + Target_Id : Entity_Id; + + begin + -- To qualify, the call must invoke one of the runtime routines which + -- perform synchronous suspension. + + if Is_Suitable_Call (N) then + Extract_Call_Attributes + (Call => N, + Target_Id => Target_Id, + Attrs => Call_Attrs); + + return + Is_RTE (Target_Id, RE_Suspend_Until_True) + or else + Is_RTE (Target_Id, RE_Wait_For_Release); + end if; + + return False; + end Is_Synchronous_Suspension_Call; + ------------------- -- Is_Task_Entry -- ------------------- @@ -7770,7 +7851,7 @@ package body Sem_Elab is return Decl; -- Otherwise the construct terminates the region where the - -- preelabortion-related pragma may appear. + -- preelaboration-related pragma may appear. else exit; @@ -11110,24 +11191,52 @@ package body Sem_Elab is if Is_Non_Library_Level_Encapsulator (Nod) then return Skip; - -- Terminate the traversal of a task body with an accept statement - -- when no entry calls in elaboration are allowed because the task - -- will block at run-time and the remaining statements will not be - -- executed. - - elsif Nkind_In (Original_Node (Nod), N_Accept_Statement, - N_Selective_Accept) + -- Terminate the traversal of a task body when encountering an + -- accept or select statement, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the accept or select statement will cause the task + -- to block at elaboration time because there are no entry + -- calls to unblock it. + -- + -- or + -- + -- * Switch -gnatd_a (stop elaboration checks on accept or + -- select statement) is in effect. + + elsif (Debug_Flag_Underscore_A + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Nkind_In (Original_Node (Nod), N_Accept_Statement, + N_Selective_Accept) then - if Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then - return Abandon; + return Abandon; - -- The same behavior is achieved when switch -gnatd_a (stop - -- elabortion checks on accept or select statement) is in - -- effect. + -- Terminate the traversal of a task body when encountering a + -- suspension call, and + -- + -- * Entry calls during elaboration are not allowed. In this + -- case the suspension call emulates an entry call and will + -- cause the task to block at elaboration time. + -- + -- or + -- + -- * Switch -gnatd_s (stop elaboration checks on synchronous + -- suspension) is in effect. + -- + -- Note that the guard should not be checking the state of flag + -- Within_Task_Body because only suspension calls which appear + -- immediately within the statements of the task are supported. + -- Flag Within_Task_Body carries over to deeper levels of the + -- traversal. - elsif Debug_Flag_Underscore_A then - return Abandon; - end if; + elsif (Debug_Flag_Underscore_S + or else Restriction_Active + (No_Entry_Calls_In_Elaboration_Code)) + and then Is_Synchronous_Suspension_Call (Nod) + and then In_Task_Body (Nod) + then + return Abandon; -- Certain nodes carry semantic lists which act as repositories -- until expansion transforms the node and relocates the contents. diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 94a27035cf3..183d0efaf4f 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -974,6 +974,8 @@ package body Switch.C is -- -gnatd_i (ignore activations and calls to instances for -- elaboration) -- -gnatd_p (ignore assertion pragmas for elaboration) + -- -gnatd_s (stop elaboration checks on synchronous + -- suspension) -- -gnatdL (ignore external calls from instances for -- elaboration) @@ -982,6 +984,7 @@ package body Switch.C is Debug_Flag_Underscore_E := True; Debug_Flag_Underscore_I := True; Debug_Flag_Underscore_P := True; + Debug_Flag_Underscore_S := True; Debug_Flag_LL := True; end if; -- 2.30.2