------------------------------------------------------------------------------
--                                                                          --
--                         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         --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--          Copyright (C) 2011-2017, Free Software Foundation, Inc.         --
--                                                                          --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the  contents of the part following the private keyword. --
--                                                                          --
-- 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.Finalization;
with System.Finalization_Masters;
with System.Storage_Elements;

package System.Storage_Pools.Subpools is
   pragma Preelaborate;

   type Root_Storage_Pool_With_Subpools is abstract
     new Root_Storage_Pool with private;
   --  The base for all implementations of Storage_Pool_With_Subpools. This
   --  type is Limited_Controlled by derivation. To use subpools, an access
   --  type must be associated with an implementation descending from type
   --  Root_Storage_Pool_With_Subpools.

   type Root_Subpool is abstract tagged limited private;
   --  The base for all implementations of Subpool. Objects of this type are
   --  managed by the pool_with_subpools.

   type Subpool_Handle is access all Root_Subpool'Class;
   for Subpool_Handle'Storage_Size use 0;
   --  Since subpools are limited types by definition, a handle is instead used
   --  to manage subpool abstractions.

   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);
   --  Allocate an object described by Size_In_Storage_Elements and Alignment
   --  on the default subpool of Pool. Controlled types allocated through this
   --  routine will NOT be handled properly.

   procedure Allocate_From_Subpool
     (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;
      Subpool                  : not null Subpool_Handle) is abstract;

   --  ??? This precondition causes errors in simple tests, disabled for now

   --      with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;
   --  This routine requires implementation. Allocate an object described by
   --  Size_In_Storage_Elements and Alignment on a subpool.

   function Create_Subpool
     (Pool : in out Root_Storage_Pool_With_Subpools)
      return not null Subpool_Handle is abstract;
   --  This routine requires implementation. Create a subpool within the given
   --  pool_with_subpools.

   overriding procedure Deallocate
     (Pool                     : in out Root_Storage_Pool_With_Subpools;
      Storage_Address          : System.Address;
      Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
      Alignment                : System.Storage_Elements.Storage_Count)
   is null;

   procedure Deallocate_Subpool
     (Pool    : in out Root_Storage_Pool_With_Subpools;
      Subpool : in out Subpool_Handle)
   is abstract;
   --  This precondition causes errors in simple tests, disabled for now???
   --  with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access;

   --  This routine requires implementation. Reclaim the storage a particular
   --  subpool occupies in a pool_with_subpools. This routine is called by
   --  Ada.Unchecked_Deallocate_Subpool.

   function Default_Subpool_For_Pool
     (Pool : in out Root_Storage_Pool_With_Subpools)
      return not null Subpool_Handle;
   --  Return a common subpool which is used for object allocations without a
   --  Subpool_Handle_Name in the allocator. The default implementation of this
   --  routine raises Program_Error.

   function Pool_Of_Subpool
     (Subpool : not null Subpool_Handle)
      return access Root_Storage_Pool_With_Subpools'Class;
   --  Return the owner of the subpool

   procedure Set_Pool_Of_Subpool
     (Subpool : not null Subpool_Handle;
      To      : in out Root_Storage_Pool_With_Subpools'Class);
   --  Set the owner of the subpool. This is intended to be called from
   --  Create_Subpool or similar subpool constructors. Raises Program_Error
   --  if the subpool already belongs to a pool.

   overriding function Storage_Size
     (Pool : Root_Storage_Pool_With_Subpools)
      return System.Storage_Elements.Storage_Count
   is
      (System.Storage_Elements.Storage_Count'Last);

private
   --  Model
   --             Pool_With_Subpools     SP_Node    SP_Node    SP_Node
   --       +-->+--------------------+   +-----+    +-----+    +-----+
   --       |   |      Subpools -------->|  ------->|  ------->|  ------->
   --       |   +--------------------+   +-----+    +-----+    +-----+
   --       |   |Finalization_Started|<------  |<-------  |<-------  |<---
   --       |   +--------------------+   +-----+    +-----+    +-----+
   --       +--- Controller.Encl_Pool|   | nul |    |  +  |    |  +  |
   --       |   +--------------------+   +-----+    +--|--+    +--:--+
   --       |   :                    :    Dummy        |  ^       :
   --       |   :                    :                 |  |       :
   --       |                            Root_Subpool  V  |
   --       |                            +-------------+  |
   --       +-------------------------------- Owner    |  |
   --               FM_Node   FM_Node    +-------------+  |
   --               +-----+   +-----+<-- Master.Objects|  |
   --            <------  |<------  |    +-------------+  |
   --               +-----+   +-----+    |    Node -------+
   --               |  ------>|  ----->  +-------------+
   --               +-----+   +-----+    :             :
   --               |ctrl |    Dummy     :             :
   --               | obj |
   --               +-----+
   --
   --  SP_Nodes are created on the heap. FM_Nodes and associated objects are
   --  created on the pool_with_subpools.

   type Any_Storage_Pool_With_Subpools_Ptr
     is access all Root_Storage_Pool_With_Subpools'Class;
   for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0;

   --  A pool controller is a special controlled object which ensures the
   --  proper initialization and finalization of the enclosing pool.

   type Pool_Controller (Enclosing_Pool : Any_Storage_Pool_With_Subpools_Ptr)
     is new Ada.Finalization.Limited_Controlled with null record;

   --  Subpool list types. Each pool_with_subpools contains a list of subpools.
   --  This is an indirect doubly linked list since subpools are not supposed
   --  to be allocatable by language design.

   type SP_Node;
   type SP_Node_Ptr is access all SP_Node;

   type SP_Node is record
      Prev    : SP_Node_Ptr := null;
      Next    : SP_Node_Ptr := null;
      Subpool : Subpool_Handle := null;
   end record;

   --  Root_Storage_Pool_With_Subpools internal structure. The type uses a
   --  special controller to perform initialization and finalization actions
   --  on itself. This is necessary because the end user of this package may
   --  decide to override Initialize and Finalize, thus disabling the desired
   --  behavior.

   --          Pool_With_Subpools     SP_Node    SP_Node    SP_Node
   --    +-->+--------------------+   +-----+    +-----+    +-----+
   --    |   |      Subpools -------->|  ------->|  ------->|  ------->
   --    |   +--------------------+   +-----+    +-----+    +-----+
   --    |   |Finalization_Started|   :     :    :     :    :     :
   --    |   +--------------------+
   --    +--- Controller.Encl_Pool|
   --        +--------------------+
   --        :       End-user     :
   --        :      components    :

   type Root_Storage_Pool_With_Subpools is abstract
     new Root_Storage_Pool with
   record
      Subpools : aliased SP_Node;
      --  A doubly linked list of subpools

      Finalization_Started : Boolean := False;
      pragma Atomic (Finalization_Started);
      --  A flag which prevents the creation of new subpools while the master
      --  pool is being finalized. The flag needs to be atomic because it is
      --  accessed without Lock_Task / Unlock_Task.

      Controller : Pool_Controller
                     (Root_Storage_Pool_With_Subpools'Unchecked_Access);
      --  A component which ensures that the enclosing pool is initialized and
      --  finalized at the appropriate places.
   end record;

   --  A subpool is an abstraction layer which sits on top of a pool. It
   --  contains links to all controlled objects allocated on a particular
   --  subpool.

   --        Pool_With_Subpools   SP_Node    SP_Node    SP_Node
   --    +-->+----------------+   +-----+    +-----+    +-----+
   --    |   |    Subpools ------>|  ------->|  ------->|  ------->
   --    |   +----------------+   +-----+    +-----+    +-----+
   --    |   :                :<------  |<-------  |<-------  |
   --    |   :                :   +-----+    +-----+    +-----+
   --    |                        |null |    |  +  |    |  +  |
   --    |                        +-----+    +--|--+    +--:--+
   --    |                                      |  ^       :
   --    |                        Root_Subpool  V  |
   --    |                        +-------------+  |
   --    +---------------------------- Owner    |  |
   --                             +-------------+  |
   --                      .......... Master    |  |
   --                             +-------------+  |
   --                             |    Node -------+
   --                             +-------------+
   --                             :   End-user  :
   --                             :  components :

   type Root_Subpool is abstract tagged limited record
      Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
      --  A reference to the master pool_with_subpools

      Master : aliased System.Finalization_Masters.Finalization_Master;
      --  A heterogeneous collection of controlled objects

      Node : SP_Node_Ptr := null;
      --  A link to the doubly linked list node which contains the subpool.
      --  This back pointer is used in subpool deallocation.
   end record;

   procedure Adjust_Controlled_Dereference
     (Addr         : in out System.Address;
      Storage_Size : in out System.Storage_Elements.Storage_Count;
      Alignment    : System.Storage_Elements.Storage_Count);
   --  Given the memory attributes of a heap-allocated object that is known to
   --  be controlled, adjust the address and size of the object to include the
   --  two hidden pointers inserted by the finalization machinery.

   --  ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed
   --  to Allocate_Any.

   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);
   --  Compiler interface. This version of Allocate handles all possible cases,
   --  either on a pool or a pool_with_subpools, regardless of the controlled
   --  status of the allocated object. Parameter usage:
   --
   --    * Pool - The pool associated with the access type. Pool can be any
   --    derivation from Root_Storage_Pool, including a pool_with_subpools.
   --
   --    * Context_Subpool - The subpool handle name of an allocator. If no
   --    subpool handle is present at the point of allocation, the actual
   --    would be null.
   --
   --    * Context_Master - The finalization master associated with the access
   --    type. If the access type's designated type is not controlled, the
   --    actual would be null.
   --
   --    * Fin_Address - TSS routine Finalize_Address of the designated type.
   --    If the designated type is not controlled, the actual would be null.
   --
   --    * Addr - The address of the allocated object.
   --
   --    * Storage_Size - The size of the allocated object.
   --
   --    * Alignment - The alignment of the allocated object.
   --
   --    * Is_Controlled - A flag which determines whether the allocated object
   --    is controlled. When set to True, the machinery generates additional
   --    data.
   --
   --    * On_Subpool - A flag which determines whether the a subpool handle
   --    name is present at the point of allocation. This is used for error
   --    diagnostics.

   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);
   --  Compiler interface. This version of Deallocate handles all possible
   --  cases, either from a pool or a pool_with_subpools, regardless of the
   --  controlled status of the deallocated object. Parameter usage:
   --
   --    * Pool - The pool associated with the access type. Pool can be any
   --    derivation from Root_Storage_Pool, including a pool_with_subpools.
   --
   --    * Addr - The address of the allocated object.
   --
   --    * Storage_Size - The size of the allocated object.
   --
   --    * Alignment - The alignment of the allocated object.
   --
   --    * Is_Controlled - A flag which determines whether the allocated object
   --    is controlled. When set to True, the machinery generates additional
   --    data.

   procedure Detach (N : not null SP_Node_Ptr);
   --  Unhook a subpool node from an arbitrary subpool list

   overriding procedure Finalize (Controller : in out Pool_Controller);
   --  Buffer routine, calls Finalize_Pool

   procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
   --  Iterate over all subpools of Pool, detach them one by one and finalize
   --  their masters. This action first detaches a controlled object from a
   --  particular master, then invokes its Finalize_Address primitive.

   function Header_Size_With_Padding
     (Alignment : System.Storage_Elements.Storage_Count)
      return System.Storage_Elements.Storage_Count;
   --  Given an arbitrary alignment, calculate the size of the header which
   --  precedes a controlled object as the nearest multiple rounded up of the
   --  alignment.

   overriding procedure Initialize (Controller : in out Pool_Controller);
   --  Buffer routine, calls Initialize_Pool

   procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
   --  Setup the doubly linked list of subpools

   procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools);
   --  Debug routine, output the contents of a pool_with_subpools

   procedure Print_Subpool (Subpool : Subpool_Handle);
   --  Debug routine, output the contents of a subpool

end System.Storage_Pools.Subpools;