[Ada] Spurious secondary stack depletion

This patch reimplements the secondary stack allocation logic to eliminate an
issue which causes the memory index to overflow while the stack itself uses
very little memory, thus causing a spurious Storage_Error.

The issue in details:

The total amount of memory that the secondary stack can accomodate is dictated
by System.Parameters.Size_Type which is really an Integer, giving roughly 2 GB
of storage.

The secondary stack is comprised of multiple frames which logically form a
contiguous array of memory. Each frame maintans a range over which it operates,
where

   Low  bound = Previous frame's high bound + 1
   High bound = Previous frame's high bound + Frame size

The allocation logic starts by first checking whether the current top frame
(which may not be the "last" frame in the secondary stack) has enough memory to
fit an object. If it does, then that frame is used. If it does not, the logic
then examines the subsequent frames, while carrying out the following actions:

   * If the frame is too small to fit the object, it is deleted

   * If the frame is big enough to fit the object, it is used

If all the frames were too small (and thus deleted), a new frame is added which
is big enough to fit the object.

Due to an issue with the deletion logic, the last frame would never be deleted.
Since any new frame's range is based on the previous frame's range, the new
range would keep growing, even though the secondary stack may have very few
frames in use. Eventually this growth overflows the memory index type.

The overflow of the memory index type happens only when the secondary stack
is full, and thus signals a Storage_Error. Due to the spurious growth of the
ranges, the overflow happens much faster and results in a bogus stack depleton.

The issue manifests only when each new memory request to the secondary stack is
slightly bigger than the previous memory request, thus prompring the secondary
stack to delete all its frames, and create a new one.

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

gcc/ada/

	* libgnat/s-secsta.adb (SS_Allocate): Reimplemented.
	(SS_Allocate_Dynamic): New routine. The allocation logic is now split
	into three distring cases rather than in one loop which attempts to
	handle all three cases. This rewrite eliminates an issue where the last
	frame of the stack cannot be freed, thus causing the memory range of a
	new frame to approach the overflow point of the memory index type.
	Since the overflow is logically treated as a
	too-much-memory-on-the-stack scenario, it causes a bogus Storage_Error.
	(SS_Allocate_Static): New routine. The routine factorizes the static
	secondary stack-related code from the former SS_Allocate.

gcc/testsuite/

	* gnat.dg/sec_stack2.adb: New testcase.

From-SVN: r260736

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d284f18f1c5f8d701087ea4a2fdc26a9d472e3a8..73dec9d74d637d6f05727729ce626bbc3d04cbbd 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2018-05-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * libgnat/s-secsta.adb (SS_Allocate): Reimplemented.
+       (SS_Allocate_Dynamic): New routine. The allocation logic is now split
+       into three distring cases rather than in one loop which attempts to
+       handle all three cases. This rewrite eliminates an issue where the last
+       frame of the stack cannot be freed, thus causing the memory range of a
+       new frame to approach the overflow point of the memory index type.
+       Since the overflow is logically treated as a
+       too-much-memory-on-the-stack scenario, it causes a bogus Storage_Error.
+       (SS_Allocate_Static): New routine. The routine factorizes the static
+       secondary stack-related code from the former SS_Allocate.
+
 2018-05-25  Sergey Rybin  <rybin@adacore.com>
 
        * doc/gnat_ugn/gnat_and_program_execution.rst: Add description of '-U'

diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb
index 1c0abca66314411a9e90b80b8cf120f386c51c23..164f7ed6e2bbc92ce9fdd55cdcb9f8db30571bbc 100644 (file)
--- a/gcc/ada/libgnat/s-secsta.adb
+++ b/gcc/ada/libgnat/s-secsta.adb
@@ -33,152 +33,358 @@ pragma Compiler_Unit_Warning;
 
 with Ada.Unchecked_Conversion;
 with Ada.Unchecked_Deallocation;
-with System.Soft_Links;
 
-package body System.Secondary_Stack is
-
-   package SSL renames System.Soft_Links;
+with System.Parameters;       use System.Parameters;
+with System.Soft_Links;       use System.Soft_Links;
+with System.Storage_Elements; use System.Storage_Elements;
 
-   use type System.Parameters.Size_Type;
+package body System.Secondary_Stack is
 
    procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
    --  Free a dynamically allocated chunk
 
+   procedure SS_Allocate_Dynamic
+     (Stack       : SS_Stack_Ptr;
+      Mem_Request : SS_Ptr;
+      Addr        : out Address);
+   pragma Inline (SS_Allocate_Dynamic);
+   --  Allocate enough space on dynamic secondary stack Stack to accommodate an
+   --  object of size Mem_Request. Addr denotes the address where the object is
+   --  to be placed.
+
+   procedure SS_Allocate_Static
+     (Stack       : SS_Stack_Ptr;
+      Mem_Request : SS_Ptr;
+      Addr        : out Address);
+   pragma Inline (SS_Allocate_Static);
+   --  Allocate enough space on static secondary stack Stack to accommodate an
+   --  object of size Mem_Request. Addr denotes the address where the object is
+   --  to be placed.
+
    -----------------
    -- SS_Allocate --
    -----------------
 
    procedure SS_Allocate
      (Addr         : out Address;
-      Storage_Size : SSE.Storage_Count)
+      Storage_Size : Storage_Count)
    is
-      use type System.Storage_Elements.Storage_Count;
+      function Round_Up (Size : Storage_Count) return SS_Ptr;
+      pragma Inline (Round_Up);
+      --  Round up Size to the nearest multiple of the maximum alignment on the
+      --  target.
+
+      function Round_Up_Overflows (Size : Storage_Count) return Boolean;
+      pragma Inline (Round_Up_Overflows);
+      --  Determine whether a round up of Size to the nearest multiple of the
+      --  maximum alignment will overflow the operation.
+
+      --------------
+      -- Round_Up --
+      --------------
+
+      function Round_Up (Size : Storage_Count) return SS_Ptr is
+         Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
+
+      begin
+         return ((SS_Ptr (Size) + Max_Align - 1) / Max_Align) * Max_Align;
+      end Round_Up;
+
+      ------------------------
+      -- Round_Up_Overflows --
+      ------------------------
+
+      function Round_Up_Overflows (Size : Storage_Count) return Boolean is
+         Max_Align : constant Storage_Count := Standard'Maximum_Alignment;
+
+      begin
+         return Storage_Count (SS_Ptr'Last) - Max_Align < Size;
+      end Round_Up_Overflows;
+
+      --  Local variables
+
+      Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
+      --  The secondary stack of the current task
 
-      Max_Align   : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
       Mem_Request : SS_Ptr;
 
-      Stack       : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all;
+   --  Start of processing for SS_Allocate
+
    begin
-      --  Round up Storage_Size to the nearest multiple of the max alignment
-      --  value for the target. This ensures efficient stack access. First
-      --  perform a check to ensure that the rounding operation does not
-      --  overflow SS_Ptr.
-
-      if SSE.Storage_Count (SS_Ptr'Last) - Standard'Maximum_Alignment <
-        Storage_Size
-      then
+      --  It should not be possible to allocate an object of size zero
+
+      pragma Assert (Storage_Size > 0);
+
+      --  Round up the requested allocation size to the nearest multiple of the
+      --  maximum alignment value for the target. This ensures efficient stack
+      --  access. Check that the rounding operation does not overflow SS_Ptr.
+
+      if Round_Up_Overflows (Storage_Size) then
          raise Storage_Error;
       end if;
 
-      Mem_Request := ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) *
-                       Max_Align;
+      Mem_Request := Round_Up (Storage_Size);
 
-      --  Case of fixed secondary stack
+      if Sec_Stack_Dynamic then
+         SS_Allocate_Dynamic (Stack, Mem_Request, Addr);
 
-      if not SP.Sec_Stack_Dynamic then
-         --  Check if max stack usage is increasing
+      else
+         SS_Allocate_Static (Stack, Mem_Request, Addr);
+      end if;
+   end SS_Allocate;
+
+   -------------------------
+   -- SS_Allocate_Dynamic --
+   -------------------------
+
+   procedure SS_Allocate_Dynamic
+     (Stack       : SS_Stack_Ptr;
+      Mem_Request : SS_Ptr;
+      Addr        : out Address)
+   is
+      procedure Delete_Chunk (Chunk : in out Chunk_Ptr);
+      pragma Inline (Delete_Chunk);
+      --  Unchain chunk Chunk from the secondary stack and delete it
 
-         if Stack.Max - Stack.Top - Mem_Request < 0 then
+      procedure Link_Chunks (First : Chunk_Ptr; Second : Chunk_Ptr);
+      pragma Inline (Link_Chunks);
+      --  Link chunk Second to chunk First
 
-            --  If so, check if the stack is exceeded, noting Stack.Top points
-            --  to the first free byte (so the value of Stack.Top on a fully
-            --  allocated stack will be Stack.Size + 1). The comparison is
-            --  formed to prevent integer overflows.
+      procedure Update_Max;
+      pragma Inline (Update_Max);
+      --  Raise the Max watermark if needed, based on Stack.Top
 
-            if Stack.Size - Stack.Top - Mem_Request < -1 then
-               raise Storage_Error;
-            end if;
+      ------------------
+      -- Delete_Chunk --
+      ------------------
+
+      procedure Delete_Chunk (Chunk : in out Chunk_Ptr) is
+         Next : constant Chunk_Ptr := Chunk.Next;
+         Prev : constant Chunk_Ptr := Chunk.Prev;
+
+      begin
+         --  A chunk must always succeed another chunk. In the base case, that
+         --  chunk is the Internal_Chunk.
+
+         pragma Assert (Prev /= null);
+
+         Chunk.Next := null;    --        Chunk --> X
+         Chunk.Prev := null;    --  X <-- Chunk
+
+         --  The chunk being deleted is the last chunk
 
-            --  Record new max usage
+         if Next = null then
+            Prev.Next := null;  --  Prev --> X
 
-            Stack.Max := Stack.Top + Mem_Request;
+         --  Otherwise link both the Prev and Next chunks
+
+         else
+            Link_Chunks (Prev, Next);
          end if;
 
-         --  Set resulting address and update top of stack pointer
+         Free (Chunk);
+      end Delete_Chunk;
+
+      -----------------
+      -- Link_Chunks --
+      -----------------
 
-         Addr := Stack.Internal_Chunk.Mem (Stack.Top)'Address;
+      procedure Link_Chunks (First : Chunk_Ptr; Second : Chunk_Ptr) is
+      begin
+         First.Next  := Second;  --  First --> Second
+         Second.Prev := First;   --  First <-- Second
+      end Link_Chunks;
+
+      ----------------
+      -- Update_Max --
+      ----------------
+
+      procedure Update_Max is
+      begin
+         if Stack.Top > Stack.Max then
+            Stack.Max := Stack.Top;
+         end if;
+      end Update_Max;
+
+      --  Local variables
+
+      Chunk      : Chunk_Ptr;
+      Chunk_Size : SS_Ptr;
+      Next_Chunk : Chunk_Ptr;
+      Top_Chunk  : Chunk_Ptr;
+
+   --  Start of processing for SS_Allocate_Dynamic
+
+   begin
+      --  Find the chunk where Top lives by going in reverse, starting from
+      --  Current_Chunk.
+      --
+      --          Top
+      --          |
+      --    +--------+ --> +----------+ --> +-----------------+
+      --    |#####|  |     |####      |     |###########      |
+      --    +--------+ <-- +----------+ <-- +-----------------+
+      --                                             ^
+      --                                        Current_Chunk
+
+      Top_Chunk := Stack.Current_Chunk;
+
+      while Top_Chunk.First > Stack.Top loop
+         Top_Chunk := Top_Chunk.Prev;
+      end loop;
+
+      --  Inspect Top_Chunk to determine whether the remaining space is big
+      --  enough to fit the object.
+      --
+      --      Addr Top
+      --      |    |
+      --    +--------+ ...
+      --    |######| |
+      --    +--------+ ...
+      --         ^
+      --     Top_Chunk
+
+      if Top_Chunk.Last - Stack.Top + 1 >= Mem_Request then
+         Addr      := Top_Chunk.Mem (Stack.Top)'Address;
          Stack.Top := Stack.Top + Mem_Request;
+         Update_Max;
 
-      --  Case of dynamic secondary stack
+         return;
+      end if;
 
-      else
-         declare
-            Chunk                : Chunk_Ptr;
-            Chunk_Size           : SS_Ptr;
-            To_Be_Released_Chunk : Chunk_Ptr;
+      --  At this point it is known that Top_Chunk is not big enough to fit
+      --  the object. Examine subsequent chunks using the following criteria:
+      --
+      --    * If a chunk is too small to fit the object, delete it
+      --
+      --    * If a chunk is big enough to fit the object, use that chunk
 
-         begin
-            Chunk := Stack.Current_Chunk;
+      Chunk := Top_Chunk.Next;
+      while Chunk /= null loop
 
-            --  The Current_Chunk may not be the best one if a lot of release
-            --  operations have taken place. Go down the stack if necessary.
+         --  Capture the next chunk in case the current one is deleted
 
-            while Chunk.First > Stack.Top loop
-               Chunk := Chunk.Prev;
-            end loop;
+         Next_Chunk := Chunk.Next;
 
-            --  Find out if the available memory in the current chunk is
-            --  sufficient, if not, go to the next one and eventually create
-            --  the necessary room.
+         --  The current chunk is too small to fit the object and must be
+         --  deleted to avoid creating a hole in the secondary stack. Note
+         --  that this may delete the Current_Chunk.
 
-            while Chunk.Last - Stack.Top - Mem_Request < -1 loop
-               if Chunk.Next /= null then
-                  --  Release unused non-first empty chunk
+         if Chunk.Last - Chunk.First + 1 < Mem_Request then
+            Delete_Chunk (Chunk);
 
-                  if Chunk.Prev /= null and then Chunk.First = Stack.Top then
-                     To_Be_Released_Chunk := Chunk;
-                     Chunk := Chunk.Prev;
-                     Chunk.Next := To_Be_Released_Chunk.Next;
-                     To_Be_Released_Chunk.Next.Prev := Chunk;
-                     Free (To_Be_Released_Chunk);
-                  end if;
+         --  Otherwise the chunk is big enough to fit the object. Use this
+         --  chunk to store the object.
+         --
+         --                    Addr   Top
+         --                    |      |
+         --    +--------+ --> +----------+ ... ...................
+         --    |#####   |     |#######|  |     :                 :
+         --    +--------+ <-- +----------+ ... ...................
+         --        ^               ^                    ^
+         --    Top_Chunk         Chunk             Current_Chunk
 
-               --  Create a new chunk
+         else
+            Addr      := Chunk.Mem (Chunk.First)'Address;
+            Stack.Top := Chunk.First + Mem_Request;
+            Update_Max;
 
-               else
-                  --  The new chunk should be no smaller than the default
-                  --  chunk size to minimize the amount of secondary stack
-                  --  management.
+            return;
+         end if;
 
-                  if Mem_Request <= Stack.Size then
-                     Chunk_Size := Stack.Size;
-                  else
-                     Chunk_Size := Mem_Request;
-                  end if;
+         Chunk := Next_Chunk;
+      end loop;
 
-                  --  Check that the indexing limits are not exceeded
+      --  At this point one of the following outcomes took place:
+      --
+      --    * Top_Chunk is the last chunk in the secondary stack
+      --
+      --    * Top_Chunk was not the last chunk originally. It was followed by
+      --      chunks which were too small to fit the object and as a result
+      --      were deleted, thus making Top_Chunk the last chunk.
 
-                  if SS_Ptr'Last - Chunk.Last - Chunk_Size < 0 then
-                     raise Storage_Error;
-                  end if;
+      pragma Assert (Top_Chunk.Next = null);
 
-                  Chunk.Next :=
-                    new Chunk_Id
-                      (First => Chunk.Last + 1,
-                       Last  => Chunk.Last + Chunk_Size);
+      --  Create a new chunk big enough to fit the object. The size of the
+      --  chunk must be at least the minimum default size.
 
-                  Chunk.Next.Prev := Chunk;
-               end if;
+      if Mem_Request <= Stack.Size then
+         Chunk_Size := Stack.Size;
+      else
+         Chunk_Size := Mem_Request;
+      end if;
 
-               Chunk     := Chunk.Next;
-               Stack.Top := Chunk.First;
-            end loop;
+      --  Check that the indexing limits are not exceeded
 
-            --  Resulting address is the address pointed by Stack.Top
+      if SS_Ptr'Last - Top_Chunk.Last < Chunk_Size then
+         raise Storage_Error;
+      end if;
 
-            Addr                := Chunk.Mem (Stack.Top)'Address;
-            Stack.Top           := Stack.Top + Mem_Request;
-            Stack.Current_Chunk := Chunk;
+      Chunk :=
+        new Chunk_Id
+              (First => Top_Chunk.Last + 1,
+               Last  => Top_Chunk.Last + Chunk_Size);
+
+      --  Grow the secondary stack by adding the new chunk to Top_Chunk. The
+      --  new chunk also becomes the Current_Chunk because it is the last in
+      --  the list of chunks.
+      --
+      --                    Addr      Top
+      --                    |         |
+      --    +--------+ --> +-------------+
+      --    |#####   |     |##########|  |
+      --    +--------+ <-- +-------------+
+      --        ^                ^
+      --    Top_Chunk       Current_Chunk
+
+      Link_Chunks (Top_Chunk, Chunk);
+      Stack.Current_Chunk := Chunk;
+
+      Addr      := Chunk.Mem (Chunk.First)'Address;
+      Stack.Top := Chunk.First + Mem_Request;
+      Update_Max;
+   end SS_Allocate_Dynamic;
+
+   ------------------------
+   -- SS_Allocate_Static --
+   ------------------------
+
+   procedure SS_Allocate_Static
+     (Stack       : SS_Stack_Ptr;
+      Mem_Request : SS_Ptr;
+      Addr        : out Address)
+   is
+   begin
+      --  Check if the max stack usage is increasing
 
-            --  Record new max usage
+      if Stack.Max - Stack.Top < Mem_Request then
 
-            if Stack.Top > Stack.Max then
-               Stack.Max := Stack.Top;
-            end if;
+         --  Check if the stack will be exceeded. Note that Stack.Top points to
+         --  the first free byte, therefore the Stack.Top of a fully allocated
+         --  stack is equal to Stack.Size + 1. This check prevents overflow.
 
-         end;
+         if Stack.Size - Stack.Top + 1 < Mem_Request then
+            raise Storage_Error;
+         end if;
+
+         --  Record new max usage
+
+         Stack.Max := Stack.Top + Mem_Request;
       end if;
-   end SS_Allocate;
+
+      --  Set resulting address and update top of stack pointer
+      --
+      --        Addr   Top
+      --        |      |
+      --    +-------------------+
+      --    |##########|        |
+      --    +-------------------+
+      --              ^
+      --        Internal_Chunk
+
+      Addr      := Stack.Internal_Chunk.Mem (Stack.Top)'Address;
+      Stack.Top := Stack.Top + Mem_Request;
+   end SS_Allocate_Static;
 
    -------------
    -- SS_Free --
@@ -186,32 +392,27 @@ package body System.Secondary_Stack is
 
    procedure SS_Free (Stack : in out SS_Stack_Ptr) is
       procedure Free is
-         new Ada.Unchecked_Deallocation (SS_Stack, SS_Stack_Ptr);
+        new Ada.Unchecked_Deallocation (SS_Stack, SS_Stack_Ptr);
+
+      Chunk : Chunk_Ptr;
+
    begin
       --  If using dynamic secondary stack, free any external chunks
 
       if SP.Sec_Stack_Dynamic then
-         declare
-            Chunk : Chunk_Ptr;
+         Chunk := Stack.Current_Chunk;
 
-            procedure Free is
-              new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
+         --  Go to top of linked list and free backwards. Do not free the
+         --  internal chunk as it is part of SS_Stack.
 
-         begin
-            Chunk := Stack.Current_Chunk;
-
-            --  Go to top of linked list and free backwards. Do not free the
-            --  internal chunk as it is part of SS_Stack.
-
-            while Chunk.Next /= null loop
-               Chunk := Chunk.Next;
-            end loop;
+         while Chunk.Next /= null loop
+            Chunk := Chunk.Next;
+         end loop;
 
-            while Chunk.Prev /= null loop
-               Chunk := Chunk.Prev;
-               Free (Chunk.Next);
-            end loop;
-         end;
+         while Chunk.Prev /= null loop
+            Chunk := Chunk.Prev;
+            Free (Chunk.Next);
+         end loop;
       end if;
 
       if Stack.Freeable then
@@ -224,7 +425,8 @@ package body System.Secondary_Stack is
    ----------------
 
    function SS_Get_Max return Long_Long_Integer is
-      Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all;
+      Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
+
    begin
       --  Stack.Max points to the first untouched byte in the stack, thus the
       --  maximum number of bytes that have been allocated on the stack is one
@@ -238,7 +440,7 @@ package body System.Secondary_Stack is
    -------------
 
    procedure SS_Info is
-      Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all;
+      Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
    begin
       Put_Line ("Secondary Stack information:");
 
@@ -257,8 +459,8 @@ package body System.Secondary_Stack is
 
       else
          declare
-            Nb_Chunks : Integer   := 1;
             Chunk     : Chunk_Ptr := Stack.Current_Chunk;
+            Nb_Chunks : Integer   := 1;
 
          begin
             while Chunk.Prev /= null loop
@@ -273,8 +475,9 @@ package body System.Secondary_Stack is
             --  Current Chunk information
 
             --  Note that First of each chunk is one more than Last of the
-            --  previous one, so Chunk.Last is the total size of all chunks; we
-            --  don't need to walk all the chunks to compute the total size.
+            --  previous one, so Chunk.Last is the total size of all chunks;
+            --  we do not need to walk all the chunks to compute the total
+            --  size.
 
             Put_Line ("  Total size              : "
                       & SS_Ptr'Image (Chunk.Last)
@@ -301,9 +504,8 @@ package body System.Secondary_Stack is
      (Stack : in out SS_Stack_Ptr;
       Size  : SP.Size_Type := SP.Unspecified_Size)
    is
-      use Parameters;
-
       Stack_Size : Size_Type;
+
    begin
       --  If Stack is not null then the stack has been allocated outside the
       --  package (by the compiler or the user) and all that is left to do is
@@ -317,6 +519,7 @@ package body System.Secondary_Stack is
 
       if Stack = null then
          if Size = Unspecified_Size then
+
             --  Cover the case when bootstraping with an old compiler that does
             --  not set Default_SS_Size.
 
@@ -393,7 +596,8 @@ package body System.Secondary_Stack is
    -------------
 
    function SS_Mark return Mark_Id is
-      Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all;
+      Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
+
    begin
       return (Sec_Stack => Stack, Sptr => Stack.Top);
    end SS_Mark;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a3c2ff9ccb0fa7ca5683eb954ecd409c7c267910..b48eaec980c1f829390527d74bbe5d807aedd17a 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-05-25  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * gnat.dg/sec_stack2.adb: New testcase.
+
 2018-05-25  Ed Schonberg  <schonberg@adacore.com>
 
        * gnat.dg/interface6.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/sec_stack2.adb b/gcc/testsuite/gnat.dg/sec_stack2.adb
new file mode 100644 (file)
index 0000000..d07f45c
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/sec_stack2.adb
@@ -0,0 +1,90 @@
+--  { dg-do run }
+--  { dg-options "-gnatws" }
+
+with Ada.Strings.Unbounded;  use Ada.Strings.Unbounded;
+with Ada.Text_IO;            use Ada.Text_IO;
+with System.Parameters;      use System.Parameters;
+with System.Secondary_Stack; use System.Secondary_Stack;
+
+procedure Sec_Stack2 is
+   procedure Overflow_SS_Index;
+   --  Create a scenario where the frame index of the secondary stack overflows
+   --  while the stack itself uses little memory.
+
+   -----------------------
+   -- Overflow_SS_Index --
+   -----------------------
+
+   procedure Overflow_SS_Index is
+      Max_Iterations : constant := 20_000;
+      --  The approximate number of iterations needed to overflow the frame
+      --  index type on a 64bit target.
+
+      Algn : constant Positive := Positive (Standard'Maximum_Alignment);
+      --  The maximum alignment of the target
+
+      Size : constant Positive := Positive (Runtime_Default_Sec_Stack_Size);
+      --  The default size of the secondary stack on the target
+
+      Base_Str : constant String (1 .. Size) := (others => 'a');
+      --  A string big enough to fill the static frame of the secondary stack
+
+      Small_Str : constant String (1 .. Algn) := (others => 'a');
+      --  A string small enough to cause a new round up to the nearest multiple
+      --  of the maximum alignment on the target at each new iteration of the
+      --  loop.
+
+      Base_US : Unbounded_String := To_Unbounded_String (Base_Str);
+      --  Unbounded version of the base string
+
+      procedure SS_Print is new SS_Info (Put_Line);
+
+   begin
+      for Iteration in 1 .. Max_Iterations loop
+
+          --  Grow the base string by a small amount at each iteration of the
+          --  loop.
+
+          Append (Base_US, Small_Str);
+
+          --  Convert the unbounded base into a new base. This causes routine
+          --  To_String to allocates the new base on the secondary stack. Since
+          --  the new base is slignly bigger than the previous base, the stack
+          --  would have to create a new frame.
+
+          --  Due to an issue with frame reclamation, the last frame (which is
+          --  also not big enough to fit the new base) is never reclaimed. This
+          --  causes the range of the new frame to shift toward the overflow
+          --  point of the frame index type.
+
+          begin
+             declare
+                New_Base_Str : constant String := To_String (Base_US);
+             begin null; end;
+
+          exception
+             when Storage_Error =>
+                Put_Line ("ERROR: SS depleted");
+                Put_Line ("Iteration:" & Iteration'Img);
+                Put_Line ("SS_Size  :" & Size'Img);
+                Put_Line ("SS_Algn  :" & Algn'Img);
+
+                SS_Print;
+                exit;
+
+             when others =>
+                Put_Line ("ERROR: unexpected exception");
+                exit;
+          end;
+      end loop;
+   end Overflow_SS_Index;
+
+--  Start of processing for SS_Depletion
+
+begin
+   --  This issue manifests only on targets with a dynamic secondary stack
+
+   if Sec_Stack_Dynamic then
+      Overflow_SS_Index;
+   end if;
+end Sec_Stack2;