===================================================================
@@ -77,18 +77,28 @@
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
begin
Lock_Task.all;
+ Attach_Unprotected (N, L);
+ Unlock_Task.all;
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
+ end Attach;
+
+ ------------------------
+ -- Attach_Unprotected --
+ ------------------------
+
+ procedure Attach_Unprotected
+ (N : not null FM_Node_Ptr;
+ L : not null FM_Node_Ptr)
+ is
+ begin
L.Next.Prev := N;
N.Next := L.Next;
L.Next := N;
N.Prev := L;
+ end Attach_Unprotected;
- Unlock_Task.all;
-
- -- Note: No need to unlock in case of an exception because the above
- -- code can never raise one.
- end Attach;
-
---------------
-- Base_Pool --
---------------
@@ -100,16 +110,14 @@
return Master.Base_Pool;
end Base_Pool;
- -----------------------------
- -- Delete_Finalize_Address --
- -----------------------------
+ -----------------------------------------
+ -- Delete_Finalize_Address_Unprotected --
+ -----------------------------------------
- procedure Delete_Finalize_Address (Obj : System.Address) is
+ procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
begin
- Lock_Task.all;
Finalize_Address_Table.Remove (Obj);
- Unlock_Task.all;
- end Delete_Finalize_Address;
+ end Delete_Finalize_Address_Unprotected;
------------
-- Detach --
@@ -117,20 +125,27 @@
procedure Detach (N : not null FM_Node_Ptr) is
begin
+ Lock_Task.all;
+ Detach_Unprotected (N);
+ Unlock_Task.all;
+
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
+ end Detach;
+
+ ------------------------
+ -- Detach_Unprotected --
+ ------------------------
+
+ procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
+ begin
if N.Prev /= null and then N.Next /= null then
- Lock_Task.all;
-
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
N.Prev := null;
N.Next := null;
-
- Unlock_Task.all;
-
- -- Note: No need to unlock in case of an exception because the above
- -- code can never raise one.
end if;
- end Detach;
+ end Detach_Unprotected;
--------------
-- Finalize --
@@ -158,10 +173,14 @@
-- Start of processing for Finalize
begin
- -- It is possible for multiple tasks to cause the finalization of the
- -- same master. Let only one task finalize the objects.
+ Lock_Task.all;
+ -- Synchronization:
+ -- Read - allocation, finalization
+ -- Write - finalization
+
if Master.Finalization_Started then
+ Unlock_Task.all;
return;
end if;
@@ -170,13 +189,20 @@
-- is explicitly deallocated or the associated access type is about to
-- go out of scope.
+ -- Synchronization:
+ -- Read - allocation, finalization
+ -- Write - finalization
+
Master.Finalization_Started := True;
while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
Curr_Ptr := Master.Objects.Next;
- Detach (Curr_Ptr);
+ -- Synchronization:
+ -- Write - allocation, deallocation, finalization
+ Detach_Unprotected (Curr_Ptr);
+
-- Skip the list header in order to offer proper object layout for
-- finalization.
@@ -185,20 +211,28 @@
-- Retrieve TSS primitive Finalize_Address depending on the master's
-- mode of operation.
+ -- Synchronization:
+ -- Read - allocation, finalization
+ -- Write - outside
+
if Master.Is_Homogeneous then
+
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, outside
+
Cleanup := Master.Finalize_Address;
+
else
- Cleanup := Finalize_Address (Obj_Addr);
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation
+
+ Cleanup := Finalize_Address_Unprotected (Obj_Addr);
end if;
- -- If Finalize_Address is not available, then this is most likely an
- -- error in the expansion of the designated type or the allocator.
-
- pragma Assert (Cleanup /= null);
-
begin
Cleanup (Obj_Addr);
-
exception
when Fin_Occur : others =>
if not Raised then
@@ -210,11 +244,22 @@
-- When the master is a heterogeneous collection, destroy the object
-- - Finalize_Address pair since it is no longer needed.
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - outside
+
if not Master.Is_Homogeneous then
- Delete_Finalize_Address (Obj_Addr);
+
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation, finalization
+
+ Delete_Finalize_Address_Unprotected (Obj_Addr);
end if;
end loop;
+ Unlock_Task.all;
+
-- If the finalization of a particular object failed or Finalize_Address
-- was not set, reraise the exception now.
@@ -234,20 +279,16 @@
return Master.Finalize_Address;
end Finalize_Address;
- ----------------------
- -- Finalize_Address --
- ----------------------
+ ----------------------------------
+ -- Finalize_Address_Unprotected --
+ ----------------------------------
- function Finalize_Address
+ function Finalize_Address_Unprotected
(Obj : System.Address) return Finalize_Address_Ptr
is
- Result : Finalize_Address_Ptr;
begin
- Lock_Task.all;
- Result := Finalize_Address_Table.Get (Obj);
- Unlock_Task.all;
- return Result;
- end Finalize_Address;
+ return Finalize_Address_Table.Get (Obj);
+ end Finalize_Address_Unprotected;
--------------------------
-- Finalization_Started --
@@ -463,36 +504,40 @@
Fin_Addr_Ptr : Finalize_Address_Ptr)
is
begin
- -- TSS primitive Finalize_Address is set at the point of allocation,
- -- either through Allocate_Any_Controlled or through this routine.
- -- Since multiple tasks can allocate on the same finalization master,
- -- access to this attribute must be protected.
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, outside
Lock_Task.all;
+ Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
+ Unlock_Task.all;
+ end Set_Finalize_Address;
+ --------------------------------------
+ -- Set_Finalize_Address_Unprotected --
+ --------------------------------------
+
+ procedure Set_Finalize_Address_Unprotected
+ (Master : in out Finalization_Master;
+ Fin_Addr_Ptr : Finalize_Address_Ptr)
+ is
+ begin
if Master.Finalize_Address = null then
Master.Finalize_Address := Fin_Addr_Ptr;
end if;
+ end Set_Finalize_Address_Unprotected;
- Unlock_Task.all;
- end Set_Finalize_Address;
+ ----------------------------------------------------
+ -- Set_Heterogeneous_Finalize_Address_Unprotected --
+ ----------------------------------------------------
- ----------------------------------------
- -- Set_Heterogeneous_Finalize_Address --
- ----------------------------------------
-
- procedure Set_Heterogeneous_Finalize_Address
+ procedure Set_Heterogeneous_Finalize_Address_Unprotected
(Obj : System.Address;
Fin_Addr_Ptr : Finalize_Address_Ptr)
is
begin
- -- Protected access is required in this case because
- -- Finalize_Address_Table is a global data structure.
-
- Lock_Task.all;
Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
- Unlock_Task.all;
- end Set_Heterogeneous_Finalize_Address;
+ end Set_Heterogeneous_Finalize_Address_Unprotected;
--------------------------
-- Set_Is_Heterogeneous --
@@ -500,7 +545,13 @@
procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
begin
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - outside
+
+ Lock_Task.all;
Master.Is_Homogeneous := False;
+ Unlock_Task.all;
end Set_Is_Heterogeneous;
end System.Finalization_Masters;
===================================================================
@@ -74,13 +74,23 @@
for Finalization_Master_Ptr'Storage_Size use 0;
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
+ -- Compiler interface, do not call from withing the run-time. Prepend a
+ -- node to a specific finalization master.
+
+ procedure Attach_Unprotected
+ (N : not null FM_Node_Ptr;
+ L : not null FM_Node_Ptr);
-- Prepend a node to a specific finalization master
- procedure Delete_Finalize_Address (Obj : System.Address);
+ procedure Delete_Finalize_Address_Unprotected (Obj : System.Address);
-- Destroy the relation pair object - Finalize_Address from the internal
-- hash table.
procedure Detach (N : not null FM_Node_Ptr);
+ -- Compiler interface, do not call from within the run-time. Remove a node
+ -- from an arbitrary finalization master.
+
+ procedure Detach_Unprotected (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
overriding procedure Finalize (Master : in out Finalization_Master);
@@ -93,7 +103,7 @@
-- Return a reference to the TSS primitive Finalize_Address associated with
-- a master.
- function Finalize_Address
+ function Finalize_Address_Unprotected
(Obj : System.Address) return Finalize_Address_Ptr;
-- Retrieve the Finalize_Address primitive associated with a particular
-- object.
@@ -119,9 +129,15 @@
procedure Set_Finalize_Address
(Master : in out Finalization_Master;
Fin_Addr_Ptr : Finalize_Address_Ptr);
+ -- Compiler interface, do not call from within the run-time. Set the clean
+ -- up routine of a finalization master
+
+ procedure Set_Finalize_Address_Unprotected
+ (Master : in out Finalization_Master;
+ Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Set the clean up routine of a finalization master
- procedure Set_Heterogeneous_Finalize_Address
+ procedure Set_Heterogeneous_Finalize_Address_Unprotected
(Obj : System.Address;
Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Add a relation pair object - Finalize_Address to the internal hash
@@ -165,11 +181,9 @@
-- is used only when the master is in homogeneous mode.
Finalization_Started : Boolean := False;
- pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization
-- of a master. The allocations must raise Program_Error. This scenario
- -- may arise in a multitask environment. The flag is atomic because it
- -- is accessed without Lock_Task / Unlock_Task.
+ -- may arise in a multitask environment.
end record;
-- Since RTSfind cannot contain names of the form RE_"+", the following
===================================================================
@@ -109,6 +109,9 @@
N_Size : Storage_Count;
Subpool : Subpool_Handle := null;
+ Allocation_Locked : Boolean;
+ -- This flag stores the state of the associated collection
+
Header_And_Padding : Storage_Offset;
-- This offset includes the size of a FM_Node plus any additional
-- padding due to a larger alignment.
@@ -156,22 +159,22 @@
-- failed to create one. This is a serious error.
if Context_Master = null then
- raise Program_Error with "missing master in pool allocation";
- end if;
+ raise Program_Error
+ with "missing master in pool allocation";
-- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should
-- still be detected.
- if Context_Subpool /= null then
- raise Program_Error with "subpool not required in pool allocation";
- end if;
+ elsif Context_Subpool /= null then
+ raise Program_Error
+ with "subpool not required in pool allocation";
-- If the allocation is intended to be on a subpool, but the access
-- type's pool does not support subpools, then this is the result of
-- erroneous end-user code.
- if On_Subpool then
+ elsif On_Subpool then
raise Program_Error
with "pool of access type does not support subpools";
end if;
@@ -187,10 +190,18 @@
if Is_Controlled then
+ -- Synchronization:
+ -- Read - allocation, finalization
+ -- Write - finalization
+
+ Lock_Task.all;
+ Allocation_Locked := Finalization_Started (Master.all);
+ Unlock_Task.all;
+
-- Do not allow the allocation of controlled objects while the
-- associated master is being finalized.
- if Finalization_Started (Master.all) then
+ if Allocation_Locked then
raise Program_Error with "allocation after finalization started";
end if;
@@ -240,6 +251,7 @@
-- Step 4: Attachment
if Is_Controlled then
+ Lock_Task.all;
-- Map the allocated memory into a FM_Node record. This converts the
-- top of the allocated bits into a list header. If there is padding
@@ -262,8 +274,11 @@
-- Prepend the allocated object to the finalization master
- Attach (N_Ptr, Objects (Master.all));
+ -- Synchronization:
+ -- Write - allocation, deallocation, finalization
+ Attach_Unprotected (N_Ptr, Objects (Master.all));
+
-- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header.
@@ -275,19 +290,34 @@
-- 2) Named access types
-- 3) Most cases of anonymous access types usage
+ -- Synchronization:
+ -- Read - allocation, finalization
+ -- Write - outside
+
if Master.Is_Homogeneous then
- Set_Finalize_Address (Master.all, Fin_Address);
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, outside
+
+ Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
+
-- Heterogeneous masters service the following:
-- 1) Allocations on / Deallocations from subpools
-- 2) Certain cases of anonymous access types usage
else
- Set_Heterogeneous_Finalize_Address (Addr, Fin_Address);
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation
+
+ Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
Finalize_Address_Table_In_Use := True;
end if;
+ Unlock_Task.all;
+
-- Non-controlled allocation
else
@@ -341,12 +371,18 @@
-- Step 1: Detachment
if Is_Controlled then
+ Lock_Task.all;
-- Destroy the relation pair object - Finalize_Address since it is no
-- longer needed.
if Finalize_Address_Table_In_Use then
- Delete_Finalize_Address (Addr);
+
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation
+
+ Delete_Finalize_Address_Unprotected (Addr);
end if;
-- Account for possible padding space before the header due to a
@@ -376,8 +412,11 @@
-- action does not need to know the prior context used during
-- allocation.
- Detach (N_Ptr);
+ -- Synchronization:
+ -- Write - allocation, deallocation, finalization
+ Detach_Unprotected (N_Ptr);
+
-- Move the address from the object to the beginning of the list
-- header.
@@ -388,6 +427,8 @@
N_Size := Storage_Size + Header_And_Padding;
+ Unlock_Task.all;
+
else
N_Addr := Addr;
N_Size := Storage_Size;