This repository has been archived on 2024-12-16. You can view files and clone it, but cannot push or open issues or pull requests.
CodeBlocksPortable/MinGW/lib/gcc/mingw32/6.3.0/adainclude/s-secsta.adb

541 lines
19 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-2013, 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 System.Soft_Links;
with System.Parameters;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
package body System.Secondary_Stack is
package SSL renames System.Soft_Links;
use type SSE.Storage_Offset;
use type System.Parameters.Size_Type;
SS_Ratio_Dynamic : constant Boolean :=
Parameters.Sec_Stack_Percentage = Parameters.Dynamic;
-- There are two entirely different implementations of the secondary
-- stack mechanism in this unit, and this Boolean is used to select
-- between them (at compile time, so the generated code will contain
-- only the code for the desired variant). If SS_Ratio_Dynamic is
-- True, then the secondary stack is dynamically allocated from the
-- heap in a linked list of chunks. If SS_Ration_Dynamic is False,
-- then the secondary stack is allocated statically by grabbing a
-- section of the primary stack and using it for this purpose.
type Memory is array (SS_Ptr range <>) of SSE.Storage_Element;
for Memory'Alignment use Standard'Maximum_Alignment;
-- This is the type used for actual allocation of secondary stack
-- areas. We require maximum alignment for all such allocations.
---------------------------------------------------------------
-- Data Structures for Dynamically Allocated Secondary Stack --
---------------------------------------------------------------
-- The following is a diagram of the data structures used for the
-- case of a dynamically allocated secondary stack, where the stack
-- is allocated as a linked list of chunks allocated from the heap.
-- +------------------+
-- | Next |
-- +------------------+
-- | | Last (200)
-- | |
-- | |
-- | |
-- | |
-- | |
-- | | First (101)
-- +------------------+
-- +----------> | | |
-- | +----------+-------+
-- | | |
-- | ^ V
-- | | |
-- | +-------+----------+
-- | | | |
-- | +------------------+
-- | | | Last (100)
-- | | C |
-- | | H |
-- +-----------------+ | +-------->| U |
-- | Current_Chunk -|--+ | | N |
-- +-----------------+ | | K |
-- | Top -|-----+ | | First (1)
-- +-----------------+ +------------------+
-- | Default_Size | | Prev |
-- +-----------------+ +------------------+
--
type Chunk_Id (First, Last : SS_Ptr);
type Chunk_Ptr is access all Chunk_Id;
type Chunk_Id (First, Last : SS_Ptr) is record
Prev, Next : Chunk_Ptr;
Mem : Memory (First .. Last);
end record;
type Stack_Id is record
Top : SS_Ptr;
Default_Size : SSE.Storage_Count;
Current_Chunk : Chunk_Ptr;
end record;
type Stack_Ptr is access Stack_Id;
-- Pointer to record used to represent a dynamically allocated secondary
-- stack descriptor for a secondary stack chunk.
procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr);
-- Free a dynamically allocated chunk
function To_Stack_Ptr is new
Ada.Unchecked_Conversion (Address, Stack_Ptr);
function To_Addr is new
Ada.Unchecked_Conversion (Stack_Ptr, Address);
-- Convert to and from address stored in task data structures
--------------------------------------------------------------
-- Data Structures for Statically Allocated Secondary Stack --
--------------------------------------------------------------
-- For the static case, the secondary stack is a single contiguous
-- chunk of storage, carved out of the primary stack, and represented
-- by the following data structure
type Fixed_Stack_Id is record
Top : SS_Ptr;
-- Index of next available location in Mem. This is initialized to
-- 0, and then incremented on Allocate, and Decremented on Release.
Last : SS_Ptr;
-- Length of usable Mem array, which is thus the index past the
-- last available location in Mem. Mem (Last-1) can be used. This
-- is used to check that the stack does not overflow.
Max : SS_Ptr;
-- Maximum value of Top. Initialized to 0, and then may be incremented
-- on Allocate, but is never Decremented. The last used location will
-- be Mem (Max - 1), so Max is the maximum count of used stack space.
Mem : Memory (0 .. 0);
-- This is the area that is actually used for the secondary stack.
-- Note that the upper bound is a dummy value properly defined by
-- the value of Last. We never actually allocate objects of type
-- Fixed_Stack_Id, so the bounds declared here do not matter.
end record;
Dummy_Fixed_Stack : Fixed_Stack_Id;
pragma Warnings (Off, Dummy_Fixed_Stack);
-- Well it is not quite true that we never allocate an object of the
-- type. This dummy object is allocated for the purpose of getting the
-- offset of the Mem field via the 'Position attribute (such a nuisance
-- that we cannot apply this to a field of a type).
type Fixed_Stack_Ptr is access Fixed_Stack_Id;
-- Pointer to record used to describe statically allocated sec stack
function To_Fixed_Stack_Ptr is new
Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr);
-- Convert from address stored in task data structures
--------------
-- Allocate --
--------------
procedure SS_Allocate
(Addr : out Address;
Storage_Size : SSE.Storage_Count)
is
Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
Max_Size : constant SS_Ptr :=
((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align)
* Max_Align;
begin
-- Case of fixed allocation secondary stack
if not SS_Ratio_Dynamic then
declare
Fixed_Stack : constant Fixed_Stack_Ptr :=
To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
begin
-- Check if max stack usage is increasing
if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then
-- If so, check if max size is exceeded
if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then
raise Storage_Error;
end if;
-- Record new max usage
Fixed_Stack.Max := Fixed_Stack.Top + Max_Size;
end if;
-- Set resulting address and update top of stack pointer
Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address;
Fixed_Stack.Top := Fixed_Stack.Top + Max_Size;
end;
-- Case of dynamically allocated secondary stack
else
declare
Stack : constant Stack_Ptr :=
To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
Chunk : Chunk_Ptr;
To_Be_Released_Chunk : Chunk_Ptr;
begin
Chunk := Stack.Current_Chunk;
-- The Current_Chunk may not be the good one if a lot of release
-- operations have taken place. So go down the stack if necessary
while Chunk.First > Stack.Top loop
Chunk := Chunk.Prev;
end loop;
-- 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.
while Chunk.Last - Stack.Top + 1 < Max_Size loop
if Chunk.Next /= null then
-- Release unused non-first empty 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;
-- Create new chunk of default size unless it is not
-- sufficient to satisfy the current request.
elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
Chunk.Next :=
new Chunk_Id
(First => Chunk.Last + 1,
Last => Chunk.Last + SS_Ptr (Stack.Default_Size));
Chunk.Next.Prev := Chunk;
-- Otherwise create new chunk of requested size
else
Chunk.Next :=
new Chunk_Id
(First => Chunk.Last + 1,
Last => Chunk.Last + Max_Size);
Chunk.Next.Prev := Chunk;
end if;
Chunk := Chunk.Next;
Stack.Top := Chunk.First;
end loop;
-- Resulting address is the address pointed by Stack.Top
Addr := Chunk.Mem (Stack.Top)'Address;
Stack.Top := Stack.Top + Max_Size;
Stack.Current_Chunk := Chunk;
end;
end if;
end SS_Allocate;
-------------
-- SS_Free --
-------------
procedure SS_Free (Stk : in out Address) is
begin
-- Case of statically allocated secondary stack, nothing to free
if not SS_Ratio_Dynamic then
return;
-- Case of dynamically allocated secondary stack
else
declare
Stack : Stack_Ptr := To_Stack_Ptr (Stk);
Chunk : Chunk_Ptr;
procedure Free is
new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr);
begin
Chunk := Stack.Current_Chunk;
while Chunk.Prev /= null loop
Chunk := Chunk.Prev;
end loop;
while Chunk.Next /= null loop
Chunk := Chunk.Next;
Free (Chunk.Prev);
end loop;
Free (Chunk);
Free (Stack);
Stk := Null_Address;
end;
end if;
end SS_Free;
----------------
-- SS_Get_Max --
----------------
function SS_Get_Max return Long_Long_Integer is
begin
if SS_Ratio_Dynamic then
return -1;
else
declare
Fixed_Stack : constant Fixed_Stack_Ptr :=
To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
begin
return Long_Long_Integer (Fixed_Stack.Max);
end;
end if;
end SS_Get_Max;
-------------
-- SS_Info --
-------------
procedure SS_Info is
begin
Put_Line ("Secondary Stack information:");
-- Case of fixed secondary stack
if not SS_Ratio_Dynamic then
declare
Fixed_Stack : constant Fixed_Stack_Ptr :=
To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
begin
Put_Line (
" Total size : "
& SS_Ptr'Image (Fixed_Stack.Last)
& " bytes");
Put_Line (
" Current allocated space : "
& SS_Ptr'Image (Fixed_Stack.Top - 1)
& " bytes");
end;
-- Case of dynamically allocated secondary stack
else
declare
Stack : constant Stack_Ptr :=
To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all);
Nb_Chunks : Integer := 1;
Chunk : Chunk_Ptr := Stack.Current_Chunk;
begin
while Chunk.Prev /= null loop
Chunk := Chunk.Prev;
end loop;
while Chunk.Next /= null loop
Nb_Chunks := Nb_Chunks + 1;
Chunk := Chunk.Next;
end loop;
-- Current Chunk information
Put_Line (
" Total size : "
& SS_Ptr'Image (Chunk.Last)
& " bytes");
Put_Line (
" Current allocated space : "
& SS_Ptr'Image (Stack.Top - 1)
& " bytes");
Put_Line (
" Number of Chunks : "
& Integer'Image (Nb_Chunks));
Put_Line (
" Default size of Chunks : "
& SSE.Storage_Count'Image (Stack.Default_Size));
end;
end if;
end SS_Info;
-------------
-- SS_Init --
-------------
procedure SS_Init
(Stk : in out Address;
Size : Natural := Default_Secondary_Stack_Size)
is
begin
-- Case of fixed size secondary stack
if not SS_Ratio_Dynamic then
declare
Fixed_Stack : constant Fixed_Stack_Ptr :=
To_Fixed_Stack_Ptr (Stk);
begin
Fixed_Stack.Top := 0;
Fixed_Stack.Max := 0;
if Size < Dummy_Fixed_Stack.Mem'Position then
Fixed_Stack.Last := 0;
else
Fixed_Stack.Last :=
SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position;
end if;
end;
-- Case of dynamically allocated secondary stack
else
declare
Stack : Stack_Ptr;
begin
Stack := new Stack_Id;
Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size));
Stack.Top := 1;
Stack.Default_Size := SSE.Storage_Count (Size);
Stk := To_Addr (Stack);
end;
end if;
end SS_Init;
-------------
-- SS_Mark --
-------------
function SS_Mark return Mark_Id is
Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all;
begin
if SS_Ratio_Dynamic then
return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top);
else
return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top);
end if;
end SS_Mark;
----------------
-- SS_Release --
----------------
procedure SS_Release (M : Mark_Id) is
begin
if SS_Ratio_Dynamic then
To_Stack_Ptr (M.Sstk).Top := M.Sptr;
else
To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr;
end if;
end SS_Release;
-------------------------
-- Package Elaboration --
-------------------------
-- Allocate a secondary stack for the main program to use
-- We make sure that the stack has maximum alignment. Some systems require
-- this (e.g. Sparc), and in any case it is a good idea for efficiency.
Stack : aliased Stack_Id;
for Stack'Alignment use Standard'Maximum_Alignment;
Static_Secondary_Stack_Size : constant := 10 * 1024;
-- Static_Secondary_Stack_Size must be static so that Chunk is allocated
-- statically, and not via dynamic memory allocation.
Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size);
for Chunk'Alignment use Standard'Maximum_Alignment;
-- Default chunk used, unless gnatbind -D is specified with a value
-- greater than Static_Secondary_Stack_Size
begin
declare
Chunk_Address : Address;
Chunk_Access : Chunk_Ptr;
begin
if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then
-- Normally we allocate the secondary stack for the main program
-- statically, using the default secondary stack size.
Chunk_Access := Chunk'Access;
else
-- Default_Secondary_Stack_Size was increased via gnatbind -D, so we
-- need to allocate a chunk dynamically.
Chunk_Access :=
new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size));
end if;
if SS_Ratio_Dynamic then
Stack.Top := 1;
Stack.Current_Chunk := Chunk_Access;
Stack.Default_Size :=
SSE.Storage_Offset (Default_Secondary_Stack_Size);
System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address);
else
Chunk_Address := Chunk_Access.all'Address;
SS_Init (Chunk_Address, Default_Secondary_Stack_Size);
System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address);
end if;
end;
end System.Secondary_Stack;