This patch adds task synchronization code to the mechanism which sets TSS primitive Finalize_Address at run time. The following test should compile and execute quietly.
------------- -- Sources -- ------------- -- main.adb: with Ada.Finalization; use Ada.Finalization; with Ada.Text_IO; use Ada.Text_IO; procedure Main is Max_Tasks : constant Natural := 200; Expected : constant Natural := Max_Tasks / 2; Even_Count : Natural := 0; Odd_Count : Natural := 0; begin declare type Even_Tracker is new Controlled with null record; procedure Finalize (Obj : in out Even_Tracker); procedure Finalize (Obj : in out Even_Tracker) is begin Even_Count := Even_Count + 1; end Finalize; type Odd_Tracker is new Controlled with null record; procedure Finalize (Obj : in out Odd_Tracker); procedure Finalize (Obj : in out Odd_Tracker) is begin Odd_Count := Odd_Count + 1; end Finalize; type Root is tagged null record; subtype Any_Root is Root'Class; type Any_Root_Ptr is access all Any_Root; type Even_Container is new Root with record Tracker : Even_Tracker; end record; type Odd_Container is new Root with record Tracker : Odd_Tracker; end record; task type Allocator is entry Create (Even_Kind : Boolean); end Allocator; type Allocator_Array is array (1 .. Max_Tasks) of Allocator; task body Allocator is begin select accept Create (Even_Kind : Boolean) do declare Temp : Any_Root_Ptr; begin if Even_Kind then Temp := Any_Root_Ptr'(new Even_Container); else Temp := Any_Root_Ptr'(new Odd_Container); end if; end; end Create; or terminate; end select; end Allocator; Allocators : Allocator_Array; begin for Index in 1 .. Max_Tasks loop Allocators (Index).Create (Index mod 2 = 0); end loop; end; if Even_Count /= Expected then Put_Line ("ERROR: even count is off"); Put_Line (" got:" & Even_Count'Img); Put_Line (" exp:" & Expected'Img); end if; if Odd_Count /= Expected then Put_Line ("ERROR: odd count is off"); Put_Line (" got:" & Odd_Count'Img); Put_Line (" exp:" & Expected'Img); end if; end Main; ------------------------------- -- Compilation and execution -- ------------------------------- gnatmake -q -gnat05 main.adb main Tested on x86_64-pc-linux-gnu, committed on trunk 2011-09-05 Hristian Kirtchev <kirtc...@adacore.com> * s-finmas.adb (Set_Finalize_Address): Explain the reason for the synchronization. Move the test for null from s-stposu.Allocate_Any_Controlled to this routine since the check needs to be protected too. (Set_Heterogeneous_Finalize_Address): Explain the reason for the synchronization code. * s-finmas.ads (Set_Heterogeneous_Finalize_Address): Add comment explaining the context in which this routine is used. * s-stposu.adb (Allocate_Any_Controlled): Move the test for null to s-finmas.Set_Finalize_Address.
Index: s-stposu.adb =================================================================== --- s-stposu.adb (revision 178550) +++ s-stposu.adb (working copy) @@ -276,9 +276,7 @@ -- 3) Most cases of anonymous access types usage if Master.Is_Homogeneous then - if Finalize_Address (Master.all) = null then - Set_Finalize_Address (Master.all, Fin_Address); - end if; + Set_Finalize_Address (Master.all, Fin_Address); -- Heterogeneous masters service the following: Index: s-finmas.adb =================================================================== --- s-finmas.adb (revision 178550) +++ s-finmas.adb (working copy) @@ -463,8 +463,17 @@ 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. + Lock_Task.all; - Master.Finalize_Address := Fin_Addr_Ptr; + + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Addr_Ptr; + end if; + Unlock_Task.all; end Set_Finalize_Address; @@ -477,6 +486,9 @@ 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; Index: s-finmas.ads =================================================================== --- s-finmas.ads (revision 178550) +++ s-finmas.ads (working copy) @@ -124,7 +124,10 @@ procedure Set_Heterogeneous_Finalize_Address (Obj : System.Address; Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Add a relation pair object - Finalize_Address to the internal hash table + -- Add a relation pair object - Finalize_Address to the internal hash + -- table. This is done in the context of allocation on a heterogeneous + -- finalization master where a single master services multiple anonymous + -- access-to-controlled types. procedure Set_Is_Heterogeneous (Master : in out Finalization_Master); -- Mark the master as being a heterogeneous collection of objects