From: Eric Botcazou <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/s-spsufi.adb | 41 ++-----
gcc/ada/libgnat/s-spsufi.ads | 6 +-
gcc/ada/libgnat/s-stposu.adb | 220 ++++++++---------------------------
gcc/ada/libgnat/s-stposu.ads | 117 +++++++------------
4 files changed, 109 insertions(+), 275 deletions(-)
diff --git a/gcc/ada/libgnat/s-spsufi.adb b/gcc/ada/libgnat/s-spsufi.adb
index 36bb9f4a0ee..185d746a4a0 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 9e7623c2fab..7ceada60a8e 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 c6d941af0a0..76032fe8dd8 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
-
- 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;
+ if Subpool.Prev /= null then
+ Subpool.Prev.Next := Subpool.Next;
+ else
+ Pool.Subpools := Subpool.Next;
+ end if;
+
+ if Subpool.Next /= null then
+ Subpool.Next.Prev := Subpool.Prev;
+ end if;
+
+ 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 13d7889471a..0a1d7e1b419 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
--
2.53.0
