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

Reply via email to