4.1.18. GNATCOLL.Storage_Pools.Headers

package GNATCOLL.Storage_Pools.Headers is

   ------------------
   -- Header_Pools --
   ------------------

   --  The actual memory layout that we need to allocate is described below. In
   --  all cases, we had a "Pad" (padding) which is used to obey the requested
   --  alignment for the object.

   --  Currently, this pool doesn't support alignment clauses (and the generic
   --  Typed package below doesn't declare any), so the padding is always 0
   --  bytes.

   --  * For a scalar, record, tagged record or constrained array:

   --      +--------+------+-----------------------+
   --      | Header | Pad  | Element               |
   --      +--------+------+-----------------------+

   --  * For an unconstrained array, whether we use a standard access
   --    type or a flattened access type (a representation clause gives
   --    it a size of a standard pointer)
   --
   --      +--------+------+-----------------------+
   --      | Header | Pad  | First+Last+Element    |
   --      +--------+------+-----------------------+
   --      First and Last are the bounds of the array.
   --      Our pool should return the address of First, and the compiler
   --      automatically deduces the address of Element to return to the
   --      user code.

   --  * For a controlled type:
   --
   --      1        2                      3
   --      +--------+------+-----------------------+
   --      | Header | Pad  | Previous+Next+Element |
   --      +--------+------+-----------------------+
   --      Previous and Next are pointers to other controlled types.
   --      In code like:
   --              A := new ...;
   --      the header pool allocates memory at 1 via malloc, but
   --         returns 2 to the compiler
   --      then the compiler stores 3 in A.
   --      Conversely, when calling Free, the compiler converts A back to
   --         2, and our pool converts this back to 1 before calling free()
   --      The trouble is that when we call "Header_Of" on A, we receive
   --      the address 3, so it is harder to find 1.
   --
   --      See System.Storage_Pools.Subpools.Allocate_Any_Controlled.

   generic
      type Extra_Header is private;
      --  The header to allocate for each element. The pool will make sure
      --  to pad its size so that the element's data is properly aligned.

      type Header_Access is access all Extra_Header;
   package Header_Pools is

      type Header_Pool is new Root_Storage_Pool with null record;

      overriding procedure Allocate
         (Self      : in out Header_Pool;
          Addr      : out System.Address;
          Size      : Storage_Count;
          Alignment : Storage_Count);
      overriding procedure Deallocate
         (Self      : in out Header_Pool;
          Addr      : System.Address;
          Size      : Storage_Count;
          Alignment : Storage_Count);
      overriding function Storage_Size
         (Self      : Header_Pool) return Storage_Count
         is (Storage_Count'Last)
         with Inline;

      Pool : Header_Pool;

      -----------
      -- Typed --
      -----------

      generic
         type Element_Type (<>) is limited private;
      package Typed is
         type Element_Access is access all Element_Type;
         for Element_Access'Size use Standard'Address_Size;
         for Element_Access'Storage_Pool use Pool;
         --  Force array bounds to be stored before the array's data, rather
         --  than as a separate dope vector.

         function Header_Of
            (Element : Element_Access) return Header_Access
            with Inline;
         --  Points to the beginning of the header for Element.
         --  Returns null if Element is null

         procedure Free is new Ada.Unchecked_Deallocation
            (Element_Type, Element_Access);
         --  Free the memory used by Element

      end Typed;

   end Header_Pools;

end GNATCOLL.Storage_Pools.Headers;