===================================================================
@@ -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;
---------------
===================================================================
@@ -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;
---------------
===================================================================
@@ -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;
---------------
===================================================================
@@ -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;
===================================================================
@@ -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;
---------------
===================================================================
@@ -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;
---------------
===================================================================
@@ -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;
---------------
===================================================================
@@ -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;
---------------
===================================================================
@@ -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
===================================================================
@@ -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;
---------------
===================================================================
@@ -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 --
---------------
===================================================================
@@ -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;
---------------