diff options
Diffstat (limited to 'gcc/ada/s-secsta.adb')
| -rw-r--r-- | gcc/ada/s-secsta.adb | 376 |
1 files changed, 376 insertions, 0 deletions
diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb new file mode 100644 index 00000000000..ac3d9bb9081 --- /dev/null +++ b/gcc/ada/s-secsta.adb @@ -0,0 +1,376 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- $Revision: 1.49 $ +-- -- +-- Copyright (C) 1992-2001 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with System.Soft_Links; +with System.Parameters; +with Unchecked_Conversion; +with 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_Ratio = Parameters.Dynamic; + + -- +------------------+ + -- | Next | + -- +------------------+ + -- | | Last (200) + -- | | + -- | | + -- | | + -- | | + -- | | + -- | | First (101) + -- +------------------+ + -- +----------> | | | + -- | +----------+-------+ + -- | | | + -- | ^ V + -- | | | + -- | +-------+----------+ + -- | | | | + -- | +------------------+ + -- | | | Last (100) + -- | | C | + -- | | H | + -- +-----------------+ | +-------->| U | + -- | Current_Chunk -|--+ | | N | + -- +-----------------+ | | K | + -- | Top -|-----+ | | First (1) + -- +-----------------+ +------------------+ + -- | Default_Size | | Prev | + -- +-----------------+ +------------------+ + -- + -- + type Memory is array (Mark_Id range <>) of SSE.Storage_Element; + + type Chunk_Id (First, Last : Mark_Id); + type Chunk_Ptr is access all Chunk_Id; + + type Chunk_Id (First, Last : Mark_Id) is record + Prev, Next : Chunk_Ptr; + Mem : Memory (First .. Last); + end record; + + type Stack_Id is record + Top : Mark_Id; + Default_Size : SSE.Storage_Count; + Current_Chunk : Chunk_Ptr; + end record; + + type Fixed_Stack_Id is record + Top : Mark_Id; + Last : Mark_Id; + Mem : Memory (1 .. Mark_Id'Last / 2 - 1); + -- This should really be 1 .. Mark_Id'Last, but there is a bug in gigi + -- with this type, introduced Sep 2001, that causes gigi to reject this + -- type because its size in bytes overflows ??? + end record; + + type Stack_Ptr is access Stack_Id; + type Fixed_Stack_Ptr is access Fixed_Stack_Id; + + function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr); + function To_Addr is new Unchecked_Conversion (Stack_Ptr, System.Address); + function To_Stack is new Unchecked_Conversion (Fixed_Stack_Ptr, Stack_Ptr); + function To_Fixed is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr); + + procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); + + -------------- + -- Allocate -- + -------------- + + procedure SS_Allocate + (Address : out System.Address; + Storage_Size : SSE.Storage_Count) + is + Stack : constant Stack_Ptr := + From_Addr (SSL.Get_Sec_Stack_Addr.all); + Fixed_Stack : Fixed_Stack_Ptr; + Chunk : Chunk_Ptr; + Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); + Max_Size : constant Mark_Id := + ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align) + * Max_Align; + + Count_Unreleased_Chunks : Natural; + To_Be_Released_Chunk : Chunk_Ptr; + + begin + -- If the secondary stack is fixed in the primary stack, then the + -- handling becomes simple + + if not SS_Ratio_Dynamic then + Fixed_Stack := To_Fixed (Stack); + + if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then + raise Storage_Error; + end if; + + Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; + Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size); + return; + end if; + + 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 eventally create the necessary room + + Count_Unreleased_Chunks := 0; + + 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 the default size unless it is not sufficient + + elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then + Chunk.Next := new Chunk_Id ( + First => Chunk.Last + 1, + Last => Chunk.Last + Mark_Id (Stack.Default_Size)); + + Chunk.Next.Prev := Chunk; + + 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 + + Address := Chunk.Mem (Stack.Top)'Address; + Stack.Top := Stack.Top + Max_Size; + Stack.Current_Chunk := Chunk; + end SS_Allocate; + + ------------- + -- SS_Free -- + ------------- + + procedure SS_Free (Stk : in out System.Address) is + Stack : Stack_Ptr; + Chunk : Chunk_Ptr; + + procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr); + + begin + if not SS_Ratio_Dynamic then + return; + end if; + + Stack := From_Addr (Stk); + 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 SS_Free; + + ------------- + -- SS_Info -- + ------------- + + procedure SS_Info is + Stack : constant Stack_Ptr := + From_Addr (SSL.Get_Sec_Stack_Addr.all); + Fixed_Stack : Fixed_Stack_Ptr; + Nb_Chunks : Integer := 1; + Chunk : Chunk_Ptr := Stack.Current_Chunk; + + begin + Put_Line ("Secondary Stack information:"); + + if not SS_Ratio_Dynamic then + Fixed_Stack := To_Fixed (Stack); + Put_Line ( + " Total size : " + & Mark_Id'Image (Fixed_Stack.Last) + & " bytes"); + Put_Line ( + " Current allocated space : " + & Mark_Id'Image (Fixed_Stack.Top - 1) + & " bytes"); + return; + end if; + + 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 : " + & Mark_Id'Image (Chunk.Last) + & " bytes"); + Put_Line ( + " Current allocated space : " + & Mark_Id'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 SS_Info; + + ------------- + -- SS_Init -- + ------------- + + procedure SS_Init + (Stk : in out System.Address; + Size : Natural := Default_Secondary_Stack_Size) + is + Stack : Stack_Ptr; + Fixed_Stack : Fixed_Stack_Ptr; + + begin + if not SS_Ratio_Dynamic then + Fixed_Stack := To_Fixed (From_Addr (Stk)); + Fixed_Stack.Top := Fixed_Stack.Mem'First; + + if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then + Fixed_Stack.Last := 0; + else + Fixed_Stack.Last := Mark_Id (Size) - + 2 * Mark_Id'Max_Size_In_Storage_Elements; + end if; + + return; + end if; + + Stack := new Stack_Id; + Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size)); + Stack.Top := 1; + Stack.Default_Size := SSE.Storage_Count (Size); + + Stk := To_Addr (Stack); + end SS_Init; + + ------------- + -- SS_Mark -- + ------------- + + function SS_Mark return Mark_Id is + begin + return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top; + end SS_Mark; + + ---------------- + -- SS_Release -- + ---------------- + + procedure SS_Release (M : Mark_Id) is + begin + From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M; + 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. Sun), and in any case it is a good idea for efficiency. + + Stack : aliased Stack_Id; + for Stack'Alignment use Standard'Maximum_Alignment; + + Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size); + for Chunk'Alignment use Standard'Maximum_Alignment; + + Chunk_Address : System.Address; + +begin + if SS_Ratio_Dynamic then + Stack.Top := 1; + Stack.Current_Chunk := Chunk'Access; + Stack.Default_Size := Default_Secondary_Stack_Size; + System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address); + + else + Chunk_Address := Chunk'Address; + SS_Init (Chunk_Address, Default_Secondary_Stack_Size); + System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address); + end if; +end System.Secondary_Stack; |