[Ada] Ignore external calls from instances for elaboration

Message ID 20171215102224.GA7559@adacore.com
State New
Headers show
Series
  • [Ada] Ignore external calls from instances for elaboration
Related show

Commit Message

Pierre-Marie de Rodat Dec. 15, 2017, 10:22 a.m.
This patch restores the functionality of debug switch -gnatdL to the behavior
prior to revision 255412.  The existing behavior has been associated with
switch -gnatd_i.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>

	* debug.adb: Move the functionality of -gnatdL to -gnatd_i. Restore
	the behavior of -gnatdL from before revision 255412.
	* sem_elab.adb: Update the section of compiler switches.
	(Build_Call_Marker): Do not create a marker for a call which originates
	from an expanded spec or body of an instantiated gener, does not invoke
	a generic formal subprogram, the target is external to the instance,
	and -gnatdL is in effect.
	(In_External_Context): New routine.
	(Process_Conditional_ABE_Activation_Impl): Update the uses of -gnatdL
	and associated flag.
	(Process_Conditional_ABE_Call): Update the uses of -gnatdL and
	associated flag.
	* switch-c.adb (Scan_Front_End_Switches): Switch -gnatJ now sets switch
	-gnatd_i.
	* exp_unst.adb: Minor typo fixes and edits.

gcc/testsuite/

2017-12-15  Hristian Kirtchev  <kirtchev@adacore.com>

	* gnat.dg/abe_pkg.adb, gnat.dg/abe_pkg.ads: New testcase.

Patch

Index: checks.adb
===================================================================
--- checks.adb	(revision 255678)
+++ checks.adb	(working copy)
@@ -6819,7 +6819,7 @@ 
 
       if Nkind (N) /= N_Attribute_Reference
         and then (not Is_Entity_Name (N)
-                    or else Treat_As_Volatile (Entity (N)))
+                   or else Treat_As_Volatile (Entity (N)))
       then
          Force_Evaluation (N, Mode => Strict);
       end if;
Index: debug.adb
===================================================================
--- debug.adb	(revision 255678)
+++ debug.adb	(working copy)
@@ -153,7 +153,7 @@ 
    --  d_f
    --  d_g
    --  d_h
-   --  d_i
+   --  d_i  Ignore activations and calls to instances for elaboration
    --  d_j
    --  d_k
    --  d_l
@@ -479,8 +479,8 @@ 
    --       error messages are target dependent and irrelevant.
 
    --  dL   The compiler ignores calls in instances and invoke subprograms
-   --       which are external to the instance for the static elaboration
-   --       model. This switch is orthogonal to d.G.
+   --       which are external to the instance for both the static and dynamic
+   --       elaboration models.
 
    --  dM   Assume all variables have been modified, and ignore current value
    --       indications. This debug flag disconnects the tracking of constant
@@ -734,8 +734,7 @@ 
    --  d.G  Previously the compiler ignored calls via generic formal parameters
    --       when doing the analysis for the static elaboration model. This is
    --       now fixed, but we provide this debug flag to revert to the previous
-   --       situation of ignoring such calls to aid in transition. This switch
-   --       is orthogonal to dL.
+   --       situation of ignoring such calls to aid in transition.
 
    --  d.H  Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
    --       the call to gigi in ASIS_Mode.
@@ -832,6 +831,10 @@ 
    --       control, conditional entry calls, timed entry calls, and requeue
    --       statements in both the static and dynamic elaboration models.
 
+   --  d_i  The compiler ignores calls and task activations when they target a
+   --       subprogram or task type defined in an external instance for both
+   --       the static and dynamic elaboration models.
+
    --  d_p  The compiler ignores calls to subprograms which verify the run-time
    --       semantics of invariants and postconditions in both the static and
    --       dynamic elaboration models.
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb	(revision 255680)
+++ exp_ch6.adb	(working copy)
@@ -5356,7 +5356,7 @@ 
 
                          Else_Statements => New_List (
                            Make_Raise_Program_Error (Loc,
-                              Reason => PE_All_Guards_Closed)));
+                             Reason => PE_All_Guards_Closed)));
 
                      --  If a separate initialization assignment was created
                      --  earlier, append that following the assignment of the
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 255680)
+++ exp_ch7.adb	(working copy)
@@ -4200,13 +4200,11 @@ 
    ----------------------------
 
    procedure Expand_Cleanup_Actions (N : Node_Id) is
-      pragma Assert
-        (Nkind_In (N,
-                   N_Extended_Return_Statement,
-                   N_Block_Statement,
-                   N_Subprogram_Body,
-                   N_Task_Body,
-                   N_Entry_Body));
+      pragma Assert (Nkind_In (N, N_Block_Statement,
+                                  N_Entry_Body,
+                                  N_Extended_Return_Statement,
+                                  N_Subprogram_Body,
+                                  N_Task_Body));
 
       Scop : constant Entity_Id := Current_Scope;
 
@@ -4311,11 +4309,13 @@ 
       end if;
 
       --  If an extended return statement contains something like
+      --
       --     X := F (...);
+      --
       --  where F is a build-in-place function call returning a controlled
-      --  type, then a temporary object will be implicitly declared as part of
-      --  the statement list, and this will need cleanup. In such cases, we
-      --  transform:
+      --  type, then a temporary object will be implicitly declared as part
+      --  of the statement list, and this will need cleanup. In such cases,
+      --  we transform:
       --
       --    return Result : T := ... do
       --       <statements> -- possibly with handlers
@@ -4336,14 +4336,15 @@ 
       if Nkind (N) = N_Extended_Return_Statement then
          declare
             Block : constant Node_Id :=
-              Make_Block_Statement (Sloc (N),
-               Declarations => Empty_List,
-               Handled_Statement_Sequence =>
-                 Handled_Statement_Sequence (N));
+                      Make_Block_Statement (Sloc (N),
+                        Declarations               => Empty_List,
+                        Handled_Statement_Sequence =>
+                          Handled_Statement_Sequence (N));
          begin
-            Set_Handled_Statement_Sequence
-              (N, Make_Handled_Sequence_Of_Statements (Sloc (N),
-                    Statements => New_List (Block)));
+            Set_Handled_Statement_Sequence (N,
+              Make_Handled_Sequence_Of_Statements (Sloc (N),
+                Statements => New_List (Block)));
+
             Analyze (Block);
          end;
 
Index: exp_unst.adb
===================================================================
--- exp_unst.adb	(revision 255680)
+++ exp_unst.adb	(working copy)
@@ -302,6 +302,16 @@ 
          return;
       end if;
 
+      --  If the main unit is a package body then we need to examine the spec
+      --  to determine whether the main unit is generic (the scope stack is not
+      --  present when this is called on the main unit).
+
+      if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
+        and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
+      then
+         return;
+      end if;
+
       --  At least for now, do not unnest anything but main source unit
 
       if not In_Extended_Main_Source_Unit (Subp_Body) then
@@ -553,8 +563,8 @@ 
                Ent := Entity (Name (N));
 
                --  We are only interested in calls to subprograms nested
-               --  within Subp. Calls to Subp itself or to subprograms that
-               --  are outside the nested structure do not affect us.
+               --  within Subp. Calls to Subp itself or to subprograms
+               --  that are outside the nested structure do not affect us.
 
                if Scope_Within (Ent, Subp) then
 
@@ -1653,7 +1663,6 @@ 
             if Present (STT.ARECnF)
               and then Nkind (CTJ.N) /= N_Attribute_Reference
             then
-
                --  CTJ.N is a call to a subprogram which may require a pointer
                --  to an activation record. The subprogram containing the call
                --  is CTJ.From and the subprogram being called is CTJ.To, so we
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 255678)
+++ exp_util.adb	(working copy)
@@ -10701,8 +10701,8 @@ 
               and then not Is_Empty_List (Then_Statements (N))
               and then not Are_Wrapped (Then_Statements (N))
               and then Requires_Cleanup_Actions
-                         (Then_Statements (N),
-                          Lib_Level => False,
+                         (L                 => Then_Statements (N),
+                          Lib_Level         => False,
                           Nested_Constructs => False)
             then
                Block := Wrap_Statements_In_Block (Then_Statements (N));
@@ -10720,8 +10720,8 @@ 
               and then not Is_Empty_List (Else_Statements (N))
               and then not Are_Wrapped (Else_Statements (N))
               and then Requires_Cleanup_Actions
-                         (Else_Statements (N),
-                          Lib_Level => False,
+                         (L                 => Else_Statements (N),
+                          Lib_Level         => False,
                           Nested_Constructs => False)
             then
                Block := Wrap_Statements_In_Block (Else_Statements (N));
@@ -10742,8 +10742,8 @@ 
             if not Is_Empty_List (Statements (N))
               and then not Are_Wrapped (Statements (N))
               and then Requires_Cleanup_Actions
-                         (Statements (N),
-                          Lib_Level => False,
+                         (L                 => Statements (N),
+                          Lib_Level         => False,
                           Nested_Constructs => False)
             then
                if Nkind (N) = N_Loop_Statement
@@ -11822,14 +11822,18 @@ 
             | N_Task_Body
          =>
             return
-              Requires_Cleanup_Actions
-                (Declarations (N), At_Lib_Level, Nested_Constructs => True)
-                or else
-                  (Present (Handled_Statement_Sequence (N))
-                    and then
-                      Requires_Cleanup_Actions
-                        (Statements (Handled_Statement_Sequence (N)),
-                         At_Lib_Level, Nested_Constructs => True));
+                Requires_Cleanup_Actions
+                  (L                 => Declarations (N),
+                   Lib_Level         => At_Lib_Level,
+                   Nested_Constructs => True)
+              or else
+                (Present (Handled_Statement_Sequence (N))
+                  and then
+                    Requires_Cleanup_Actions
+                      (L                 =>
+                         Statements (Handled_Statement_Sequence (N)),
+                       Lib_Level         => At_Lib_Level,
+                       Nested_Constructs => True));
 
          --  Extended return statements are the same as the above, except that
          --  there is no Declarations field. We do not want to clean up the
@@ -11837,20 +11841,24 @@ 
 
          when N_Extended_Return_Statement =>
             return
-               Present (Handled_Statement_Sequence (N))
-               and then Requires_Cleanup_Actions
-                          (Statements (Handled_Statement_Sequence (N)),
-                           At_Lib_Level, Nested_Constructs => True);
+              Present (Handled_Statement_Sequence (N))
+                and then Requires_Cleanup_Actions
+                           (L                 =>
+                              Statements (Handled_Statement_Sequence (N)),
+                            Lib_Level         => At_Lib_Level,
+                            Nested_Constructs => True);
 
          when N_Package_Specification =>
             return
-              Requires_Cleanup_Actions
-                (Visible_Declarations (N), At_Lib_Level,
-                 Nested_Constructs => True)
-                  or else
-              Requires_Cleanup_Actions
-                (Private_Declarations (N), At_Lib_Level,
-                 Nested_Constructs => True);
+                Requires_Cleanup_Actions
+                  (L                 => Visible_Declarations (N),
+                   Lib_Level         => At_Lib_Level,
+                   Nested_Constructs => True)
+              or else
+                Requires_Cleanup_Actions
+                  (L                 => Private_Declarations (N),
+                   Lib_Level         => At_Lib_Level,
+                   Nested_Constructs => True);
 
          when others =>
             raise Program_Error;
Index: libgnat/s-tsmona.adb
===================================================================
--- libgnat/s-tsmona.adb	(revision 255678)
+++ libgnat/s-tsmona.adb	(working copy)
@@ -48,9 +48,9 @@ 
    -- Get --
    ---------
 
-   function Get (Addr : System.Address;
-                 Load_Addr : access System.Address)
-      return String
+   function Get
+     (Addr      : System.Address;
+      Load_Addr : access System.Address) return String
    is
       pragma Unreferenced (Addr);
       pragma Unreferenced (Load_Addr);
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 255678)
+++ rtsfind.ads	(working copy)
@@ -542,8 +542,8 @@ 
 
      RE_Null,
 
+     RO_CA_Clock_Time,                   -- Ada.Calendar
      RO_CA_Time,                         -- Ada.Calendar
-     RO_CA_Clock_Time,                   -- Ada.Calendar
 
      RO_CA_Delay_For,                    -- Ada.Calendar.Delays
      RO_CA_Delay_Until,                  -- Ada.Calendar.Delays
@@ -1780,8 +1780,8 @@ 
 
      RE_Null                             => RTU_Null,
 
+     RO_CA_Clock_Time                    => Ada_Calendar,
      RO_CA_Time                          => Ada_Calendar,
-     RO_CA_Clock_Time                    => Ada_Calendar,
 
      RO_CA_Delay_For                     => Ada_Calendar_Delays,
      RO_CA_Delay_Until                   => Ada_Calendar_Delays,
Index: sem_elab.adb
===================================================================
--- sem_elab.adb	(revision 255678)
+++ sem_elab.adb	(working copy)
@@ -405,12 +405,20 @@ 
    --           actual subprograms through generic formal subprograms. As a
    --           result, the calls are not recorded or processed.
    --
-   --  -gnatdL  ignore activations and calls to instances for elaboration
+   --  -gnatd_i ignore activations and calls to instances for elaboration
    --
    --           The ABE mechanism ignores calls and task activations when they
    --           target a subprogram or task type defined an external instance.
    --           As a result, the calls and task activations are not processed.
    --
+   --  -gnatdL  ignore external calls from instances for elaboration
+   --
+   --           The ABE mechanism does not generate N_Call_Marker nodes for
+   --           calls which occur in expanded instances, do not invoke generic
+   --           actual subprograms through formal subprograms, and the target
+   --           is external to the instance. As a result, the calls are not
+   --           recorded or processed.
+   --
    --  -gnatd.o conservative elaboration order for indirect calls
    --
    --           The ABE mechanism treats '[Unrestricted_]Access of an entry,
@@ -488,6 +496,7 @@ 
    --              -gnatd_a
    --              -gnatd_e
    --              -gnatd.G
+   --              -gnatd_i
    --              -gnatdL
    --              -gnatd_p
    --              -gnatd.U
@@ -1781,6 +1790,13 @@ 
    -----------------------
 
    procedure Build_Call_Marker (N : Node_Id) is
+      function In_External_Context
+        (Call         : Node_Id;
+         Target_Attrs : Target_Attributes) return Boolean;
+      pragma Inline (In_External_Context);
+      --  Determine whether a target described by attributes Target_Attrs is
+      --  external to call Call which must reside within an instance.
+
       function In_Premature_Context (Call : Node_Id) return Boolean;
       --  Determine whether call Call appears within a premature context
 
@@ -1798,6 +1814,55 @@ 
       --  Determine whether subprogram Subp_Id denotes a generic formal
       --  subprogram which appears in the "prologue" of an instantiation.
 
+      -------------------------
+      -- In_External_Context --
+      -------------------------
+
+      function In_External_Context
+        (Call         : Node_Id;
+         Target_Attrs : Target_Attributes) return Boolean
+      is
+         Inst      : Node_Id;
+         Inst_Body : Node_Id;
+         Inst_Decl : Node_Id;
+
+      begin
+         --  Performance note: parent traversal
+
+         Inst := Find_Enclosing_Instance (Call);
+
+         --  The call appears within an instance
+
+         if Present (Inst) then
+
+            --  The call comes from the main unit and the target does not
+
+            if In_Extended_Main_Code_Unit (Call)
+              and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl)
+            then
+               return True;
+
+            --  Otherwise the target declaration must not appear within the
+            --  instance spec or body.
+
+            else
+               Extract_Instance_Attributes
+                 (Exp_Inst  => Inst,
+                  Inst_Decl => Inst_Decl,
+                  Inst_Body => Inst_Body);
+
+               --  Performance note: parent traversal
+
+               return not In_Subtree
+                            (N     => Target_Attrs.Spec_Decl,
+                             Root1 => Inst_Decl,
+                             Root2 => Inst_Body);
+            end if;
+         end if;
+
+         return False;
+      end In_External_Context;
+
       --------------------------
       -- In_Premature_Context --
       --------------------------
@@ -1987,11 +2052,28 @@ 
         (Target_Id => Target_Id,
          Attrs     => Target_Attrs);
 
+      --  Nothing to do when the call appears within the expanded spec or
+      --  body of an instantiated generic, the call does not invoke a generic
+      --  formal subprogram, the target is external to the instance, and switch
+      --  -gnatdL (ignore external calls from instances for elaboration) is in
+      --  effect.
+
+      if Debug_Flag_LL
+        and then not Is_Generic_Formal_Subp (Entity (Call_Nam))
+
+        --  Performance note: parent traversal
+
+        and then In_External_Context
+                   (Call         => N,
+                    Target_Attrs => Target_Attrs)
+      then
+         return;
+
       --  Nothing to do when the call invokes an assertion pragma procedure
       --  and switch -gnatd_p (ignore assertion pragmas for elaboration) is
       --  in effect.
 
-      if Debug_Flag_Underscore_P
+      elsif Debug_Flag_Underscore_P
         and then Is_Assertion_Pragma_Target (Target_Id)
       then
          return;
@@ -8611,10 +8693,10 @@ 
       end if;
 
       --  Nothing to do when the call activates a task whose type is defined
-      --  within an instance and switch -gnatdL (ignore activations and calls
+      --  within an instance and switch -gnatd_i (ignore activations and calls
       --  to instances for elaboration) is in effect.
 
-      if Debug_Flag_LL
+      if Debug_Flag_Underscore_I
         and then In_External_Instance
                    (N           => Call,
                     Target_Decl => Task_Attrs.Task_Decl)
@@ -8980,10 +9062,10 @@ 
       end if;
 
       --  Nothing to do when the call invokes a target defined within an
-      --  instance and switch -gnatdL (ignore activations and calls to
+      --  instance and switch -gnatd_i (ignore activations and calls to
       --  instances for elaboration) is in effect.
 
-      if Debug_Flag_LL
+      if Debug_Flag_Underscore_I
         and then In_External_Instance
                    (N           => Call,
                     Target_Decl => Target_Attrs.Spec_Decl)
Index: switch-c.adb
===================================================================
--- switch-c.adb	(revision 255678)
+++ switch-c.adb	(working copy)
@@ -950,11 +950,11 @@ 
 
                --  Common relaxations for both ABE mechanisms
                --
-               --  -gnatd.G (ignore calls through generic formal parameters for
-               --            elaboration)
-               --  -gnatd.U (ignore indirect calls for static elaboration)
-               --  -gnatd.y (disable implicit pragma Elaborate_All on task
-               --            bodies)
+               --    -gnatd.G (ignore calls through generic formal parameters
+               --              for elaboration)
+               --    -gnatd.U (ignore indirect calls for static elaboration)
+               --    -gnatd.y (disable implicit pragma Elaborate_All on task
+               --              bodies)
 
                Debug_Flag_Dot_GG := True;
                Debug_Flag_Dot_UU := True;
@@ -967,17 +967,20 @@ 
 
                --  Relaxations to the default ABE mechanism
                --
-               --  -gnatd_a (stop elaboration checks on accept or select
-               --            statement)
-               --  -gnatd_e (ignore entry calls and requeue statements for
-               --            elaboration)
-               --  -gnatd_p (ignore assertion pragmas for elaboration)
-               --  -gnatdL  (ignore activations and calls to instances for
-               --            elaboration)
+               --    -gnatd_a (stop elaboration checks on accept or select
+               --              statement)
+               --    -gnatd_e (ignore entry calls and requeue statements for
+               --              elaboration)
+               --    -gnatd_i (ignore activations and calls to instances for
+               --              elaboration)
+               --    -gnatd_p (ignore assertion pragmas for elaboration)
+               --    -gnatdL  (ignore external calls from instances for
+               --              elaboration)
 
                else
                   Debug_Flag_Underscore_A := True;
                   Debug_Flag_Underscore_E := True;
+                  Debug_Flag_Underscore_I := True;
                   Debug_Flag_Underscore_P := True;
                   Debug_Flag_LL           := True;
                end if;
Index: ../testsuite/gnat.dg/abe_pkg.ads
===================================================================
--- ../testsuite/gnat.dg/abe_pkg.ads	(revision 0)
+++ ../testsuite/gnat.dg/abe_pkg.ads	(revision 0)
@@ -0,0 +1,8 @@ 
+package ABE_Pkg is
+   procedure ABE;
+
+   generic
+   package Gen is
+      procedure Force_Body;
+   end Gen;
+end ABE_Pkg;
Index: ../testsuite/gnat.dg/abe_pkg.adb
===================================================================
--- ../testsuite/gnat.dg/abe_pkg.adb	(revision 0)
+++ ../testsuite/gnat.dg/abe_pkg.adb	(revision 0)
@@ -0,0 +1,13 @@ 
+--  { dg-do compile }
+--  { dg-options "-gnatJ" }
+package body ABE_Pkg is
+   package body Gen is
+      procedure Force_Body is begin null; end Force_Body;
+   begin
+      ABE;
+   end Gen;
+
+   package Inst is new Gen;
+
+   procedure ABE is begin null; end ABE;
+end ABE_Pkg;