[Ada] Finer grained secondary stack management

[Arnaud Charlet <charlet at adacore dot com>]

This patch has several effects:

1) The management of the secondary stack is now "tighter". A transient block
   created for the purpose of managing the secondary stack will do so unless
   the block appears within a function returning on the secondary stack or when
   2) is in effect. Previously, due to some questionable logic, the management
   was left to the nearest enclosing scoping construct and not the block even
   though the block was created to manage the secondary stack in the first
   place.

2) Switch -gnatd.s now controls an optimization where a transient block created
   for the purpose of managing the secondary stack will no longer manage the
   secondary stack when there is an enclosing scoping construct which already
   does so.

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

--  pack.ads

package Pack is
   type Truth_Array is array (Positive range <>) of Boolean;

   procedure Diagnose_Truth (Val : Truth_Array);
   function  Diagnose_Truth (Val : Truth_Array) return Boolean;

   function Invert_Truth (Val : Truth_Array) return Truth_Array;

   function Is_All_False (Val : Truth_Array) return Boolean;
   function Is_All_True  (Val : Truth_Array) return Boolean;
   function Is_Gray_Area (Val : Truth_Array) return Boolean;

   function Make_Truth (Ts : Natural; Fs : Natural) return Truth_Array;
end Pack;

--  pack.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack is
   procedure Diagnose_Truth (Val : Truth_Array) is
   begin
      if Is_All_False (Val) then
         Put_Line ("  it is all lies");
      elsif Is_All_True (Val) then
         Put_Line ("  it is all true");
      elsif Is_Gray_Area (Val) then
         Put_Line ("  50 shades of gray");
      else
         Put_Line ("  truth not found");
      end if;
   end Diagnose_Truth;

   function Diagnose_Truth (Val : Truth_Array) return Boolean is
   begin
      Diagnose_Truth (Val);
      return True;
   end Diagnose_Truth;

   function Invert_Truth (Val : Truth_Array) return Truth_Array is
      Result : Truth_Array := Val;

   begin
      for Index in Result'Range loop
          Result (Index) := not Val (Index);
      end loop;

      return Result;
   end Invert_Truth;

   function Is_All_False (Val : Truth_Array) return Boolean is
      Has_True : Boolean := False;
      Is_Empty : Boolean := True;

   begin
      for Index in Val'Range loop
         Is_Empty := False;

         if Val (Index) then
            Has_True := True;
            exit;
         end if;
      end loop;

      return not Is_Empty and not Has_True;
   end Is_All_False;

   function Is_All_True (Val : Truth_Array) return Boolean is
      Has_False : Boolean := False;
      Is_Empty  : Boolean := True;

   begin
      for Index in Val'Range loop
         Is_Empty := False;

         if not Val (Index) then
            Has_False := True;
            exit;
         end if;
      end loop;

      return not Is_Empty and not Has_False;
   end Is_All_True;

   function Is_Gray_Area (Val : Truth_Array) return Boolean is
      Has_False : Boolean := False;
      Has_True  : Boolean := False;
      Is_Empty  : Boolean := True;

   begin
      for Index in Val'Range loop
         Is_Empty := False;

         if Val (Index) then
            Has_True  := True;
         else
            Has_False := True;
         end if;
      end loop;

      return not Is_Empty and Has_False and Has_True;
   end Is_Gray_Area;

   function Make_Truth (Ts : Natural; Fs : Natural) return Truth_Array is
      Result : Truth_Array (1 .. Ts + Fs) := (others => False);

   begin
      for Index in 1 .. Ts loop
         Result (Index) := True;
      end loop;

      return Result;
   end Make_Truth;
end Pack;

--  optimization.adb

with Ada.Text_IO; use Ada.Text_IO;
with Pack;        use Pack;

pragma Warnings (Off);
with System.Secondary_Stack; use System.Secondary_Stack;
pragma Warnings (On);

procedure Optimization is
   procedure Leaks (Val : Boolean) is
      Obj : constant Truth_Array := Make_Truth (100_000, 0);

   begin
      if Val then
         Diagnose_Truth (Invert_Truth (Make_Truth (0, 100_000)));
      end if;
   end Leaks;

   SS_Before : constant Mark_Id := SS_Mark;

begin
   Leaks (True);

   if SS_Mark = SS_Before then
      Put_Line ("OK");
   else
      Put_Line ("ERROR: secondary stack not reclaimed");
   end if;
end Optimization;

----------------------------
-- Compilation and output --  (only relevant parts shown)
----------------------------

$ gnatmake -q -f -gnatG -gnatdI optimization.adb
$ ./optimization
$ gnatmake -q -f -gnatG -gnatdI optimization.adb -gnatd.s
$ ./optimization

   procedure optimization__leaks (val : boolean) is
      M...b : constant system__secondary_stack__mark_id :=
        $system__secondary_stack__ss_mark;
      procedure optimization__leaks___finalizer;

      procedure optimization__leaks___finalizer is
      begin
         $system__secondary_stack__ss_release (M...b);
         return;
      end optimization__leaks___finalizer;
   begin
      type optimization__leaks__A...b is access all pack__truth_array;
      R...b : constant optimization__leaks__A...b := pack__make_truth (
        100000, 0)'reference;
      B...b : constant integer := R...b.all'first(1);
      B...b : constant integer := R...b.all'last(1);
      subtype optimization__leaks__TobjS is pack__truth_array (B...b ..
        B...b);
      [constraint_error when
        B...b >= B...b and then (B...b < 1)
        "range check failed"]
      obj : pack__truth_array renames R...b.all;
      if val then
         B...b : declare
            M...b : constant system__secondary_stack__mark_id :=
              $system__secondary_stack__ss_mark;
            procedure optimization__leaks__B...b___finalizer;

            procedure optimization__leaks__B...b___finalizer is
            begin
               $system__secondary_stack__ss_release (M...b);
               return;
            end optimization__leaks__B...b___finalizer;
         begin
            pack__diagnose_truth (pack__invert_truth (pack__make_truth
              (0, 100000)));
         at end
            optimization__leaks__B...b___finalizer;
         end B...b;
      end if;
      return;
   at end
      optimization__leaks___finalizer;
   end optimization__leaks;

  it is all true
OK

   procedure optimization__leaks (val : boolean) is
      M...b : constant system__secondary_stack__mark_id :=
        $system__secondary_stack__ss_mark;
      procedure optimization__leaks___finalizer;

      procedure optimization__leaks___finalizer is
      begin
         $system__secondary_stack__ss_release (M...b);
         return;
      end optimization__leaks___finalizer;
   begin
      type optimization__leaks__A...b is access all pack__truth_array;
      R...b : constant optimization__leaks__A...b := pack__make_truth (
        100000, 0)'reference;
      B...b : constant integer := R...b.all'first(1);
      B...b : constant integer := R...b.all'last(1);
      subtype optimization__leaks__TobjS is pack__truth_array (B...b ..
        B...b);
      [constraint_error when
        B...b >= B...b and then (B...b < 1)
        "range check failed"]
      obj : pack__truth_array renames R...b.all;
      if val then
         B...b : declare
         begin
            pack__diagnose_truth (pack__invert_truth (pack__make_truth
              (0, 100000)));
         end B...b;
      end if;
      return;
   at end
      optimization__leaks___finalizer;
   end optimization__leaks;

  it is all true
OK

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

2017-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* debug.adb: Document the use of switch -gnatd.s.
	* einfo.ads Update the documentation on attribute
	Sec_Stack_Needed_For_Return and attribute Uses_Sec_Stack. Remove
	the uses of these attributes from certain entities.
	* exp_ch7.adb (Make_Transient_Block): Reimplement the circuitry
	which determines whether the block should continue to manage
	the secondary stack.
	(Manages_Sec_Stack): New routine.

Attachment: difs
Description: Text document