diff options
Diffstat (limited to 'gcc/ada/s-stposu.adb')
| -rw-r--r-- | gcc/ada/s-stposu.adb | 209 |
1 files changed, 195 insertions, 14 deletions
diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index bf3a87e662f..0cdc90b7084 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -31,8 +31,9 @@ with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Deallocation; - +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; @@ -248,21 +249,39 @@ package body System.Storage_Pools.Subpools is -- +- Header_And_Padding --+ N_Ptr := Address_To_FM_Node_Ptr - (N_Addr + Header_And_Padding - Header_Offset); + (N_Addr + Header_And_Padding - Header_Offset); -- Prepend the allocated object to the finalization master Attach (N_Ptr, Master.Objects'Unchecked_Access); - if Master.Finalize_Address = null then - Master.Finalize_Address := Fin_Address; - end if; - -- 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; + -- Subpool allocations use heterogeneous masters to manage various + -- controlled objects. Associate a Finalize_Address with the object. + -- This relation pair is deleted when the object is deallocated or + -- when the associated master is finalized. + + if Is_Subpool_Allocation then + pragma Assert (not Master.Is_Homogeneous); + + Set_Finalize_Address (Addr, Fin_Address); + + -- Normal allocations chain objects on homogeneous collections + + else + pragma Assert (Master.Is_Homogeneous); + + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Address; + end if; + end if; + + -- Non-controlled allocation + else Addr := N_Addr; end if; @@ -315,6 +334,14 @@ package body System.Storage_Pools.Subpools is if Is_Controlled then + -- Destroy the relation pair object - Finalize_Address since it is no + -- longer needed. If the object was chained on a homogeneous master, + -- this call does nothing. This is unconditional destruction since we + -- do not want to drag in additional data to determine the master + -- kind. + + Delete_Finalize_Address (Addr); + -- Account for possible padding space before the header due to a -- larger alignment. @@ -382,6 +409,8 @@ package body System.Storage_Pools.Subpools is N.Prev.Next := N.Next; N.Next.Prev := N.Prev; + N.Prev := null; + N.Next := null; Unlock_Task.all; @@ -405,9 +434,22 @@ package body System.Storage_Pools.Subpools is procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is Curr_Ptr : SP_Node_Ptr; Ex_Occur : Exception_Occurrence; - Next_Ptr : SP_Node_Ptr; 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. @@ -423,11 +465,8 @@ package body System.Storage_Pools.Subpools is Pool.Finalization_Started := True; - -- Skip the dummy head - - Curr_Ptr := Pool.Subpools.Next; - while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop - Next_Ptr := Curr_Ptr.Next; + while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop + Curr_Ptr := Pool.Subpools.Next; -- Perform the following actions: @@ -446,8 +485,6 @@ package body System.Storage_Pools.Subpools is Save_Occurrence (Ex_Occur, Fin_Occur); end if; end; - - Curr_Ptr := Next_Ptr; end loop; -- If the finalization of a particular master failed, reraise the @@ -537,6 +574,150 @@ package body System.Storage_Pools.Subpools is 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 -- ------------------------- |