utils.c (create_subprog_decl): Move code dealing with conflicting inlining status of nested subprograms to...

* gcc-interface/utils.c (create_subprog_decl): Move code dealing with
	conflicting inlining status of nested subprograms to...
	* gcc-interface/trans.c (check_inlining_for_nested_subprog): ...here.
	(Attribute_to_gnu) <Attr_Access>: Call it.
	(Call_to_gnu): Likewise.
	(Subprogram_Body_to_gnu): Drop the body if it is an inlined external
	function that has been marked uninlinable.

From-SVN: r217151

gcc/ada/ChangeLog

@@ -1,3 +1,13 @@
+2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gcc-interface/utils.c (create_subprog_decl): Move code dealing with
+	conflicting inlining status of nested subprograms to...
+	* gcc-interface/trans.c (check_inlining_for_nested_subprog): ...here.
+	(Attribute_to_gnu) <Attr_Access>: Call it.
+	(Call_to_gnu): Likewise.
+	(Subprogram_Body_to_gnu): Drop the body if it is an inlined external
+	function that has been marked uninlinable.
+
 2014-10-31  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* aspects.adb Add an entry for aspect Ghost in table

gcc/ada/gcc-interface/trans.c

@@ -1481,6 +1481,49 @@ Pragma_to_gnu (Node_Id gnat_node)
   return gnu_result;
 }
 
+
+/* Check the inlining status of nested function FNDECL in the current context.
+
+   If a non-inline nested function is referenced from an inline external
+   function, we cannot honor both requests at the same time without cloning
+   the nested function in the current unit since it is private to its unit.
+   We could inline it as well but it's probably better to err on the side
+   of too little inlining.
+
+   This must be invoked only on nested functions present in the source code
+   and not on nested functions generated by the compiler, e.g. finalizers,
+   because they are not marked inline and we don't want them to block the
+   inlining of the parent function.  */
+
+static void
+check_inlining_for_nested_subprog (tree fndecl)
+{
+  if (!DECL_DECLARED_INLINE_P (fndecl)
+      && current_function_decl
+      && DECL_EXTERNAL (current_function_decl)
+      && DECL_DECLARED_INLINE_P (current_function_decl))
+    {
+      const location_t loc1 = DECL_SOURCE_LOCATION (fndecl);
+      const location_t loc2 = DECL_SOURCE_LOCATION (current_function_decl);
+
+      if (lookup_attribute ("always_inline",
+			    DECL_ATTRIBUTES (current_function_decl)))
+	{
+	  error_at (loc1, "subprogram %q+F not marked Inline_Always", fndecl);
+	  error_at (loc2, "parent subprogram cannot be inlined");
+	}
+      else
+	{
+	  warning_at (loc1, OPT_Winline, "subprogram %q+F not marked Inline",
+		      fndecl);
+	  warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined");
+	}
+
+      DECL_DECLARED_INLINE_P (current_function_decl) = 0;
+      DECL_UNINLINABLE (current_function_decl) = 1;
+    }
+}
+
 /* Return an expression for the length of TYPE, an integral type, computed in
    RESULT_TYPE, another integral type.
 
@@ -1696,6 +1739,9 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 	    {
 	      set_expr_location_from_node (gnu_expr, gnat_node);
 
+	      /* Also check the inlining status.  */
+	      check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
+
 	      /* Check that we're not violating the No_Implicit_Dynamic_Code
 		 restriction.  Be conservative if we don't know anything
 		 about the trampoline strategy for the target.  */
@@ -3729,7 +3775,12 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
       gnu_subprog_language->other_ret_val = NULL;
     }
 
-  rest_of_subprog_body_compilation (gnu_subprog_decl);
+  /* If this is an inlined external function that has been marked uninlinable,
+     drop the body and stop there.  Otherwise compile the body.  */
+  if (DECL_EXTERNAL (gnu_subprog_decl) && DECL_UNINLINABLE (gnu_subprog_decl))
+    DECL_SAVED_TREE (gnu_subprog_decl) = NULL_TREE;
+  else
+    rest_of_subprog_body_compilation (gnu_subprog_decl);
 }
 
 /* Return true if GNAT_NODE requires atomic synchronization.  */
@@ -3874,6 +3925,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
       return call_expr;
     }
 
+  /* For a call to a nested function, check the inlining status.  */
+  if (TREE_CODE (gnu_subprog) == FUNCTION_DECL
+      && decl_function_context (gnu_subprog))
+    check_inlining_for_nested_subprog (gnu_subprog);
+
   /* The only way we can be making a call via an access type is if Name is an
      explicit dereference.  In that case, get the list of formal args from the
      type the access type is pointing to.  Otherwise, get the formals from the

gcc/ada/gcc-interface/utils.c

@@ -3027,18 +3027,6 @@ create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type,
 				 TREE_TYPE (subprog_type));
   DECL_ARGUMENTS (subprog_decl) = param_decl_list;
 
-  /* If this is a non-inline function nested inside an inlined external
-     function, we cannot honor both requests without cloning the nested
-     function in the current unit since it is private to the other unit.
-     We could inline the nested function as well but it's probably better
-     to err on the side of too little inlining.  */
-  if ((inline_status == is_suppressed || inline_status == is_disabled)
-      && !public_flag
-      && current_function_decl
-      && DECL_DECLARED_INLINE_P (current_function_decl)
-      && DECL_EXTERNAL (current_function_decl))
-    DECL_DECLARED_INLINE_P (current_function_decl) = 0;
-
   DECL_ARTIFICIAL (subprog_decl) = artificial_flag;
   DECL_EXTERNAL (subprog_decl) = extern_flag;
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,30 @@
+2014-11-05  Eric Botcazou  <ebotcazou@adacore.com>
+
+	* gnat.dg/inline1.adb: New test.
+	* gnat.dg/inline1_pkg.ad[sb]: New helper.
+	* gnat.dg/inline2.adb: New test.
+	* gnat.dg/inline2_pkg.ad[sb]: New helper.
+	* gnat.dg/inline3.adb: New test.
+	* gnat.dg/inline3_pkg.ad[sb]: New helper.
+	* gnat.dg/inline4.adb: New test.
+	* gnat.dg/inline4_pkg.ad[sb]: New helper.
+	* gnat.dg/inline5.adb: New test.
+	* gnat.dg/inline5_pkg.ad[sb]: New helper.
+	* gnat.dg/inline6.adb: New test.
+	* gnat.dg/inline6_pkg.ad[sb]: New helper.	
+	* gnat.dg/inline7.adb: New test.
+	* gnat.dg/inline7_pkg1.ad[sb]: New helper.
+	* gnat.dg/inline7_pkg2.ad[sb]: Likewise.
+	* gnat.dg/inline8.adb: New test.
+	* gnat.dg/inline8_pkg1.ad[sb]: New helper.
+	* gnat.dg/inline8_pkg2.ad[sb]: New helper.
+	* gnat.dg/inline9.adb: New test.
+	* gnat.dg/inline9_pkg.ad[sb]: New helper.
+	* gnat.dg/inline10.adb: New test.
+	* gnat.dg/inline10_pkg.ad[sb]: New helper.
+	* gnat.dg/inline11.adb: New test.
+	* gnat.dg/inline11_pkg.ad[sb]: New helper.
+
 2014-11-05  Anthony Brandon  <anthony.brandon@gmail.com>
 
 	PR driver/36312

gcc/testsuite/gnat.dg/inline1.adb

@@ -0,0 +1,11 @@
+-- { dg-do compile }
+
+with Inline1_Pkg; use Inline1_Pkg;
+
+procedure Inline1 is
+   F : Float := Invalid_Real;
+begin
+   if Valid_Real (F) then
+      F := F + 1.0;
+   end if;
+end;

gcc/testsuite/gnat.dg/inline10.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+
+with Inline10_Pkg; use Inline10_Pkg;
+
+procedure Inline10 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline10_pkg.adb

@@ -0,0 +1,21 @@
+package body Inline10_Pkg is
+
+  procedure Test (I : Integer) is
+
+    function F (J : Integer) return Integer is
+    begin
+      return I - J;
+    end;
+    pragma Inline (F);
+
+    type FPT is access function (I : Integer) return Integer;
+
+    P : FPT := F'Access;
+
+  begin
+    if I /= P (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline10_Pkg;

gcc/testsuite/gnat.dg/inline10_pkg.ads

@@ -0,0 +1,6 @@
+package Inline10_Pkg is
+
+  procedure Test (I : Integer);
+  pragma Inline (Test);
+
+end Inline10_Pkg;

gcc/testsuite/gnat.dg/inline11.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+
+with Inline11_Pkg; use Inline11_Pkg;
+
+procedure Inline11 is
+begin
+  Trace (0);
+end;

gcc/testsuite/gnat.dg/inline11_pkg.adb

@@ -0,0 +1,15 @@
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Inline11_Pkg is
+
+  function My_Img (I : Integer) return String is
+  begin
+    return I'Img;
+  end;
+
+  procedure Trace (I : Integer) is
+  begin
+    Put_Line (My_Img (I));
+  end;
+
+end Inline11_Pkg;

gcc/testsuite/gnat.dg/inline11_pkg.ads

@@ -0,0 +1,6 @@
+package Inline11_Pkg is
+
+  procedure Trace (I : Integer);
+  pragma Inline (Trace);
+
+end Inline11_Pkg;

gcc/testsuite/gnat.dg/inline1_pkg.adb

@@ -0,0 +1,34 @@
+with Ada.Unchecked_Conversion;
+
+package body Inline1_Pkg is
+
+   type Ieee_Short_Real is
+      record
+         Mantisse_Sign : Integer range 0 .. 1;
+         Exponent      : Integer range 0 .. 2 **  8 - 1;
+         Mantisse      : Integer range 0 .. 2 ** 23 - 1;
+      end record;
+
+   for Ieee_Short_Real use
+      record
+         Mantisse_Sign at 0 range 31 .. 31;
+         Exponent      at 0 range 23 .. 30;
+         Mantisse      at 0 range  0 .. 22;
+      end record;
+
+   function Valid_Real (Number : Float) return Boolean is
+      function To_Ieee_Short_Real is
+         new Ada.Unchecked_Conversion (Float, Ieee_Short_Real);
+   begin
+      return To_Ieee_Short_Real (Number).Exponent /= 255;
+   end Valid_Real;
+
+   function Invalid_Real return Float is
+      function To_Float is
+         new Ada.Unchecked_Conversion (Ieee_Short_Real, Float);
+   begin
+      return To_Float (Ieee_Short_Real'(Mantisse_Sign => 0,
+                                        Exponent => 255, Mantisse => 0));
+   end Invalid_Real;
+
+end Inline1_Pkg;

gcc/testsuite/gnat.dg/inline1_pkg.ads

@@ -0,0 +1,9 @@
+package Inline1_Pkg is
+
+   function Valid_Real (Number : Float) return Boolean;
+   pragma Inline_Always (Valid_Real);
+
+   function Invalid_Real return Float;
+   pragma Inline_Always (Invalid_Real);
+
+end Inline1_Pkg;

gcc/testsuite/gnat.dg/inline2.adb

@@ -0,0 +1,12 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+
+with Inline2_Pkg; use Inline2_Pkg;
+
+procedure Inline2 is
+   F : Float := Invalid_Real;
+begin
+   if Valid_Real (F) then
+      F := F + 1.0;
+   end if;
+end;

gcc/testsuite/gnat.dg/inline2_pkg.adb

@@ -0,0 +1,34 @@
+with Ada.Unchecked_Conversion;
+
+package body Inline2_Pkg is
+
+   type Ieee_Short_Real is
+      record
+         Mantisse_Sign : Integer range 0 .. 1;
+         Exponent      : Integer range 0 .. 2 **  8 - 1;
+         Mantisse      : Integer range 0 .. 2 ** 23 - 1;
+      end record;
+
+   for Ieee_Short_Real use
+      record
+         Mantisse_Sign at 0 range 31 .. 31;
+         Exponent      at 0 range 23 .. 30;
+         Mantisse      at 0 range  0 .. 22;
+      end record;
+
+   function Valid_Real (Number : Float) return Boolean is
+      function To_Ieee_Short_Real is
+         new Ada.Unchecked_Conversion (Float, Ieee_Short_Real);
+   begin
+      return To_Ieee_Short_Real (Number).Exponent /= 255;
+   end Valid_Real;
+
+   function Invalid_Real return Float is
+      function To_Float is
+         new Ada.Unchecked_Conversion (Ieee_Short_Real, Float);
+   begin
+      return To_Float (Ieee_Short_Real'(Mantisse_Sign => 0,
+                                        Exponent => 255, Mantisse => 0));
+   end Invalid_Real;
+
+end Inline2_Pkg;

gcc/testsuite/gnat.dg/inline2_pkg.ads

@@ -0,0 +1,9 @@
+package Inline2_Pkg is
+
+   function Valid_Real (Number : Float) return Boolean;
+   pragma Inline (Valid_Real);
+
+   function Invalid_Real return Float;
+   pragma Inline (Invalid_Real);
+
+end Inline2_Pkg;

gcc/testsuite/gnat.dg/inline3.adb

@@ -0,0 +1,10 @@
+-- { dg-do compile }
+-- { dg-error "not marked Inline_Always" "" { target *-*-* } 0 }
+-- { dg-error "cannot be inlined" "" { target *-*-* } 0 }
+
+with Inline3_Pkg; use Inline3_Pkg;
+
+procedure Inline3 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline3_pkg.adb

@@ -0,0 +1,17 @@
+package body Inline3_Pkg is
+
+  procedure Test (I : Integer) is
+
+    function F (J : Integer) return Integer is
+
+    begin
+      return I - J;
+    end;
+
+  begin
+    if I /= F (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline3_Pkg;

gcc/testsuite/gnat.dg/inline3_pkg.ads

@@ -0,0 +1,6 @@
+package Inline3_Pkg is
+
+  procedure Test (I : Integer);
+  pragma Inline_Always (Test);
+
+end Inline3_Pkg;

gcc/testsuite/gnat.dg/inline4.adb

@@ -0,0 +1,8 @@
+-- { dg-do compile }
+
+with Inline4_Pkg; use Inline4_Pkg;
+
+procedure Inline4 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline4_pkg.adb

@@ -0,0 +1,17 @@
+package body Inline4_Pkg is
+
+  procedure Test (I : Integer) is
+
+    function F (J : Integer) return Integer is
+    begin
+      return I - J;
+    end;
+    pragma Inline_Always (F);
+
+  begin
+    if I /= F (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline4_Pkg;

gcc/testsuite/gnat.dg/inline4_pkg.ads

@@ -0,0 +1,6 @@
+package Inline4_Pkg is
+
+  procedure Test (I : Integer);
+  pragma Inline_Always (Test);
+
+end Inline4_Pkg;

gcc/testsuite/gnat.dg/inline5.adb

@@ -0,0 +1,11 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+-- { dg-warning "not marked Inline" "" { target *-*-* } 0 }
+-- { dg-warning "cannot be inlined" "" { target *-*-* } 0 }
+
+with Inline5_Pkg; use Inline5_Pkg;
+
+procedure Inline5 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline5_pkg.adb

@@ -0,0 +1,16 @@
+package body Inline5_Pkg is
+
+  procedure Test (I : Integer) is
+
+    function F (J : Integer) return Integer is
+    begin
+      return I - J;
+    end;
+
+  begin
+    if I /= F (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline5_Pkg;

gcc/testsuite/gnat.dg/inline5_pkg.ads

@@ -0,0 +1,6 @@
+package Inline5_Pkg is
+
+  procedure Test (I : Integer);
+  pragma Inline (Test);
+
+end Inline5_Pkg;

gcc/testsuite/gnat.dg/inline6.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+
+with Inline6_Pkg; use Inline6_Pkg;
+
+procedure Inline6 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline6_pkg.adb

@@ -0,0 +1,17 @@
+package body Inline6_Pkg is
+
+  procedure Test (I : Integer) is
+
+    function F (J : Integer) return Integer is
+    begin
+      return I - J;
+    end;
+    pragma Inline (F);
+
+  begin
+    if I /= F (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline6_Pkg;

gcc/testsuite/gnat.dg/inline6_pkg.ads

@@ -0,0 +1,6 @@
+package Inline6_Pkg is
+
+  procedure Test (I : Integer);
+  pragma Inline (Test);
+
+end Inline6_Pkg;

gcc/testsuite/gnat.dg/inline7.adb

@@ -0,0 +1,11 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+-- { dg-warning "not marked Inline" "" { target *-*-* } 0 }
+-- { dg-warning "cannot be inlined" "" { target *-*-* } 0 }
+
+with Inline7_Pkg1; use Inline7_Pkg1;
+
+procedure Inline7 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline7_pkg1.adb

@@ -0,0 +1,15 @@
+with Inline7_Pkg2;
+
+package body Inline7_Pkg1 is
+
+  procedure Test (I : Integer) is
+
+    function F is new Inline7_Pkg2.Calc (I);
+
+  begin
+    if I /= F (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline7_Pkg1;

gcc/testsuite/gnat.dg/inline7_pkg1.ads

@@ -0,0 +1,6 @@
+package Inline7_Pkg1 is
+
+  procedure Test (I : Integer);
+  pragma Inline (Test);
+
+end Inline7_Pkg1;

gcc/testsuite/gnat.dg/inline7_pkg2.adb

@@ -0,0 +1,8 @@
+package body Inline7_Pkg2 is
+
+  function Calc (A : Integer) return Integer is
+  begin
+    return D - A;
+  end;
+
+end Inline7_Pkg2;

gcc/testsuite/gnat.dg/inline7_pkg2.ads

@@ -0,0 +1,7 @@
+package Inline7_Pkg2 is
+
+  generic
+    D : Integer;
+  function Calc (A : Integer) return Integer;
+
+end Inline7_Pkg2;

gcc/testsuite/gnat.dg/inline8.adb

@@ -0,0 +1,9 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+
+with Inline8_Pkg1; use Inline8_Pkg1;
+
+procedure Inline8 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline8_pkg1.adb

@@ -0,0 +1,16 @@
+with Inline8_Pkg2;
+
+package body Inline8_Pkg1 is
+
+  procedure Test (I : Integer) is
+
+    function F is new Inline8_Pkg2.Calc (I);
+    pragma Inline (F);
+
+  begin
+    if I /= F (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline8_Pkg1;

gcc/testsuite/gnat.dg/inline8_pkg1.ads

@@ -0,0 +1,6 @@
+package Inline8_Pkg1 is
+
+  procedure Test (I : Integer);
+  pragma Inline (Test);
+
+end Inline8_Pkg1;

gcc/testsuite/gnat.dg/inline8_pkg2.adb

@@ -0,0 +1,8 @@
+package body Inline8_Pkg2 is
+
+  function Calc (A : Integer) return Integer is
+  begin
+    return D - A;
+  end;
+
+end Inline8_Pkg2;

gcc/testsuite/gnat.dg/inline8_pkg2.ads

@@ -0,0 +1,7 @@
+package Inline8_Pkg2 is
+
+  generic
+    D : Integer;
+  function Calc (A : Integer) return Integer;
+
+end Inline8_Pkg2;

gcc/testsuite/gnat.dg/inline9.adb

@@ -0,0 +1,11 @@
+-- { dg-do compile }
+-- { dg-options "-O -gnatn -Winline" }
+-- { dg-warning "not marked Inline" "" { target *-*-* } 0 }
+-- { dg-warning "cannot be inlined" "" { target *-*-* } 0 }
+
+with Inline9_Pkg; use Inline9_Pkg;
+
+procedure Inline9 is
+begin
+  Test (0);
+end;

gcc/testsuite/gnat.dg/inline9_pkg.adb

@@ -0,0 +1,20 @@
+package body Inline9_Pkg is
+
+  procedure Test (I : Integer) is
+
+    function F (J : Integer) return Integer is
+    begin
+      return I - J;
+    end;
+
+    type FPT is access function (I : Integer) return Integer;
+
+    P : FPT := F'Access;
+
+  begin
+    if I /= P (I) then
+      raise Program_Error;
+    end if;
+  end;
+
+end Inline9_Pkg;

gcc/testsuite/gnat.dg/inline9_pkg.ads

@@ -0,0 +1,6 @@
+package Inline9_Pkg is
+
+  procedure Test (I : Integer);
+  pragma Inline (Test);
+
+end Inline9_Pkg;