From: Eric Botcazou <ebotca...@adacore.com>
This changes the implementation of finalization collections from using the
global task lock to using per-collection spinlocks. Spinlocks are a good
fit in this context because they are very cheap and therefore can be taken
with a fine granularity only around the portions of code implementing the
shuffling of pointers required by attachment and detachment actions.
gcc/ada/
* libgnat/s-finpri.ads (Lock_Type): New modular type.
(Collection_Node): Add Enclosing_Collection component.
(Finalization_Collection): Add Lock component.
* libgnat/s-finpri.adb: Add clauses for System.Atomic_Primitives.
(Attach_Object_To_Collection): Lock and unlock the collection.
Save a pointer to the enclosing collection in the node.
(Detach_Object_From_Collection): Lock and unlock the collection.
(Finalize): Likewise.
(Initialize): Initialize the lock.
(Lock_Collection): New procedure.
(Unlock_Collection): Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/libgnat/s-finpri.adb | 79 +++++++++++++++++++++++++++++-------
gcc/ada/libgnat/s-finpri.ads | 12 +++++-
2 files changed, 75 insertions(+), 16 deletions(-)
diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb
index 8026b3fb284..09f2761a5b9 100644
--- a/gcc/ada/libgnat/s-finpri.adb
+++ b/gcc/ada/libgnat/s-finpri.adb
@@ -32,7 +32,8 @@
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
-with System.Soft_Links; use System.Soft_Links;
+with System.Atomic_Primitives; use System.Atomic_Primitives;
+with System.Soft_Links; use System.Soft_Links;
package body System.Finalization_Primitives is
@@ -42,7 +43,21 @@ package body System.Finalization_Primitives is
new Ada.Unchecked_Conversion (Address, Collection_Node_Ptr);
procedure Detach_Node_From_Collection (Node : not null Collection_Node_Ptr);
- -- Removes a collection node from its associated finalization collection
+ -- Remove a collection node from its associated finalization collection.
+ -- Calls to the procedure with a Node that has already been detached have
+ -- no effects.
+
+ procedure Lock_Collection (Collection : in out Finalization_Collection);
+ -- Lock the finalization collection. Upon return, the caller owns the lock
+ -- to the collection and no other call with the same actual parameter will
+ -- return until a corresponding call to Unlock_Collection has been made by
+ -- the caller. This means that it is not possible to call Lock_Collection
+ -- more than once on a collection without a call to Unlock_Collection in
+ -- between.
+
+ procedure Unlock_Collection (Collection : in out Finalization_Collection);
+ -- Unlock the finalization collection, i.e. relinquish ownership of the
+ -- lock to the collection.
---------------------------
-- Add_Offset_To_Address --
@@ -69,7 +84,7 @@ package body System.Finalization_Primitives is
To_Collection_Node_Ptr (Object_Address - Header_Size);
begin
- Lock_Task.all;
+ Lock_Collection (Collection);
-- Do not allow the attachment of controlled objects while the
-- associated collection is being finalized.
@@ -89,22 +104,23 @@ package body System.Finalization_Primitives is
pragma Assert
(Finalize_Address /= null, "primitive Finalize_Address not available");
- Node.Finalize_Address := Finalize_Address;
- Node.Prev := Collection.Head'Unchecked_Access;
- Node.Next := Collection.Head.Next;
+ Node.Enclosing_Collection := Collection'Unrestricted_Access;
+ Node.Finalize_Address := Finalize_Address;
+ Node.Prev := Collection.Head'Unchecked_Access;
+ Node.Next := Collection.Head.Next;
Collection.Head.Next.Prev := Node;
Collection.Head.Next := Node;
- Unlock_Task.all;
+ Unlock_Collection (Collection);
exception
when others =>
- -- Unlock the task in case the attachment failed and reraise the
- -- exception.
+ -- Unlock the collection in case the attachment failed and reraise
+ -- the exception.
- Unlock_Task.all;
+ Unlock_Collection (Collection);
raise;
end Attach_Object_To_Collection;
@@ -180,11 +196,11 @@ package body System.Finalization_Primitives is
To_Collection_Node_Ptr (Object_Address - Header_Size);
begin
- Lock_Task.all;
+ Lock_Collection (Node.Enclosing_Collection.all);
Detach_Node_From_Collection (Node);
- Unlock_Task.all;
+ Unlock_Collection (Node.Enclosing_Collection.all);
end Detach_Object_From_Collection;
--------------
@@ -213,14 +229,14 @@ package body System.Finalization_Primitives is
end Is_Empty_List;
begin
- Lock_Task.all;
+ Lock_Collection (Collection);
-- Synchronization:
-- Read - attachment, finalization
-- Write - finalization
if Collection.Finalization_Started then
- Unlock_Task.all;
+ Unlock_Collection (Collection);
-- Double finalization may occur during the handling of stand-alone
-- libraries or the finalization of a pool with subpools.
@@ -258,6 +274,11 @@ package body System.Finalization_Primitives is
Obj_Addr := Curr_Ptr.all'Address + Header_Size;
+ -- Temporarily release the lock because the call to Finalize_Address
+ -- may ultimately invoke Detach_Object_From_Collection.
+
+ Unlock_Collection (Collection);
+
begin
Curr_Ptr.Finalize_Address (Obj_Addr);
exception
@@ -267,9 +288,13 @@ package body System.Finalization_Primitives is
Save_Occurrence (Exc_Occur, Fin_Occur);
end if;
end;
+
+ -- Retake the lock for the next iteration
+
+ Lock_Collection (Collection);
end loop;
- Unlock_Task.all;
+ Unlock_Collection (Collection);
-- If one of the finalization actions raised an exception, reraise it
@@ -387,8 +412,21 @@ package body System.Finalization_Primitives is
Collection.Head.Prev := Collection.Head'Unchecked_Access;
Collection.Head.Next := Collection.Head'Unchecked_Access;
+
+ Collection.Lock := 0;
end Initialize;
+ ---------------------
+ -- Lock_Collection --
+ ---------------------
+
+ procedure Lock_Collection (Collection : in out Finalization_Collection) is
+ begin
+ while Atomic_Test_And_Set (Collection.Lock'Address, Acquire) loop
+ null;
+ end loop;
+ end Lock_Collection;
+
-------------------------------------
-- Suppress_Object_Finalize_At_End --
-------------------------------------
@@ -398,4 +436,15 @@ package body System.Finalization_Primitives is
Node.Finalize_Address := null;
end Suppress_Object_Finalize_At_End;
+ -----------------------
+ -- Unlock_Collection --
+ -----------------------
+
+ procedure Unlock_Collection (Collection : in out Finalization_Collection) is
+ procedure Lock_Store is new Atomic_Store (Lock_Type);
+
+ begin
+ Lock_Store (Collection.Lock'Address, 0, Release);
+ end Unlock_Collection;
+
end System.Finalization_Primitives;
diff --git a/gcc/ada/libgnat/s-finpri.ads b/gcc/ada/libgnat/s-finpri.ads
index 874a82f5349..4ba13dadec0 100644
--- a/gcc/ada/libgnat/s-finpri.ads
+++ b/gcc/ada/libgnat/s-finpri.ads
@@ -214,13 +214,19 @@ private
-- Collection node type structure
type Collection_Node is record
+ Enclosing_Collection : Finalization_Collection_Ptr := null;
+ -- A pointer to the collection to which the node is attached
+
Finalize_Address : Finalize_Address_Ptr := null;
+ -- A pointer to the Finalize_Address procedure of the object
Prev : Collection_Node_Ptr := null;
Next : Collection_Node_Ptr := null;
- -- Finalization_Collections are managed as a circular doubly-linked list
+ -- Collection nodes are managed as a circular doubly-linked list
end record;
+ type Lock_Type is mod 2**8 with Size => 8;
+
-- Finalization collection type structure
type Finalization_Collection is
@@ -233,6 +239,10 @@ private
-- A flag used to detect allocations which occur during the finalization
-- of a collection. The allocations must raise Program_Error. This may
-- arise in a multitask environment.
+
+ Lock : Lock_Type;
+ pragma Atomic (Lock);
+ -- A spinlock to synchronize concurrent accesses to the collection
end record;
-- This operation is very simple and thus can be performed in line
--
2.43.2
