Skip to content

R
riscv-gcc-1
Commit d86fb53f by Arnaud Charlet
Options

[multiple changes] 

2017-05-02  Bob Duff  <duff@adacore.com>

	* s-taprop-linux.adb (Prio_To_Linux_Prio): New function to correctly
	compute the linux priority from the Ada priority. Call this everywhere
	required. In particular, the previous version was not doing this
	computation when setting the ceiling priority in various places. It
	was just converting to C.int, which results in a ceiling that is off
	by 1.

2017-05-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb: Comment predicate inheritance.

From-SVN: r247473
parent c5b4738f
Showing with 145 additions and 120 deletions
gcc/ada/ChangeLog
2017-05-02 Bob Duff <duff@adacore.com>
* s-taprop-linux.adb (Prio_To_Linux_Prio): New function to correctly
compute the linux priority from the Ada priority. Call this everywhere
required. In particular, the previous version was not doing this
computation when setting the ceiling priority in various places. It
was just converting to C.int, which results in a ceiling that is off
by 1.
2017-05-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb: Comment predicate inheritance.
2017-05-02 Tristan Gingold <gingold@adacore.com> 2017-05-02 Tristan Gingold <gingold@adacore.com>
* s-trasym.ads: Add comment. * s-trasym.ads: Add comment.
......
gcc/ada/s-taprop-linux.adb
...@@ -38,7 +38,7 @@ pragma Polling (Off); ...@@ -38,7 +38,7 @@ pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during tasking -- Turn off polling, we do not want ATC polling to take place during tasking
-- operations. It causes infinite loops and other problems. -- 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.Task_Info;
with System.Tasking.Debug; with System.Tasking.Debug;
...@@ -60,7 +60,6 @@ package body System.Task_Primitives.Operations is ...@@ -60,7 +60,6 @@ package body System.Task_Primitives.Operations is
use System.Tasking.Debug; use System.Tasking.Debug;
use System.Tasking; use System.Tasking;
use Interfaces.C;
use System.OS_Interface; use System.OS_Interface;
use System.Parameters; use System.Parameters;
use System.OS_Primitives; use System.OS_Primitives;
...@@ -111,14 +110,6 @@ package body System.Task_Primitives.Operations is ...@@ -111,14 +110,6 @@ package body System.Task_Primitives.Operations is
-- Constant to indicate that the thread identifier has not yet been -- Constant to indicate that the thread identifier has not yet been
-- initialized. -- 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 -- -- Local Packages --
-------------------- --------------------
...@@ -170,17 +161,52 @@ package body System.Task_Primitives.Operations is ...@@ -170,17 +161,52 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (signo : Signal); procedure Abort_Handler (signo : Signal);
function GNAT_pthread_condattr_setup function GNAT_pthread_condattr_setup
(attr : access pthread_condattr_t) return int; (attr : access pthread_condattr_t) return C.int;
pragma Import (C, pragma Import
GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup"); (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; type RTS_Lock_Ptr is not null access all RTS_Lock;
function Init_Mutex function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int;
(L : RTS_Lock_Ptr; Prio : Any_Priority) -- Initialize the mutex L. If Ceiling_Support is True, then set the ceiling
return Interfaces.C.int; -- to Prio. Returns 0 for success, or ENOMEM for out-of-memory.
-- Initialize the mutex L. If the locking policy is Ceiling_Locking, then
-- set the ceiling to Prio.
------------------- -------------------
-- Abort_Handler -- -- Abort_Handler --
...@@ -190,7 +216,7 @@ package body System.Task_Primitives.Operations is ...@@ -190,7 +216,7 @@ package body System.Task_Primitives.Operations is
pragma Unreferenced (signo); pragma Unreferenced (signo);
Self_Id : constant Task_Id := Self; Self_Id : constant Task_Id := Self;
Result : Interfaces.C.int; Result : C.int;
Old_Set : aliased sigset_t; Old_Set : aliased sigset_t;
begin begin
...@@ -272,30 +298,26 @@ package body System.Task_Primitives.Operations is ...@@ -272,30 +298,26 @@ package body System.Task_Primitives.Operations is
-- Init_Mutex -- -- Init_Mutex --
---------------- ----------------
function Init_Mutex function Init_Mutex (L : RTS_Lock_Ptr; Prio : Any_Priority) return C.int is
(L : RTS_Lock_Ptr; Prio : Any_Priority)
return Interfaces.C.int
is
Mutex_Attr : aliased pthread_mutexattr_t; Mutex_Attr : aliased pthread_mutexattr_t;
Result : Interfaces.C.int; Result, Result_2 : C.int;
begin begin
Result := pthread_mutexattr_init (Mutex_Attr'Access); 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 if Result = ENOMEM then
return ENOMEM; return Result;
end if; end if;
if Locking_Policy = 'C' then if Ceiling_Support then
if Superuser then Result := pthread_mutexattr_setprotocol
Result := pthread_mutexattr_setprotocol (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
(Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); pragma Assert (Result = 0);
pragma Assert (Result = 0);
Result := pthread_mutexattr_setprioceiling Result := pthread_mutexattr_setprioceiling
(Mutex_Attr'Access, Interfaces.C.int (Prio)); (Mutex_Attr'Access, Prio_To_Linux_Prio (Prio));
pragma Assert (Result = 0); pragma Assert (Result = 0);
end if;
elsif Locking_Policy = 'I' then elsif Locking_Policy = 'I' then
Result := pthread_mutexattr_setprotocol Result := pthread_mutexattr_setprotocol
...@@ -304,16 +326,11 @@ package body System.Task_Primitives.Operations is ...@@ -304,16 +326,11 @@ package body System.Task_Primitives.Operations is
end if; end if;
Result := pthread_mutex_init (L, Mutex_Attr'Access); 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_2 := pthread_mutexattr_destroy (Mutex_Attr'Access);
Result := pthread_mutexattr_destroy (Mutex_Attr'Access); pragma Assert (Result_2 = 0);
return ENOMEM; return Result; -- of pthread_mutex_init, not pthread_mutexattr_destroy
end if;
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
pragma Assert (Result = 0);
return 0;
end Init_Mutex; end Init_Mutex;
--------------------- ---------------------
...@@ -327,14 +344,14 @@ package body System.Task_Primitives.Operations is ...@@ -327,14 +344,14 @@ package body System.Task_Primitives.Operations is
-- routines should be able to be handled safely. -- routines should be able to be handled safely.
procedure Initialize_Lock procedure Initialize_Lock
(Prio : System.Any_Priority; (Prio : Any_Priority;
L : not null access Lock) L : not null access Lock)
is is
begin begin
if Locking_Policy = 'R' then if Locking_Policy = 'R' then
declare declare
RWlock_Attr : aliased pthread_rwlockattr_t; RWlock_Attr : aliased pthread_rwlockattr_t;
Result : Interfaces.C.int; Result : C.int;
begin begin
-- Set the rwlock to prefer writer to avoid writers starvation -- Set the rwlock to prefer writer to avoid writers starvation
...@@ -349,7 +366,7 @@ package body System.Task_Primitives.Operations is ...@@ -349,7 +366,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_rwlock_init (L.RW'Access, RWlock_Attr'Access); 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 if Result = ENOMEM then
raise Storage_Error with "Failed to allocate a lock"; raise Storage_Error with "Failed to allocate a lock";
...@@ -378,7 +395,7 @@ package body System.Task_Primitives.Operations is ...@@ -378,7 +395,7 @@ package body System.Task_Primitives.Operations is
------------------- -------------------
procedure Finalize_Lock (L : not null access Lock) is procedure Finalize_Lock (L : not null access Lock) is
Result : Interfaces.C.int; Result : C.int;
begin begin
if Locking_Policy = 'R' then if Locking_Policy = 'R' then
Result := pthread_rwlock_destroy (L.RW'Access); Result := pthread_rwlock_destroy (L.RW'Access);
...@@ -389,7 +406,7 @@ package body System.Task_Primitives.Operations is ...@@ -389,7 +406,7 @@ package body System.Task_Primitives.Operations is
end Finalize_Lock; end Finalize_Lock;
procedure Finalize_Lock (L : not null access RTS_Lock) is procedure Finalize_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int; Result : C.int;
begin begin
Result := pthread_mutex_destroy (L); Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0); pragma Assert (Result = 0);
...@@ -403,7 +420,7 @@ package body System.Task_Primitives.Operations is ...@@ -403,7 +420,7 @@ package body System.Task_Primitives.Operations is
(L : not null access Lock; (L : not null access Lock;
Ceiling_Violation : out Boolean) Ceiling_Violation : out Boolean)
is is
Result : Interfaces.C.int; Result : C.int;
begin begin
if Locking_Policy = 'R' then if Locking_Policy = 'R' then
Result := pthread_rwlock_wrlock (L.RW'Access); Result := pthread_rwlock_wrlock (L.RW'Access);
...@@ -413,15 +430,15 @@ package body System.Task_Primitives.Operations is ...@@ -413,15 +430,15 @@ package body System.Task_Primitives.Operations is
-- The cause of EINVAL is a priority ceiling violation -- The cause of EINVAL is a priority ceiling violation
pragma Assert (Result in 0 | EINVAL);
Ceiling_Violation := Result = EINVAL; Ceiling_Violation := Result = EINVAL;
pragma Assert (Result = 0 or else Ceiling_Violation);
end Write_Lock; end Write_Lock;
procedure Write_Lock procedure Write_Lock
(L : not null access RTS_Lock; (L : not null access RTS_Lock;
Global_Lock : Boolean := False) Global_Lock : Boolean := False)
is is
Result : Interfaces.C.int; Result : C.int;
begin begin
if not Single_Lock or else Global_Lock then if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L); Result := pthread_mutex_lock (L);
...@@ -430,7 +447,7 @@ package body System.Task_Primitives.Operations is ...@@ -430,7 +447,7 @@ package body System.Task_Primitives.Operations is
end Write_Lock; end Write_Lock;
procedure Write_Lock (T : Task_Id) is procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int; Result : C.int;
begin begin
if not Single_Lock then if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access); Result := pthread_mutex_lock (T.Common.LL.L'Access);
...@@ -446,7 +463,7 @@ package body System.Task_Primitives.Operations is ...@@ -446,7 +463,7 @@ package body System.Task_Primitives.Operations is
(L : not null access Lock; (L : not null access Lock;
Ceiling_Violation : out Boolean) Ceiling_Violation : out Boolean)
is is
Result : Interfaces.C.int; Result : C.int;
begin begin
if Locking_Policy = 'R' then if Locking_Policy = 'R' then
Result := pthread_rwlock_rdlock (L.RW'Access); Result := pthread_rwlock_rdlock (L.RW'Access);
...@@ -456,8 +473,8 @@ package body System.Task_Primitives.Operations is ...@@ -456,8 +473,8 @@ package body System.Task_Primitives.Operations is
-- The cause of EINVAL is a priority ceiling violation -- The cause of EINVAL is a priority ceiling violation
pragma Assert (Result in 0 | EINVAL);
Ceiling_Violation := Result = EINVAL; Ceiling_Violation := Result = EINVAL;
pragma Assert (Result = 0 or else Ceiling_Violation);
end Read_Lock; end Read_Lock;
------------ ------------
...@@ -465,7 +482,7 @@ package body System.Task_Primitives.Operations is ...@@ -465,7 +482,7 @@ package body System.Task_Primitives.Operations is
------------ ------------
procedure Unlock (L : not null access Lock) is procedure Unlock (L : not null access Lock) is
Result : Interfaces.C.int; Result : C.int;
begin begin
if Locking_Policy = 'R' then if Locking_Policy = 'R' then
Result := pthread_rwlock_unlock (L.RW'Access); Result := pthread_rwlock_unlock (L.RW'Access);
...@@ -479,7 +496,7 @@ package body System.Task_Primitives.Operations is ...@@ -479,7 +496,7 @@ package body System.Task_Primitives.Operations is
(L : not null access RTS_Lock; (L : not null access RTS_Lock;
Global_Lock : Boolean := False) Global_Lock : Boolean := False)
is is
Result : Interfaces.C.int; Result : C.int;
begin begin
if not Single_Lock or else Global_Lock then if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L); Result := pthread_mutex_unlock (L);
...@@ -488,7 +505,7 @@ package body System.Task_Primitives.Operations is ...@@ -488,7 +505,7 @@ package body System.Task_Primitives.Operations is
end Unlock; end Unlock;
procedure Unlock (T : Task_Id) is procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int; Result : C.int;
begin begin
if not Single_Lock then if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access); Result := pthread_mutex_unlock (T.Common.LL.L'Access);
...@@ -504,7 +521,7 @@ package body System.Task_Primitives.Operations is ...@@ -504,7 +521,7 @@ package body System.Task_Primitives.Operations is
procedure Set_Ceiling procedure Set_Ceiling
(L : not null access Lock; (L : not null access Lock;
Prio : System.Any_Priority) Prio : Any_Priority)
is is
pragma Unreferenced (L, Prio); pragma Unreferenced (L, Prio);
begin begin
...@@ -521,7 +538,7 @@ package body System.Task_Primitives.Operations is ...@@ -521,7 +538,7 @@ package body System.Task_Primitives.Operations is
is is
pragma Unreferenced (Reason); pragma Unreferenced (Reason);
Result : Interfaces.C.int; Result : C.int;
begin begin
pragma Assert (Self_ID = Self); pragma Assert (Self_ID = Self);
...@@ -535,7 +552,7 @@ package body System.Task_Primitives.Operations is ...@@ -535,7 +552,7 @@ package body System.Task_Primitives.Operations is
-- EINTR is not considered a failure -- EINTR is not considered a failure
pragma Assert (Result = 0 or else Result = EINTR); pragma Assert (Result in 0 | EINTR);
end Sleep; end Sleep;
----------------- -----------------
...@@ -560,7 +577,7 @@ package body System.Task_Primitives.Operations is ...@@ -560,7 +577,7 @@ package body System.Task_Primitives.Operations is
Check_Time : Duration := Base_Time; Check_Time : Duration := Base_Time;
Abs_Time : Duration; Abs_Time : Duration;
Request : aliased timespec; Request : aliased timespec;
Result : Interfaces.C.int; Result : C.int;
begin begin
Timedout := True; Timedout := True;
...@@ -588,7 +605,7 @@ package body System.Task_Primitives.Operations is ...@@ -588,7 +605,7 @@ package body System.Task_Primitives.Operations is
Check_Time := Monotonic_Clock; Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; 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 -- Somebody may have called Wakeup for us
...@@ -618,7 +635,7 @@ package body System.Task_Primitives.Operations is ...@@ -618,7 +635,7 @@ package body System.Task_Primitives.Operations is
Abs_Time : Duration; Abs_Time : Duration;
Request : aliased timespec; Request : aliased timespec;
Result : Interfaces.C.int; Result : C.int;
pragma Warnings (Off, Result); pragma Warnings (Off, Result);
begin begin
...@@ -651,9 +668,7 @@ package body System.Task_Primitives.Operations is ...@@ -651,9 +668,7 @@ package body System.Task_Primitives.Operations is
Check_Time := Monotonic_Clock; Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
pragma Assert (Result = 0 or else pragma Assert (Result in 0 | ETIMEDOUT | EINTR);
Result = ETIMEDOUT or else
Result = EINTR);
end loop; end loop;
Self_ID.Common.State := Runnable; Self_ID.Common.State := Runnable;
...@@ -674,7 +689,7 @@ package body System.Task_Primitives.Operations is ...@@ -674,7 +689,7 @@ package body System.Task_Primitives.Operations is
function Monotonic_Clock return Duration is function Monotonic_Clock return Duration is
TS : aliased timespec; TS : aliased timespec;
Result : int; Result : C.int;
begin begin
Result := clock_gettime Result := clock_gettime
(clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access); (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
...@@ -689,7 +704,7 @@ package body System.Task_Primitives.Operations is ...@@ -689,7 +704,7 @@ package body System.Task_Primitives.Operations is
function RT_Resolution return Duration is function RT_Resolution return Duration is
TS : aliased timespec; TS : aliased timespec;
Result : int; Result : C.int;
begin begin
Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access); Result := clock_getres (OSC.CLOCK_REALTIME, TS'Unchecked_Access);
...@@ -704,7 +719,7 @@ package body System.Task_Primitives.Operations is ...@@ -704,7 +719,7 @@ package body System.Task_Primitives.Operations is
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason); pragma Unreferenced (Reason);
Result : Interfaces.C.int; Result : C.int;
begin begin
Result := pthread_cond_signal (T.Common.LL.CV'Access); Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0); pragma Assert (Result = 0);
...@@ -715,7 +730,7 @@ package body System.Task_Primitives.Operations is ...@@ -715,7 +730,7 @@ package body System.Task_Primitives.Operations is
----------- -----------
procedure Yield (Do_Yield : Boolean := True) is procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int; Result : C.int;
pragma Unreferenced (Result); pragma Unreferenced (Result);
begin begin
if Do_Yield then if Do_Yield then
...@@ -729,15 +744,15 @@ package body System.Task_Primitives.Operations is ...@@ -729,15 +744,15 @@ package body System.Task_Primitives.Operations is
procedure Set_Priority procedure Set_Priority
(T : Task_Id; (T : Task_Id;
Prio : System.Any_Priority; Prio : Any_Priority;
Loss_Of_Inheritance : Boolean := False) Loss_Of_Inheritance : Boolean := False)
is is
pragma Unreferenced (Loss_Of_Inheritance); pragma Unreferenced (Loss_Of_Inheritance);
Result : Interfaces.C.int; Result : C.int;
Param : aliased struct_sched_param; 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"); pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
-- Get priority specific dispatching policy -- Get priority specific dispatching policy
...@@ -748,9 +763,7 @@ package body System.Task_Primitives.Operations is ...@@ -748,9 +763,7 @@ package body System.Task_Primitives.Operations is
begin begin
T.Common.Current_Priority := Prio; T.Common.Current_Priority := Prio;
-- Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99 Param.sched_priority := Prio_To_Linux_Prio (Prio);
Param.sched_priority := Interfaces.C.int (Prio) + 1;
if Dispatching_Policy = 'R' if Dispatching_Policy = 'R'
or else Priority_Specific_Policy = 'R' or else Priority_Specific_Policy = 'R'
...@@ -776,14 +789,14 @@ package body System.Task_Primitives.Operations is ...@@ -776,14 +789,14 @@ package body System.Task_Primitives.Operations is
SCHED_OTHER, Param'Access); SCHED_OTHER, Param'Access);
end if; end if;
pragma Assert (Result = 0 or else Result = EPERM); pragma Assert (Result in 0 | EPERM | EINVAL);
end Set_Priority; end Set_Priority;
------------------ ------------------
-- Get_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 begin
return T.Common.Current_Priority; return T.Common.Current_Priority;
end Get_Priority; end Get_Priority;
...@@ -817,7 +830,7 @@ package body System.Task_Primitives.Operations is ...@@ -817,7 +830,7 @@ package body System.Task_Primitives.Operations is
Len : Natural := 0; Len : Natural := 0;
-- Length of the task name contained in Task_Name -- Length of the task name contained in Task_Name
Result : int; Result : C.int;
-- Result from the prctl call -- Result from the prctl call
begin begin
Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address)); Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
...@@ -849,7 +862,7 @@ package body System.Task_Primitives.Operations is ...@@ -849,7 +862,7 @@ package body System.Task_Primitives.Operations is
elsif Self_ID.Common.Task_Image_Len > 0 then elsif Self_ID.Common.Task_Image_Len > 0 then
declare declare
Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1); Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
Result : int; Result : C.int;
begin begin
Task_Name (1 .. Self_ID.Common.Task_Image_Len) := Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
...@@ -868,7 +881,7 @@ package body System.Task_Primitives.Operations is ...@@ -868,7 +881,7 @@ package body System.Task_Primitives.Operations is
then then
declare declare
Stack : aliased stack_t; Stack : aliased stack_t;
Result : Interfaces.C.int; Result : C.int;
begin begin
Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack; Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
Stack.ss_size := Alternate_Stack_Size; Stack.ss_size := Alternate_Stack_Size;
...@@ -903,7 +916,7 @@ package body System.Task_Primitives.Operations is ...@@ -903,7 +916,7 @@ package body System.Task_Primitives.Operations is
-------------------- --------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
Result : Interfaces.C.int; Result : C.int;
Cond_Attr : aliased pthread_condattr_t; Cond_Attr : aliased pthread_condattr_t;
begin begin
...@@ -917,7 +930,7 @@ package body System.Task_Primitives.Operations is ...@@ -917,7 +930,7 @@ package body System.Task_Primitives.Operations is
if not Single_Lock then if not Single_Lock then
if Init_Mutex 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 then
Succeeded := False; Succeeded := False;
return; return;
...@@ -925,7 +938,7 @@ package body System.Task_Primitives.Operations is ...@@ -925,7 +938,7 @@ package body System.Task_Primitives.Operations is
end if; end if;
Result := pthread_condattr_init (Cond_Attr'Access); 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 if Result = 0 then
Result := GNAT_pthread_condattr_setup (Cond_Attr'Access); Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
...@@ -934,7 +947,7 @@ package body System.Task_Primitives.Operations is ...@@ -934,7 +947,7 @@ package body System.Task_Primitives.Operations is
Result := Result :=
pthread_cond_init pthread_cond_init
(Self_ID.Common.LL.CV'Access, Cond_Attr'Access); (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; end if;
if Result = 0 then if Result = 0 then
...@@ -960,14 +973,14 @@ package body System.Task_Primitives.Operations is ...@@ -960,14 +973,14 @@ package body System.Task_Primitives.Operations is
(T : Task_Id; (T : Task_Id;
Wrapper : System.Address; Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type; Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority; Priority : Any_Priority;
Succeeded : out Boolean) Succeeded : out Boolean)
is is
Thread_Attr : aliased pthread_attr_t; Thread_Attr : aliased pthread_attr_t;
Adjusted_Stack_Size : Interfaces.C.size_t; Adjusted_Stack_Size : C.size_t;
Result : Interfaces.C.int; Result : C.int;
use type System.Multiprocessors.CPU_Range; use type Multiprocessors.CPU_Range, Interfaces.C.size_t;
begin begin
-- Check whether both Dispatching_Domain and CPU are specified for -- Check whether both Dispatching_Domain and CPU are specified for
...@@ -975,7 +988,7 @@ package body System.Task_Primitives.Operations is ...@@ -975,7 +988,7 @@ package body System.Task_Primitives.Operations is
-- processors for the domain. -- processors for the domain.
if T.Common.Domain /= null 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 and then
(T.Common.Base_CPU not in T.Common.Domain'Range (T.Common.Base_CPU not in T.Common.Domain'Range
or else not T.Common.Domain (T.Common.Base_CPU)) or else not T.Common.Domain (T.Common.Base_CPU))
...@@ -984,11 +997,10 @@ package body System.Task_Primitives.Operations is ...@@ -984,11 +997,10 @@ package body System.Task_Primitives.Operations is
return; return;
end if; end if;
Adjusted_Stack_Size := Adjusted_Stack_Size := C.size_t (Stack_Size + Alternate_Stack_Size);
Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
Result := pthread_attr_init (Thread_Attr'Access); 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 if Result /= 0 then
Succeeded := False; Succeeded := False;
...@@ -1013,16 +1025,15 @@ package body System.Task_Primitives.Operations is ...@@ -1013,16 +1025,15 @@ package body System.Task_Primitives.Operations is
-- Do nothing if required support not provided by the operating system -- 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; null;
-- Support is available -- 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 declare
CPUs : constant size_t := CPUs : constant size_t :=
Interfaces.C.size_t C.size_t (Multiprocessors.Number_Of_CPUs);
(System.Multiprocessors.Number_Of_CPUs);
CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
Size : constant size_t := CPU_ALLOC_SIZE (CPUs); Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
...@@ -1061,8 +1072,7 @@ package body System.Task_Primitives.Operations is ...@@ -1061,8 +1072,7 @@ package body System.Task_Primitives.Operations is
then then
declare declare
CPUs : constant size_t := CPUs : constant size_t :=
Interfaces.C.size_t C.size_t (Multiprocessors.Number_Of_CPUs);
(System.Multiprocessors.Number_Of_CPUs);
CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs); CPU_Set : constant cpu_set_t_ptr := CPU_ALLOC (CPUs);
Size : constant size_t := CPU_ALLOC_SIZE (CPUs); Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
...@@ -1103,8 +1113,7 @@ package body System.Task_Primitives.Operations is ...@@ -1103,8 +1113,7 @@ package body System.Task_Primitives.Operations is
Thread_Body_Access (Wrapper), Thread_Body_Access (Wrapper),
To_Address (T)); To_Address (T));
pragma Assert pragma Assert (Result in 0 | EAGAIN | ENOMEM);
(Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
if Result /= 0 then if Result /= 0 then
Succeeded := False; Succeeded := False;
...@@ -1126,7 +1135,7 @@ package body System.Task_Primitives.Operations is ...@@ -1126,7 +1135,7 @@ package body System.Task_Primitives.Operations is
------------------ ------------------
procedure Finalize_TCB (T : Task_Id) is procedure Finalize_TCB (T : Task_Id) is
Result : Interfaces.C.int; Result : C.int;
begin begin
if not Single_Lock then if not Single_Lock then
...@@ -1158,7 +1167,7 @@ package body System.Task_Primitives.Operations is ...@@ -1158,7 +1167,7 @@ package body System.Task_Primitives.Operations is
---------------- ----------------
procedure Abort_Task (T : Task_Id) is procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int; Result : C.int;
ESRCH : constant := 3; -- No such process ESRCH : constant := 3; -- No such process
-- It can happen that T has already vanished, in which case pthread_kill -- It can happen that T has already vanished, in which case pthread_kill
...@@ -1170,7 +1179,7 @@ package body System.Task_Primitives.Operations is ...@@ -1170,7 +1179,7 @@ package body System.Task_Primitives.Operations is
pthread_kill pthread_kill
(T.Common.LL.Thread, (T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt)); Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0 or else Result = ESRCH); pragma Assert (Result in 0 | ESRCH);
end if; end if;
end Abort_Task; end Abort_Task;
...@@ -1179,7 +1188,7 @@ package body System.Task_Primitives.Operations is ...@@ -1179,7 +1188,7 @@ package body System.Task_Primitives.Operations is
---------------- ----------------
procedure Initialize (S : in out Suspension_Object) is procedure Initialize (S : in out Suspension_Object) is
Result : Interfaces.C.int; Result : C.int;
begin begin
-- Initialize internal state (always to False (RM D.10(6))) -- Initialize internal state (always to False (RM D.10(6)))
...@@ -1191,7 +1200,7 @@ package body System.Task_Primitives.Operations is ...@@ -1191,7 +1200,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_mutex_init (S.L'Access, null); 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 if Result = ENOMEM then
raise Storage_Error; raise Storage_Error;
...@@ -1201,7 +1210,7 @@ package body System.Task_Primitives.Operations is ...@@ -1201,7 +1210,7 @@ package body System.Task_Primitives.Operations is
Result := pthread_cond_init (S.CV'Access, null); 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 if Result /= 0 then
Result := pthread_mutex_destroy (S.L'Access); Result := pthread_mutex_destroy (S.L'Access);
...@@ -1218,7 +1227,7 @@ package body System.Task_Primitives.Operations is ...@@ -1218,7 +1227,7 @@ package body System.Task_Primitives.Operations is
-------------- --------------
procedure Finalize (S : in out Suspension_Object) is procedure Finalize (S : in out Suspension_Object) is
Result : Interfaces.C.int; Result : C.int;
begin begin
-- Destroy internal mutex -- Destroy internal mutex
...@@ -1249,7 +1258,7 @@ package body System.Task_Primitives.Operations is ...@@ -1249,7 +1258,7 @@ package body System.Task_Primitives.Operations is
--------------- ---------------
procedure Set_False (S : in out Suspension_Object) is procedure Set_False (S : in out Suspension_Object) is
Result : Interfaces.C.int; Result : C.int;
begin begin
SSL.Abort_Defer.all; SSL.Abort_Defer.all;
...@@ -1270,7 +1279,7 @@ package body System.Task_Primitives.Operations is ...@@ -1270,7 +1279,7 @@ package body System.Task_Primitives.Operations is
-------------- --------------
procedure Set_True (S : in out Suspension_Object) is procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int; Result : C.int;
begin begin
SSL.Abort_Defer.all; SSL.Abort_Defer.all;
...@@ -1305,7 +1314,7 @@ package body System.Task_Primitives.Operations is ...@@ -1305,7 +1314,7 @@ package body System.Task_Primitives.Operations is
------------------------ ------------------------
procedure Suspend_Until_True (S : in out Suspension_Object) is procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int; Result : C.int;
begin begin
SSL.Abort_Defer.all; SSL.Abort_Defer.all;
...@@ -1343,7 +1352,7 @@ package body System.Task_Primitives.Operations is ...@@ -1343,7 +1352,7 @@ package body System.Task_Primitives.Operations is
-- POSIX does not guarantee it so this may change in future. -- POSIX does not guarantee it so this may change in future.
Result := pthread_cond_wait (S.CV'Access, S.L'Access); 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; exit when not S.Waiting;
end loop; end loop;
...@@ -1456,7 +1465,7 @@ package body System.Task_Primitives.Operations is ...@@ -1456,7 +1465,7 @@ package body System.Task_Primitives.Operations is
act : aliased struct_sigaction; act : aliased struct_sigaction;
old_act : aliased struct_sigaction; old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t; Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int; Result : C.int;
-- Whether to use an alternate signal stack for stack overflows -- Whether to use an alternate signal stack for stack overflows
function State function State
...@@ -1538,7 +1547,7 @@ package body System.Task_Primitives.Operations is ...@@ -1538,7 +1547,7 @@ package body System.Task_Primitives.Operations is
----------------------- -----------------------
procedure Set_Task_Affinity (T : ST.Task_Id) is procedure Set_Task_Affinity (T : ST.Task_Id) is
use type System.Multiprocessors.CPU_Range; use type Multiprocessors.CPU_Range;
begin begin
-- Do nothing if there is no support for setting affinities or the -- Do nothing if there is no support for setting affinities or the
...@@ -1546,17 +1555,16 @@ package body System.Task_Primitives.Operations is ...@@ -1546,17 +1555,16 @@ package body System.Task_Primitives.Operations is
-- yet been created then the proper affinity will be set during its -- yet been created then the proper affinity will be set during its
-- creation. -- 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 and then T.Common.LL.Thread /= Null_Thread_Id
then then
declare declare
CPUs : constant size_t := CPUs : constant size_t :=
Interfaces.C.size_t C.size_t (Multiprocessors.Number_Of_CPUs);
(System.Multiprocessors.Number_Of_CPUs);
CPU_Set : cpu_set_t_ptr := null; CPU_Set : cpu_set_t_ptr := null;
Size : constant size_t := CPU_ALLOC_SIZE (CPUs); Size : constant size_t := CPU_ALLOC_SIZE (CPUs);
Result : Interfaces.C.int; Result : C.int;
begin begin
-- We look at the specific CPU (Base_CPU) first, then at the -- We look at the specific CPU (Base_CPU) first, then at the
......
gcc/ada/sem_ch3.adb
...@@ -3133,7 +3133,11 @@ package body Sem_Ch3 is ...@@ -3133,7 +3133,11 @@ package body Sem_Ch3 is
when N_Derived_Type_Definition => when N_Derived_Type_Definition =>
Derived_Type_Declaration (T, N, T /= Def_Id); Derived_Type_Declaration (T, N, T /= Def_Id);
if Ekind (T) /= E_Void and then Has_Predicates (T) then -- ????
-- Inherit predicates from parent, and protect against
-- illegal derivations.
if Is_Type (T) and then Has_Predicates (T) then
Set_Has_Predicates (Def_Id); Set_Has_Predicates (Def_Id);
end if; end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment