From: Daniel King <dmk...@adacore.com> gcc/ada/ChangeLog:
* Makefile.rtl: Use s-secsta__cheri.adb on Morello CheriBSD. * libgnat/s-secsta__cheri.adb: New file. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/Makefile.rtl | 3 +- gcc/ada/libgnat/s-secsta__cheri.adb | 1085 +++++++++++++++++++++++++++ 2 files changed, 1087 insertions(+), 1 deletion(-) create mode 100644 gcc/ada/libgnat/s-secsta__cheri.adb diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 904ec34026f..4d32bc47185 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1805,7 +1805,8 @@ ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),) ifneq (,$(findstring morello,$(target_alias))) LIBGNAT_TARGET_PAIRS += \ s-intman.adb<libgnarl/s-intman__cheribsd.adb \ - s-osinte.ads<libgnarl/s-osinte__cheribsd.ads + s-osinte.ads<libgnarl/s-osinte__cheribsd.ads \ + s-secsta.adb<libgnat/s-secsta__cheri.adb EXTRA_GNATRTL_NONTASKING_OBJS += i-cheri.o i-cheri-exceptions.o else diff --git a/gcc/ada/libgnat/s-secsta__cheri.adb b/gcc/ada/libgnat/s-secsta__cheri.adb new file mode 100644 index 00000000000..ca2a2b3786e --- /dev/null +++ b/gcc/ada/libgnat/s-secsta__cheri.adb @@ -0,0 +1,1085 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2024, 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 Interfaces.CHERI; use Interfaces.CHERI; +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 := 0; + 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. + + function Padding_For_Bounds_Alignment + (Ptr : Address; + Size : Memory_Size) + return Memory_Size; + pragma Inline (Padding_For_Bounds_Alignment); + -- Calculate the amount of padding needed to align an address up to the + -- next representable boundary. + + ---------------------- + -- 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; + Padding : 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; + + -- Align the address to ensure that the CHERI bounds will be + -- representable. + + Padding := Padding_For_Bounds_Alignment (Addr, Mem_Size); + Addr := Addr + Storage_Offset (Padding); + + -- 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 + Padding; + + -- 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 + Padding : Memory_Size; + + begin + -- First check if the chunk is full (Byte is > Memory'Last in that + -- case), then check there is enough free memory. + + -- 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. + + -- We also need to consider any extra padding needed to align the + -- address to ensure that the CHERI lower bound is representable. + + Padding := + Padding_For_Bounds_Alignment (Chunk.Memory (Byte)'Address, Mem_Size); + + return Chunk.Memory'Last >= Byte + and then Chunk.Size - (Byte - 1) >= Mem_Size + and then Chunk.Size - (Byte - 1) - Mem_Size >= Padding; + + 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; + Alignment : SSE.Storage_Count := Standard'Maximum_Alignment) + 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 + + function Align_Addr (Addr : Address) return Address; + pragma Inline (Align_Addr); + -- Align Addr to the next multiple of Alignment + + ---------------- + -- Align_Addr -- + ---------------- + + function Align_Addr (Addr : Address) return Address is + begin + + -- L : Alignment + -- A : Standard'Maximum_Alignment + + -- Addr + -- L | L L + -- A--A--A--A--A--A--A--A--A--A--A + -- | | + -- \----/ | | + -- Addr mod L | Addr + L + -- | + -- Addr + L - (Addr mod L) + + return Addr + (Alignment - (Addr mod Alignment)); + end Align_Addr; + + -------------- + -- 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 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; + + Over_Aligning : constant Boolean := + Alignment > Standard'Maximum_Alignment; + + Over_Align_Padding : SSE.Storage_Count := 0; + + Adjusted_Storage_Size : Interfaces.CHERI.Bounds_Length; + -- Storage_Size plus padding for over-alignment and extra padding to + -- align the capability's upper bound. + + Capability_Lower_Bound : Address; + + -- Start of processing for SS_Allocate + + begin + -- Alignment must be a power of two and can be: + + -- - lower than or equal to Maximum_Alignment, in which case the result + -- will be aligned on Maximum_Alignment; + -- - higher than Maximum_Alignment, in which case the result will be + -- dynamically realigned. + + if Over_Aligning then + Over_Align_Padding := Alignment; + end if; + + -- It should not be possible to request an allocation of negative + -- size. + + pragma Assert (Storage_Size >= 0); + + -- Round the requested size (plus the needed padding in case of + -- over-alignment) to ensure that the CHERI bounds length will be + -- representable. + + Adjusted_Storage_Size := + Representable_Length + (Bounds_Length (Storage_Size + Over_Align_Padding)); + + -- Round up to the nearest multiple of the default alignment to ensure + -- efficient access and that the next available Byte is always aligned + -- on the default alignement value. + + Mem_Size := Round_Up (Storage_Count (Adjusted_Storage_Size)); + + if Sec_Stack_Dynamic then + Allocate_Dynamic (Stack, Mem_Size, Addr); + else + Allocate_Static (Stack, Mem_Size, Addr); + end if; + + -- Restrict the capability bounds to the requested allocation size, + -- possibly with some padding for alignment of the bounds. + + Capability_Lower_Bound := + Capability_With_Address_Aligned_Up (Addr, Adjusted_Storage_Size); + + Addr := Capability_With_Exact_Bounds + (Capability_Lower_Bound, Adjusted_Storage_Size); + + if Over_Aligning then + Addr := Align_Addr (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; + + ---------------------------------- + -- Padding_For_Bounds_Alignment -- + ---------------------------------- + + function Padding_For_Bounds_Alignment + (Ptr : Address; + Size : Memory_Size) + return Memory_Size + is + IA : constant Integer_Address := To_Integer (Ptr); + begin + return Memory_Size (Align_Address_Up (IA, Bounds_Length (Size)) - IA); + end Padding_For_Bounds_Alignment; + +end System.Secondary_Stack; -- 2.43.0