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
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 --
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.
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;
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;
--------------
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.
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
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
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 --
-------------------------------------
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;
-- 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
-- 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
projects / thirdparty / gcc.git / commitdiff
