https://gcc.gnu.org/g:7dc00168e69d1654c0f8dbb605a5ce2f72be8c24
commit r17-1171-g7dc00168e69d1654c0f8dbb605a5ce2f72be8c24 Author: Eric Botcazou <[email protected]> Date: Tue Mar 31 11:48:11 2026 +0200 ada: Implement AI12-0331 Binding Interpretation The Binding Interpretation defines the order of the four steps that occur during the finalization of subpools. The order was previously unspecified but the AI mentions that there was no real leeway, i.e. that there was a unique possible order; however it turns out that GNAT implements another order, which therefore needs to be changed. Moreover GNAT's implementation is unnecessarily convoluted: 1) it uses a circular doubly-linked list with a fake head to implement the subpools, but the subpools have a pointer to the owner of the list, so a simple doubly-linked list is sufficient and 2) it allocates special nodes on the heap to chain the subpools onto the list, which is a bit awkward. gcc/ada/ChangeLog: PR ada/124143 * libgnat/s-spsufi.ads (Finalize_And_Deallocate): Adjust comment. * libgnat/s-spsufi.adb: Remove clause for Ada.Unchecked_Deallocation (Finalize_And_Deallocate): Adjust and implement AI12-0331. * libgnat/s-stposu.ads (Allocate_From_Subpool): Remove ??? comment. (Deallocate_Subpool): Likewise. (SP_Node): Delete. (SP_Node_Ptr): Likewise. (Root_Storage_Pool_With_Subpools): Adjust type of Subpools component (Root_Subpool): Remove Node, add Prev and Next components. (Detach): Adjust signature. (Initialize): Delete. (Initialize_Pool): Likewise. * libgnat/s-stposu.adb (Allocate_Any_Controlled): Adjust. (Attach): Reimplement. (Detach): Likewise. (Finalize_Pool): Loop over a simple doubly linked list. (Initialize): Delete. (Initialize_Pool): Likewise. (Print_Pool): Adjust. (Print_Subpool): Likewise. (Set_Pool_Of_Subpool): Remove obsolete code. Diff: --- gcc/ada/libgnat/s-spsufi.adb | 41 +++----- gcc/ada/libgnat/s-spsufi.ads | 6 +- gcc/ada/libgnat/s-stposu.adb | 218 ++++++++++--------------------------------- gcc/ada/libgnat/s-stposu.ads | 117 +++++++++-------------- 4 files changed, 108 insertions(+), 274 deletions(-) diff --git a/gcc/ada/libgnat/s-spsufi.adb b/gcc/ada/libgnat/s-spsufi.adb index 36bb9f4a0ee6..185d746a4a03 100644 --- a/gcc/ada/libgnat/s-spsufi.adb +++ b/gcc/ada/libgnat/s-spsufi.adb @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Unchecked_Deallocation; - with System.Finalization_Primitives; use System.Finalization_Primitives; package body System.Storage_Pools.Subpools.Finalization is @@ -40,50 +38,35 @@ package body System.Storage_Pools.Subpools.Finalization is ----------------------------- procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is - procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr); - begin -- Do nothing if the subpool was never created or never used. The latter -- case may arise with an array of subpool implementations. - if Subpool = null - or else Subpool.Owner = null - or else Subpool.Node = null - then + if Subpool = null or else Subpool.Owner = null then return; end if; - -- Clean up all controlled objects chained on the subpool's collection + -- Finalize all the objects chained on the subpool's collection Finalize (Subpool.Collection); -- Remove the subpool from its owner's list of subpools - Detach (Subpool.Node); + Detach (Subpool, Subpool.Owner.all); - -- Destroy the associated doubly linked list node which was created in - -- Set_Pool_Of_Subpools. + -- Dispatch to the user-defined implementation of Deallocate_Subpool - Free (Subpool.Node); + Deallocate_Subpool (Subpool.Owner.all, Subpool); - -- Dispatch to the user-defined implementation of Deallocate_Subpool. It - -- is important to first set Subpool.Owner to null, because RM-13.11.5 - -- requires that "The subpool no longer belongs to any pool" BEFORE - -- calling Deallocate_Subpool. The actual dispatching call required is: - -- - -- Deallocate_Subpool(Pool_Of_Subpool(Subpool).all, Subpool); - -- - -- but that can't be taken literally, because Pool_Of_Subpool will - -- return null. + -- The subpool ceases to belong to any pool. Note that ACATS cdb4001 + -- sets Subpool to null on exit from Deallocate_Subpool, but it is also + -- possible for the designated subpool object to be reused and, then, + -- the next call to Set_Pool_Of_Subpool must succeed. - declare - Owner : constant Any_Storage_Pool_With_Subpools_Ptr := Subpool.Owner; - begin + if Subpool /= null then Subpool.Owner := null; - Deallocate_Subpool (Owner.all, Subpool); - end; - - Subpool := null; + Subpool := null; + end if; end Finalize_And_Deallocate; end System.Storage_Pools.Subpools.Finalization; diff --git a/gcc/ada/libgnat/s-spsufi.ads b/gcc/ada/libgnat/s-spsufi.ads index 9e7623c2fab8..7ceada60a8e2 100644 --- a/gcc/ada/libgnat/s-spsufi.ads +++ b/gcc/ada/libgnat/s-spsufi.ads @@ -38,9 +38,9 @@ package System.Storage_Pools.Subpools.Finalization is procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle); -- This routine performs the following actions: - -- 1) Finalize all objects chained on the subpool's collection + -- 1) Finalize all the objects chained on the subpool's collection -- 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 + -- 3) Dispatch to the user-defined implementation of Deallocate_Subpool + -- 4) Set Pool_Of_Subpool (Subpool) and then Subpool to null end System.Storage_Pools.Subpools.Finalization; diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb index c6d941af0a07..76032fe8dd87 100644 --- a/gcc/ada/libgnat/s-stposu.adb +++ b/gcc/ada/libgnat/s-stposu.adb @@ -41,8 +41,10 @@ use System.Storage_Pools.Subpools.Finalization; package body System.Storage_Pools.Subpools is - procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr); - -- Attach a subpool node to a pool + procedure Attach + (Subpool : not null Subpool_Handle; + Pool : in out Root_Storage_Pool_With_Subpools'Class); + -- Attach a subpool to a pool ----------------------------------- -- Adjust_Controlled_Dereference -- @@ -140,13 +142,10 @@ package body System.Storage_Pools.Subpools is Subpool := Named_Subpool; end if; - -- Ensure proper ownership and chaining of the subpool + -- Ensure proper ownership 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; @@ -258,18 +257,23 @@ package body System.Storage_Pools.Subpools is -- Attach -- ------------ - procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is + procedure Attach + (Subpool : not null Subpool_Handle; + Pool : in out Root_Storage_Pool_With_Subpools'Class) + is begin - -- Ensure that the node has not been attached already + -- Ensure that the subpool has not been attached already - pragma Assert (N.Prev = null and then N.Next = null); + pragma Assert (Subpool.Prev = null and then Subpool.Next = null); Lock_Task.all; - L.Next.Prev := N; - N.Next := L.Next; - L.Next := N; - N.Prev := L; + if Pool.Subpools /= null then + Pool.Subpools.Prev := Subpool; + Subpool.Next := Pool.Subpools; + end if; + + Pool.Subpools := Subpool; Unlock_Task.all; @@ -363,18 +367,25 @@ package body System.Storage_Pools.Subpools is -- Detach -- ------------ - procedure Detach (N : not null SP_Node_Ptr) is + procedure Detach + (Subpool : not null Subpool_Handle; + Pool : in out Root_Storage_Pool_With_Subpools'Class) + is begin - -- Ensure that the node is attached to some list + Lock_Task.all; - pragma Assert (N.Next /= null and then N.Prev /= null); + if Subpool.Prev /= null then + Subpool.Prev.Next := Subpool.Next; + else + Pool.Subpools := Subpool.Next; + end if; - Lock_Task.all; + if Subpool.Next /= null then + Subpool.Next.Prev := Subpool.Prev; + end if; - N.Prev.Next := N.Next; - N.Next.Prev := N.Prev; - N.Prev := null; - N.Next := null; + Subpool.Prev := null; + Subpool.Next := null; Unlock_Task.all; @@ -396,22 +407,9 @@ 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; - Handle : Subpool_Handle; 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; + Subpool : Subpool_Handle; -- Start of processing for Finalize_Pool @@ -430,16 +428,12 @@ package body System.Storage_Pools.Subpools is Pool.Finalization_Started := True; - while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop - Curr_Ptr := Pool.Subpools.Next; - - -- Finalize and deallocate the subpool. Beware that the node pointed - -- to by Curr_Ptr will be deallocated so may not be passed as actual - -- in the call, since the formal parameter is In Out. + while Pool.Subpools /= null loop + -- Finalize and deallocate the subpool begin - Handle := Curr_Ptr.Subpool; - Finalize_And_Deallocate (Handle); + Subpool := Pool.Subpools; + Finalize_And_Deallocate (Subpool); exception when Fin_Occur : others => @@ -481,27 +475,6 @@ package body System.Storage_Pools.Subpools is 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 -- --------------------- @@ -519,100 +492,29 @@ package body System.Storage_Pools.Subpools is ---------------- 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 + -- Controller: OK <or> ERROR Put ("Pool : "); Put_Line (Address_Image (Pool'Address)); Put ("Subpools : "); - Put_Line (Address_Image (Pool.Subpools'Address)); + Put_Line (Pool.Subpools'Img); Put ("Fin_Start : "); Put_Line (Pool.Finalization_Started'Img); - Put ("Controlled: "); + Put ("Controller: "); if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then Put_Line ("OK"); else - Put_Line ("NOK (ERROR)"); + Put_Line ("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; ------------------- @@ -630,30 +532,20 @@ package body System.Storage_Pools.Subpools is -- Owner : 0x123456789 -- Collection: 0x123456789 - -- Node : 0x123456789 + -- Prev : 0x123456789 + -- Next : 0x123456789 - Put ("Owner : "); - if Subpool.Owner = null then - Put_Line ("null"); - else - Put_Line (Address_Image (Subpool.Owner'Address)); - end if; + Put ("Owner : "); + Put_Line (Subpool.Owner'Img); Put ("Collection: "); Put_Line (Address_Image (Subpool.Collection'Address)); - Put ("Node : "); - if Subpool.Node = null then - Put ("null"); + Put ("Prev : "); + Put_Line (Subpool.Prev'Img); - if Subpool.Owner = null then - Put_Line (" OK"); - else - Put_Line (" (ERROR)"); - end if; - else - Put_Line (Address_Image (Subpool.Node'Address)); - end if; + Put ("Next : "); + Put_Line (Subpool.Next'Img); end Print_Subpool; ------------------------- @@ -664,8 +556,6 @@ package body System.Storage_Pools.Subpools is (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. @@ -684,15 +574,7 @@ package body System.Storage_Pools.Subpools is 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); + Attach (Subpool, To); end Set_Pool_Of_Subpool; ------------------- diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads index 13d7889471a8..0a1d7e1b4195 100644 --- a/gcc/ada/libgnat/s-stposu.ads +++ b/gcc/ada/libgnat/s-stposu.ads @@ -75,10 +75,9 @@ package System.Storage_Pools.Subpools is Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; Alignment : System.Storage_Elements.Storage_Count; Subpool : not null Subpool_Handle) is abstract; + -- The precondition specified in the RM is illegal: + -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; - -- ??? 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. @@ -99,7 +98,7 @@ package System.Storage_Pools.Subpools is (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??? + -- The precondition specified in the RM is illegal: -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; -- This routine requires implementation. Reclaim the storage a particular @@ -144,9 +143,6 @@ package System.Storage_Pools.Subpools is -- of Ada.Containers.Bounded_Indefinite_Holders. private - -- SP_Nodes are created on the heap, while collection 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; @@ -157,40 +153,12 @@ private 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 : + -- Root_Storage_Pool_With_Subpools internal structure type Root_Storage_Pool_With_Subpools is abstract new Root_Storage_Pool with record - Subpools : aliased SP_Node; + Subpools : Subpool_Handle := null; -- A doubly linked list of subpools Finalization_Started : Boolean := False; @@ -205,32 +173,7 @@ private -- 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 -------->| ------->| ------->| -------> - -- | +--------------------+ +-----+ +-----+ +-----+ - -- | |Finalization_Started|<------ |<------- |<------- |<--- - -- | +--------------------+ +-----+ +-----+ +-----+ - -- +--- Controller.Encl_Pool| | nul | | + | | + | - -- | +--------------------+ +-----+ +--|--+ +--:--+ - -- | : : Dummy | ^ : - -- | : : | | : - -- | Root_Subpool V | - -- | +-------------+ | - -- +-------------------------------- Owner | | - -- Collection nodes +-------------+ | - -- +-----+ +-----+<-- | Collection | - -- <------ |<------ | +-------------+ | - -- +-----+ +-----+ | Node -------+ - -- | ------>| -----> +-------------+ - -- +-----+ +-----+ : : - -- |ctrl | Dummy : : - -- | obj | - -- +-----+ + -- Root_Subpool internal structure type Root_Subpool is abstract tagged limited record Owner : Any_Storage_Pool_With_Subpools_Ptr := null; @@ -239,11 +182,41 @@ private Collection : aliased Finalization_Primitives.Finalization_Collection; -- A 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. + Prev : Subpool_Handle := null; + Next : Subpool_Handle := null; + -- Links for the doubly linked list which contains the subpool end record; + -- The subpool is an abstraction layer that sits on top of a pool and + -- contains links to all controlled objects allocated on this subpool. + -- + -- Pool_With_Subpools + -- +-->+--------------------+ + -- | | Subpools ---------------+ + -- | +--------------------+ | + -- | |Finalization_Started| | + -- | +--------------------+ | + -- +--- Controller.Encl_Pool| | + -- | +--------------------+ V + -- | : : Subpool Subpool + -- | +-------------+ +-------------+ + -- +--------------------------<----- Owner | <----- Owner | + -- +-------------+ +-------------+ + -- +---------------- | Collection | | Collection | + -- | +-------------+ +-------------+ + -- | | Prev | <---- Prev | + -- | | Next ------> | Next ------> + -- V +-------------+ +-------------+ + -- Node Node : : : : + -- +-----+ +-----+ + -- <------ |<------ | + -- +-----+ +-----+ + -- | ------>| -----> + -- +-----+ +-----+ + -- Dummy |ctrl | + -- | obj | + -- +-----+ + procedure Adjust_Controlled_Dereference (Addr : in out System.Address; Storage_Size : in out System.Storage_Elements.Storage_Count; @@ -316,8 +289,10 @@ private -- * Is_Controlled - A flag which determines whether the allocated object -- is controlled. When set to True, the address must be displaced. - procedure Detach (N : not null SP_Node_Ptr); - -- Unhook a subpool node from an arbitrary subpool list + procedure Detach + (Subpool : not null Subpool_Handle; + Pool : in out Root_Storage_Pool_With_Subpools'Class); + -- Detach a subpool from a pool overriding procedure Finalize (Controller : in out Pool_Controller); -- Buffer routine, calls Finalize_Pool @@ -334,12 +309,6 @@ private -- 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
