-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- operations. It causes infinite loops and other problems.
with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
with Interfaces.C;
with System.Tasking.Debug;
with System.Interrupt_Management;
+with System.OS_Constants;
with System.OS_Primitives;
with System.Task_Info;
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking.Debug;
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
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 --
---------------------------------
function To_Address is
new Ada.Unchecked_Conversion (Task_Id, System.Address);
+ function GNAT_pthread_condattr_setup
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C,
+ GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+
-------------------
-- Abort_Handler --
-------------------
-- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
-- need to send the Abort signal to a task.
- if ZCX_By_Default and then GCC_ZCX_Support then
+ if ZCX_By_Default then
return;
end if;
pragma Assert (Result = 0);
end if;
- Result := pthread_mutex_init (L, Attributes'Access);
+ Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = ENOMEM then
procedure Finalize_Lock (L : not null access Lock) is
Result : Interfaces.C.int;
begin
- Result := pthread_mutex_destroy (L);
+ Result := pthread_mutex_destroy (L.WO'Access);
pragma Assert (Result = 0);
end Finalize_Lock;
Result : Interfaces.C.int;
begin
- Result := pthread_mutex_lock (L);
+ Result := pthread_mutex_lock (L.WO'Access);
-- Assume that the cause of EINVAL is a priority ceiling violation
procedure Unlock (L : not null access Lock) is
Result : Interfaces.C.int;
begin
- Result := pthread_mutex_unlock (L);
+ Result := pthread_mutex_unlock (L.WO'Access);
pragma Assert (Result = 0);
end Unlock;
Result : Interfaces.C.int;
begin
Result := clock_gettime
- (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
+ (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
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 --
-------------------
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
+ Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
Result :=
pthread_cond_init
(Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
+ -- Note: the use of Unrestricted_Access in the following call is needed
+ -- because otherwise we have an error of getting a access-to-volatile
+ -- value which points to a non-volatile object. But in this case it is
+ -- safe to do this, since we know we have no problems with aliasing and
+ -- Unrestricted_Access bypasses this check.
+
Result := pthread_create
- (T.Common.LL.Thread'Access,
+ (T.Common.LL.Thread'Unrestricted_Access,
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
------------------
procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
- Tmp : Task_Id := T;
- Is_Self : constant Boolean := T = Self;
-
- procedure Free is new
- Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Result : Interfaces.C.int;
begin
if not Single_Lock then
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;
---------------
Result := pthread_mutex_destroy (S.L'Access);
pragma Assert (Result = 0);
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
+ -- Storage_Error is propagated as intended if the allocation of the
+ -- underlying OS entities fails.
+
+ raise Storage_Error;
+
+ else
+ Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
+ pragma Assert (Result = 0);
end if;
Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
Result := pthread_mutex_destroy (S.L'Access);
pragma Assert (Result = 0);
- if Result = ENOMEM then
- Result := pthread_condattr_destroy (Cond_Attr'Access);
- pragma Assert (Result = 0);
- raise Storage_Error;
- end if;
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
+ -- Storage_Error is propagated as intended if the allocation of the
+ -- underlying OS entities fails.
+
+ raise Storage_Error;
end if;
Result := pthread_condattr_destroy (Cond_Attr'Access);
end if;
end Initialize;
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ pragma Unreferenced (T);
+
+ begin
+ -- Setting task affinity is not supported by the underlying system
+
+ null;
+ end Set_Task_Affinity;
+
end System.Task_Primitives.Operations;
OSDN Git Service
