This patch fixes a race condition in an allocator for a type that needs
finalization. The race condition is unlikely to occur in practice;
it occurs when the allocator is in a Finalize that occurs after the
corresponding master has already started its finalization. Finalize
operations often deallocate memory, but rarely allocate.
However, this fix is also an efficiency improvement, because it reduces the
number of lock/unlock calls.
No test is available; it's too hard to force the race condition to happen.
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-05-02 Bob Duff <d...@adacore.com>
* s-stposu.adb (Allocate_Any_Controlled): Don't lock/unlock twice.
Index: s-stposu.adb
===================================================================
--- s-stposu.adb (revision 235706)
+++ s-stposu.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -123,9 +123,6 @@
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.
@@ -170,25 +167,25 @@
else
-- If the master is missing, then the expansion of the access type
- -- failed to create one. This is a serious error.
+ -- failed to create one. This is a compiler bug.
- if Context_Master = null then
- raise Program_Error
- with "missing master in pool allocation";
+ pragma Assert
+ (Context_Master /= null, "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.
- elsif Context_Subpool /= null then
+ if Context_Subpool /= null then
raise Program_Error
with "subpool not required in pool allocation";
+ end if;
-- 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.
+ -- incorrect end-user code.
- elsif On_Subpool then
+ if On_Subpool then
raise Program_Error
with "pool of access type does not support subpools";
end if;
@@ -209,24 +206,20 @@
-- 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 Allocation_Locked then
+ if Finalization_Started (Master.all) then
raise Program_Error with "allocation after finalization started";
end if;
-- Check whether primitive Finalize_Address is available. If it is
-- not, then either the expansion of the designated type failed or
- -- the expansion of the allocator failed. This is a serious error.
+ -- the expansion of the allocator failed. This is a compiler bug.
- if Fin_Address = null then
- raise Program_Error
- with "primitive Finalize_Address not available";
- end if;
+ pragma Assert
+ (Fin_Address /= null, "primitive Finalize_Address not available");
-- The size must acount for the hidden header preceding the object.
-- Account for possible padding space before the header due to a
@@ -262,7 +255,7 @@
-- Step 4: Attachment
if Is_Controlled then
- Lock_Task.all;
+ -- Note that we already did "Lock_Task.all;" in Step 2 above.
-- 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
@@ -334,6 +327,16 @@
else
Addr := N_Addr;
end if;
+
+ exception
+ when others =>
+ -- If we locked, we want to unlock
+
+ if Is_Controlled then
+ Unlock_Task.all;
+ end if;
+
+ raise;
end Allocate_Any_Controlled;
------------
@@ -384,59 +387,67 @@
if Is_Controlled then
Lock_Task.all;
- -- Destroy the relation pair object - Finalize_Address since it is no
- -- longer needed.
+ begin
+ -- Destroy the relation pair object - Finalize_Address since it is
+ -- no longer needed.
- if Finalize_Address_Table_In_Use then
+ if Finalize_Address_Table_In_Use then
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, deallocation
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation
- Delete_Finalize_Address_Unprotected (Addr);
- end if;
+ Delete_Finalize_Address_Unprotected (Addr);
+ end if;
- -- Account for possible padding space before the header due to a
- -- larger alignment.
+ -- Account for possible padding space before the header due to a
+ -- larger alignment.
- Header_And_Padding := Header_Size_With_Padding (Alignment);
+ Header_And_Padding := Header_Size_With_Padding (Alignment);
- -- N_Addr N_Ptr Addr (from input)
- -- | | |
- -- V V V
- -- +-------+---------------+----------------------+
- -- |Padding| Header | Object |
- -- +-------+---------------+----------------------+
- -- ^ ^ ^
- -- | +- Header_Size -+
- -- | |
- -- +- Header_And_Padding --+
+ -- N_Addr N_Ptr Addr (from input)
+ -- | | |
+ -- V V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
- -- Convert the bits preceding the object into a list header
+ -- Convert the bits preceding the object into a list header
- N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);
+ N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);
- -- Detach the object from the related finalization master. This
- -- action does not need to know the prior context used during
- -- allocation.
+ -- Detach the object from the related finalization master. This
+ -- action does not need to know the prior context used during
+ -- allocation.
- -- Synchronization:
- -- Write - allocation, deallocation, finalization
+ -- Synchronization:
+ -- Write - allocation, deallocation, finalization
- Detach_Unprotected (N_Ptr);
+ Detach_Unprotected (N_Ptr);
- -- Move the address from the object to the beginning of the list
- -- header.
+ -- Move the address from the object to the beginning of the list
+ -- header.
- N_Addr := Addr - Header_And_Padding;
+ N_Addr := Addr - Header_And_Padding;
- -- The size of the deallocated object must include the size of the
- -- hidden list header.
+ -- The size of the deallocated object must include the size of the
+ -- hidden list header.
- N_Size := Storage_Size + Header_And_Padding;
+ N_Size := Storage_Size + Header_And_Padding;
- Unlock_Task.all;
+ Unlock_Task.all;
+ exception
+ when others =>
+ -- If we locked, we want to unlock
+
+ Unlock_Task.all;
+ raise;
+ end;
else
N_Addr := Addr;
N_Size := Storage_Size;
