@@ -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
@@ -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,
@@ -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.
@@ -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;
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 Tested on x86_64-pc-linux-gnu, committed on trunk 2018-05-23 Hristian Kirtchev <kirtchev@adacore.com> 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.