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

5 files changed, 160 insertions, 17 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index abc289c..f24eda6 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index c9b4aad..0324433 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 b7d0766..5385258 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 72d80f8..0b369ea 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 94a2703..183d0ef 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;