------------------------------------------------------------------------------
--                                                                          --
--                         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;