975 lines
33 KiB
Ada
975 lines
33 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- S Y S T E M . S E C O N D A R Y _ S T A C K --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
-- --
|
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
|
-- version 3.1, as published by the Free Software Foundation. --
|
|
-- --
|
|
-- You should have received a copy of the GNU General Public License and --
|
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
-- <http://www.gnu.org/licenses/>. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
pragma Compiler_Unit_Warning;
|
|
|
|
with Ada.Unchecked_Conversion;
|
|
with Ada.Unchecked_Deallocation;
|
|
|
|
with System; use System;
|
|
with System.Parameters; use System.Parameters;
|
|
with System.Soft_Links; use System.Soft_Links;
|
|
with System.Storage_Elements; use System.Storage_Elements;
|
|
|
|
package body System.Secondary_Stack is
|
|
|
|
------------------------------------
|
|
-- Binder Allocated Stack Support --
|
|
------------------------------------
|
|
|
|
-- When at least one of the following restrictions
|
|
--
|
|
-- No_Implicit_Heap_Allocations
|
|
-- No_Implicit_Task_Allocations
|
|
--
|
|
-- is in effect, the binder creates a static secondary stack pool, where
|
|
-- each stack has a default size. Assignment of these stacks to tasks is
|
|
-- performed by SS_Init. The following variables are defined in this unit
|
|
-- in order to avoid depending on the binder. Their values are set by the
|
|
-- binder.
|
|
|
|
Binder_SS_Count : Natural;
|
|
pragma Export (Ada, Binder_SS_Count, "__gnat_binder_ss_count");
|
|
-- The number of secondary stacks in the pool created by the binder
|
|
|
|
Binder_Default_SS_Size : Size_Type;
|
|
pragma Export (Ada, Binder_Default_SS_Size, "__gnat_default_ss_size");
|
|
-- The default secondary stack size as specified by the binder. The value
|
|
-- is defined here rather than in init.c or System.Init because the ZFP and
|
|
-- Ravenscar-ZFP run-times lack these locations.
|
|
|
|
Binder_Default_SS_Pool : Address;
|
|
pragma Export (Ada, Binder_Default_SS_Pool, "__gnat_default_ss_pool");
|
|
-- The address of the secondary stack pool created by the binder
|
|
|
|
Binder_Default_SS_Pool_Index : Natural := 0;
|
|
-- Index into the secondary stack pool created by the binder
|
|
|
|
-----------------------
|
|
-- Local subprograms --
|
|
-----------------------
|
|
|
|
procedure Allocate_Dynamic
|
|
(Stack : SS_Stack_Ptr;
|
|
Mem_Size : Memory_Size;
|
|
Addr : out Address);
|
|
pragma Inline (Allocate_Dynamic);
|
|
-- Allocate enough space on dynamic secondary stack Stack to fit a request
|
|
-- of size Mem_Size. Addr denotes the address of the first byte of the
|
|
-- allocation.
|
|
|
|
procedure Allocate_On_Chunk
|
|
(Stack : SS_Stack_Ptr;
|
|
Prev_Chunk : SS_Chunk_Ptr;
|
|
Chunk : SS_Chunk_Ptr;
|
|
Byte : Memory_Index;
|
|
Mem_Size : Memory_Size;
|
|
Addr : out Address);
|
|
pragma Inline (Allocate_On_Chunk);
|
|
-- Allocate enough space on chunk Chunk to fit a request of size Mem_Size.
|
|
-- Stack is the owner of the allocation Chunk. Prev_Chunk is the preceding
|
|
-- chunk of Chunk. Byte indicates the first free byte within Chunk. Addr
|
|
-- denotes the address of the first byte of the allocation. This routine
|
|
-- updates the state of Stack.all to reflect the side effects of the
|
|
-- allocation.
|
|
|
|
procedure Allocate_Static
|
|
(Stack : SS_Stack_Ptr;
|
|
Mem_Size : Memory_Size;
|
|
Addr : out Address);
|
|
pragma Inline (Allocate_Static);
|
|
-- Allocate enough space on static secondary stack Stack to fit a request
|
|
-- of size Mem_Size. Addr denotes the address of the first byte of the
|
|
-- allocation.
|
|
|
|
procedure Free is new Ada.Unchecked_Deallocation (SS_Chunk, SS_Chunk_Ptr);
|
|
-- Free a dynamically allocated chunk
|
|
|
|
procedure Free is new Ada.Unchecked_Deallocation (SS_Stack, SS_Stack_Ptr);
|
|
-- Free a dynamically allocated secondary stack
|
|
|
|
function Has_Enough_Free_Memory
|
|
(Chunk : SS_Chunk_Ptr;
|
|
Byte : Memory_Index;
|
|
Mem_Size : Memory_Size) return Boolean;
|
|
pragma Inline (Has_Enough_Free_Memory);
|
|
-- Determine whether chunk Chunk has enough room to fit a memory request of
|
|
-- size Mem_Size, starting from the first free byte of the chunk denoted by
|
|
-- Byte.
|
|
|
|
function Number_Of_Chunks (Stack : SS_Stack_Ptr) return Chunk_Count;
|
|
pragma Inline (Number_Of_Chunks);
|
|
-- Count the number of static and dynamic chunks of secondary stack Stack
|
|
|
|
function Size_Up_To_And_Including (Chunk : SS_Chunk_Ptr) return Memory_Size;
|
|
pragma Inline (Size_Up_To_And_Including);
|
|
-- Calculate the size of secondary stack which houses chunk Chunk, from the
|
|
-- start of the secondary stack up to and including Chunk itself. The size
|
|
-- includes the following kinds of memory:
|
|
--
|
|
-- * Free memory in used chunks due to alignment holes
|
|
-- * Occupied memory by allocations
|
|
--
|
|
-- This is a constant time operation, regardless of the secondary stack's
|
|
-- nature.
|
|
|
|
function Top_Chunk_Id (Stack : SS_Stack_Ptr) return Chunk_Id_With_Invalid;
|
|
pragma Inline (Top_Chunk_Id);
|
|
-- Obtain the Chunk_Id of the chunk indicated by secondary stack Stack's
|
|
-- pointer.
|
|
|
|
function Used_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size;
|
|
pragma Inline (Used_Memory_Size);
|
|
-- Calculate the size of stack Stack's occupied memory usage. This includes
|
|
-- the following kinds of memory:
|
|
--
|
|
-- * Free memory in used chunks due to alignment holes
|
|
-- * Occupied memory by allocations
|
|
--
|
|
-- This is a constant time operation, regardless of the secondary stack's
|
|
-- nature.
|
|
|
|
----------------------
|
|
-- Allocate_Dynamic --
|
|
----------------------
|
|
|
|
procedure Allocate_Dynamic
|
|
(Stack : SS_Stack_Ptr;
|
|
Mem_Size : Memory_Size;
|
|
Addr : out Address)
|
|
is
|
|
function Allocate_New_Chunk return SS_Chunk_Ptr;
|
|
pragma Inline (Allocate_New_Chunk);
|
|
-- Create a new chunk which is big enough to fit a request of size
|
|
-- Mem_Size.
|
|
|
|
------------------------
|
|
-- Allocate_New_Chunk --
|
|
------------------------
|
|
|
|
function Allocate_New_Chunk return SS_Chunk_Ptr is
|
|
Chunk_Size : Memory_Size;
|
|
|
|
begin
|
|
-- The size of the new chunk must fit the memory request precisely.
|
|
-- In the case where the memory request is way too small, use the
|
|
-- default chunk size. This avoids creating multiple tiny chunks.
|
|
|
|
Chunk_Size := Mem_Size;
|
|
|
|
if Chunk_Size < Stack.Default_Chunk_Size then
|
|
Chunk_Size := Stack.Default_Chunk_Size;
|
|
end if;
|
|
|
|
return new SS_Chunk (Chunk_Size);
|
|
|
|
-- The creation of the new chunk may exhaust the heap. Raise a new
|
|
-- Storage_Error to indicate that the secondary stack is exhausted
|
|
-- as well.
|
|
|
|
exception
|
|
when Storage_Error =>
|
|
raise Storage_Error with "secondary stack exhausted";
|
|
end Allocate_New_Chunk;
|
|
|
|
-- Local variables
|
|
|
|
Next_Chunk : SS_Chunk_Ptr;
|
|
|
|
-- Start of processing for Allocate_Dynamic
|
|
|
|
begin
|
|
-- Determine whether the chunk indicated by the stack pointer is big
|
|
-- enough to fit the memory request and if it is, allocate on it.
|
|
|
|
if Has_Enough_Free_Memory
|
|
(Chunk => Stack.Top.Chunk,
|
|
Byte => Stack.Top.Byte,
|
|
Mem_Size => Mem_Size)
|
|
then
|
|
Allocate_On_Chunk
|
|
(Stack => Stack,
|
|
Prev_Chunk => null,
|
|
Chunk => Stack.Top.Chunk,
|
|
Byte => Stack.Top.Byte,
|
|
Mem_Size => Mem_Size,
|
|
Addr => Addr);
|
|
|
|
return;
|
|
end if;
|
|
|
|
-- At this point it is known that the chunk indicated by the stack
|
|
-- pointer is not big enough to fit the memory request. Examine all
|
|
-- subsequent chunks, and apply the following criteria:
|
|
--
|
|
-- * If the current chunk is too small, free it
|
|
--
|
|
-- * If the current chunk is big enough, allocate on it
|
|
--
|
|
-- This ensures that no space is wasted. The process is costly, however
|
|
-- allocation is costly in general. Paying the price here keeps routines
|
|
-- SS_Mark and SS_Release cheap.
|
|
|
|
while Stack.Top.Chunk.Next /= null loop
|
|
|
|
-- The current chunk is big enough to fit the memory request,
|
|
-- allocate on it.
|
|
|
|
if Has_Enough_Free_Memory
|
|
(Chunk => Stack.Top.Chunk.Next,
|
|
Byte => Stack.Top.Chunk.Next.Memory'First,
|
|
Mem_Size => Mem_Size)
|
|
then
|
|
Allocate_On_Chunk
|
|
(Stack => Stack,
|
|
Prev_Chunk => Stack.Top.Chunk,
|
|
Chunk => Stack.Top.Chunk.Next,
|
|
Byte => Stack.Top.Chunk.Next.Memory'First,
|
|
Mem_Size => Mem_Size,
|
|
Addr => Addr);
|
|
|
|
return;
|
|
|
|
-- Otherwise the chunk is too small, free it
|
|
|
|
else
|
|
Next_Chunk := Stack.Top.Chunk.Next.Next;
|
|
|
|
-- Unchain the chunk from the stack. This keeps the next candidate
|
|
-- chunk situated immediately after Top.Chunk.
|
|
--
|
|
-- Top.Chunk Top.Chunk.Next Top.Chunk.Next.Next
|
|
-- | | (Next_Chunk)
|
|
-- v v v
|
|
-- +-------+ +------------+ +--------------+
|
|
-- | | --> | | --> | |
|
|
-- +-------+ +------------+ +--------------+
|
|
-- to be freed
|
|
|
|
Free (Stack.Top.Chunk.Next);
|
|
Stack.Top.Chunk.Next := Next_Chunk;
|
|
end if;
|
|
end loop;
|
|
|
|
-- At this point one of the following outcomes took place:
|
|
--
|
|
-- * Top.Chunk is the last chunk in the stack
|
|
--
|
|
-- * Top.Chunk was not the last chunk originally. It was followed by
|
|
-- chunks which were too small and as a result were deleted, thus
|
|
-- making Top.Chunk the last chunk in the stack.
|
|
--
|
|
-- Either way, nothing should be hanging off the chunk indicated by the
|
|
-- stack pointer.
|
|
|
|
pragma Assert (Stack.Top.Chunk.Next = null);
|
|
|
|
-- Create a new chunk big enough to fit the memory request, and allocate
|
|
-- on it.
|
|
|
|
Stack.Top.Chunk.Next := Allocate_New_Chunk;
|
|
|
|
Allocate_On_Chunk
|
|
(Stack => Stack,
|
|
Prev_Chunk => Stack.Top.Chunk,
|
|
Chunk => Stack.Top.Chunk.Next,
|
|
Byte => Stack.Top.Chunk.Next.Memory'First,
|
|
Mem_Size => Mem_Size,
|
|
Addr => Addr);
|
|
end Allocate_Dynamic;
|
|
|
|
-----------------------
|
|
-- Allocate_On_Chunk --
|
|
-----------------------
|
|
|
|
procedure Allocate_On_Chunk
|
|
(Stack : SS_Stack_Ptr;
|
|
Prev_Chunk : SS_Chunk_Ptr;
|
|
Chunk : SS_Chunk_Ptr;
|
|
Byte : Memory_Index;
|
|
Mem_Size : Memory_Size;
|
|
Addr : out Address)
|
|
is
|
|
New_High_Water_Mark : Memory_Size;
|
|
|
|
begin
|
|
-- The allocation occurs on a reused or a brand new chunk. Such a chunk
|
|
-- must always be connected to some previous chunk.
|
|
|
|
if Prev_Chunk /= null then
|
|
pragma Assert (Prev_Chunk.Next = Chunk);
|
|
|
|
-- Update the Size_Up_To_Chunk because this value is invalidated for
|
|
-- reused and new chunks.
|
|
--
|
|
-- Prev_Chunk Chunk
|
|
-- v v
|
|
-- . . . . . . . +--------------+ +--------
|
|
-- . --> |##############| --> |
|
|
-- . . . . . . . +--------------+ +--------
|
|
-- | |
|
|
-- -------------------+------------+
|
|
-- Size_Up_To_Chunk Size
|
|
--
|
|
-- The Size_Up_To_Chunk is equal to the size of the whole stack up to
|
|
-- the previous chunk, plus the size of the previous chunk itself.
|
|
|
|
Chunk.Size_Up_To_Chunk := Size_Up_To_And_Including (Prev_Chunk);
|
|
end if;
|
|
|
|
-- The chunk must have enough room to fit the memory request. If this is
|
|
-- not the case, then a previous step picked the wrong chunk.
|
|
|
|
pragma Assert (Has_Enough_Free_Memory (Chunk, Byte, Mem_Size));
|
|
|
|
-- The first byte of the allocation is the first free byte within the
|
|
-- chunk.
|
|
|
|
Addr := Chunk.Memory (Byte)'Address;
|
|
|
|
-- The chunk becomes the chunk indicated by the stack pointer. This is
|
|
-- either the currently indicated chunk, an existing chunk, or a brand
|
|
-- new chunk.
|
|
|
|
Stack.Top.Chunk := Chunk;
|
|
|
|
-- The next free byte is immediately after the memory request
|
|
--
|
|
-- Addr Top.Byte
|
|
-- | |
|
|
-- +-----|--------|----+
|
|
-- |##############| |
|
|
-- +-------------------+
|
|
|
|
-- ??? this calculation may overflow on 32bit targets
|
|
|
|
Stack.Top.Byte := Byte + Mem_Size;
|
|
|
|
-- At this point the next free byte cannot go beyond the memory capacity
|
|
-- of the chunk indicated by the stack pointer, except when the chunk is
|
|
-- full, in which case it indicates the byte beyond the chunk. Ensure
|
|
-- that the occupied memory is at most as much as the capacity of the
|
|
-- chunk. Top.Byte - 1 denotes the last occupied byte.
|
|
|
|
pragma Assert (Stack.Top.Byte - 1 <= Stack.Top.Chunk.Size);
|
|
|
|
-- Calculate the new high water mark now that the memory request has
|
|
-- been fulfilled, and update if necessary. The new high water mark is
|
|
-- technically the size of the used memory by the whole stack.
|
|
|
|
New_High_Water_Mark := Used_Memory_Size (Stack);
|
|
|
|
if New_High_Water_Mark > Stack.High_Water_Mark then
|
|
Stack.High_Water_Mark := New_High_Water_Mark;
|
|
end if;
|
|
end Allocate_On_Chunk;
|
|
|
|
---------------------
|
|
-- Allocate_Static --
|
|
---------------------
|
|
|
|
procedure Allocate_Static
|
|
(Stack : SS_Stack_Ptr;
|
|
Mem_Size : Memory_Size;
|
|
Addr : out Address)
|
|
is
|
|
begin
|
|
-- Static secondary stack allocations are performed only on the static
|
|
-- chunk. There should be no dynamic chunks following the static chunk.
|
|
|
|
pragma Assert (Stack.Top.Chunk = Stack.Static_Chunk'Access);
|
|
pragma Assert (Stack.Top.Chunk.Next = null);
|
|
|
|
-- Raise Storage_Error if the static chunk does not have enough room to
|
|
-- fit the memory request. This indicates that the stack is about to be
|
|
-- depleted.
|
|
|
|
if not Has_Enough_Free_Memory
|
|
(Chunk => Stack.Top.Chunk,
|
|
Byte => Stack.Top.Byte,
|
|
Mem_Size => Mem_Size)
|
|
then
|
|
raise Storage_Error with "secondary stack exhaused";
|
|
end if;
|
|
|
|
Allocate_On_Chunk
|
|
(Stack => Stack,
|
|
Prev_Chunk => null,
|
|
Chunk => Stack.Top.Chunk,
|
|
Byte => Stack.Top.Byte,
|
|
Mem_Size => Mem_Size,
|
|
Addr => Addr);
|
|
end Allocate_Static;
|
|
|
|
--------------------
|
|
-- Get_Chunk_Info --
|
|
--------------------
|
|
|
|
function Get_Chunk_Info
|
|
(Stack : SS_Stack_Ptr;
|
|
C_Id : Chunk_Id) return Chunk_Info
|
|
is
|
|
function Find_Chunk return SS_Chunk_Ptr;
|
|
pragma Inline (Find_Chunk);
|
|
-- Find the chunk which corresponds to Id. Return null if no such chunk
|
|
-- exists.
|
|
|
|
----------------
|
|
-- Find_Chunk --
|
|
----------------
|
|
|
|
function Find_Chunk return SS_Chunk_Ptr is
|
|
Chunk : SS_Chunk_Ptr;
|
|
Id : Chunk_Id;
|
|
|
|
begin
|
|
Chunk := Stack.Static_Chunk'Access;
|
|
Id := 1;
|
|
while Chunk /= null loop
|
|
if Id = C_Id then
|
|
return Chunk;
|
|
end if;
|
|
|
|
Chunk := Chunk.Next;
|
|
Id := Id + 1;
|
|
end loop;
|
|
|
|
return null;
|
|
end Find_Chunk;
|
|
|
|
-- Local variables
|
|
|
|
Chunk : constant SS_Chunk_Ptr := Find_Chunk;
|
|
|
|
-- Start of processing for Get_Chunk_Info
|
|
|
|
begin
|
|
if Chunk = null then
|
|
return Invalid_Chunk;
|
|
|
|
else
|
|
return (Size => Chunk.Size,
|
|
Size_Up_To_Chunk => Chunk.Size_Up_To_Chunk);
|
|
end if;
|
|
end Get_Chunk_Info;
|
|
|
|
--------------------
|
|
-- Get_Stack_Info --
|
|
--------------------
|
|
|
|
function Get_Stack_Info (Stack : SS_Stack_Ptr) return Stack_Info is
|
|
Info : Stack_Info;
|
|
|
|
begin
|
|
Info.Default_Chunk_Size := Stack.Default_Chunk_Size;
|
|
Info.Freeable := Stack.Freeable;
|
|
Info.High_Water_Mark := Stack.High_Water_Mark;
|
|
Info.Number_Of_Chunks := Number_Of_Chunks (Stack);
|
|
Info.Top.Byte := Stack.Top.Byte;
|
|
Info.Top.Chunk := Top_Chunk_Id (Stack);
|
|
|
|
return Info;
|
|
end Get_Stack_Info;
|
|
|
|
----------------------------
|
|
-- Has_Enough_Free_Memory --
|
|
----------------------------
|
|
|
|
function Has_Enough_Free_Memory
|
|
(Chunk : SS_Chunk_Ptr;
|
|
Byte : Memory_Index;
|
|
Mem_Size : Memory_Size) return Boolean
|
|
is
|
|
begin
|
|
-- Byte - 1 denotes the last occupied byte. Subtracting that byte from
|
|
-- the memory capacity of the chunk yields the size of the free memory
|
|
-- within the chunk. The chunk can fit the request as long as the free
|
|
-- memory is as big as the request.
|
|
|
|
return Chunk.Size - (Byte - 1) >= Mem_Size;
|
|
end Has_Enough_Free_Memory;
|
|
|
|
----------------------
|
|
-- Number_Of_Chunks --
|
|
----------------------
|
|
|
|
function Number_Of_Chunks (Stack : SS_Stack_Ptr) return Chunk_Count is
|
|
Chunk : SS_Chunk_Ptr;
|
|
Count : Chunk_Count;
|
|
|
|
begin
|
|
Chunk := Stack.Static_Chunk'Access;
|
|
Count := 0;
|
|
while Chunk /= null loop
|
|
Chunk := Chunk.Next;
|
|
Count := Count + 1;
|
|
end loop;
|
|
|
|
return Count;
|
|
end Number_Of_Chunks;
|
|
|
|
------------------------------
|
|
-- Size_Up_To_And_Including --
|
|
------------------------------
|
|
|
|
function Size_Up_To_And_Including
|
|
(Chunk : SS_Chunk_Ptr) return Memory_Size
|
|
is
|
|
begin
|
|
return Chunk.Size_Up_To_Chunk + Chunk.Size;
|
|
end Size_Up_To_And_Including;
|
|
|
|
-----------------
|
|
-- SS_Allocate --
|
|
-----------------
|
|
|
|
procedure SS_Allocate
|
|
(Addr : out Address;
|
|
Storage_Size : Storage_Count)
|
|
is
|
|
function Round_Up (Size : Storage_Count) return Memory_Size;
|
|
pragma Inline (Round_Up);
|
|
-- Round Size up to the nearest multiple of the maximum alignment
|
|
|
|
--------------
|
|
-- Round_Up --
|
|
--------------
|
|
|
|
function Round_Up (Size : Storage_Count) return Memory_Size is
|
|
Algn_MS : constant Memory_Size := Memory_Alignment;
|
|
Size_MS : constant Memory_Size := Memory_Size (Size);
|
|
|
|
begin
|
|
-- Detect a case where the Storage_Size is very large and may yield
|
|
-- a rounded result which is outside the range of Chunk_Memory_Size.
|
|
-- Treat this case as secondary-stack depletion.
|
|
|
|
if Memory_Size'Last - Algn_MS < Size_MS then
|
|
raise Storage_Error with "secondary stack exhausted";
|
|
end if;
|
|
|
|
return ((Size_MS + Algn_MS - 1) / Algn_MS) * Algn_MS;
|
|
end Round_Up;
|
|
|
|
-- Local variables
|
|
|
|
Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
Mem_Size : Memory_Size;
|
|
|
|
-- Start of processing for SS_Allocate
|
|
|
|
begin
|
|
-- Round the requested size up to the nearest multiple of the maximum
|
|
-- alignment to ensure efficient access.
|
|
|
|
if Storage_Size = 0 then
|
|
Mem_Size := Memory_Alignment;
|
|
else
|
|
-- It should not be possible to request an allocation of negative
|
|
-- size.
|
|
|
|
pragma Assert (Storage_Size >= 0);
|
|
Mem_Size := Round_Up (Storage_Size);
|
|
end if;
|
|
|
|
if Sec_Stack_Dynamic then
|
|
Allocate_Dynamic (Stack, Mem_Size, Addr);
|
|
else
|
|
Allocate_Static (Stack, Mem_Size, Addr);
|
|
end if;
|
|
end SS_Allocate;
|
|
|
|
-------------
|
|
-- SS_Free --
|
|
-------------
|
|
|
|
procedure SS_Free (Stack : in out SS_Stack_Ptr) is
|
|
Static_Chunk : constant SS_Chunk_Ptr := Stack.Static_Chunk'Access;
|
|
Next_Chunk : SS_Chunk_Ptr;
|
|
|
|
begin
|
|
-- Free all dynamically allocated chunks. The first dynamic chunk is
|
|
-- found immediately after the static chunk of the stack.
|
|
|
|
while Static_Chunk.Next /= null loop
|
|
Next_Chunk := Static_Chunk.Next.Next;
|
|
Free (Static_Chunk.Next);
|
|
Static_Chunk.Next := Next_Chunk;
|
|
end loop;
|
|
|
|
-- At this point one of the following outcomes has taken place:
|
|
--
|
|
-- * The stack lacks any dynamic chunks
|
|
--
|
|
-- * The stack had dynamic chunks which were all freed
|
|
--
|
|
-- Either way, there should be nothing hanging off the static chunk
|
|
|
|
pragma Assert (Static_Chunk.Next = null);
|
|
|
|
-- Free the stack only when it was dynamically allocated
|
|
|
|
if Stack.Freeable then
|
|
Free (Stack);
|
|
end if;
|
|
end SS_Free;
|
|
|
|
----------------
|
|
-- SS_Get_Max --
|
|
----------------
|
|
|
|
function SS_Get_Max return Long_Long_Integer is
|
|
Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
|
|
begin
|
|
return Long_Long_Integer (Stack.High_Water_Mark);
|
|
end SS_Get_Max;
|
|
|
|
-------------
|
|
-- SS_Info --
|
|
-------------
|
|
|
|
procedure SS_Info is
|
|
procedure SS_Info_Dynamic (Stack : SS_Stack_Ptr);
|
|
pragma Inline (SS_Info_Dynamic);
|
|
-- Output relevant information concerning dynamic secondary stack Stack
|
|
|
|
function Total_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size;
|
|
pragma Inline (Total_Memory_Size);
|
|
-- Calculate the size of stack Stack's total memory usage. This includes
|
|
-- the following kinds of memory:
|
|
--
|
|
-- * Free memory in used chunks due to alignment holes
|
|
-- * Free memory in the topmost chunk due to partial usage
|
|
-- * Free memory in unused chunks following the chunk indicated by the
|
|
-- stack pointer.
|
|
-- * Memory occupied by allocations
|
|
--
|
|
-- This is a linear-time operation on the number of chunks.
|
|
|
|
---------------------
|
|
-- SS_Info_Dynamic --
|
|
---------------------
|
|
|
|
procedure SS_Info_Dynamic (Stack : SS_Stack_Ptr) is
|
|
begin
|
|
Put_Line
|
|
(" Number of Chunks : " & Number_Of_Chunks (Stack)'Img);
|
|
|
|
Put_Line
|
|
(" Default size of Chunks : " & Stack.Default_Chunk_Size'Img);
|
|
end SS_Info_Dynamic;
|
|
|
|
-----------------------
|
|
-- Total_Memory_Size --
|
|
-----------------------
|
|
|
|
function Total_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size is
|
|
Chunk : SS_Chunk_Ptr;
|
|
Total : Memory_Size;
|
|
|
|
begin
|
|
-- The total size of the stack is equal to the size of the stack up
|
|
-- to the chunk indicated by the stack pointer, plus the size of the
|
|
-- indicated chunk, plus the size of any subsequent chunks.
|
|
|
|
Total := Size_Up_To_And_Including (Stack.Top.Chunk);
|
|
|
|
Chunk := Stack.Top.Chunk.Next;
|
|
while Chunk /= null loop
|
|
Total := Total + Chunk.Size;
|
|
Chunk := Chunk.Next;
|
|
end loop;
|
|
|
|
return Total;
|
|
end Total_Memory_Size;
|
|
|
|
-- Local variables
|
|
|
|
Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
|
|
-- Start of processing for SS_Info
|
|
|
|
begin
|
|
Put_Line ("Secondary Stack information:");
|
|
|
|
Put_Line
|
|
(" Total size : "
|
|
& Total_Memory_Size (Stack)'Img
|
|
& " bytes");
|
|
|
|
Put_Line
|
|
(" Current allocated space : "
|
|
& Used_Memory_Size (Stack)'Img
|
|
& " bytes");
|
|
|
|
if Sec_Stack_Dynamic then
|
|
SS_Info_Dynamic (Stack);
|
|
end if;
|
|
end SS_Info;
|
|
|
|
-------------
|
|
-- SS_Init --
|
|
-------------
|
|
|
|
procedure SS_Init
|
|
(Stack : in out SS_Stack_Ptr;
|
|
Size : Size_Type := Unspecified_Size)
|
|
is
|
|
function Next_Available_Binder_Sec_Stack return SS_Stack_Ptr;
|
|
pragma Inline (Next_Available_Binder_Sec_Stack);
|
|
-- Return a pointer to the next available stack from the pool created by
|
|
-- the binder. This routine updates global Default_Sec_Stack_Pool_Index.
|
|
|
|
-------------------------------------
|
|
-- Next_Available_Binder_Sec_Stack --
|
|
-------------------------------------
|
|
|
|
function Next_Available_Binder_Sec_Stack return SS_Stack_Ptr is
|
|
|
|
-- The default-sized secondary stack pool generated by the binder
|
|
-- is passed to this unit as an Address because it is not possible
|
|
-- to define a pointer to an array of unconstrained components. The
|
|
-- pointer is instead obtained using an unchecked conversion to a
|
|
-- constrained array of secondary stacks with the same size as that
|
|
-- specified by the binder.
|
|
|
|
-- WARNING: The following data structure must be synchronized with
|
|
-- the one created in Bindgen.Gen_Output_File_Ada. The version in
|
|
-- bindgen is called Sec_Default_Sized_Stacks.
|
|
|
|
type SS_Pool is
|
|
array (1 .. Binder_SS_Count)
|
|
of aliased SS_Stack (Binder_Default_SS_Size);
|
|
|
|
type SS_Pool_Ptr is access SS_Pool;
|
|
-- A reference to the secondary stack pool
|
|
|
|
function To_SS_Pool_Ptr is
|
|
new Ada.Unchecked_Conversion (Address, SS_Pool_Ptr);
|
|
|
|
-- Use an unchecked conversion to obtain a pointer to one of the
|
|
-- secondary stacks from the pool generated by the binder. There
|
|
-- are several reasons for using the conversion:
|
|
--
|
|
-- * Accessibility checks prevent a value of a local pointer to be
|
|
-- stored outside this scope. The conversion is safe because the
|
|
-- pool is global to the whole application.
|
|
--
|
|
-- * Unchecked_Access may circumvent the accessibility checks, but
|
|
-- it is incompatible with restriction No_Unchecked_Access.
|
|
--
|
|
-- * Unrestricted_Access may circumvent the accessibility checks,
|
|
-- but it is incompatible with pure Ada constructs.
|
|
-- ??? cannot find the restriction or switch
|
|
|
|
pragma Warnings (Off);
|
|
function To_SS_Stack_Ptr is
|
|
new Ada.Unchecked_Conversion (Address, SS_Stack_Ptr);
|
|
pragma Warnings (On);
|
|
|
|
Pool : SS_Pool_Ptr;
|
|
|
|
begin
|
|
-- Obtain a typed view of the pool
|
|
|
|
Pool := To_SS_Pool_Ptr (Binder_Default_SS_Pool);
|
|
|
|
-- Advance the stack index to the next available stack
|
|
|
|
Binder_Default_SS_Pool_Index := Binder_Default_SS_Pool_Index + 1;
|
|
|
|
-- Return a pointer to the next available stack
|
|
|
|
return To_SS_Stack_Ptr (Pool (Binder_Default_SS_Pool_Index)'Address);
|
|
end Next_Available_Binder_Sec_Stack;
|
|
|
|
-- Local variables
|
|
|
|
Stack_Size : Memory_Size_With_Invalid;
|
|
|
|
-- Start of processing for SS_Init
|
|
|
|
begin
|
|
-- Allocate a new stack on the heap or use one from the pool created by
|
|
-- the binder.
|
|
|
|
if Stack = null then
|
|
|
|
-- The caller requested a pool-allocated stack. Determine the proper
|
|
-- size of the stack based on input from the binder or the runtime in
|
|
-- case the pool is exhausted.
|
|
|
|
if Size = Unspecified_Size then
|
|
|
|
-- Use the default secondary stack size as specified by the binder
|
|
-- only when it has been set. This prevents a bootstrap issue with
|
|
-- older compilers where the size is never set.
|
|
|
|
if Binder_Default_SS_Size > 0 then
|
|
Stack_Size := Binder_Default_SS_Size;
|
|
|
|
-- Otherwise use the default stack size of the particular runtime
|
|
|
|
else
|
|
Stack_Size := Runtime_Default_Sec_Stack_Size;
|
|
end if;
|
|
|
|
-- Otherwise the caller requested a heap-allocated stack. Use the
|
|
-- specified size directly.
|
|
|
|
else
|
|
Stack_Size := Size;
|
|
end if;
|
|
|
|
-- The caller requested a pool-allocated stack. Use one as long as
|
|
-- the pool created by the binder has available stacks. This stack
|
|
-- cannot be deallocated.
|
|
|
|
if Size = Unspecified_Size
|
|
and then Binder_SS_Count > 0
|
|
and then Binder_Default_SS_Pool_Index < Binder_SS_Count
|
|
then
|
|
Stack := Next_Available_Binder_Sec_Stack;
|
|
Stack.Freeable := False;
|
|
|
|
-- Otherwise the caller requested a heap-allocated stack, or the pool
|
|
-- created by the binder ran out of available stacks. This stack can
|
|
-- be deallocated.
|
|
|
|
else
|
|
-- It should not be possible to create a stack with a negative
|
|
-- default chunk size.
|
|
|
|
pragma Assert (Stack_Size in Memory_Size);
|
|
|
|
Stack := new SS_Stack (Stack_Size);
|
|
Stack.Freeable := True;
|
|
end if;
|
|
|
|
-- Otherwise the stack was already created either by the compiler or by
|
|
-- the user, and is about to be reused.
|
|
|
|
else
|
|
null;
|
|
end if;
|
|
|
|
-- The static chunk becomes the chunk indicated by the stack pointer.
|
|
-- Note that the stack may still hold dynamic chunks, which in turn may
|
|
-- be reused or freed.
|
|
|
|
Stack.Top.Chunk := Stack.Static_Chunk'Access;
|
|
|
|
-- The first free byte is the first free byte of the chunk indicated by
|
|
-- the stack pointer.
|
|
|
|
Stack.Top.Byte := Stack.Top.Chunk.Memory'First;
|
|
|
|
-- Since the chunk indicated by the stack pointer is also the first
|
|
-- chunk in the stack, there are no prior chunks, therefore the size
|
|
-- of the stack up to the chunk is zero.
|
|
|
|
Stack.Top.Chunk.Size_Up_To_Chunk := 0;
|
|
|
|
-- Reset the high water mark to account for brand new allocations
|
|
|
|
Stack.High_Water_Mark := 0;
|
|
end SS_Init;
|
|
|
|
-------------
|
|
-- SS_Mark --
|
|
-------------
|
|
|
|
function SS_Mark return Mark_Id is
|
|
Stack : constant SS_Stack_Ptr := Get_Sec_Stack.all;
|
|
|
|
begin
|
|
return (Stack => Stack, Top => Stack.Top);
|
|
end SS_Mark;
|
|
|
|
----------------
|
|
-- SS_Release --
|
|
----------------
|
|
|
|
procedure SS_Release (M : Mark_Id) is
|
|
begin
|
|
M.Stack.Top := M.Top;
|
|
end SS_Release;
|
|
|
|
------------------
|
|
-- Top_Chunk_Id --
|
|
------------------
|
|
|
|
function Top_Chunk_Id (Stack : SS_Stack_Ptr) return Chunk_Id_With_Invalid is
|
|
Chunk : SS_Chunk_Ptr;
|
|
Id : Chunk_Id;
|
|
|
|
begin
|
|
Chunk := Stack.Static_Chunk'Access;
|
|
Id := 1;
|
|
while Chunk /= null loop
|
|
if Chunk = Stack.Top.Chunk then
|
|
return Id;
|
|
end if;
|
|
|
|
Chunk := Chunk.Next;
|
|
Id := Id + 1;
|
|
end loop;
|
|
|
|
return Invalid_Chunk_Id;
|
|
end Top_Chunk_Id;
|
|
|
|
----------------------
|
|
-- Used_Memory_Size --
|
|
----------------------
|
|
|
|
function Used_Memory_Size (Stack : SS_Stack_Ptr) return Memory_Size is
|
|
begin
|
|
-- The size of the occupied memory is equal to the size up to the chunk
|
|
-- indicated by the stack pointer, plus the size in use by the indicated
|
|
-- chunk itself. Top.Byte - 1 is the last occupied byte.
|
|
--
|
|
-- Top.Byte
|
|
-- |
|
|
-- . . . . . . . +--------------|----+
|
|
-- . ..> |##############| |
|
|
-- . . . . . . . +-------------------+
|
|
-- | |
|
|
-- -------------------+-------------+
|
|
-- Size_Up_To_Chunk size in use
|
|
|
|
-- ??? this calculation may overflow on 32bit targets
|
|
|
|
return Stack.Top.Chunk.Size_Up_To_Chunk + Stack.Top.Byte - 1;
|
|
end Used_Memory_Size;
|
|
|
|
end System.Secondary_Stack;
|