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 405 additions and 94 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>
* doc/gnat_ugn/gnat_and_program_execution.rst: Add description of '-U'
......
gcc/ada/libgnat/s-secsta.adb
......@@ -33,112 +33,280 @@ 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);
Mem_Request : SS_Ptr;
Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all;
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.
return ((SS_Ptr (Size) + Max_Align - 1) / Max_Align) * Max_Align;
end Round_Up;
if SSE.Storage_Count (SS_Ptr'Last) - Standard'Maximum_Alignment <
Storage_Size
then
raise Storage_Error;
end if;
------------------------
-- Round_Up_Overflows --
------------------------
Mem_Request := ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) *
Max_Align;
function Round_Up_Overflows (Size : Storage_Count) return Boolean is
Max_Align : constant Storage_Count := Standard'Maximum_Alignment;
-- Case of fixed secondary stack
begin
return Storage_Count (SS_Ptr'Last) - Max_Align < Size;
end Round_Up_Overflows;
if not SP.Sec_Stack_Dynamic then
-- Check if max stack usage is increasing
-- Local variables
if Stack.Max - Stack.Top - Mem_Request < 0 then
Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
-- The secondary stack of the current task
-- 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.
Mem_Request : SS_Ptr;
-- Start of processing for SS_Allocate
begin
-- It should not be possible to allocate an object of size zero
if Stack.Size - Stack.Top - Mem_Request < -1 then
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;
-- Record new max usage
Mem_Request := Round_Up (Storage_Size);
Stack.Max := Stack.Top + Mem_Request;
if Sec_Stack_Dynamic then
SS_Allocate_Dynamic (Stack, Mem_Request, Addr);
else
SS_Allocate_Static (Stack, Mem_Request, Addr);
end if;
end SS_Allocate;
-- Set resulting address and update top of stack pointer
-------------------------
-- SS_Allocate_Dynamic --
-------------------------
Addr := Stack.Internal_Chunk.Mem (Stack.Top)'Address;
Stack.Top := Stack.Top + Mem_Request;
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
-- Case of dynamic secondary stack
procedure Link_Chunks (First : Chunk_Ptr; Second : Chunk_Ptr);
pragma Inline (Link_Chunks);
-- Link chunk Second to chunk First
procedure Update_Max;
pragma Inline (Update_Max);
-- Raise the Max watermark if needed, based on Stack.Top
------------------
-- 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
if Next = null then
Prev.Next := null; -- Prev --> X
-- Otherwise link both the Prev and Next chunks
else
declare
Link_Chunks (Prev, Next);
end if;
Free (Chunk);
end Delete_Chunk;
-----------------
-- Link_Chunks --
-----------------
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;
To_Be_Released_Chunk : Chunk_Ptr;
Next_Chunk : Chunk_Ptr;
Top_Chunk : Chunk_Ptr;
-- Start of processing for SS_Allocate_Dynamic
begin
Chunk := Stack.Current_Chunk;
-- 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;
-- The Current_Chunk may not be the best one if a lot of release
-- operations have taken place. Go down the stack if necessary.
-- 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;
while Chunk.First > Stack.Top loop
Chunk := Chunk.Prev;
end loop;
return;
end if;
-- 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.
-- 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
while Chunk.Last - Stack.Top - Mem_Request < -1 loop
if Chunk.Next /= null then
-- Release unused non-first empty chunk
Chunk := Top_Chunk.Next;
while Chunk /= null loop
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;
-- Capture the next chunk in case the current one is deleted
Next_Chunk := Chunk.Next;
-- 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.
if Chunk.Last - Chunk.First + 1 < Mem_Request then
Delete_Chunk (Chunk);
-- Create a new chunk
-- Otherwise the chunk is big enough to fit the object. Use this
-- chunk to store the object.
--
-- Addr Top
-- | |
-- +--------+ --> +----------+ ... ...................
-- |##### | |#######| | : :
-- +--------+ <-- +----------+ ... ...................
-- ^ ^ ^
-- Top_Chunk Chunk Current_Chunk
else
-- The new chunk should be no smaller than the default
-- chunk size to minimize the amount of secondary stack
-- management.
Addr := Chunk.Mem (Chunk.First)'Address;
Stack.Top := Chunk.First + Mem_Request;
Update_Max;
return;
end if;
Chunk := Next_Chunk;
end loop;
-- 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.
pragma Assert (Top_Chunk.Next = null);
-- Create a new chunk big enough to fit the object. The size of the
-- chunk must be at least the minimum default size.
if Mem_Request <= Stack.Size then
Chunk_Size := Stack.Size;
......@@ -148,37 +316,75 @@ package body System.Secondary_Stack is
-- Check that the indexing limits are not exceeded
if SS_Ptr'Last - Chunk.Last - Chunk_Size < 0 then
if SS_Ptr'Last - Top_Chunk.Last < Chunk_Size then
raise Storage_Error;
end if;
Chunk.Next :=
Chunk :=
new Chunk_Id
(First => Chunk.Last + 1,
Last => Chunk.Last + Chunk_Size);
(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;
Chunk.Next.Prev := Chunk;
end if;
Addr := Chunk.Mem (Chunk.First)'Address;
Stack.Top := Chunk.First + Mem_Request;
Update_Max;
end SS_Allocate_Dynamic;
Chunk := Chunk.Next;
Stack.Top := Chunk.First;
end loop;
------------------------
-- SS_Allocate_Static --
------------------------
-- Resulting address is the address pointed by Stack.Top
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
Addr := Chunk.Mem (Stack.Top)'Address;
Stack.Top := Stack.Top + Mem_Request;
Stack.Current_Chunk := Chunk;
if Stack.Max - Stack.Top < Mem_Request then
-- Record new max usage
-- 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.
if Stack.Top > Stack.Max then
Stack.Max := Stack.Top;
if Stack.Size - Stack.Top + 1 < Mem_Request then
raise Storage_Error;
end if;
end;
-- 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 --
......@@ -187,17 +393,13 @@ 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);
begin
-- If using dynamic secondary stack, free any external chunks
if SP.Sec_Stack_Dynamic then
declare
Chunk : Chunk_Ptr;
procedure Free is
new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
begin
-- If using dynamic secondary stack, free any external chunks
if SP.Sec_Stack_Dynamic then
Chunk := Stack.Current_Chunk;
-- Go to top of linked list and free backwards. Do not free the
......@@ -211,7 +413,6 @@ package body System.Secondary_Stack is
Chunk := Chunk.Prev;
Free (Chunk.Next);
end loop;
end;
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;
......
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>
* 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