procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Suspension and elaboration warnings/checks

Browse source 
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  <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.

From-SVN: r260585
This commit is contained in:
Hristian Kirtchev 2018-05-23 10:22:52 +00:00 • committed by Pierre-Marie de Rodat
parent 51ab2a39e9
commit 0c9849e18b
5 changed files with 159 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
gcc/ada/ChangeLog
View file

@ -1,3 +1,20 @@
2018-05-23 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <miranda@adacore.com>
* exp_disp.adb (Make_DT): Restrict the initialization of

6
gcc/ada/debug.adb
View file

@ -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

10
gcc/ada/rtsfind.ads
View file

@ -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,

139
gcc/ada/sem_elab.adb
View file

@ -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.
-- 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 Nkind_In (Original_Node (Nod), N_Accept_Statement,
N_Selective_Accept)
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.

3
gcc/ada/switch-c.adb
View file

@ -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;