[Ada] Remove restriction on inlining in related units

[Eric Botcazou <ebotcazou@adacore.com>]

[-- Attachment #1: Type: text/plain, Size: 2371 bytes --]

This change makes it possible for the compiler to inline into a child package
a subprogram declared in a parent package, even if the parent package has a
with clause for the child package in the body.  It also fixes segfaults that
can occur when inlining into a package a subprogram coming from an unrelated
package containing a Taft Amendment type that closes a dependency cycle with
at least one member type declared in the first package.

The following code must compile quietly with -O -gnatn -Winline:

package Buf.Support is
  type Sup_T is new Integer;
  procedure Doit (Obj : T);
end Buf.Support;

package body Buf.Support is
  procedure Doit (Obj : T) is
  begin
    if Buf.Get_Support (Obj) > 100 then
      raise Program_Error;
    end if;
  end Doit;
end Buf.Support;

limited with Buf.Support;

package Buf is
  type T is limited private;
  function Get_Support (Obj : T) return Buf.Support.Sup_T with Inline;
private
  type T is new Integer;
end Buf;

with Buf.Support;

package body Buf is
  function Get_Support (Obj : T) return Buf.Support.Sup_T is
  begin
    return Buf.Support.Sup_T (Obj + 1);
  end Get_Support;
end Buf;

Tested on x86_64-suse-linux, applied on the mainline.


2017-05-22  Ed Schonberg  <schonberg@adacore.com>
            Eric Botcazou  <ebotcazou@adacore.com>

	* sem_ch4.adb (Analyze_Call): In Ada2012 an incomplete type from a
	limited view may appear in the profile of a function, and a call to
	that function in another unit in which the full view is available must
	use this full view to spurious type errors at the point of call.
	* inline.adb (Analyze_Inlined_Bodies): Remove restriction on loading
	of parent body with a with clause for the main unit.
	* gcc-interface/decl.c (defer_limited_with_list): Document new usage.
	(gnat_to_gnu_entity) <E_Access_Type>: Handle completed Taft Amendment
	types declared in external units like types from limited with clauses.
	Adjust final processing of defer_limited_with_list accordingly.
	* gcc-interface/trans.c (gnat_to_gnu) < N_Selected_Component>: Try
	again to translate the prefix after the field if it is incomplete.


2017-05-22  Eric Botcazou  <ebotcazou@adacore.com>

	* gnat.dg/limited_with5.ad[sb]: New test.
	* gnat.dg/limited_with5_pkg.ad[sb]: New helper.
	* gnat.dg/limited_with6.ad[sb]: New test.
	* gnat.dg/limited_with6_pkg.ad[sb]: New helper.

-- 
Eric Botcazou

[-- Attachment #2: p.diff --]
[-- Type: text/x-patch, Size: 11331 bytes --]

Index: gcc-interface/decl.c
===================================================================
--- gcc-interface/decl.c	(revision 248320)
+++ gcc-interface/decl.c	(working copy)
@@ -101,8 +101,8 @@ struct incomplete
 static int defer_incomplete_level = 0;
 static struct incomplete *defer_incomplete_list;
 
-/* This variable is used to delay expanding From_Limited_With types until the
-   end of the spec.  */
+/* This variable is used to delay expanding types coming from a limited with
+   clause and completed Taft Amendment types until the end of the spec.  */
 static struct incomplete *defer_limited_with_list;
 
 typedef struct subst_pair_d {
@@ -3580,6 +3580,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	const bool is_from_limited_with
 	  = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
 	     && From_Limited_With (gnat_desig_equiv));
+	/* Whether it is a completed Taft Amendment type.  Such a type is to
+	   be treated as coming from a limited with clause if it is not in
+	   the main unit, i.e. we break potential circularities here in case
+	   the body of an external unit is loaded for inter-unit inlining.  */
+        const bool is_completed_taft_type
+	  = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
+	     && Has_Completion_In_Body (gnat_desig_equiv)
+	     && Present (Full_View (gnat_desig_equiv)));
 	/* The "full view" of the designated type.  If this is an incomplete
 	   entity from a limited with, treat its non-limited view as the full
 	   view.  Otherwise, if this is an incomplete or private type, use the
@@ -3646,13 +3654,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 
 	/* Get the type of the thing we are to point to and build a pointer to
 	   it.  If it is a reference to an incomplete or private type with a
-	   full view that is a record or an array, make a dummy type node and
-	   get the actual type later when we have verified it is safe.  */
+	   full view that is a record, an array or an access, make a dummy type
+	   and get the actual type later when we have verified it is safe.  */
 	else if ((!in_main_unit
 		  && !present_gnu_tree (gnat_desig_equiv)
 		  && Present (gnat_desig_full)
 		  && (Is_Record_Type (gnat_desig_full)
-		      || Is_Array_Type (gnat_desig_full)))
+		      || Is_Array_Type (gnat_desig_full)
+		      || Is_Access_Type (gnat_desig_full)))
 		 /* Likewise if this is a reference to a record, an array or a
 		    subprogram type and we are to defer elaborating incomplete
 		    types.  We do this because this access type may be the full
@@ -3763,7 +3772,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	    save_gnu_tree (gnat_entity, gnu_decl, false);
 	    saved = true;
 
-	    if (defer_incomplete_level == 0 && !is_from_limited_with)
+	    if (defer_incomplete_level == 0
+		&& !is_from_limited_with
+		&& !is_completed_taft_type)
 	      {
 		update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
 				   gnat_to_gnu_type (gnat_desig_equiv));
@@ -3772,7 +3783,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	      {
 		struct incomplete *p = XNEW (struct incomplete);
 		struct incomplete **head
-		  = (is_from_limited_with
+		  = (is_from_limited_with || is_completed_taft_type
 		     ? &defer_limited_with_list : &defer_incomplete_list);
 
 		p->old_type = gnu_desig_type;
@@ -4766,7 +4777,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entit
 	  }
 
       for (p = defer_limited_with_list; p; p = p->next)
-	if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
+	if (p->old_type
+	    && (Non_Limited_View (p->full_type) == gnat_entity
+		|| Full_View (p->full_type) == gnat_entity))
 	  {
 	    update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
 			       TREE_TYPE (gnu_decl));
Index: gcc-interface/trans.c
===================================================================
--- gcc-interface/trans.c	(revision 248140)
+++ gcc-interface/trans.c	(working copy)
@@ -6413,7 +6413,6 @@ gnat_to_gnu (Node_Id gnat_node)
 	Entity_Id gnat_prefix = Prefix (gnat_node);
 	Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
 	tree gnu_prefix = gnat_to_gnu (gnat_prefix);
-	tree gnu_field;
 
 	gnu_prefix = maybe_implicit_deref (gnu_prefix);
 
@@ -6442,8 +6441,19 @@ gnat_to_gnu (Node_Id gnat_node)
 				       NULL_TREE, gnu_prefix);
 	else
 	  {
-	    gnu_field = gnat_to_gnu_field_decl (gnat_field);
+	    tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
 
+	    /* If the prefix has incomplete type, try again to translate it.
+	       The idea is that the translation of the field just above may
+	       have completed it through gnat_to_gnu_entity, in case it is
+	       the dereference of an access to Taft Amendment type used in
+	       the instantiation of a generic body from an external unit.  */
+	    if (!COMPLETE_TYPE_P (TREE_TYPE (gnu_prefix)))
+	      {
+		gnu_prefix = gnat_to_gnu (gnat_prefix);
+		gnu_prefix = maybe_implicit_deref (gnu_prefix);
+	      }
+		
 	    gnu_result
 	      = build_component_ref (gnu_prefix, gnu_field,
 				     (Nkind (Parent (gnat_node))
Index: inline.adb
===================================================================
--- inline.adb	(revision 248140)
+++ inline.adb	(working copy)
@@ -667,57 +667,6 @@ package body Inline is
          Table_Name           => "Pending_Inlined");
       --  The workpile used to compute the transitive closure
 
-      function Is_Ancestor_Of_Main
-        (U_Name : Entity_Id;
-         Nam    : Node_Id) return Boolean;
-      --  Determine whether the unit whose body is loaded is an ancestor of
-      --  the main unit, and has a with_clause on it. The body is not
-      --  analyzed yet, so the check is purely lexical: the name of the with
-      --  clause is a selected component, and names of ancestors must match.
-
-      -------------------------
-      -- Is_Ancestor_Of_Main --
-      -------------------------
-
-      function Is_Ancestor_Of_Main
-        (U_Name : Entity_Id;
-         Nam    : Node_Id) return Boolean
-      is
-         Pref : Node_Id;
-
-      begin
-         if Nkind (Nam) /= N_Selected_Component then
-            return False;
-
-         else
-            if Chars (Selector_Name (Nam)) /=
-               Chars (Cunit_Entity (Main_Unit))
-            then
-               return False;
-            end if;
-
-            Pref := Prefix (Nam);
-            if Nkind (Pref) = N_Identifier then
-
-               --  Par is an ancestor of Par.Child.
-
-               return Chars (Pref) = Chars (U_Name);
-
-            elsif Nkind (Pref) = N_Selected_Component
-              and then Chars (Selector_Name (Pref)) = Chars (U_Name)
-            then
-               --  Par.Child is an ancestor of Par.Child.Grand.
-
-               return True;   --  should check that ancestor match
-
-            else
-               --  A is an ancestor of A.B.C if it is an ancestor of A.B
-
-               return Is_Ancestor_Of_Main (U_Name, Pref);
-            end if;
-         end if;
-      end Is_Ancestor_Of_Main;
-
    --  Start of processing for Analyze_Inlined_Bodies
 
    begin
@@ -766,7 +715,7 @@ package body Inline is
                begin
                   if not Is_Loaded (Bname) then
                      Style_Check := False;
-                     Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False);
+                     Load_Needed_Body (Comp_Unit, OK);
 
                      if not OK then
 
@@ -780,43 +729,6 @@ package body Inline is
                         Error_Msg_File_1 :=
                           Get_File_Name (Bname, Subunit => False);
                         Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
-
-                     else
-                        --  If the package to be inlined is an ancestor unit of
-                        --  the main unit, and it has a semantic dependence on
-                        --  it, the inlining cannot take place to prevent an
-                        --  elaboration circularity. The desired body is not
-                        --  analyzed yet, to prevent the completion of Taft
-                        --  amendment types that would lead to elaboration
-                        --  circularities in gigi.
-
-                        declare
-                           U_Id      : constant Entity_Id :=
-                                         Defining_Entity (Unit (Comp_Unit));
-                           Body_Unit : constant Node_Id :=
-                                         Library_Unit (Comp_Unit);
-                           Item      : Node_Id;
-
-                        begin
-                           Item := First (Context_Items (Body_Unit));
-                           while Present (Item) loop
-                              if Nkind (Item) = N_With_Clause
-                                and then
-                                  Is_Ancestor_Of_Main (U_Id, Name (Item))
-                              then
-                                 Set_Is_Inlined (U_Id, False);
-                                 exit;
-                              end if;
-
-                              Next (Item);
-                           end loop;
-
-                           --  If no suspicious with_clauses, analyze the body
-
-                           if Is_Inlined (U_Id) then
-                              Semantics (Body_Unit);
-                           end if;
-                        end;
                      end if;
                   end if;
                end;
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 248140)
+++ sem_ch4.adb	(working copy)
@@ -1469,18 +1469,26 @@ package body Sem_Ch4 is
          --  can also happen when the function declaration appears before the
          --  full view of the type (which is legal in Ada 2012) and the call
          --  appears in a different unit, in which case the incomplete view
-         --  must be replaced with the full view to prevent subsequent type
-         --  errors.
+         --  must be replaced with the full view (or the non-limited view)
+         --  to prevent subsequent type errors. Note that the usual install/
+         --  removal of limited_with clauses is not sufficient to handle this
+         --  case, because the limited view may have been captured is another
+         --  compilation unit that defines the current function.
 
-         if Is_Incomplete_Type (Etype (N))
-           and then Present (Full_View (Etype (N)))
-         then
-            if Is_Entity_Name (Nam) then
-               Set_Etype (Nam, Full_View (Etype (N)));
-               Set_Etype (Entity (Nam), Full_View (Etype (N)));
-            end if;
+         if Is_Incomplete_Type (Etype (N)) then
+            if Present (Full_View (Etype (N))) then
+               if Is_Entity_Name (Nam) then
+                  Set_Etype (Nam, Full_View (Etype (N)));
+                  Set_Etype (Entity (Nam), Full_View (Etype (N)));
+               end if;
+
+               Set_Etype (N, Full_View (Etype (N)));
 
-            Set_Etype (N, Full_View (Etype (N)));
+            elsif From_Limited_With (Etype (N))
+              and then Present (Non_Limited_View (Etype (N)))
+            then
+               Set_Etype (N, Non_Limited_View (Etype (N)));
+            end if;
          end if;
       end if;
    end Analyze_Call;

[-- Attachment #3: limited_with5.adb --]
[-- Type: text/x-adasrc, Size: 290 bytes --]

-- { dg-do compile }
-- { dg-options "-O -gnatn -Winline" }

package body Limited_With5 is
  procedure Doit (Obj : Limited_With5_Pkg.T) is
  begin
    if Limited_With5_Pkg.Get_Expression_Support (Obj) > Sup_T'(100) then
      raise Program_Error;
    end if;
  end Doit;
end Limited_With5;

[-- Attachment #4: limited_with5.ads --]
[-- Type: text/x-adasrc, Size: 144 bytes --]

with Limited_With5_Pkg;

package Limited_With5 is
  type Sup_T is new Integer;
  procedure Doit (Obj : Limited_With5_Pkg.T);
end Limited_With5;

[-- Attachment #5: limited_with6.ads --]
[-- Type: text/x-adasrc, Size: 216 bytes --]

with Limited_With6_Pkg;

package Limited_With6 is
  type Sup_T is new Integer;
  procedure Doit (Obj : Limited_With6_Pkg.T);

  type Rec is record
    A : Limited_With6_Pkg.Taft_Ptr;
  end record;
end Limited_With6;

[-- Attachment #6: limited_with5_pkg.adb --]
[-- Type: text/x-adasrc, Size: 232 bytes --]

with Limited_With5;

package body Limited_With5_Pkg is
  function Get_Expression_Support (Obj : T) return Limited_With5.Sup_T is
  begin
    return Limited_With5.Sup_T (Obj + 1);
  end Get_Expression_Support;
end Limited_With5_Pkg;

[-- Attachment #7: limited_with5_pkg.ads --]
[-- Type: text/x-adasrc, Size: 227 bytes --]

limited with Limited_With5;

package Limited_With5_Pkg is
  type T is limited private;
  function Get_Expression_Support (Obj : T) return Limited_With5.Sup_T with Inline;
private
  type T is new Integer;
end Limited_With5_Pkg;

[-- Attachment #8: limited_with6_pkg.adb --]
[-- Type: text/x-adasrc, Size: 276 bytes --]

with Limited_With6;

package body Limited_With6_Pkg is
  function Get_Expression_Support (Obj : T) return Limited_With6.Sup_T is
  begin
    return Limited_With6.Sup_T (Obj + 1);
  end Get_Expression_Support;

  type TT is access all Limited_With6.Rec;
end Limited_With6_Pkg;

[-- Attachment #9: limited_with6.adb --]
[-- Type: text/x-adasrc, Size: 290 bytes --]

-- { dg-do compile }
-- { dg-options "-O -gnatn -Winline" }

package body Limited_With6 is
  procedure Doit (Obj : Limited_With6_Pkg.T) is
  begin
    if Limited_With6_Pkg.Get_Expression_Support (Obj) > Sup_T'(100) then
      raise Program_Error;
    end if;
  end Doit;
end Limited_With6;

[-- Attachment #10: limited_with6_pkg.ads --]
[-- Type: text/x-adasrc, Size: 299 bytes --]

limited with Limited_With6;

package Limited_With6_Pkg is
  type T is limited private;
  function Get_Expression_Support (Obj : T) return Limited_With6.Sup_T with Inline;

  type Taft_Ptr is private;

private
  type T is new Integer;

  type TT;
  type Taft_Ptr is access TT;
end Limited_With6_Pkg;