Skip to content

R
riscv-gcc-1
Commit 25eadeea by Hristian Kirtchev Committed by Pierre-Marie de Rodat
Options

[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
parent bd42db1f
Showing with 431 additions and 120 deletions
gcc/ada/ChangeLog
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> 2018-05-25 Sergey Rybin <rybin@adacore.com>
* doc/gnat_ugn/gnat_and_program_execution.rst: Add description of '-U' * doc/gnat_ugn/gnat_and_program_execution.rst: Add description of '-U'
......
gcc/ada/libgnat/s-secsta.adb
...@@ -33,152 +33,358 @@ pragma Compiler_Unit_Warning; ...@@ -33,152 +33,358 @@ pragma Compiler_Unit_Warning;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
with System.Soft_Links;
package body System.Secondary_Stack is with System.Parameters; use System.Parameters;
with System.Soft_Links; use System.Soft_Links;
package SSL renames 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); procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
-- Free a dynamically allocated chunk -- 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 -- -- SS_Allocate --
----------------- -----------------
procedure SS_Allocate procedure SS_Allocate
(Addr : out Address; (Addr : out Address;
Storage_Size : SSE.Storage_Count) Storage_Size : Storage_Count)
is 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; Mem_Request : SS_Ptr;
Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; -- Start of processing for SS_Allocate
begin begin
-- Round up Storage_Size to the nearest multiple of the max alignment -- It should not be possible to allocate an object of size zero
-- value for the target. This ensures efficient stack access. First
-- perform a check to ensure that the rounding operation does not pragma Assert (Storage_Size > 0);
-- overflow SS_Ptr.
-- Round up the requested allocation size to the nearest multiple of the
if SSE.Storage_Count (SS_Ptr'Last) - Standard'Maximum_Alignment < -- maximum alignment value for the target. This ensures efficient stack
Storage_Size -- access. Check that the rounding operation does not overflow SS_Ptr.
then
if Round_Up_Overflows (Storage_Size) then
raise Storage_Error; raise Storage_Error;
end if; end if;
Mem_Request := ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) * Mem_Request := Round_Up (Storage_Size);
Max_Align;
-- Case of fixed secondary stack if Sec_Stack_Dynamic then
SS_Allocate_Dynamic (Stack, Mem_Request, Addr);
if not SP.Sec_Stack_Dynamic then else
-- Check if max stack usage is increasing 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 procedure Update_Max;
-- to the first free byte (so the value of Stack.Top on a fully pragma Inline (Update_Max);
-- allocated stack will be Stack.Size + 1). The comparison is -- Raise the Max watermark if needed, based on Stack.Top
-- formed to prevent integer overflows.
if Stack.Size - Stack.Top - Mem_Request < -1 then ------------------
raise Storage_Error; -- Delete_Chunk --
end if; ------------------
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; 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; Stack.Top := Stack.Top + Mem_Request;
Update_Max;
-- Case of dynamic secondary stack return;
end if;
else -- At this point it is known that Top_Chunk is not big enough to fit
declare -- the object. Examine subsequent chunks using the following criteria:
Chunk : Chunk_Ptr; --
Chunk_Size : SS_Ptr; -- * If a chunk is too small to fit the object, delete it
To_Be_Released_Chunk : Chunk_Ptr; --
-- * If a chunk is big enough to fit the object, use that chunk
begin Chunk := Top_Chunk.Next;
Chunk := Stack.Current_Chunk; while Chunk /= null loop
-- The Current_Chunk may not be the best one if a lot of release -- Capture the next chunk in case the current one is deleted
-- operations have taken place. Go down the stack if necessary.
while Chunk.First > Stack.Top loop Next_Chunk := Chunk.Next;
Chunk := Chunk.Prev;
end loop;
-- Find out if the available memory in the current chunk is -- The current chunk is too small to fit the object and must be
-- sufficient, if not, go to the next one and eventually create -- deleted to avoid creating a hole in the secondary stack. Note
-- the necessary room. -- that this may delete the Current_Chunk.
while Chunk.Last - Stack.Top - Mem_Request < -1 loop if Chunk.Last - Chunk.First + 1 < Mem_Request then
if Chunk.Next /= null then Delete_Chunk (Chunk);
-- Release unused non-first empty chunk
if Chunk.Prev /= null and then Chunk.First = Stack.Top then -- Otherwise the chunk is big enough to fit the object. Use this
To_Be_Released_Chunk := Chunk; -- chunk to store the object.
Chunk := Chunk.Prev; --
Chunk.Next := To_Be_Released_Chunk.Next; -- Addr Top
To_Be_Released_Chunk.Next.Prev := Chunk; -- | |
Free (To_Be_Released_Chunk); -- +--------+ --> +----------+ ... ...................
end if; -- |##### | |#######| | : :
-- +--------+ <-- +----------+ ... ...................
-- ^ ^ ^
-- 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 return;
-- The new chunk should be no smaller than the default end if;
-- chunk size to minimize the amount of secondary stack
-- management.
if Mem_Request <= Stack.Size then Chunk := Next_Chunk;
Chunk_Size := Stack.Size; end loop;
else
Chunk_Size := Mem_Request;
end if;
-- 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 pragma Assert (Top_Chunk.Next = null);
raise Storage_Error;
end if;
Chunk.Next := -- Create a new chunk big enough to fit the object. The size of the
new Chunk_Id -- chunk must be at least the minimum default size.
(First => Chunk.Last + 1,
Last => Chunk.Last + Chunk_Size);
Chunk.Next.Prev := Chunk; if Mem_Request <= Stack.Size then
end if; Chunk_Size := Stack.Size;
else
Chunk_Size := Mem_Request;
end if;
Chunk := Chunk.Next; -- Check that the indexing limits are not exceeded
Stack.Top := Chunk.First;
end loop;
-- 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; Chunk :=
Stack.Top := Stack.Top + Mem_Request; new Chunk_Id
Stack.Current_Chunk := Chunk; (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 -- Check if the stack will be exceeded. Note that Stack.Top points to
Stack.Max := Stack.Top; -- the first free byte, therefore the Stack.Top of a fully allocated
end if; -- 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 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 -- -- SS_Free --
...@@ -186,32 +392,27 @@ package body System.Secondary_Stack is ...@@ -186,32 +392,27 @@ package body System.Secondary_Stack is
procedure SS_Free (Stack : in out SS_Stack_Ptr) is procedure SS_Free (Stack : in out SS_Stack_Ptr) is
procedure Free 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 begin
-- If using dynamic secondary stack, free any external chunks -- If using dynamic secondary stack, free any external chunks
if SP.Sec_Stack_Dynamic then if SP.Sec_Stack_Dynamic then
declare Chunk := Stack.Current_Chunk;
Chunk : Chunk_Ptr;
procedure Free is -- Go to top of linked list and free backwards. Do not free the
new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); -- internal chunk as it is part of SS_Stack.
begin while Chunk.Next /= null loop
Chunk := Stack.Current_Chunk; Chunk := Chunk.Next;
end loop;
-- 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.Prev /= null loop while Chunk.Prev /= null loop
Chunk := Chunk.Prev; Chunk := Chunk.Prev;
Free (Chunk.Next); Free (Chunk.Next);
end loop; end loop;
end;
end if; end if;
if Stack.Freeable then if Stack.Freeable then
...@@ -224,7 +425,8 @@ package body System.Secondary_Stack is ...@@ -224,7 +425,8 @@ package body System.Secondary_Stack is
---------------- ----------------
function SS_Get_Max return Long_Long_Integer 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 begin
-- Stack.Max points to the first untouched byte in the stack, thus the -- 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 -- maximum number of bytes that have been allocated on the stack is one
...@@ -238,7 +440,7 @@ package body System.Secondary_Stack is ...@@ -238,7 +440,7 @@ package body System.Secondary_Stack is
------------- -------------
procedure SS_Info 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 begin
Put_Line ("Secondary Stack information:"); Put_Line ("Secondary Stack information:");
...@@ -257,8 +459,8 @@ package body System.Secondary_Stack is ...@@ -257,8 +459,8 @@ package body System.Secondary_Stack is
else else
declare declare
Nb_Chunks : Integer := 1;
Chunk : Chunk_Ptr := Stack.Current_Chunk; Chunk : Chunk_Ptr := Stack.Current_Chunk;
Nb_Chunks : Integer := 1;
begin begin
while Chunk.Prev /= null loop while Chunk.Prev /= null loop
...@@ -273,8 +475,9 @@ package body System.Secondary_Stack is ...@@ -273,8 +475,9 @@ package body System.Secondary_Stack is
-- Current Chunk information -- Current Chunk information
-- Note that First of each chunk is one more than Last of the -- 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 -- previous one, so Chunk.Last is the total size of all chunks;
-- don't need to walk all the chunks to compute the total size. -- we do not need to walk all the chunks to compute the total
-- size.
Put_Line (" Total size : " Put_Line (" Total size : "
& SS_Ptr'Image (Chunk.Last) & SS_Ptr'Image (Chunk.Last)
...@@ -301,9 +504,8 @@ package body System.Secondary_Stack is ...@@ -301,9 +504,8 @@ package body System.Secondary_Stack is
(Stack : in out SS_Stack_Ptr; (Stack : in out SS_Stack_Ptr;
Size : SP.Size_Type := SP.Unspecified_Size) Size : SP.Size_Type := SP.Unspecified_Size)
is is
use Parameters;
Stack_Size : Size_Type; Stack_Size : Size_Type;
begin begin
-- If Stack is not null then the stack has been allocated outside the -- 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 -- 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 ...@@ -317,6 +519,7 @@ package body System.Secondary_Stack is
if Stack = null then if Stack = null then
if Size = Unspecified_Size then if Size = Unspecified_Size then
-- Cover the case when bootstraping with an old compiler that does -- Cover the case when bootstraping with an old compiler that does
-- not set Default_SS_Size. -- not set Default_SS_Size.
...@@ -393,7 +596,8 @@ package body System.Secondary_Stack is ...@@ -393,7 +596,8 @@ package body System.Secondary_Stack is
------------- -------------
function SS_Mark return Mark_Id 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 begin
return (Sec_Stack => Stack, Sptr => Stack.Top); return (Sec_Stack => Stack, Sptr => Stack.Top);
end SS_Mark; end SS_Mark;
......
gcc/testsuite/ChangeLog
2018-05-25 Hristian Kirtchev <kirtchev@adacore.com>
* gnat.dg/sec_stack2.adb: New testcase.
2018-05-25 Ed Schonberg <schonberg@adacore.com> 2018-05-25 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/interface6.adb: New testcase. * gnat.dg/interface6.adb: New testcase.
......
gcc/testsuite/gnat.dg/sec_stack2.adb 0 → 100644
-- { 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment