------------------------------------------------------------------------------ -- -- -- 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-2018, 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 -- -- . -- -- -- -- 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.Soft_Links; package body System.Secondary_Stack is package SSL renames System.Soft_Links; use type System.Parameters.Size_Type; procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); -- Free a dynamically allocated chunk ----------------- -- SS_Allocate -- ----------------- procedure SS_Allocate (Addr : out Address; Storage_Size : SSE.Storage_Count) is use type System.Storage_Elements.Storage_Count; 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. if SSE.Storage_Count (SS_Ptr'Last) - Standard'Maximum_Alignment < Storage_Size then raise Storage_Error; end if; Mem_Request := ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) * Max_Align; -- Case of fixed secondary stack if not SP.Sec_Stack_Dynamic then -- Check if max stack usage is increasing if Stack.Max - Stack.Top - Mem_Request < 0 then -- 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. if Stack.Size - Stack.Top - Mem_Request < -1 then raise Storage_Error; end if; -- Record new max usage Stack.Max := Stack.Top + Mem_Request; end if; -- Set resulting address and update top of stack pointer Addr := Stack.Internal_Chunk.Mem (Stack.Top)'Address; Stack.Top := Stack.Top + Mem_Request; -- Case of dynamic secondary stack else declare Chunk : Chunk_Ptr; Chunk_Size : SS_Ptr; To_Be_Released_Chunk : Chunk_Ptr; begin Chunk := Stack.Current_Chunk; -- The Current_Chunk may not be the best one if a lot of release -- operations have taken place. 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 - Mem_Request < -1 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 a new chunk else -- The new chunk should be no smaller than the default -- chunk size to minimize the amount of secondary stack -- management. if Mem_Request <= Stack.Size then Chunk_Size := Stack.Size; else Chunk_Size := Mem_Request; end if; -- Check that the indexing limits are not exceeded if SS_Ptr'Last - Chunk.Last - Chunk_Size < 0 then raise Storage_Error; end if; Chunk.Next := new Chunk_Id (First => Chunk.Last + 1, Last => Chunk.Last + Chunk_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 + Mem_Request; Stack.Current_Chunk := Chunk; -- Record new max usage if Stack.Top > Stack.Max then Stack.Max := Stack.Top; end if; end; end if; end SS_Allocate; ------------- -- SS_Free -- ------------- 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 Chunk := Stack.Current_Chunk; -- Go to top of linked list and free backwards. Do not free the -- internal chunk as it is part of SS_Stack. while Chunk.Next /= null loop Chunk := Chunk.Next; end loop; while Chunk.Prev /= null loop Chunk := Chunk.Prev; Free (Chunk.Next); end loop; end; end if; 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 := SSL.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 -- less the value of Stack.Max. return Long_Long_Integer (Stack.Max - 1); end SS_Get_Max; ------------- -- SS_Info -- ------------- procedure SS_Info is Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; begin Put_Line ("Secondary Stack information:"); -- Case of fixed secondary stack if not SP.Sec_Stack_Dynamic then Put_Line (" Total size : " & SS_Ptr'Image (Stack.Size) & " bytes"); Put_Line (" Current allocated space : " & SS_Ptr'Image (Stack.Top - 1) & " bytes"); -- Case of dynamic secondary stack else declare 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 -- 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. 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 : " & SP.Size_Type'Image (Stack.Size)); end; end if; end SS_Info; ------------- -- SS_Init -- ------------- procedure SS_Init (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 -- initialize the stack. Otherwise, SS_Init will allocate a secondary -- stack from either the heap or the default-sized secondary stack pool -- generated by the binder. In the later case, this pool is generated -- only when the either No_Implicit_Heap_Allocations -- or No_Implicit_Task_Allocations are active, and SS_Init will allocate -- all requests for a secondary stack of Unspecified_Size from this -- pool. 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. if Default_SS_Size > 0 then Stack_Size := Default_SS_Size; else Stack_Size := Runtime_Default_Sec_Stack_Size; end if; else Stack_Size := Size; end if; if Size = Unspecified_Size and then Binder_SS_Count > 0 and then Num_Of_Assigned_Stacks < Binder_SS_Count then -- The default-sized secondary stack pool is passed from the -- binder to this package as an Address since it is not possible -- to have a pointer to an array of unconstrained objects. A -- pointer to the pool is obtainable via an unchecked conversion -- to a constrained array of SS_Stacks that mirrors the one used -- by the binder. -- However, Ada understandably does not allow a local pointer to -- a stack in the pool to be stored in a pointer outside of this -- scope. While the conversion is safe in this case, since a view -- of a global object is being used, using Unchecked_Access -- would prevent users from specifying the restriction -- No_Unchecked_Access whenever the secondary stack is used. As -- a workaround, the local stack pointer is converted to a global -- pointer via System.Address. declare type Stk_Pool_Array is array (1 .. Binder_SS_Count) of aliased SS_Stack (Default_SS_Size); type Stk_Pool_Access is access Stk_Pool_Array; function To_Stack_Pool is new Ada.Unchecked_Conversion (Address, Stk_Pool_Access); pragma Warnings (Off); function To_Global_Ptr is new Ada.Unchecked_Conversion (Address, SS_Stack_Ptr); pragma Warnings (On); -- Suppress aliasing warning since the pointer we return will -- be the only access to the stack. Local_Stk_Address : System.Address; begin Num_Of_Assigned_Stacks := Num_Of_Assigned_Stacks + 1; Local_Stk_Address := To_Stack_Pool (Default_Sized_SS_Pool) (Num_Of_Assigned_Stacks)'Address; Stack := To_Global_Ptr (Local_Stk_Address); end; Stack.Freeable := False; else Stack := new SS_Stack (Stack_Size); Stack.Freeable := True; end if; end if; Stack.Top := 1; Stack.Max := 1; Stack.Current_Chunk := Stack.Internal_Chunk'Access; end SS_Init; ------------- -- SS_Mark -- ------------- function SS_Mark return Mark_Id is Stack : constant SS_Stack_Ptr := SSL.Get_Sec_Stack.all; begin return (Sec_Stack => Stack, Sptr => Stack.Top); end SS_Mark; ---------------- -- SS_Release -- ---------------- procedure SS_Release (M : Mark_Id) is begin M.Sec_Stack.Top := M.Sptr; end SS_Release; end System.Secondary_Stack;