diff options
Diffstat (limited to 'gcc-4.8.1/gcc/ada/s-secsta.adb')
| -rw-r--r-- | gcc-4.8.1/gcc/ada/s-secsta.adb | 540 |
1 files changed, 540 insertions, 0 deletions
diff --git a/gcc-4.8.1/gcc/ada/s-secsta.adb b/gcc-4.8.1/gcc/ada/s-secsta.adb new file mode 100644 index 000000000..0afea184b --- /dev/null +++ b/gcc-4.8.1/gcc/ada/s-secsta.adb @@ -0,0 +1,540 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2011, 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; + +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; |