-- 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;
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
- -- The following are effectively constants, but they need to be initialized
- -- by calling a pthread_ function.
-
- Mutex_Attr : aliased pthread_mutexattr_t;
- Cond_Attr : aliased pthread_condattr_t;
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads)
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 --
---------------------------------
is
pragma Unreferenced (Prio);
- Result : Interfaces.C.int;
-
begin
- Result := pthread_mutex_init (L, Mutex_Attr'Access);
+ if Locking_Policy = 'R' then
+ declare
+ RWlock_Attr : aliased pthread_rwlockattr_t;
+ Result : Interfaces.C.int;
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ begin
+ -- Set the rwlock to prefer writer to avoid writers starvation
- if Result = ENOMEM then
- raise Storage_Error with "Failed to allocate a lock";
+ Result := pthread_rwlockattr_init (RWlock_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result := pthread_rwlockattr_setkind_np
+ (RWlock_Attr'Access,
+ PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP);
+ pragma Assert (Result = 0);
+
+ Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end;
+
+ else
+ declare
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_init (L.WO'Access, null);
+
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
+ end;
end if;
end Initialize_Lock;
Result : Interfaces.C.int;
begin
- Result := pthread_mutex_init (L, Mutex_Attr'Access);
+ Result := pthread_mutex_init (L, null);
pragma Assert (Result = 0 or else Result = ENOMEM);
procedure Finalize_Lock (L : not null access Lock) is
Result : Interfaces.C.int;
begin
- Result := pthread_mutex_destroy (L);
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_destroy (L.RW'Access);
+ else
+ Result := pthread_mutex_destroy (L.WO'Access);
+ end if;
pragma Assert (Result = 0);
end Finalize_Lock;
is
Result : Interfaces.C.int;
begin
- Result := pthread_mutex_lock (L);
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_wrlock (L.RW'Access);
+ else
+ Result := pthread_mutex_lock (L.WO'Access);
+ end if;
+
Ceiling_Violation := Result = EINVAL;
-- Assume the cause of EINVAL is a priority ceiling violation
(L : not null access Lock;
Ceiling_Violation : out Boolean)
is
+ Result : Interfaces.C.int;
begin
- Write_Lock (L, Ceiling_Violation);
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_rdlock (L.RW'Access);
+ else
+ Result := pthread_mutex_lock (L.WO'Access);
+ end if;
+
+ Ceiling_Violation := Result = EINVAL;
+
+ -- Assume the cause of EINVAL is a priority ceiling violation
+
+ pragma Assert (Result = 0 or else Result = EINVAL);
end Read_Lock;
------------
procedure Unlock (L : not null access Lock) is
Result : Interfaces.C.int;
begin
- Result := pthread_mutex_unlock (L);
+ if Locking_Policy = 'R' then
+ Result := pthread_rwlock_unlock (L.RW'Access);
+ else
+ Result := pthread_mutex_unlock (L.WO'Access);
+ end if;
pragma Assert (Result = 0);
end Unlock;
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 --
-------------------
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+ Result : Interfaces.C.int;
begin
-- Give the task a unique serial number
Self_ID.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
- Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
+ Result :=
+ pthread_mutex_init (Self_ID.Common.LL.L'Access, null);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result /= 0 then
end if;
end if;
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
use type System.Multiprocessors.CPU_Range;
begin
+ -- Check whether both Dispatching_Domain and CPU are specified for
+ -- the task, and the CPU value is not contained within the range of
+ -- processors for the domain.
+
+ if T.Common.Domain /= null
+ and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
+ and then
+ (T.Common.Base_CPU not in T.Common.Domain'Range
+ or else not T.Common.Domain (T.Common.Base_CPU))
+ then
+ Succeeded := False;
+ return;
+ end if;
+
Adjusted_Stack_Size :=
Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
end if;
Result :=
- pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
+ pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
Result :=
elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
declare
- CPU_Set : aliased cpu_set_t := (bits => (others => False));
+ CPUs : constant size_t :=
+ Interfaces.C.size_t
+ (System.Multiprocessors.Number_Of_CPUs);
+ CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
begin
- CPU_Set.bits (Integer (T.Common.Base_CPU)) := True;
+ CPU_ZERO (Size, CPU_Set);
+ System.OS_Interface.CPU_SET
+ (int (T.Common.Base_CPU), Size, CPU_Set);
Result :=
- pthread_attr_setaffinity_np
- (Attributes'Access,
- CPU_SETSIZE / 8,
- CPU_Set'Access);
+ pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set);
pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
end;
-- Handle Task_Info
- elsif T.Common.Task_Info /= null
- and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU
- then
+ elsif T.Common.Task_Info /= null then
Result :=
pthread_attr_setaffinity_np
(Attributes'Access,
-- Handle dispatching domains
- elsif T.Common.Domain /= null then
+ -- To avoid changing CPU affinities when not needed, we set the
+ -- affinity only when assigning to a domain other than the default
+ -- one, or when the default one has been modified.
+
+ elsif T.Common.Domain /= null and then
+ (T.Common.Domain /= ST.System_Domain
+ or else T.Common.Domain.all /=
+ (Multiprocessors.CPU'First ..
+ Multiprocessors.Number_Of_CPUs => True))
+ then
declare
- CPU_Set : aliased cpu_set_t := (bits => (others => False));
+ CPUs : constant size_t :=
+ Interfaces.C.size_t
+ (System.Multiprocessors.Number_Of_CPUs);
+ CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
begin
+ CPU_ZERO (Size, CPU_Set);
+
-- Set the affinity to all the processors belonging to the
-- dispatching domain.
for Proc in T.Common.Domain'Range loop
- CPU_Set.bits (Integer (Proc)) := T.Common.Domain (Proc);
+ if T.Common.Domain (Proc) then
+ System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
+ end if;
end loop;
Result :=
- pthread_attr_setaffinity_np
- (Attributes'Access,
- CPU_SETSIZE / 8,
- CPU_Set'Access);
+ pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set);
pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
end;
end if;
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ -- 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'Unrestricted_Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+
pragma Assert
(Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
------------------
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
if T.Known_Tasks_Index /= -1 then
Known_Tasks (T.Known_Tasks_Index) := null;
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;
---------------
-- Initialize internal mutex
- Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
+ Result := pthread_mutex_init (S.L'Access, null);
pragma Assert (Result = 0 or else Result = ENOMEM);
-- Initialize internal condition variable
- Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
+ Result := pthread_cond_init (S.CV'Access, null);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
end loop;
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0);
-
- Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result = 0);
-
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the global RTS lock
and then T.Common.LL.Thread /= Null_Thread_Id
then
declare
- type cpu_set_t_ptr is access all cpu_set_t;
-
+ CPUs : constant size_t :=
+ Interfaces.C.size_t
+ (System.Multiprocessors.Number_Of_CPUs);
CPU_Set : cpu_set_t_ptr := null;
+ Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
+
Result : Interfaces.C.int;
begin
-- Set the affinity to an unique CPU
- CPU_Set := new cpu_set_t'(bits => (others => False));
- CPU_Set.bits (Integer (T.Common.Base_CPU)) := True;
+ CPU_Set := CPU_ALLOC (CPUs);
+ System.OS_Interface.CPU_ZERO (Size, CPU_Set);
+ System.OS_Interface.CPU_SET
+ (int (T.Common.Base_CPU), Size, CPU_Set);
-- Handle Task_Info
- elsif T.Common.Task_Info /= null
- and then T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU
- then
+ elsif T.Common.Task_Info /= null then
CPU_Set := T.Common.Task_Info.CPU_Affinity'Access;
-- Handle dispatching domains
-- domain other than the default one, or when the default one
-- has been modified.
- CPU_Set := new cpu_set_t'(bits => (others => False));
+ CPU_Set := CPU_ALLOC (CPUs);
+ System.OS_Interface.CPU_ZERO (Size, CPU_Set);
for Proc in T.Common.Domain'Range loop
- CPU_Set.bits (Integer (Proc)) := T.Common.Domain (Proc);
+ System.OS_Interface.CPU_SET (int (Proc), Size, CPU_Set);
end loop;
end if;
if CPU_Set /= null then
Result :=
- pthread_setaffinity_np
- (T.Common.LL.Thread, CPU_SETSIZE / 8, CPU_Set);
+ pthread_setaffinity_np (T.Common.LL.Thread, Size, CPU_Set);
pragma Assert (Result = 0);
+
+ CPU_FREE (CPU_Set);
end if;
end;
end if;
OSDN Git Service
