This change fixes a defect in the tasking runtime library whereby a task freeing its own Ada Task Control Block would reference it after it had been deallocated, because the deallocation is made with abortion deferred, and Abort_Undefer needs access to the ATCB.
In particular this happens when a foreign thread unregisters using GNAT.Threads.Unregister_Thread. Tested on x86_64-pc-linux-gnu, committed on trunk 2011-09-06 Thomas Quinot <qui...@adacore.com> * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb, s-tpoaal.adb, s-taprop-mingw.adb, s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop.ads, s-taprop-hpux-dce.adb, s-taprop-dummy.adb, s-taprop-posix.adb (ATCB_Allocation): New subpackage of System.Tasking.Primitive_Operations, shared across all targets with full tasking runtime. (ATCB_Allocation.New_ATCB): Moved there (from target specific s-taprop bodies). (ATCB_Allocation.Free_ATCB): New subprogram. Deallocate an ATCB, taking care of establishing a local temporary ATCB if the one being deallocated is Self, to avoid a reference to the freed ATCB in Abort_Undefer.
Index: s-taprop-vxworks.adb =================================================================== --- s-taprop-vxworks.adb (revision 178565) +++ s-taprop-vxworks.adb (working copy) @@ -39,7 +39,6 @@ -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -140,6 +139,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -828,15 +834,6 @@ end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -986,13 +983,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := (T = Self); + Result : int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Result := semDelete (T.Common.LL.L.Mutex); @@ -1008,11 +1000,7 @@ Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Delete; - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-taprop-tru64.adb =================================================================== --- s-taprop-tru64.adb (revision 178565) +++ s-taprop-tru64.adb (working copy) @@ -38,8 +38,6 @@ -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces; with Interfaces.C; @@ -127,6 +125,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -695,15 +700,6 @@ Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -930,13 +926,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; + Result : Interfaces.C.int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Result := pthread_mutex_destroy (T.Common.LL.L'Access); @@ -950,11 +941,7 @@ Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-taprop-vms.adb =================================================================== --- s-taprop-vms.adb (revision 178565) +++ s-taprop-vms.adb (working copy) @@ -39,7 +39,6 @@ -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -114,6 +113,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -680,15 +686,6 @@ Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -839,13 +836,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; + Result : Interfaces.C.int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Result := pthread_mutex_destroy (T.Common.LL.L'Access); @@ -859,11 +851,7 @@ Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-tpoaal.adb =================================================================== --- s-tpoaal.adb (revision 0) +++ s-tpoaal.adb (revision 0) @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.ATCB_ALLOCATION -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +separate (System.Task_Primitives.Operations) +package body ATCB_Allocation is + + --------------- + -- Free_ATCB -- + --------------- + + procedure Free_ATCB (T : Task_Id) is + Tmp : Task_Id := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + + begin + if Is_Self then + declare + Local_ATCB : aliased Ada_Task_Control_Block (0); + -- Create a dummy ATCB and initialize it minimally so that "Free" + -- can still call Self and Defer/Undefer_Abort after Tmp is freed + -- by the underlying memory management library. + + begin + Local_ATCB.Common.LL.Thread := T.Common.LL.Thread; + Local_ATCB.Common.Current_Priority := T.Common.Current_Priority; + + Specific.Set (Local_ATCB'Unchecked_Access); + Free (Tmp); + Specific.Set (null); + end; + + else + Free (Tmp); + end if; + end Free_ATCB; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + +end ATCB_Allocation; Index: s-taprop-mingw.adb =================================================================== --- s-taprop-mingw.adb (revision 178565) +++ s-taprop-mingw.adb (working copy) @@ -38,8 +38,6 @@ -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces.C; with Interfaces.C.Strings; @@ -176,6 +174,13 @@ end Specific; + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -820,15 +825,6 @@ Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -987,14 +983,9 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Self_ID : Task_Id := T; Result : DWORD; Succeeded : BOOL; - Is_Self : constant Boolean := T = Self; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Finalize_Lock (T.Common.LL.L'Access); @@ -1017,11 +1008,7 @@ pragma Assert (Succeeded = Win32.TRUE); end if; - Free (Self_ID); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-taprop-linux.adb =================================================================== --- s-taprop-linux.adb (revision 178565) +++ s-taprop-linux.adb (working copy) @@ -38,8 +38,6 @@ -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces.C; with System.Task_Info; @@ -137,6 +135,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -731,15 +736,6 @@ end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -978,13 +974,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; + Result : Interfaces.C.int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Result := pthread_mutex_destroy (T.Common.LL.L'Access); @@ -999,11 +990,8 @@ end if; SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); - Free (Tmp); - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-taprop-solaris.adb =================================================================== --- s-taprop-solaris.adb (revision 178565) +++ s-taprop-solaris.adb (working copy) @@ -38,8 +38,6 @@ -- Turn off polling, we do not want ATC polling to take place during tasking -- operations. It causes infinite loops and other problems. -with Ada.Unchecked_Deallocation; - with Interfaces.C; with System.Multiprocessors; @@ -226,6 +224,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -868,26 +873,15 @@ procedure Enter_Task (Self_ID : Task_Id) is begin Self_ID.Common.LL.Thread := thr_self; + Self_ID.Common.LL.LWP := lwp_self; - Self_ID.Common.LL.LWP := lwp_self; - Set_Task_Affinity (Self_ID); - Specific.Set (Self_ID); -- We need the above code even if we do direct fetch of Task_Id in Self -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -1032,13 +1026,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; + Result : Interfaces.C.int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin T.Common.LL.Thread := Null_Thread_Id; @@ -1054,11 +1043,7 @@ Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-taprop-irix.adb =================================================================== --- s-taprop-irix.adb (revision 178565) +++ s-taprop-irix.adb (working copy) @@ -39,7 +39,6 @@ -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -127,6 +126,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -699,15 +705,6 @@ end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -901,13 +898,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; + Result : Interfaces.C.int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Result := pthread_mutex_destroy (T.Common.LL.L'Access); @@ -921,11 +913,7 @@ Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-taprop.ads =================================================================== --- s-taprop.ads (revision 178565) +++ s-taprop.ads (working copy) @@ -87,10 +87,25 @@ -- The effects of further calls to operations defined below on the task -- are undefined thereafter. - function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; - pragma Inline (New_ATCB); - -- Allocate a new ATCB with the specified number of entries + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + package ATCB_Allocation is + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id; + pragma Inline (New_ATCB); + -- Allocate a new ATCB with the specified number of entries + + procedure Free_ATCB (T : ST.Task_Id); + pragma Inline (Free_ATCB); + -- Deallocate an ATCB previously allocated by New_ATCB + + end ATCB_Allocation; + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_Id + renames ATCB_Allocation.New_ATCB; + procedure Initialize_TCB (Self_ID : ST.Task_Id; Succeeded : out Boolean); pragma Inline (Initialize_TCB); -- Initialize all fields of the TCB Index: s-taprop-hpux-dce.adb =================================================================== --- s-taprop-hpux-dce.adb (revision 178565) +++ s-taprop-hpux-dce.adb (working copy) @@ -39,7 +39,6 @@ -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -130,6 +129,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -696,15 +702,6 @@ Specific.Set (Self_ID); end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -839,13 +836,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; + Result : Interfaces.C.int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Result := pthread_mutex_destroy (T.Common.LL.L'Access); @@ -859,11 +851,7 @@ Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; --------------- Index: s-taprop-dummy.adb =================================================================== --- s-taprop-dummy.adb (revision 178565) +++ s-taprop-dummy.adb (working copy) @@ -46,6 +46,13 @@ pragma Warnings (Off); -- Turn off warnings since so many unreferenced parameters + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + ---------------- -- Abort_Task -- ---------------- @@ -252,15 +259,6 @@ return 0.0; end Monotonic_Clock; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - --------------- -- Read_Lock -- --------------- Index: s-taprop-posix.adb =================================================================== --- s-taprop-posix.adb (revision 178565) +++ s-taprop-posix.adb (working copy) @@ -45,7 +45,6 @@ -- operations. It causes infinite loops and other problems. with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with Interfaces.C; @@ -144,6 +143,13 @@ package body Specific is separate; -- The body of this package is target specific + ---------------------------------- + -- ATCB allocation/deallocation -- + ---------------------------------- + + package body ATCB_Allocation is separate; + -- The body of this package is shared across several targets + --------------------------------- -- Support for foreign threads -- --------------------------------- @@ -782,15 +788,6 @@ end if; end Enter_Task; - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - ------------------- -- Is_Valid_Task -- ------------------- @@ -1000,13 +997,8 @@ ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; - Is_Self : constant Boolean := T = Self; + Result : Interfaces.C.int; - procedure Free is new - Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - begin if not Single_Lock then Result := pthread_mutex_destroy (T.Common.LL.L'Access); @@ -1020,11 +1012,7 @@ Known_Tasks (T.Known_Tasks_Index) := null; end if; - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; + ATCB_Allocation.Free_ATCB (T); end Finalize_TCB; ---------------