------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--        S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2011-2021, 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.Exceptions;           use Ada.Exceptions;
with Ada.Unchecked_Conversion;

with System.Address_Image;
with System.Finalization_Masters; use System.Finalization_Masters;
with System.IO;                   use System.IO;
with System.Soft_Links;           use System.Soft_Links;
with System.Storage_Elements;     use System.Storage_Elements;

with System.Storage_Pools.Subpools.Finalization;
use  System.Storage_Pools.Subpools.Finalization;

package body System.Storage_Pools.Subpools is

   Finalize_Address_Table_In_Use : Boolean := False;
   --  This flag should be set only when a successful allocation on a subpool
   --  has been performed and the associated Finalize_Address has been added to
   --  the hash table in System.Finalization_Masters.

   function Address_To_FM_Node_Ptr is
     new Ada.Unchecked_Conversion (Address, FM_Node_Ptr);

   procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr);
   --  Attach a subpool node to a pool

   -----------------------------------
   -- Adjust_Controlled_Dereference --
   -----------------------------------

   procedure Adjust_Controlled_Dereference
     (Addr         : in out System.Address;
      Storage_Size : in out System.Storage_Elements.Storage_Count;
      Alignment    : System.Storage_Elements.Storage_Count)
   is
      Header_And_Padding : constant Storage_Offset :=
                             Header_Size_With_Padding (Alignment);
   begin
      --  Expose the two hidden pointers by shifting the address from the
      --  start of the object to the FM_Node equivalent of the pointers.

      Addr := Addr - Header_And_Padding;

      --  Update the size of the object to include the two pointers

      Storage_Size := Storage_Size + Header_And_Padding;
   end Adjust_Controlled_Dereference;

   --------------
   -- Allocate --
   --------------

   overriding procedure Allocate
     (Pool                     : in out Root_Storage_Pool_With_Subpools;
      Storage_Address          : out System.Address;
      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
      Alignment                : System.Storage_Elements.Storage_Count)
   is
   begin
      --  Dispatch to the user-defined implementations of Allocate_From_Subpool
      --  and Default_Subpool_For_Pool.

      Allocate_From_Subpool
        (Root_Storage_Pool_With_Subpools'Class (Pool),
         Storage_Address,
         Size_In_Storage_Elements,
         Alignment,
         Default_Subpool_For_Pool
           (Root_Storage_Pool_With_Subpools'Class (Pool)));
   end Allocate;

   -----------------------------
   -- Allocate_Any_Controlled --
   -----------------------------

   procedure Allocate_Any_Controlled
     (Pool            : in out Root_Storage_Pool'Class;
      Context_Subpool : Subpool_Handle;
      Context_Master  : Finalization_Masters.Finalization_Master_Ptr;
      Fin_Address     : Finalization_Masters.Finalize_Address_Ptr;
      Addr            : out System.Address;
      Storage_Size    : System.Storage_Elements.Storage_Count;
      Alignment       : System.Storage_Elements.Storage_Count;
      Is_Controlled   : Boolean;
      On_Subpool      : Boolean)
   is
      Is_Subpool_Allocation : constant Boolean :=
                                Pool in Root_Storage_Pool_With_Subpools'Class;

      Master     : Finalization_Master_Ptr := null;
      N_Addr     : Address;
      N_Ptr      : FM_Node_Ptr;
      N_Size     : Storage_Count;
      Subpool    : Subpool_Handle := null;
      Lock_Taken : Boolean := False;

      Header_And_Padding : Storage_Offset;
      --  This offset includes the size of a FM_Node plus any additional
      --  padding due to a larger alignment.

   begin
      --  Step 1: Pool-related runtime checks

      --  Allocation on a pool_with_subpools. In this scenario there is a
      --  master for each subpool. The master of the access type is ignored.

      if Is_Subpool_Allocation then

         --  Case of an allocation without a Subpool_Handle. Dispatch to the
         --  implementation of Default_Subpool_For_Pool.

         if Context_Subpool = null then
            Subpool :=
              Default_Subpool_For_Pool
                (Root_Storage_Pool_With_Subpools'Class (Pool));

         --  Allocation with a Subpool_Handle

         else
            Subpool := Context_Subpool;
         end if;

         --  Ensure proper ownership and chaining of the subpool

         if Subpool.Owner /=
              Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access
           or else Subpool.Node = null
           or else Subpool.Node.Prev = null
           or else Subpool.Node.Next = null
         then
            raise Program_Error with "incorrect owner of subpool";
         end if;

         Master := Subpool.Master'Unchecked_Access;

      --  Allocation on a simple pool. In this scenario there is a master for
      --  each access-to-controlled type. No context subpool should be present.

      else
         --  If the master is missing, then the expansion of the access type
         --  failed to create one. This is a compiler bug.

         pragma Assert
           (Context_Master /= null, "missing master in pool allocation");

         --  If a subpool is present, then this is the result of erroneous
         --  allocator expansion. This is not a serious error, but it should
         --  still be detected.

         if Context_Subpool /= null then
            raise Program_Error
              with "subpool not required in pool allocation";
         end if;

         --  If the allocation is intended to be on a subpool, but the access
         --  type's pool does not support subpools, then this is the result of
         --  incorrect end-user code.

         if On_Subpool then
            raise Program_Error
              with "pool of access type does not support subpools";
         end if;

         Master := Context_Master;
      end if;

      --  Step 2: Master, Finalize_Address-related runtime checks and size
      --  calculations.

      --  Allocation of a descendant from [Limited_]Controlled, a class-wide
      --  object or a record with controlled components.

      if Is_Controlled then

         --  Synchronization:
         --    Read  - allocation, finalization
         --    Write - finalization

         Lock_Taken := True;
         Lock_Task.all;

         --  Do not allow the allocation of controlled objects while the
         --  associated master is being finalized.

         if Finalization_Started (Master.all) then
            raise Program_Error with "allocation after finalization started";
         end if;

         --  Check whether primitive Finalize_Address is available. If it is
         --  not, then either the expansion of the designated type failed or
         --  the expansion of the allocator failed. This is a compiler bug.

         pragma Assert
           (Fin_Address /= null, "primitive Finalize_Address not available");

         --  The size must account for the hidden header preceding the object.
         --  Account for possible padding space before the header due to a
         --  larger alignment.

         Header_And_Padding := Header_Size_With_Padding (Alignment);

         N_Size := Storage_Size + Header_And_Padding;

      --  Non-controlled allocation

      else
         N_Size := Storage_Size;
      end if;

      --  Step 3: Allocation of object

      --  For descendants of Root_Storage_Pool_With_Subpools, dispatch to the
      --  implementation of Allocate_From_Subpool.

      if Is_Subpool_Allocation then
         Allocate_From_Subpool
           (Root_Storage_Pool_With_Subpools'Class (Pool),
            N_Addr, N_Size, Alignment, Subpool);

      --  For descendants of Root_Storage_Pool, dispatch to the implementation
      --  of Allocate.

      else
         Allocate (Pool, N_Addr, N_Size, Alignment);
      end if;

      --  Step 4: Attachment

      if Is_Controlled then

         --  Note that we already did "Lock_Task.all;" in Step 2 above

         --  Map the allocated memory into a FM_Node record. This converts the
         --  top of the allocated bits into a list header. If there is padding
         --  due to larger alignment, the header is placed right next to the
         --  object:

         --     N_Addr  N_Ptr
         --     |       |
         --     V       V
         --     +-------+---------------+----------------------+
         --     |Padding|    Header     |        Object        |
         --     +-------+---------------+----------------------+
         --     ^       ^               ^
         --     |       +- Header_Size -+
         --     |                       |
         --     +- Header_And_Padding --+

         N_Ptr :=
           Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);

         --  Prepend the allocated object to the finalization master

         --  Synchronization:
         --    Write - allocation, deallocation, finalization

         Attach_Unprotected (N_Ptr, Objects (Master.all));

         --  Move the address from the hidden list header to the start of the
         --  object. This operation effectively hides the list header.

         Addr := N_Addr + Header_And_Padding;

         --  Homogeneous masters service the following:

         --    1) Allocations on / Deallocations from regular pools
         --    2) Named access types
         --    3) Most cases of anonymous access types usage

         --  Synchronization:
         --    Read  - allocation, finalization
         --    Write - outside

         if Master.Is_Homogeneous then

            --  Synchronization:
            --    Read  - finalization
            --    Write - allocation, outside

            Set_Finalize_Address_Unprotected (Master.all, Fin_Address);

         --  Heterogeneous masters service the following:

         --    1) Allocations on / Deallocations from subpools
         --    2) Certain cases of anonymous access types usage

         else
            --  Synchronization:
            --    Read  - finalization
            --    Write - allocation, deallocation

            Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
            Finalize_Address_Table_In_Use := True;
         end if;

         Unlock_Task.all;
         Lock_Taken := False;

      --  Non-controlled allocation

      else
         Addr := N_Addr;
      end if;

   exception
      when others =>

         --  Unlock the task in case the allocation step failed and reraise the
         --  exception.

         if Lock_Taken then
            Unlock_Task.all;
         end if;

         raise;
   end Allocate_Any_Controlled;

   ------------
   -- Attach --
   ------------

   procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is
   begin
      --  Ensure that the node has not been attached already

      pragma Assert (N.Prev = null and then N.Next = null);

      Lock_Task.all;

      L.Next.Prev := N;
      N.Next := L.Next;
      L.Next := N;
      N.Prev := L;

      Unlock_Task.all;

      --  Note: No need to unlock in case of an exception because the above
      --  code can never raise one.
   end Attach;

   -------------------------------
   -- Deallocate_Any_Controlled --
   -------------------------------

   procedure Deallocate_Any_Controlled
     (Pool          : in out Root_Storage_Pool'Class;
      Addr          : System.Address;
      Storage_Size  : System.Storage_Elements.Storage_Count;
      Alignment     : System.Storage_Elements.Storage_Count;
      Is_Controlled : Boolean)
   is
      N_Addr : Address;
      N_Ptr  : FM_Node_Ptr;
      N_Size : Storage_Count;

      Header_And_Padding : Storage_Offset;
      --  This offset includes the size of a FM_Node plus any additional
      --  padding due to a larger alignment.

   begin
      --  Step 1: Detachment

      if Is_Controlled then
         Lock_Task.all;

         begin
            --  Destroy the relation pair object - Finalize_Address since it is
            --  no longer needed.

            if Finalize_Address_Table_In_Use then

               --  Synchronization:
               --    Read  - finalization
               --    Write - allocation, deallocation

               Delete_Finalize_Address_Unprotected (Addr);
            end if;

            --  Account for possible padding space before the header due to a
            --  larger alignment.

            Header_And_Padding := Header_Size_With_Padding (Alignment);

            --    N_Addr  N_Ptr           Addr (from input)
            --    |       |               |
            --    V       V               V
            --    +-------+---------------+----------------------+
            --    |Padding|    Header     |        Object        |
            --    +-------+---------------+----------------------+
            --    ^       ^               ^
            --    |       +- Header_Size -+
            --    |                       |
            --    +- Header_And_Padding --+

            --  Convert the bits preceding the object into a list header

            N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);

            --  Detach the object from the related finalization master. This
            --  action does not need to know the prior context used during
            --  allocation.

            --  Synchronization:
            --    Write - allocation, deallocation, finalization

            Detach_Unprotected (N_Ptr);

            --  Move the address from the object to the beginning of the list
            --  header.

            N_Addr := Addr - Header_And_Padding;

            --  The size of the deallocated object must include the size of the
            --  hidden list header.

            N_Size := Storage_Size + Header_And_Padding;

            Unlock_Task.all;

         exception
            when others =>

               --  Unlock the task in case the computations performed above
               --  fail for some reason.

               Unlock_Task.all;
               raise;
         end;
      else
         N_Addr := Addr;
         N_Size := Storage_Size;
      end if;

      --  Step 2: Deallocation

      --  Dispatch to the proper implementation of Deallocate. This action
      --  covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools
      --  implementations.

      Deallocate (Pool, N_Addr, N_Size, Alignment);
   end Deallocate_Any_Controlled;

   ------------------------------
   -- Default_Subpool_For_Pool --
   ------------------------------

   function Default_Subpool_For_Pool
     (Pool : in out Root_Storage_Pool_With_Subpools)
      return not null Subpool_Handle
   is
      pragma Unreferenced (Pool);
   begin
      return raise Program_Error with
        "default Default_Subpool_For_Pool called; must be overridden";
   end Default_Subpool_For_Pool;

   ------------
   -- Detach --
   ------------

   procedure Detach (N : not null SP_Node_Ptr) is
   begin
      --  Ensure that the node is attached to some list

      pragma Assert (N.Next /= null and then N.Prev /= null);

      Lock_Task.all;

      N.Prev.Next := N.Next;
      N.Next.Prev := N.Prev;
      N.Prev := null;
      N.Next := null;

      Unlock_Task.all;

      --  Note: No need to unlock in case of an exception because the above
      --  code can never raise one.
   end Detach;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize (Controller : in out Pool_Controller) is
   begin
      Finalize_Pool (Controller.Enclosing_Pool.all);
   end Finalize;

   -------------------
   -- Finalize_Pool --
   -------------------

   procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
      Curr_Ptr : SP_Node_Ptr;
      Ex_Occur : Exception_Occurrence;
      Raised   : Boolean := False;

      function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
      --  Determine whether a list contains only one element, the dummy head

      -------------------
      -- Is_Empty_List --
      -------------------

      function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
      begin
         return L.Next = L and then L.Prev = L;
      end Is_Empty_List;

   --  Start of processing for Finalize_Pool

   begin
      --  It is possible for multiple tasks to cause the finalization of a
      --  common pool. Allow only one task to finalize the contents.

      if Pool.Finalization_Started then
         return;
      end if;

      --  Lock the pool to prevent the creation of additional subpools while
      --  the available ones are finalized. The pool remains locked because
      --  either it is about to be deallocated or the associated access type
      --  is about to go out of scope.

      Pool.Finalization_Started := True;

      while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
         Curr_Ptr := Pool.Subpools.Next;

         --  Perform the following actions:

         --    1) Finalize all objects chained on the subpool's master
         --    2) Remove the subpool from the owner's list of subpools
         --    3) Deallocate the doubly linked list node associated with the
         --       subpool.
         --    4) Call Deallocate_Subpool

         begin
            Finalize_And_Deallocate (Curr_Ptr.Subpool);

         exception
            when Fin_Occur : others =>
               if not Raised then
                  Raised := True;
                  Save_Occurrence (Ex_Occur, Fin_Occur);
               end if;
         end;
      end loop;

      --  If the finalization of a particular master failed, reraise the
      --  exception now.

      if Raised then
         Reraise_Occurrence (Ex_Occur);
      end if;
   end Finalize_Pool;

   ------------------------------
   -- Header_Size_With_Padding --
   ------------------------------

   function Header_Size_With_Padding
     (Alignment : System.Storage_Elements.Storage_Count)
      return System.Storage_Elements.Storage_Count
   is
      Size : constant Storage_Count := Header_Size;

   begin
      if Size mod Alignment = 0 then
         return Size;

      --  Add enough padding to reach the nearest multiple of the alignment
      --  rounding up.

      else
         return ((Size + Alignment - 1) / Alignment) * Alignment;
      end if;
   end Header_Size_With_Padding;

   ----------------
   -- Initialize --
   ----------------

   overriding procedure Initialize (Controller : in out Pool_Controller) is
   begin
      Initialize_Pool (Controller.Enclosing_Pool.all);
   end Initialize;

   ---------------------
   -- Initialize_Pool --
   ---------------------

   procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
   begin
      --  The dummy head must point to itself in both directions

      Pool.Subpools.Next := Pool.Subpools'Unchecked_Access;
      Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access;
   end Initialize_Pool;

   ---------------------
   -- Pool_Of_Subpool --
   ---------------------

   function Pool_Of_Subpool
     (Subpool : not null Subpool_Handle)
      return access Root_Storage_Pool_With_Subpools'Class
   is
   begin
      return Subpool.Owner;
   end Pool_Of_Subpool;

   ----------------
   -- Print_Pool --
   ----------------

   procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
      Head      : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
      Head_Seen : Boolean := False;
      SP_Ptr    : SP_Node_Ptr;

   begin
      --  Output the contents of the pool

      --    Pool      : 0x123456789
      --    Subpools  : 0x123456789
      --    Fin_Start : TRUE <or> FALSE
      --    Controller: OK <or> NOK

      Put ("Pool      : ");
      Put_Line (Address_Image (Pool'Address));

      Put ("Subpools  : ");
      Put_Line (Address_Image (Pool.Subpools'Address));

      Put ("Fin_Start : ");
      Put_Line (Pool.Finalization_Started'Img);

      Put ("Controlled: ");
      if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
         Put_Line ("OK");
      else
         Put_Line ("NOK (ERROR)");
      end if;

      SP_Ptr := Head;
      while SP_Ptr /= null loop  --  Should never be null
         Put_Line ("V");

         --  We see the head initially; we want to exit when we see the head a
         --  second time.

         if SP_Ptr = Head then
            exit when Head_Seen;

            Head_Seen := True;
         end if;

         --  The current element is null. This should never happend since the
         --  list is circular.

         if SP_Ptr.Prev = null then
            Put_Line ("null (ERROR)");

         --  The current element points back to the correct element

         elsif SP_Ptr.Prev.Next = SP_Ptr then
            Put_Line ("^");

         --  The current element points to an erroneous element

         else
            Put_Line ("? (ERROR)");
         end if;

         --  Output the contents of the node

         Put ("|Header: ");
         Put (Address_Image (SP_Ptr.all'Address));
         if SP_Ptr = Head then
            Put_Line (" (dummy head)");
         else
            Put_Line ("");
         end if;

         Put ("|  Prev: ");

         if SP_Ptr.Prev = null then
            Put_Line ("null");
         else
            Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
         end if;

         Put ("|  Next: ");

         if SP_Ptr.Next = null then
            Put_Line ("null");
         else
            Put_Line (Address_Image (SP_Ptr.Next.all'Address));
         end if;

         Put ("|  Subp: ");

         if SP_Ptr.Subpool = null then
            Put_Line ("null");
         else
            Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
         end if;

         SP_Ptr := SP_Ptr.Next;
      end loop;
   end Print_Pool;

   -------------------
   -- Print_Subpool --
   -------------------

   procedure Print_Subpool (Subpool : Subpool_Handle) is
   begin
      if Subpool = null then
         Put_Line ("null");
         return;
      end if;

      --  Output the contents of a subpool

      --    Owner : 0x123456789
      --    Master: 0x123456789
      --    Node  : 0x123456789

      Put ("Owner : ");
      if Subpool.Owner = null then
         Put_Line ("null");
      else
         Put_Line (Address_Image (Subpool.Owner'Address));
      end if;

      Put ("Master: ");
      Put_Line (Address_Image (Subpool.Master'Address));

      Put ("Node  : ");
      if Subpool.Node = null then
         Put ("null");

         if Subpool.Owner = null then
            Put_Line (" OK");
         else
            Put_Line (" (ERROR)");
         end if;
      else
         Put_Line (Address_Image (Subpool.Node'Address));
      end if;

      Print_Master (Subpool.Master);
   end Print_Subpool;

   -------------------------
   -- Set_Pool_Of_Subpool --
   -------------------------

   procedure Set_Pool_Of_Subpool
     (Subpool : not null Subpool_Handle;
      To      : in out Root_Storage_Pool_With_Subpools'Class)
   is
      N_Ptr : SP_Node_Ptr;

   begin
      --  If the subpool is already owned, raise Program_Error. This is a
      --  direct violation of the RM rules.

      if Subpool.Owner /= null then
         raise Program_Error with "subpool already belongs to a pool";
      end if;

      --  Prevent the creation of a new subpool while the owner is being
      --  finalized. This is a serious error.

      if To.Finalization_Started then
         raise Program_Error
           with "subpool creation after finalization started";
      end if;

      Subpool.Owner := To'Unchecked_Access;

      --  Create a subpool node and decorate it. Since this node is not
      --  allocated on the owner's pool, it must be explicitly destroyed by
      --  Finalize_And_Detach.

      N_Ptr := new SP_Node;
      N_Ptr.Subpool := Subpool;
      Subpool.Node := N_Ptr;

      Attach (N_Ptr, To.Subpools'Unchecked_Access);

      --  Mark the subpool's master as being a heterogeneous collection of
      --  controlled objects.

      Set_Is_Heterogeneous (Subpool.Master);
   end Set_Pool_Of_Subpool;

end System.Storage_Pools.Subpools;