Patchwork [Ada] Indirect calls in static elaboration model

login
register
mail settings
Submitter Arnaud Charlet
Date March 15, 2012, 9:16 a.m.
Message ID <20120315091623.GA12275@adacore.com>
Download mbox | patch
Permalink /patch/146868/
State New
Headers show

Comments

Arnaud Charlet - March 15, 2012, 9:16 a.m.
This patch makes the static elaboration model more conservative in the case of
indirect calls, by treating Subp'Access as a call for elaboration purposes.

The following test should print 3, even when compiled with the binder switch
-p, which enables pessimistic (worst-case) elaboration order.

gnatmake -f a4 -bargs -p

Expected output:

warning: use of -p switch questionable
warning: since all units compiled with static elaboration model
 3

package a1 is
   function f return Integer;
end a1;

with a2;
package body a1 is
   function f return integer is
   begin
      return a2.f;
   end;
end a1;

package a2 is
   function f return Integer;
end a2;

package body a2 is
   function Ident (X : Integer) return Integer is
   begin
      return X;
   end;

   Var : Integer := Ident (3);

   function f return Integer is
   begin
      return Var;
   end f;
end a2;

with a1;
package a3 is
   type P is access function return Integer;
   PP : P := a1.f'Access;
   R  : Integer := PP.all;
end a3;

with a3;
with Text_IO; use Text_IO;
procedure a4 is
begin
   Put_Line (a3.R'Img);
end;

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

2012-03-15  Bob Duff  <duff@adacore.com>

	* debug.adb: Add new debug switch -gnatd.U, which disables the
	support added below, in case someone trips over a cycle, and needs
	to disable this.
	* sem_attr.adb (Analyze_Access_Attribute):
	Treat Subp'Access as a call for elaboration purposes.
	* sem_elab.ads, sem_elab.adb (Check_Elab_Call): Add support
	for Subp'Access.

Patch

Index: debug.adb
===================================================================
--- debug.adb	(revision 185390)
+++ debug.adb	(working copy)
@@ -138,7 +138,7 @@ 
    --  d.R
    --  d.S  Force Optimize_Alignment (Space)
    --  d.T  Force Optimize_Alignment (Time)
-   --  d.U
+   --  d.U  Ignore indirect calls for static elaboration
    --  d.V
    --  d.W  Print out debugging information for Walk_Library_Items
    --  d.X  Use Expression_With_Actions
@@ -642,6 +642,12 @@ 
 
    --  d.T  Force Optimize_Alignment (Time) mode as the default
 
+   --  d.U  Ignore indirect calls for static elaboration. The static
+   --       elaboration model is conservative, especially regarding indirect
+   --       calls. If you say Proc'Access, it will assume you might call
+   --       Proc. This can cause elaboration cycles at bind time. This flag
+   --       reverts to the behavior of earlier compilers.
+
    --  d.W  Print out debugging information for Walk_Library_Items, including
    --       the order in which units are walked. This is primarily for use in
    --       debugging CodePeer mode.
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 185420)
+++ sem_attr.adb	(working copy)
@@ -28,6 +28,7 @@ 
 with Atree;    use Atree;
 with Casing;   use Casing;
 with Checks;   use Checks;
+with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Eval_Fat;
@@ -54,6 +55,7 @@ 
 with Sem_Ch10; use Sem_Ch10;
 with Sem_Dim;  use Sem_Dim;
 with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
 with Sem_Elim; use Sem_Elim;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
@@ -644,6 +646,13 @@ 
                Kill_Current_Values;
             end if;
 
+            --  Treat as call for elaboration purposes and we are all
+            --  done. Suppress this treatment under debug flag.
+
+            if not Debug_Flag_Dot_UU then
+               Check_Elab_Call (N);
+            end if;
+
             return;
 
          --  Component is an operation of a protected type
Index: sem_elab.adb
===================================================================
--- sem_elab.adb	(revision 185390)
+++ sem_elab.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1997-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1997-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -180,7 +180,7 @@ 
       Inter_Unit_Only   : Boolean;
       Generate_Warnings : Boolean := True;
       In_Init_Proc      : Boolean := False);
-   --  This is the internal recursive routine that is called to check for a
+   --  This is the internal recursive routine that is called to check for
    --  possible elaboration error. The argument N is a subprogram call or
    --  generic instantiation to be checked, and E is the entity of the called
    --  subprogram, or instantiated generic unit. The flag Outer_Scope is the
@@ -188,8 +188,11 @@ 
    --  call is only to be checked in the case where it is to another unit (and
    --  skipped if within a unit). Generate_Warnings is set to False to suppress
    --  warning messages about missing pragma Elaborate_All's. These messages
-   --  are not wanted for inner calls in the dynamic model. Flag In_Init_Proc
-   --  should be set whenever the current context is a type init proc.
+   --  are not wanted for inner calls in the dynamic model. Note that an
+   --  instance of the Access attribute applied to a subprogram also generates
+   --  a call to this procedure (since the referenced subprogram may be called
+   --  later indirectly). Flag In_Init_Proc should be set whenever the current
+   --  context is a type init proc.
 
    procedure Check_Bad_Instantiation (N : Node_Id);
    --  N is a node for an instantiation (if called with any other node kind,
@@ -270,6 +273,13 @@ 
    --  On entry C_Scope is set to some scope. On return, C_Scope is reset
    --  to be the enclosing compilation unit of this scope.
 
+   function Get_Referenced_Ent (N : Node_Id) return Entity_Id;
+   --  N is either a function or procedure call or an access attribute that
+   --  references a subprogram. This call retrieves the relevant entity. If
+   --  this is a call to a protected subprogram, the entity is a selected
+   --  component. The callable entity may be absent, in which case Empty is
+   --  returned. This happens with non-analyzed calls in nested generics.
+
    procedure Set_Elaboration_Constraint
     (Call : Node_Id;
      Subp : Entity_Id;
@@ -827,15 +837,20 @@ 
          --  the init proc is in the root package, and we start from the entity
          --  of the name in the call.
 
-         if Is_Entity_Name (Name (N))
-           and then Is_Init_Proc (Entity (Name (N)))
-           and then not In_Same_Extended_Unit (N, Entity (Name (N)))
-         then
-            W_Scope := Scope (Entity (Name (N)));
-         else
-            W_Scope := E;
-         end if;
+         declare
+            Ent : constant Entity_Id := Get_Referenced_Ent (N);
+         begin
+            if Is_Init_Proc (Ent)
+              and then not In_Same_Extended_Unit (N, Ent)
+            then
+               W_Scope := Scope (Ent);
+            else
+               W_Scope := E;
+            end if;
+         end;
 
+         --  Now loop through scopes to get to the enclosing compilation unit
+
          while not Is_Compilation_Unit (W_Scope) loop
             W_Scope := Scope (W_Scope);
          end loop;
@@ -1126,36 +1141,6 @@ 
       Ent : Entity_Id;
       P   : Node_Id;
 
-      function Get_Called_Ent return Entity_Id;
-      --  Retrieve called entity. If this is a call to a protected subprogram,
-      --  entity is a selected component. The callable entity may be absent,
-      --  in which case there is no check to perform. This happens with
-      --  non-analyzed calls in nested generics.
-
-      --------------------
-      -- Get_Called_Ent --
-      --------------------
-
-      function Get_Called_Ent return Entity_Id is
-         Nam : Node_Id;
-
-      begin
-         Nam := Name (N);
-
-         if No (Nam) then
-            return Empty;
-
-         elsif Nkind (Nam) = N_Selected_Component then
-            return Entity (Selector_Name (Nam));
-
-         elsif not Is_Entity_Name (Nam) then
-            return Empty;
-
-         else
-            return Entity (Nam);
-         end if;
-      end Get_Called_Ent;
-
    --  Start of processing for Check_Elab_Call
 
    begin
@@ -1174,11 +1159,12 @@ 
       then
          Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
 
-      --  Nothing to do if this is not a call (happens in some error
-      --  conditions, and in some cases where rewriting occurs).
+      --  Nothing to do if this is not a call or attribute reference (happens
+      --  in some error conditions, and in some cases where rewriting occurs).
 
       elsif Nkind (N) /= N_Function_Call
         and then Nkind (N) /= N_Procedure_Call_Statement
+        and then Nkind (N) /= N_Attribute_Reference
       then
          return;
 
@@ -1267,6 +1253,7 @@ 
             if Comes_From_Source (N)
               and then In_Preelaborated_Unit
               and then not In_Inlined_Body
+              and then Nkind (N) /= N_Attribute_Reference
             then
                --  This is a warning in GNAT mode allowing such calls to be
                --  used in the predefined library with appropriate care.
@@ -1352,12 +1339,10 @@ 
 
                      elsif Dynamic_Elaboration_Checks then
 
-                        --  This is a rather new check, going into version
-                        --  3.14a1 for the first time (V1.80 of this unit), so
-                        --  we provide a debug flag to enable it. That way we
-                        --  have an easy work around for regressions that are
-                        --  caused by this new check. This debug flag can be
-                        --  removed later.
+                        --  We provide a debug flag to disable this check. That
+                        --  way we have an easy work around for regressions
+                        --  that are caused by this new check. This debug flag
+                        --  can be removed later.
 
                         if Debug_Flag_DD then
                            return;
@@ -1373,7 +1358,7 @@ 
                         --  but we need to capture local suppress pragmas
                         --  that may inhibit checks on this call.
 
-                        Ent := Get_Called_Ent;
+                        Ent := Get_Referenced_Ent (N);
 
                         if No (Ent) then
                            return;
@@ -1400,7 +1385,7 @@ 
          end if;
       end if;
 
-      Ent := Get_Called_Ent;
+      Ent := Get_Referenced_Ent (N);
 
       if No (Ent) then
          return;
@@ -2012,6 +1997,20 @@ 
 
             return OK;
 
+         --  If we have an access attribute for a subprogram, check
+         --  it. Suppress this behavior under debug flag.
+
+         elsif not Debug_Flag_Dot_UU
+           and then Nkind (N) = N_Attribute_Reference
+           and then (Attribute_Name (N) = Name_Access
+                       or else
+                     Attribute_Name (N) = Name_Unrestricted_Access)
+           and then Is_Entity_Name (Prefix (N))
+           and then Is_Subprogram (Entity (Prefix (N)))
+         then
+            Check_Elab_Call (N, Outer_Scope);
+            return OK;
+
          --  If we have a generic instantiation, check it
 
          elsif Nkind (N) in N_Generic_Instantiation then
@@ -2605,6 +2604,34 @@ 
       Set_Suppress_Elaboration_Warnings (Elab_Unit, True);
    end Set_Elaboration_Constraint;
 
+   ------------------------
+   -- Get_Referenced_Ent --
+   ------------------------
+
+   function Get_Referenced_Ent (N : Node_Id) return Entity_Id is
+      Nam : Node_Id;
+
+   begin
+      if Nkind (N) = N_Attribute_Reference then
+         Nam := Prefix (N);
+      else
+         Nam := Name (N);
+      end if;
+
+      if No (Nam) then
+         return Empty;
+
+      elsif Nkind (Nam) = N_Selected_Component then
+         return Entity (Selector_Name (Nam));
+
+      elsif not Is_Entity_Name (Nam) then
+         return Empty;
+
+      else
+         return Entity (Nam);
+      end if;
+   end Get_Referenced_Ent;
+
    ----------------------
    -- Has_Generic_Body --
    ----------------------
Index: sem_elab.ads
===================================================================
--- sem_elab.ads	(revision 185390)
+++ sem_elab.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1997-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1997-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -122,8 +122,9 @@ 
      (N            : Node_Id;
       Outer_Scope  : Entity_Id := Empty;
       In_Init_Proc : Boolean   := False);
-   --  Check a call for possible elaboration problems. The node N is either
-   --  an N_Function_Call or N_Procedure_Call_Statement node. The Outer_Scope
+   --  Check a call for possible elaboration problems. The node N is either an
+   --  N_Function_Call or N_Procedure_Call_Statement node or an access
+   --  attribute reference whose prefix is a subprogram. The Outer_Scope
    --  argument indicates whether this is an outer level call from Sem_Res
    --  (Outer_Scope set to Empty), or an internal recursive call (Outer_Scope
    --  set to entity of outermost call, see body). Flag In_Init_Proc should be