[Ada] Premature secondary stack reclamation

[Ada] Premature secondary stack reclamation

This patch modifies the creation of transient scopes to eliminate potential
premature secondary stack reclamations when there is no suitable transient
context and the scope was intended to manage the secondary stack. Instead,
the logic was changed to accommodate a special case where an assignment with
suppressed controlled actions that appears within a type initialization
procedure requires secondary stack reclamation.

The patch also corrects the handling of function calls which utilize the
secondary stack in loop parameter specifications. Previously the predicate
which determined whether the function will utilize the secondary stack was
not accurate enough, and in certain cases could lead to leaks.

------------
-- Source --
------------

--  iterators.ads

package Iterators is
   type Iterator is limited interface;
   type Iterator_Access is access all Iterator'Class;

   function Next
     (I       : in out Iterator;
      Element : out Character) return Boolean is abstract;

   procedure Iterate
     (I    : in out Iterator'Class;
      Proc : access procedure (Element : Character));
end Iterators;

--  iterators.adb

package body Iterators is
   procedure Iterate
     (I    : in out Iterator'Class;
      Proc : access procedure (Element : Character))
   is
      Element : Character;
   begin
      while I.Next (Element) loop
         Proc (Element);
      end loop;
   end Iterate;
end Iterators;

--  base.ads

with Iterators; use Iterators;

package Base is
   type String_Access is access all String;
   type Node is tagged record
      S : String_Access;
   end record;

   type Node_Access is access all Node'Class;
   type Node_Array is array (Positive range <>) of Node_Access;

   function As_Array (N : Node_Access) return Node_Array;
   function Get_String (C : Character) return String;

   type Node_Iterator is limited new Iterator with record
      Node : Node_Access;
      I    : Positive;
   end record;

   overriding function Next
     (It      : in out Node_Iterator;
      Element : out Character) return Boolean;

   function Constructor_1 (N : Node_Access) return Node_Iterator;
   function Constructor_2 (N : Node_Access) return Node_Iterator;
end Base;

--  base.adb

package body Base is
   function As_Array (N : Node_Access) return Node_Array is
   begin
      return (1 => N);
   end As_Array;

   function Get_String (C : Character) return String is
   begin
      return (1 .. 40 => C);
   end Get_String;

   function Next
     (It      : in out Node_Iterator;
      Element : out Character) return Boolean
   is
   begin
      if It.I > It.Node.S'Last then
         return False;
      else
         It.I := It.I + 1;
         Element := It.Node.S (It.I - 1);
         return True;
      end if;
   end Next;

   function Constructor_1 (N : Node_Access) return Node_Iterator is
   begin
      return Node_Iterator'(N, 1);
   end Constructor_1;

   function Constructor_2 (N : Node_Access) return Node_Iterator is
   begin
      return Constructor_1 (As_Array (N) (1));
   end Constructor_2;
end Base;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Base;        use Base;
with Iterators;   use Iterators;

procedure Main is
   N : constant Node_Access := new Node'(S => new String'("hello world"));

   procedure Process (C : Character) is
   begin
      Put_Line (Get_String (C));
   end Process;

   C : Iterator'Class := Constructor_2 (N);

begin
   C.Iterate (Process'Access);
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q main.adb
$ ./main
hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee
llllllllllllllllllllllllllllllllllllllll
llllllllllllllllllllllllllllllllllllllll
oooooooooooooooooooooooooooooooooooooooo

wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
oooooooooooooooooooooooooooooooooooooooo
rrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
llllllllllllllllllllllllllllllllllllllll
dddddddddddddddddddddddddddddddddddddddd

2018-05-21  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_ch7.adb (Establish_Transient_Scope): Code cleanup. Do not
	delegate the secondary stack management when there is no suitable
	transient context, and the transient scope was intended to manage the
	secondary stack because this causes premature reclamation. Change the
	transient scope creation logic by special casing assignment statements
	of controlled components for type initialization procedures.
	(Find_Node_To_Be_Wrapped): Renamed to Find_Transient_Context. Update
	the comment on usage.
	(Find_Transient_Context): Change the initinte loop into a while loop.
	Iterations schemes and iterator specifications are not valid transient
	contexts because they rely on special processing. Assignment statements
	are now treated as a normal transient context, special cases are
	handled by the caller. Add special processing for pragma Check.
	(Is_OK_Construct): Removed. Its functionality has been merged in
	routine Find_Transient_Context.
	* sem_ch5.adb (Check_Call): Reimplemented. Add code to properly
	retrieve the subprogram being invoked. Use a more accurate predicate
	(Requires_Transient_Scope) to determine that the function will emply
	the secondary stack.

From-SVN: r260443