------------------------------------------------------------------------------ -- -- -- 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-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 -- -- . -- -- -- -- 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 FALSE -- Controller: OK 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;