------------------------------------------------------------------------------ -- -- -- 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-2019, 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; 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 := Standard'Maximum_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 exhaused"; 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 -- It should not be possible to request an allocation of negative or -- zero size. pragma Assert (Storage_Size > 0); -- Round the requested size up to the nearest multiple of the maximum -- alignment to ensure efficient access. Mem_Size := Round_Up (Storage_Size); 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;