ada: Implement per-finalization-collection spinlocks

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.

2 files changed, 75 insertions, 16 deletions

diff --git a/gcc/ada/libgnat/s-finpri.adb b/gcc/ada/libgnat/s-finpri.adb
index 8026b3f..09f2761 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 874a82f..4ba13da 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