| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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-2022, 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. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Ada.Unchecked_Conversion; |
| with Ada.Unchecked_Deallocation; |
| |
| 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 := Memory_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 exhausted"; |
| 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 |
| -- Round the requested size up to the nearest multiple of the maximum |
| -- alignment to ensure efficient access. |
| |
| if Storage_Size = 0 then |
| Mem_Size := Memory_Alignment; |
| else |
| -- It should not be possible to request an allocation of negative |
| -- size. |
| |
| pragma Assert (Storage_Size >= 0); |
| Mem_Size := Round_Up (Storage_Size); |
| end if; |
| |
| 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; |
