From 14f0f659acfb490fc37e1a9de8f19c4759845337 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 29 Aug 2011 16:29:25 +0200 Subject: [PATCH] [multiple changes] 2011-08-29 Johannes Kanig * debug.adb: Add comments. 2011-08-29 Hristian Kirtchev * impunit.adb, s-stposu.adb, s-stposu.ads, exp_ch4.adb, s-finmas.adb, s-finmas.ads: Redo previous change. From-SVN: r178247 --- gcc/ada/ChangeLog | 9 +- gcc/ada/debug.adb | 5 +- gcc/ada/exp_ch4.adb | 2 + gcc/ada/impunit.adb | 2 - gcc/ada/s-finmas.adb | 199 +++++++++++++++++++++++++++++++------ gcc/ada/s-finmas.ads | 154 +++++++++++++++++++---------- gcc/ada/s-stposu.adb | 229 +++++++++++++++++++++++++++++++++++++++---- gcc/ada/s-stposu.ads | 11 ++- 8 files changed, 501 insertions(+), 110 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b89a0f81a37..00c9e10909d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2011-08-29 Johannes Kanig + + * debug.adb: Add comments. + 2011-08-29 Thomas Quinot * a-except.adb, a-except-2005.adb: Minor comment rewording and @@ -118,11 +122,6 @@ * exp_ch5.adb (Expand_Iterator_Loop): Handle properly a loop over a container of a derived type. -2011-08-29 Hristian Kirtchev - - * impunit.adb, s-stposu.adb, s-stposu.ads, exp_ch4.adb, s-finmas.adb, - s-finmas.ads: Revert previous change. - 2011-08-29 Ed Schonberg * a-cidlli.adb, a-cidlli.ads, a-cihama.adb, a-cihama.ads, diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index da34d8a4437..6f9a7d68d49 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -128,7 +128,7 @@ package body Debug is -- d.H Standard package only mode for gnat2why -- d.I SCIL generation mode -- d.J Disable parallel SCIL generation mode - -- d.K + -- d.K Alfa detection only mode for gnat2why -- d.L Depend on back end for limited types in conditional expressions -- d.M -- d.N @@ -600,6 +600,9 @@ package body Debug is -- done in parallel to speed processing. This switch disables this -- behavior. + -- d.K Alfa detection only mode for gnat2why. In this mode, gnat2why + -- will only generate the .alfa file, but no Why code. + -- d.L Normally the front end generates special expansion for conditional -- expressions of a limited type. This debug flag removes this special -- case expansion, leaving it up to the back end to handle conditional diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 8ac78ac1f5e..4824df02583 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -1137,6 +1137,8 @@ package body Exp_Ch4 is Rewrite (Exp, New_Copy (Expression (Exp))); end if; else + Build_Allocate_Deallocate_Proc (N, True); + -- If we have: -- type A is access T1; -- X : A := new T2'(...); diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index ea636fe8b0a..9aa86d523f6 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -346,7 +346,6 @@ package body Impunit is "s-addima", -- System.Address_Image "s-assert", -- System.Assertions - "s-finmas", -- System.Finalization_Masters "s-memory", -- System.Memory "s-parint", -- System.Partition_Interface "s-pooglo", -- System.Pool_Global @@ -529,7 +528,6 @@ package body Impunit is -- GNAT Defined Additions to Ada 20012 -- ----------------------------------------- - "s-spsufi", -- System.Storage_Pools.Subpools.Finalization "a-cofove", -- Ada.Containers.Formal_Vectors "a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists "a-cforse", -- Ada.Containers.Formal_Ordered_Sets diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb index 857db696b00..72b87dfe462 100644 --- a/gcc/ada/s-finmas.adb +++ b/gcc/ada/s-finmas.adb @@ -31,12 +31,32 @@ with Ada.Exceptions; use Ada.Exceptions; with System.Address_Image; +with System.HTable; use System.HTable; with System.IO; use System.IO; with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; package body System.Finalization_Masters is + -- Finalize_Address hash table types. In general, masters are homogeneous + -- collections of controlled objects. Rare cases such as allocations on a + -- subpool require heterogeneous masters. The following table provides a + -- relation between object address and its Finalize_Address routine. + + type Header_Num is range 0 .. 127; + + function Hash (Key : System.Address) return Header_Num; + + -- Address --> Finalize_Address_Ptr + + package Finalize_Address_Table is new Simple_HTable + (Header_Num => Header_Num, + Element => Finalize_Address_Ptr, + No_Element => null, + Key => System.Address, + Hash => Hash, + Equal => "="); + --------------------------- -- Add_Offset_To_Address -- --------------------------- @@ -79,6 +99,17 @@ package body System.Finalization_Masters is return Master.Base_Pool; end Base_Pool; + ----------------------------- + -- Delete_Finalize_Address -- + ----------------------------- + + procedure Delete_Finalize_Address (Obj : System.Address) is + begin + Lock_Task.all; + Finalize_Address_Table.Remove (Obj); + Unlock_Task.all; + end Delete_Finalize_Address; + ------------ -- Detach -- ------------ @@ -94,10 +125,10 @@ package body System.Finalization_Masters is N.Next := null; Unlock_Task.all; - end if; - -- Note: No need to unlock in case of an exception because the above - -- code can never raise one. + -- Note: No need to unlock in case of an exception because the above + -- code can never raise one. + end if; end Detach; -------------- @@ -105,6 +136,7 @@ package body System.Finalization_Masters is -------------- overriding procedure Finalize (Master : in out Finalization_Master) is + Cleanup : Finalize_Address_Ptr; Curr_Ptr : FM_Node_Ptr; Ex_Occur : Exception_Occurrence; Obj_Addr : Address; @@ -144,23 +176,41 @@ package body System.Finalization_Masters is Detach (Curr_Ptr); - if Master.Finalize_Address /= null then + -- Skip the list header in order to offer proper object layout for + -- finalization. - -- Skip the list header in order to offer proper object layout for - -- finalization and call Finalize_Address. + Obj_Addr := Curr_Ptr.all'Address + Header_Offset; - Obj_Addr := Curr_Ptr.all'Address + Header_Offset; + -- Retrieve TSS primitive Finalize_Address depending on the master's + -- mode of operation. - begin - Master.Finalize_Address (Obj_Addr); + if Master.Is_Homogeneous then + Cleanup := Master.Finalize_Address; + else + Cleanup := Finalize_Address (Obj_Addr); + end if; - exception - when Fin_Occur : others => - if not Raised then - Raised := True; - Save_Occurrence (Ex_Occur, Fin_Occur); - end if; - end; + -- If Finalize_Address is not available, then this is most likely an + -- error in the expansion of the designated type or the allocator. + + pragma Assert (Cleanup /= null); + + begin + Cleanup (Obj_Addr); + + exception + when Fin_Occur : others => + if not Raised then + Raised := True; + Save_Occurrence (Ex_Occur, Fin_Occur); + end if; + end; + + -- When the master is a heterogeneous collection, destroy the object + -- - Finalize_Address pair since it is no longer needed. + + if not Master.Is_Homogeneous then + Delete_Finalize_Address (Obj_Addr); end if; end loop; @@ -172,6 +222,56 @@ package body System.Finalization_Masters is end if; end Finalize; + ---------------------- + -- Finalize_Address -- + ---------------------- + + function Finalize_Address + (Master : Finalization_Master) return Finalize_Address_Ptr + is + begin + return Master.Finalize_Address; + end Finalize_Address; + + ---------------------- + -- Finalize_Address -- + ---------------------- + + function Finalize_Address + (Obj : System.Address) return Finalize_Address_Ptr + is + Result : Finalize_Address_Ptr; + + begin + Lock_Task.all; + Result := Finalize_Address_Table.Get (Obj); + Unlock_Task.all; + + return Result; + end Finalize_Address; + + -------------------------- + -- Finalization_Started -- + -------------------------- + + function Finalization_Started + (Master : Finalization_Master) return Boolean + is + begin + return Master.Finalization_Started; + end Finalization_Started; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : System.Address) return Header_Num is + begin + return + Header_Num + (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length)); + end Hash; + ----------------- -- Header_Size -- ----------------- @@ -202,11 +302,29 @@ package body System.Finalization_Masters is Master.Objects.Prev := Master.Objects'Unchecked_Access; end Initialize; - -------- - -- pm -- - -------- + -------------------- + -- Is_Homogeneous -- + -------------------- - procedure pm (Master : Finalization_Master) is + function Is_Homogeneous (Master : Finalization_Master) return Boolean is + begin + return Master.Is_Homogeneous; + end Is_Homogeneous; + + ------------- + -- Objects -- + ------------- + + function Objects (Master : Finalization_Master) return FM_Node_Ptr is + begin + return Master.Objects'Unrestricted_Access; + end Objects; + + ------------------ + -- Print_Master -- + ------------------ + + procedure Print_Master (Master : Finalization_Master) is Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; Head_Seen : Boolean := False; N_Ptr : FM_Node_Ptr; @@ -215,6 +333,7 @@ package body System.Finalization_Masters is -- Output the basic contents of a master -- Master : 0x123456789 + -- Is_Hmgen : TURE FALSE -- Base_Pool: null 0x123456789 -- Fin_Addr : null 0x123456789 -- Fin_Start: TRUE FALSE @@ -222,16 +341,17 @@ package body System.Finalization_Masters is Put ("Master : "); Put_Line (Address_Image (Master'Address)); - Put ("Base_Pool: "); + Put ("Is_Hmgen : "); + Put_Line (Master.Is_Homogeneous'Img); + Put ("Base_Pool: "); if Master.Base_Pool = null then - Put_Line (" null"); + Put_Line ("null"); else Put_Line (Address_Image (Master.Base_Pool'Address)); end if; Put ("Fin_Addr : "); - if Master.Finalize_Address = null then Put_Line ("null"); else @@ -255,17 +375,17 @@ package body System.Finalization_Masters is -- Header - the address of the list header -- Prev - the address of the list header which the current element - -- - points back to + -- points back to -- Next - the address of the list header which the current element - -- - points to + -- points to -- (dummy head) - present if dummy head N_Ptr := Head; - while N_Ptr /= null loop -- Should never be null; we being defensive + while N_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. + -- second time. if N_Ptr = Head then exit when Head_Seen; @@ -321,7 +441,7 @@ package body System.Finalization_Masters is N_Ptr := N_Ptr.Next; end loop; - end pm; + end Print_Master; ------------------- -- Set_Base_Pool -- @@ -347,4 +467,27 @@ package body System.Finalization_Masters is Master.Finalize_Address := Fin_Addr_Ptr; end Set_Finalize_Address; + -------------------------- + -- Set_Finalize_Address -- + -------------------------- + + procedure Set_Finalize_Address + (Obj : System.Address; + Fin_Addr_Ptr : Finalize_Address_Ptr) + is + begin + Lock_Task.all; + Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); + Unlock_Task.all; + end Set_Finalize_Address; + + -------------------------- + -- Set_Is_Heterogeneous -- + -------------------------- + + procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is + begin + Master.Is_Homogeneous := False; + end Set_Is_Heterogeneous; + end System.Finalization_Masters; diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads index 87a607678bc..0ffc78af2d0 100644 --- a/gcc/ada/s-finmas.ads +++ b/gcc/ada/s-finmas.ads @@ -30,15 +30,13 @@ ------------------------------------------------------------------------------ with Ada.Finalization; -with Ada.Unchecked_Conversion; - with System.Storage_Elements; with System.Storage_Pools; pragma Compiler_Unit; package System.Finalization_Masters is - pragma Preelaborate (System.Finalization_Masters); + pragma Preelaborate; -- A reference to primitive Finalize_Address. The expander generates an -- implementation of this procedure for each controlled and class-wide @@ -48,17 +46,11 @@ package System.Finalization_Masters is type Finalize_Address_Ptr is access procedure (Obj : System.Address); - -- Heterogeneous collection type structure. The implementation allows for - -- finalizable objects of different base types to be serviced by the same - -- master. + -- Heterogeneous collection type structure - type FM_Node; + type FM_Node is private; type FM_Node_Ptr is access all FM_Node; - - type FM_Node is record - Prev : FM_Node_Ptr := null; - Next : FM_Node_Ptr := null; - end record; + pragma No_Strict_Aliasing (FM_Node_Ptr); -- A reference to any derivation from Root_Storage_Pool. Since this type -- may not be used to allocate objects, its storage size is zero. @@ -69,50 +61,24 @@ package System.Finalization_Masters is -- Finalization master type structure. A unique master is associated with -- each access-to-controlled or access-to-class-wide type. Masters also act - -- as components of subpools. + -- as components of subpools. By default, a master contains objects of the + -- same designated type but it may also accomodate heterogeneous objects. type Finalization_Master is - new Ada.Finalization.Limited_Controlled with - record - Base_Pool : Any_Storage_Pool_Ptr := null; - -- A reference to the pool which this finalization master services. This - -- field is used in conjunction with the build-in-place machinery. + new Ada.Finalization.Limited_Controlled with private; - Objects : aliased FM_Node; - -- A doubly linked list which contains the headers of all controlled - -- objects allocated in a [sub]pool. - - Finalize_Address : Finalize_Address_Ptr := null; - -- A reference to the routine reponsible for object finalization - - Finalization_Started : Boolean := False; - pragma Atomic (Finalization_Started); - -- A flag used to detect allocations which occur during the finalization - -- of a master. The allocations must raise Program_Error. This scenario - -- may arise in a multitask environment. The flag is atomic because it - -- is accessed without Lock_Task / Unlock_Task. - end record; + -- A reference to a finalization master. Since this type may not be used + -- to allocate objects, its storage size is zero. type Finalization_Master_Ptr is access all Finalization_Master; for Finalization_Master_Ptr'Storage_Size use 0; - -- Since RTSfind cannot contain names of the form RE_"+", the following - -- routine serves as a wrapper around System.Storage_Elements."+". - - function Add_Offset_To_Address - (Addr : System.Address; - Offset : System.Storage_Elements.Storage_Offset) return System.Address; - - function Address_To_FM_Node_Ptr is - new Ada.Unchecked_Conversion (Address, FM_Node_Ptr); - procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr); -- Prepend a node to a specific finalization master - function Base_Pool - (Master : Finalization_Master) return Any_Storage_Pool_Ptr; - -- Return a reference to the underlying storage pool on which the master - -- operates. + procedure Delete_Finalize_Address (Obj : System.Address); + -- Destroy the relation pair object - Finalize_Address from the internal + -- hash table. procedure Detach (N : not null FM_Node_Ptr); -- Remove a node from an arbitrary finalization master @@ -122,26 +88,106 @@ package System.Finalization_Masters is -- the list of allocated controlled objects, finalizing each one by calling -- its specific Finalize_Address. In the end, deallocate the dummy head. + function Finalize_Address + (Master : Finalization_Master) return Finalize_Address_Ptr; + -- Return a reference to the TSS primitive Finalize_Address associated with + -- a master. + + function Finalize_Address + (Obj : System.Address) return Finalize_Address_Ptr; + -- Retrieve the Finalize_Address primitive associated with a particular + -- object. + + function Finalization_Started (Master : Finalization_Master) return Boolean; + -- Return the finalization status of a master + function Header_Offset return System.Storage_Elements.Storage_Offset; -- Return the size of type FM_Node as Storage_Offset function Header_Size return System.Storage_Elements.Storage_Count; -- Return the size of type FM_Node as Storage_Count + function Is_Homogeneous (Master : Finalization_Master) return Boolean; + -- Return the behavior flag of a master + + function Objects (Master : Finalization_Master) return FM_Node_Ptr; + -- Return the header of the doubly-linked list of controlled objects + + procedure Print_Master (Master : Finalization_Master); + -- Debug routine, outputs the contents of a master + + procedure Set_Finalize_Address + (Master : in out Finalization_Master; + Fin_Addr_Ptr : Finalize_Address_Ptr); + -- Set the clean up routine of a finalization master. Note: this routine + -- must precede the one below since RTSfind needs to match this one. + + procedure Set_Finalize_Address + (Obj : System.Address; + Fin_Addr_Ptr : Finalize_Address_Ptr); + -- Add a relation pair object - Finalize_Address to the internal hash table + + procedure Set_Is_Heterogeneous (Master : in out Finalization_Master); + -- Mark the master as being a heterogeneous collection of objects + +private + -- Heterogeneous collection type structure + + type FM_Node is record + Prev : FM_Node_Ptr := null; + Next : FM_Node_Ptr := null; + end record; + + -- Finalization master type structure. A unique master is associated with + -- each access-to-controlled or access-to-class-wide type. Masters also act + -- as components of subpools. By default, a master contains objects of the + -- same designated type but it may also accomodate heterogeneous objects. + + type Finalization_Master is + new Ada.Finalization.Limited_Controlled with + record + Is_Homogeneous : Boolean := True; + -- A flag which controls the behavior of the master. A value of False + -- denotes a heterogeneous collection. + + Base_Pool : Any_Storage_Pool_Ptr := null; + -- A reference to the pool which this finalization master services. This + -- field is used in conjunction with the build-in-place machinery. + + Objects : aliased FM_Node; + -- A doubly linked list which contains the headers of all controlled + -- objects allocated in a [sub]pool. + + Finalize_Address : Finalize_Address_Ptr := null; + -- A reference to the routine reponsible for object finalization. This + -- is used only when the master is in homogeneous mode. + + Finalization_Started : Boolean := False; + pragma Atomic (Finalization_Started); + -- A flag used to detect allocations which occur during the finalization + -- of a master. The allocations must raise Program_Error. This scenario + -- may arise in a multitask environment. The flag is atomic because it + -- is accessed without Lock_Task / Unlock_Task. + end record; + + -- Since RTSfind cannot contain names of the form RE_"+", the following + -- routine serves as a wrapper around System.Storage_Elements."+". + + function Add_Offset_To_Address + (Addr : System.Address; + Offset : System.Storage_Elements.Storage_Offset) return System.Address; + + function Base_Pool + (Master : Finalization_Master) return Any_Storage_Pool_Ptr; + -- Return a reference to the underlying storage pool on which the master + -- operates. + overriding procedure Initialize (Master : in out Finalization_Master); -- Initialize the dummy head of a finalization master - procedure pm (Master : Finalization_Master); - -- Debug routine, outputs the contents of a master - procedure Set_Base_Pool (Master : in out Finalization_Master; Pool_Ptr : Any_Storage_Pool_Ptr); -- Set the underlying pool of a finalization master - procedure Set_Finalize_Address - (Master : in out Finalization_Master; - Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Set the clean up routine of a finalization master - end System.Finalization_Masters; diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb index bf3a87e662f..2b4e7fc4044 100644 --- a/gcc/ada/s-stposu.adb +++ b/gcc/ada/s-stposu.adb @@ -30,14 +30,24 @@ ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; +with Ada.Unchecked_Conversion; 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; package body System.Storage_Pools.Subpools is + Finalize_Address_Table_In_Use : Boolean := False; + -- This flag should be set only when a successfull 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 @@ -169,7 +179,7 @@ package body System.Storage_Pools.Subpools is Master := Context_Master; end if; - -- Step 2: Master and Finalize_Address-related runtime checks and size + -- Step 2: Master, Finalize_Address-related runtime checks and size -- calculations. -- Allocation of a descendant from [Limited_]Controlled, a class-wide @@ -180,7 +190,7 @@ package body System.Storage_Pools.Subpools is -- Do not allow the allocation of controlled objects while the -- associated master is being finalized. - if Master.Finalization_Started then + if Finalization_Started (Master.all) then raise Program_Error with "allocation after finalization started"; end if; @@ -248,21 +258,40 @@ 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; + Attach (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; + -- 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); + Finalize_Address_Table_In_Use := True; + + -- Normal allocations chain objects on homogeneous collections + + else + pragma Assert (Master.Is_Homogeneous); + + if Finalize_Address (Master.all) = null then + Set_Finalize_Address (Master.all, Fin_Address); + end if; + end if; + + -- Non-controlled allocation + else Addr := N_Addr; end if; @@ -315,6 +344,13 @@ 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 Finalize_Address_Table_In_Use then + Delete_Finalize_Address (Addr); + end if; + -- Account for possible padding space before the header due to a -- larger alignment. @@ -382,6 +418,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 +443,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 +474,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 +494,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 +583,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 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 -- ------------------------- @@ -574,6 +764,11 @@ package body System.Storage_Pools.Subpools is Subpool.Node := N_Ptr; Attach (N_Ptr, Pool.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; diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads index bd268186926..0c5bd218515 100644 --- a/gcc/ada/s-stposu.ads +++ b/gcc/ada/s-stposu.ads @@ -34,12 +34,11 @@ ------------------------------------------------------------------------------ with Ada.Finalization; - with System.Finalization_Masters; with System.Storage_Elements; package System.Storage_Pools.Subpools is - pragma Preelaborate (System.Storage_Pools.Subpools); + pragma Preelaborate; type Root_Storage_Pool_With_Subpools is abstract new Root_Storage_Pool with private; @@ -242,7 +241,7 @@ private -- A reference to the master pool_with_subpools Master : aliased System.Finalization_Masters.Finalization_Master; - -- A collection of controlled objects + -- A heterogeneous collection of controlled objects Node : SP_Node_Ptr := null; -- A link to the doubly linked list node which contains the subpool. @@ -336,4 +335,10 @@ private 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;