-- Turn off polling, we do not want ATC polling to take place during tasking
-- operations. It causes infinite loops and other problems.
-with Interfaces.C;
+with Interfaces.C; use Interfaces; use type Interfaces.C.int;
with System.Task_Info;
with System.Tasking.Debug;
use System.Tasking.Debug;
use System.Tasking;
- use Interfaces.C;
use System.OS_Interface;
use System.Parameters;
use System.OS_Primitives;
-- Constant to indicate that the thread identifier has not yet been
-- initialized.
- function geteuid return Integer;
- pragma Import (C, geteuid, "geteuid");
- pragma Warnings (Off, "non-static call not allowed in preelaborated unit");
- Superuser : constant Boolean := geteuid = 0;
- pragma Warnings (On, "non-static call not allowed in preelaborated unit");
- -- True if we are running as 'root'. On Linux, ceiling priorities work only
- -- in that case, so if this is False, we ignore Locking_Policy = 'C'.
-
--------------------
-- Local Packages --
--------------------
procedure Abort_Handler (signo : Signal);
function GNAT_pthread_condattr_setup
- (attr : access pthread_condattr_t) return int;
- pragma Import (C,
- GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+ (attr : access pthread_condattr_t) return C.int;
+ pragma Import
+ (C, GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+
+ function Prio_To_Linux_Prio (Prio : Any_Priority) return C.int is
+ (C.int (Prio) + 1);
+ -- Convert Ada priority to Linux priority. Priorities are 1 .. 99 on
+ -- GNU/Linux, so we map 0 .. 98 to 1 .. 99.
+
+ function Get_Ceiling_Support return Boolean;
+ -- Get the value of the Ceiling_Support constant (see below).
+ -- ???For now, we're returning True only if running as superuser,
+ -- and ignore capabilities.
+
+ function Get_Ceiling_Support return Boolean is
+ Ceiling_Support : Boolean := False;
+ begin
+ if Locking_Policy = 'C' then
+ declare
+ function geteuid return Integer;
+ pragma Import (C, geteuid, "geteuid");
+ Superuser : constant Boolean := geteuid = 0;
+ begin
+ if Superuser then
+ Ceiling_Support := True;
+ end if;
+ end;
+ end if;
+
+ return Ceiling_Support;
+ end Get_Ceiling_Support;
+
+ pragma Warnings (Off, "non-static call not allowed in preelaborated unit");
+ Ceiling_Support : constant Boolean := Get_Ceiling_Support;
+ pragma Warnings (On, "non-static call not allowed in preelaborated unit");
+ -- True if the locking policy is Ceiling_Locking, and the current process
+ -- has permission to use this policy. The process has permission if it is
+ -- running as 'root', or if the capability was set by the setcap command,
+ -- as in "sudo /sbin/setcap cap_sys_nice=ep exe_file". If it doesn't have
+ -- permission, then a request for Ceiling_Locking is ignored.
type RTS_Lock_Ptr is not null access all RTS_Lock;
- function Init_Mutex
- (L : RTS_Lock_Ptr; Prio : Any_Priority)
- return Interfaces.C.int;
- -- Initialize the mutex L. If the locking policy is Ceiling_Locking, then
- -- set the ceiling to Prio.
+ function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int;
+ -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
+ -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
-------------------
-- Abort_Handler --
pragma Unreferenced (signo);
Self_Id : constant Task_Id := Self;
- Result : Interfaces.C.int;
+ Result : C.int;
Old_Set : aliased sigset_t;
begin
-- Init_Mutex --
----------------
- function Init_Mutex
- (L : RTS_Lock_Ptr; Prio : Any_Priority)
- return Interfaces.C.int
- is
+ function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is
Mutex_Attr : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
+ Result, Result_2 : C.int;
+
begin
Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
if Result = ENOMEM then
- return ENOMEM;
+ return Result;
end if;
- if Locking_Policy = 'C' then
- if Superuser then
- Result := pthread_mutexattr_setprotocol
- (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
+ if Ceiling_Support then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
- Result := pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access, Interfaces.C.int (Prio));
- pragma Assert (Result = 0);
- end if;
+ Result := pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access, Prio_To_Linux_Prio (Prio));
+ pragma Assert (Result = 0);
elsif Locking_Policy = 'I' then
Result := pthread_mutexattr_setprotocol
end if;
Result := pthread_mutex_init (L, Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
- if Result = ENOMEM then
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- return ENOMEM;
- end if;
-
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
- return 0;
+ Result_2 := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result_2 = 0);
+ return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy
end Init_Mutex;
---------------------
-- routines should be able to be handled safely.
procedure Initialize_Lock
- (Prio : System.Any_Priority;
+ (Prio : Any_Priority;
L : not null access Lock)
is
begin
if Locking_Policy = 'R' then
declare
RWlock_Attr : aliased pthread_rwlockattr_t;
- Result : Interfaces.C.int;
+ Result : C.int;
begin
-- Set the rwlock to prefer writer to avoid writers starvation
Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
if Result = ENOMEM then
raise Storage_Error with "Failed to allocate a lock";
-------------------
procedure Finalize_Lock (L : not null access Lock) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if Locking_Policy = 'R' then
Result := pthread_rwlock_destroy (L.RW'Access);
end Finalize_Lock;
procedure Finalize_Lock (L : not null access RTS_Lock) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
(L : not null access Lock;
Ceiling_Violation : out Boolean)
is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if Locking_Policy = 'R' then
Result := pthread_rwlock_wrlock (L.RW'Access);
-- The cause of EINVAL is a priority ceiling violation
+ pragma Assert (Result in 0 | EINVAL);
Ceiling_Violation := Result = EINVAL;
- pragma Assert (Result = 0 or else Ceiling_Violation);
end Write_Lock;
procedure Write_Lock
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
end Write_Lock;
procedure Write_Lock (T : Task_Id) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
(L : not null access Lock;
Ceiling_Violation : out Boolean)
is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if Locking_Policy = 'R' then
Result := pthread_rwlock_rdlock (L.RW'Access);
-- The cause of EINVAL is a priority ceiling violation
+ pragma Assert (Result in 0 | EINVAL);
Ceiling_Violation := Result = EINVAL;
- pragma Assert (Result = 0 or else Ceiling_Violation);
end Read_Lock;
------------
------------
procedure Unlock (L : not null access Lock) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if Locking_Policy = 'R' then
Result := pthread_rwlock_unlock (L.RW'Access);
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
end Unlock;
procedure Unlock (T : Task_Id) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
procedure Set_Ceiling
(L : not null access Lock;
- Prio : System.Any_Priority)
+ Prio : Any_Priority)
is
pragma Unreferenced (L, Prio);
begin
is
pragma Unreferenced (Reason);
- Result : Interfaces.C.int;
+ Result : C.int;
begin
pragma Assert (Self_ID = Self);
-- EINTR is not considered a failure
- pragma Assert (Result = 0 or else Result = EINTR);
+ pragma Assert (Result in 0 | EINTR);
end Sleep;
-----------------
Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
- Result : Interfaces.C.int;
+ Result : C.int;
begin
Timedout := True;
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
- if Result = 0 or else Result = EINTR then
+ if Result in 0 | EINTR then
-- Somebody may have called Wakeup for us
Abs_Time : Duration;
Request : aliased timespec;
- Result : Interfaces.C.int;
+ Result : C.int;
pragma Warnings (Off, Result);
begin
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
- pragma Assert (Result = 0 or else
- Result = ETIMEDOUT or else
- Result = EINTR);
+ pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
end loop;
Self_ID.Common.State := Runnable;
function Monotonic_Clock return Duration is
TS : aliased timespec;
- Result : int;
+ Result : C.int;
begin
Result := clock_gettime
(clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
function RT_Resolution return Duration is
TS : aliased timespec;
- Result : int;
+ Result : C.int;
begin
Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
- Result : Interfaces.C.int;
+ Result : C.int;
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
-----------
procedure Yield (Do_Yield : Boolean := True) is
- Result : Interfaces.C.int;
+ Result : C.int;
pragma Unreferenced (Result);
begin
if Do_Yield then
procedure Set_Priority
(T : Task_Id;
- Prio : System.Any_Priority;
+ Prio : Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
pragma Unreferenced (Loss_Of_Inheritance);
- Result : Interfaces.C.int;
+ Result : C.int;
Param : aliased struct_sched_param;
- function Get_Policy (Prio : System.Any_Priority) return Character;
+ function Get_Policy (Prio : Any_Priority) return Character;
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
-- Get priority specific dispatching policy
begin
T.Common.Current_Priority := Prio;
- -- Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99
-
- Param.sched_priority := Interfaces.C.int (Prio) + 1;
+ Param.sched_priority := Prio_To_Linux_Prio (Prio);
if Dispatching_Policy = 'R'
or else Priority_Specific_Policy = 'R'
SCHED_OTHER, Param'Access);
end if;
- pragma Assert (Result = 0 or else Result = EPERM);
+ pragma Assert (Result in 0 | EPERM | EINVAL);
end Set_Priority;
------------------
-- Get_Priority --
------------------
- function Get_Priority (T : Task_Id) return System.Any_Priority is
+ function Get_Priority (T : Task_Id) return Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
Len : Natural := 0;
-- Length of the task name contained in Task_Name
- Result : int;
+ Result : C.int;
-- Result from the prctl call
begin
Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
elsif Self_ID.Common.Task_Image_Len > 0 then
declare
Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
- Result : int;
+ Result : C.int;
begin
Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
then
declare
Stack : aliased stack_t;
- Result : Interfaces.C.int;
+ Result : C.int;
begin
Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
Stack.ss_size := Alternate_Stack_Size;
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Result : Interfaces.C.int;
+ Result : C.int;
Cond_Attr : aliased pthread_condattr_t;
begin
if not Single_Lock then
if Init_Mutex
- (Self_ID.Common.LL.L'Access, System.Any_Priority'Last) /= 0
+ (Self_ID.Common.LL.L'Access, Any_Priority'Last) /= 0
then
Succeeded := False;
return;
end if;
Result := pthread_condattr_init (Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
if Result = 0 then
Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
Result :=
pthread_cond_init
(Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
end if;
if Result = 0 then
(T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
+ Priority : Any_Priority;
Succeeded : out Boolean)
is
Thread_Attr : aliased pthread_attr_t;
- Adjusted_Stack_Size : Interfaces.C.size_t;
- Result : Interfaces.C.int;
+ Adjusted_Stack_Size : C.size_t;
+ Result : C.int;
- use type System.Multiprocessors.CPU_Range;
+ use type Multiprocessors.CPU_Range, Interfaces.C.size_t;
begin
-- Check whether both Dispatching_Domain and CPU are specified for
-- 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 /= 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))
return;
end if;
- Adjusted_Stack_Size :=
- Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
+ Adjusted_Stack_Size := C.size_t (Stack_Size + Alternate_Stack_Size);
Result := pthread_attr_init (Thread_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
if Result /= 0 then
Succeeded := False;
-- Do nothing if required support not provided by the operating system
- if pthread_attr_setaffinity_np'Address = System.Null_Address then
+ if pthread_attr_setaffinity_np'Address = Null_Address then
null;
-- Support is available
- elsif T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU then
+ elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then
declare
CPUs : constant size_t :=
- Interfaces.C.size_t
- (System.Multiprocessors.Number_Of_CPUs);
+ C.size_t (Multiprocessors.Number_Of_CPUs);
CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
then
declare
CPUs : constant size_t :=
- Interfaces.C.size_t
- (System.Multiprocessors.Number_Of_CPUs);
+ C.size_t (Multiprocessors.Number_Of_CPUs);
CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
Thread_Body_Access (Wrapper),
To_Address (T));
- pragma Assert
- (Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
+ pragma Assert (Result in 0 | EAGAIN | ENOMEM);
if Result /= 0 then
Succeeded := False;
------------------
procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
if not Single_Lock then
----------------
procedure Abort_Task (T : Task_Id) is
- Result : Interfaces.C.int;
+ Result : C.int;
ESRCH : constant := 3; -- No such process
-- It can happen that T has already vanished, in which case pthread_kill
pthread_kill
(T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0 or else Result = ESRCH);
+ pragma Assert (Result in 0 | ESRCH);
end if;
end Abort_Task;
----------------
procedure Initialize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
-- Initialize internal state (always to False (RM D.10(6)))
Result := pthread_mutex_init (S.L'Access, null);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
if Result = ENOMEM then
raise Storage_Error;
Result := pthread_cond_init (S.CV'Access, null);
- pragma Assert (Result = 0 or else Result = ENOMEM);
+ pragma Assert (Result in 0 | ENOMEM);
if Result /= 0 then
Result := pthread_mutex_destroy (S.L'Access);
--------------
procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
-- Destroy internal mutex
---------------
procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
SSL.Abort_Defer.all;
--------------
procedure Set_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
SSL.Abort_Defer.all;
------------------------
procedure Suspend_Until_True (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : C.int;
begin
SSL.Abort_Defer.all;
-- POSIX does not guarantee it so this may change in future.
Result := pthread_cond_wait (S.CV'Access, S.L'Access);
- pragma Assert (Result = 0 or else Result = EINTR);
+ pragma Assert (Result in 0 | EINTR);
exit when not S.Waiting;
end loop;
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
+ Result : C.int;
-- Whether to use an alternate signal stack for stack overflows
function State
-----------------------
procedure Set_Task_Affinity (T : ST.Task_Id) is
- use type System.Multiprocessors.CPU_Range;
+ use type Multiprocessors.CPU_Range;
begin
-- Do nothing if there is no support for setting affinities or the
-- yet been created then the proper affinity will be set during its
-- creation.
- if pthread_setaffinity_np'Address /= System.Null_Address
+ if pthread_setaffinity_np'Address /= Null_Address
and then T.Common.LL.Thread /= Null_Thread_Id
then
declare
CPUs : constant size_t :=
- Interfaces.C.size_t
- (System.Multiprocessors.Number_Of_CPUs);
+ C.size_t (Multiprocessors.Number_Of_CPUs);
CPU_Set : cpu_set_t_ptr := null;
Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
- Result : Interfaces.C.int;
+ Result : C.int;
begin
-- We look at the specific CPU (Base_CPU) first, then at the
projects / gcc.git / commitdiff