s-osinte-posix.adb, [...] (To_Target_Priority): New function maps from System.Any_Priority to a POSIX priority on the target.
2006-10-31 Arnaud Charlet <charlet@adacore.com> Jose Ruiz <ruiz@adacore.com> * s-osinte-posix.adb, s-osinte-linux.ads, s-osinte-freebsd.adb, s-osinte-freebsd.ads, s-osinte-solaris-posix.ads, s-osinte-hpux.ads, s-osinte-darwin.adb, s-osinte-darwin.ads, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb (To_Target_Priority): New function maps from System.Any_Priority to a POSIX priority on the target. * system-linux-ia64.ads: Extend range of Priority types on Linux to use the whole range made available by the system. * s-osinte-aix.adb, s-osinte-aix.ads (To_Target_Priority): New function maps from System.Any_Priority to a POSIX priority on the target. (PTHREAD_PRIO_PROTECT): Set real value. (PTHREAD_PRIO_INHERIT): Now a function. (SIGCPUFAIL): New signal. (Reserved): Add SIGALRM1, SIGWAITING, SIGCPUFAIL, since these signals are documented as reserved by the OS. * system-aix.ads: Use the full range of priorities provided by the system on AIX. * s-taprop-posix.adb: Call new function To_Target_Priority. (Set_Priority): Take into account Task_Dispatching_Policy and Priority_Specific_Dispatching pragmas when determining if Round Robin must be used for scheduling the task. * system-linux-x86_64.ads, system-linux-x86.ads, system-linux-ppc.ads: Extend range of Priority types on Linux to use the whole range made available by the system. * s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-irix.adb, s-taprop-tru64.adb, s-taprop-linux.adb, s-taprop-hpux-dce.adb, s-taprop-lynxos.adb (Finalize_TCB): invalidate the stack-check cache when deallocating the TCB in order to avoid potential references to deallocated data. (Set_Priority): Take into account Task_Dispatching_Policy and Priority_Specific_Dispatching pragmas when determining if Round Robin or FIFO within priorities must be used for scheduling the task. * s-taprop-vxworks.adb (Enter_Task): Store the user-level task id in the Thread field (to be used internally by the run-time system) and the kernel-level task id in the LWP field (to be used by the debugger). (Create_Task): Reorganize to unify the calls to taskSpawn into a single instance, and propagate the current task options to the spawned task. (Set_Priority): Take into account Priority_Specific_Dispatching pragmas. (Initialize): Set Round Robin dispatching when the corresponding pragma is in effect. From-SVN: r118235
This commit is contained in:
parent
6e451134f0
commit
ec946d1845
|
@ -55,6 +55,20 @@ package body System.OS_Interface is
|
|||
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
|
||||
end To_Duration;
|
||||
|
||||
------------------------
|
||||
-- To_Target_Priority --
|
||||
------------------------
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int
|
||||
is
|
||||
begin
|
||||
-- Priorities on AIX are defined in the range 1 .. 127, so we
|
||||
-- map 0 .. 126 to 1 .. 127.
|
||||
|
||||
return Interfaces.C.int (Prio) + 1;
|
||||
end To_Target_Priority;
|
||||
|
||||
-----------------
|
||||
-- To_Timespec --
|
||||
-----------------
|
||||
|
@ -138,20 +152,85 @@ package body System.OS_Interface is
|
|||
-- AIX Thread does not have sched_yield;
|
||||
|
||||
function sched_yield return int is
|
||||
|
||||
procedure pthread_yield;
|
||||
pragma Import (C, pthread_yield, "sched_yield");
|
||||
|
||||
begin
|
||||
pthread_yield;
|
||||
return 0;
|
||||
end sched_yield;
|
||||
|
||||
--------------------
|
||||
-- Get_Stack_Base --
|
||||
--------------------
|
||||
|
||||
function Get_Stack_Base (thread : pthread_t) return Address is
|
||||
pragma Warnings (Off, thread);
|
||||
|
||||
begin
|
||||
return Null_Address;
|
||||
end Get_Stack_Base;
|
||||
|
||||
--------------------------
|
||||
-- PTHREAD_PRIO_INHERIT --
|
||||
--------------------------
|
||||
|
||||
AIX_Version : Integer := 0;
|
||||
-- AIX version in the form xy for AIX version x.y (0 means not set)
|
||||
|
||||
SYS_NMLN : constant := 32;
|
||||
-- AIX system constant used to define utsname, see sys/utsname.h
|
||||
|
||||
subtype String_NMLN is String (1 .. SYS_NMLN);
|
||||
|
||||
type utsname is record
|
||||
sysname : String_NMLN;
|
||||
nodename : String_NMLN;
|
||||
release : String_NMLN;
|
||||
version : String_NMLN;
|
||||
machine : String_NMLN;
|
||||
procserial : String_NMLN;
|
||||
end record;
|
||||
pragma Convention (C, utsname);
|
||||
|
||||
procedure uname (name : out utsname);
|
||||
pragma Import (C, uname);
|
||||
|
||||
function PTHREAD_PRIO_INHERIT return int is
|
||||
name : utsname;
|
||||
|
||||
function Val (C : Character) return Integer;
|
||||
-- Transform a numeric character ('0' .. '9') to an integer
|
||||
|
||||
---------
|
||||
-- Val --
|
||||
---------
|
||||
|
||||
function Val (C : Character) return Integer is
|
||||
begin
|
||||
return Character'Pos (C) - Character'Pos ('0');
|
||||
end Val;
|
||||
|
||||
-- Start of processing for PTHREAD_PRIO_INHERIT
|
||||
|
||||
begin
|
||||
if AIX_Version = 0 then
|
||||
|
||||
-- Set AIX_Version
|
||||
|
||||
uname (name);
|
||||
AIX_Version := Val (name.version (1)) * 10 + Val (name.release (1));
|
||||
end if;
|
||||
|
||||
if AIX_Version < 53 then
|
||||
|
||||
-- Under AIX < 5.3, PTHREAD_PRIO_INHERIT is defined as 0 in pthread.h
|
||||
|
||||
return 0;
|
||||
|
||||
else
|
||||
-- Under AIX >= 5.3, PTHREAD_PRIO_INHERIT is defined as 3
|
||||
|
||||
return 3;
|
||||
end if;
|
||||
end PTHREAD_PRIO_INHERIT;
|
||||
|
||||
end System.OS_Interface;
|
||||
|
|
|
@ -7,7 +7,7 @@
|
|||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1991-1994, Florida State University --
|
||||
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1995-2006, 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- --
|
||||
|
@ -116,13 +116,15 @@ package System.OS_Interface is
|
|||
SIGXFSZ : constant := 25; -- filesize limit exceeded
|
||||
SIGWAITING : constant := 39; -- m:n scheduling
|
||||
|
||||
-- the following signals are AIX specific
|
||||
-- The following signals are AIX specific
|
||||
|
||||
SIGMSG : constant := 27; -- input data is in the ring buffer
|
||||
SIGDANGER : constant := 33; -- system crash imminent
|
||||
SIGMIGRATE : constant := 35; -- migrate process
|
||||
SIGPRE : constant := 36; -- programming exception
|
||||
SIGVIRT : constant := 37; -- AIX virtual time alarm
|
||||
SIGALRM1 : constant := 38; -- m:n condition variables
|
||||
SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors
|
||||
SIGKAP : constant := 60; -- keep alive poll from native keyboard
|
||||
SIGGRANT : constant := SIGKAP; -- monitor mode granted
|
||||
SIGRETRACT : constant := 61; -- monitor mode should be relinguished
|
||||
|
@ -137,7 +139,8 @@ package System.OS_Interface is
|
|||
|
||||
Unmasked : constant Signal_Set :=
|
||||
(SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
|
||||
Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP);
|
||||
Reserved : constant Signal_Set :=
|
||||
(SIGABRT, SIGKILL, SIGSTOP, SIGALRM1, SIGWAITING, SIGCPUFAIL);
|
||||
|
||||
type sigset_t is private;
|
||||
|
||||
|
@ -229,6 +232,10 @@ package System.OS_Interface is
|
|||
SCHED_RR : constant := 2;
|
||||
SCHED_OTHER : constant := 0;
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int;
|
||||
-- Maps System.Any_Priority to a POSIX priority.
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
@ -393,9 +400,11 @@ package System.OS_Interface is
|
|||
-- POSIX.1c Section 13 --
|
||||
--------------------------
|
||||
|
||||
PTHREAD_PRIO_NONE : constant := 0;
|
||||
PTHREAD_PRIO_PROTECT : constant := 0;
|
||||
PTHREAD_PRIO_INHERIT : constant := 0;
|
||||
PTHREAD_PRIO_PROTECT : constant := 2;
|
||||
|
||||
function PTHREAD_PRIO_INHERIT return int;
|
||||
-- Return value of C macro PTHREAD_PRIO_INHERIT. This function is needed
|
||||
-- since the value is different between AIX versions.
|
||||
|
||||
function pthread_mutexattr_setprotocol
|
||||
(attr : access pthread_mutexattr_t;
|
||||
|
|
|
@ -55,6 +55,17 @@ package body System.OS_Interface is
|
|||
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
|
||||
end To_Duration;
|
||||
|
||||
------------------------
|
||||
-- To_Target_Priority --
|
||||
------------------------
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int
|
||||
is
|
||||
begin
|
||||
return Interfaces.C.int (Prio);
|
||||
end To_Target_Priority;
|
||||
|
||||
-----------------
|
||||
-- To_Timespec --
|
||||
-----------------
|
||||
|
|
|
@ -208,6 +208,10 @@ package System.OS_Interface is
|
|||
SCHED_RR : constant := 2;
|
||||
SCHED_FIFO : constant := 4;
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int;
|
||||
-- Maps System.Any_Priority to a POSIX priority.
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2005 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1991-2006, 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- --
|
||||
|
@ -67,6 +67,17 @@ package body System.OS_Interface is
|
|||
return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
|
||||
end To_Duration;
|
||||
|
||||
------------------------
|
||||
-- To_Target_Priority --
|
||||
------------------------
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int
|
||||
is
|
||||
begin
|
||||
return Interfaces.C.int (Prio);
|
||||
end To_Target_Priority;
|
||||
|
||||
-----------------
|
||||
-- To_Timespec --
|
||||
-----------------
|
||||
|
|
|
@ -247,6 +247,10 @@ package System.OS_Interface is
|
|||
SCHED_OTHER : constant := 2;
|
||||
SCHED_RR : constant := 3;
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int;
|
||||
-- Maps System.Any_Priority to a POSIX priority.
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
|
|
@ -227,6 +227,10 @@ package System.OS_Interface is
|
|||
SCHED_RR : constant := 1;
|
||||
SCHED_OTHER : constant := 2;
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int;
|
||||
-- Maps System.Any_Priority to a POSIX priority.
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
|
|
@ -7,7 +7,7 @@
|
|||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1991-1994, Florida State University --
|
||||
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1995-2006, 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- --
|
||||
|
@ -251,6 +251,10 @@ package System.OS_Interface is
|
|||
SCHED_FIFO : constant := 1;
|
||||
SCHED_RR : constant := 2;
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int;
|
||||
-- Maps System.Any_Priority to a POSIX priority.
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1999-2006 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1999-2006, 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- --
|
||||
|
@ -78,6 +78,17 @@ package body System.OS_Interface is
|
|||
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
|
||||
end To_Duration;
|
||||
|
||||
------------------------
|
||||
-- To_Target_Priority --
|
||||
------------------------
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int
|
||||
is
|
||||
begin
|
||||
return Interfaces.C.int (Prio);
|
||||
end To_Target_Priority;
|
||||
|
||||
-----------------
|
||||
-- To_Timespec --
|
||||
-----------------
|
||||
|
|
|
@ -7,7 +7,7 @@
|
|||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1991-1994, Florida State University --
|
||||
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1995-2006, 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- --
|
||||
|
@ -219,6 +219,10 @@ package System.OS_Interface is
|
|||
SCHED_RR : constant := 16#00100000#;
|
||||
SCHED_OTHER : constant := 16#00400000#;
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int;
|
||||
-- Maps System.Any_Priority to a POSIX priority.
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
|
|
@ -7,7 +7,7 @@
|
|||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1991-1994, Florida State University --
|
||||
-- Copyright (C) 1995-2005, AdaCore --
|
||||
-- Copyright (C) 1995-2006, AdaCore --
|
||||
-- --
|
||||
-- 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- --
|
||||
|
@ -79,6 +79,17 @@ package body System.OS_Interface is
|
|||
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
|
||||
end To_Duration;
|
||||
|
||||
------------------------
|
||||
-- To_Target_Priority --
|
||||
------------------------
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int
|
||||
is
|
||||
begin
|
||||
return Interfaces.C.int (Prio);
|
||||
end To_Target_Priority;
|
||||
|
||||
-----------------
|
||||
-- To_Timespec --
|
||||
-----------------
|
||||
|
|
|
@ -7,7 +7,7 @@
|
|||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1991-1994, Florida State University --
|
||||
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1995-2006, 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- --
|
||||
|
@ -49,6 +49,10 @@ package System.OS_Interface is
|
|||
pragma Linker_Options ("-lposix4");
|
||||
pragma Linker_Options ("-lpthread");
|
||||
|
||||
-- The following is needed to allow --enable-threads=solaris
|
||||
|
||||
pragma Linker_Options ("-lthread");
|
||||
|
||||
subtype int is Interfaces.C.int;
|
||||
subtype short is Interfaces.C.short;
|
||||
subtype long is Interfaces.C.long;
|
||||
|
@ -214,6 +218,10 @@ package System.OS_Interface is
|
|||
SCHED_RR : constant := 2;
|
||||
SCHED_OTHER : constant := 0;
|
||||
|
||||
function To_Target_Priority
|
||||
(Prio : System.Any_Priority) return Interfaces.C.int;
|
||||
-- Maps System.Any_Priority to a POSIX priority.
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
@ -260,7 +268,7 @@ package System.OS_Interface is
|
|||
-----------
|
||||
|
||||
Stack_Base_Available : constant Boolean := False;
|
||||
-- Indicates wether the stack base is available on this target.
|
||||
-- Indicates whether the stack base is available on this target.
|
||||
|
||||
function Get_Stack_Base (thread : pthread_t) return Address;
|
||||
pragma Inline (Get_Stack_Base);
|
||||
|
|
|
@ -479,14 +479,16 @@ package body System.Task_Primitives.Operations is
|
|||
-----------------
|
||||
|
||||
procedure Timed_Delay
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
is
|
||||
Check_Time : constant Duration := Monotonic_Clock;
|
||||
Abs_Time : Duration;
|
||||
Request : aliased timespec;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
Result : Interfaces.C.int;
|
||||
pragma Warnings (Off, Result);
|
||||
|
||||
begin
|
||||
if Single_Lock then
|
||||
|
@ -515,11 +517,15 @@ package body System.Task_Primitives.Operations is
|
|||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
|
||||
|
||||
if Single_Lock then
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access,
|
||||
Request'Access);
|
||||
else
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access,
|
||||
Request'Access);
|
||||
end if;
|
||||
|
||||
exit when Abs_Time <= Monotonic_Clock;
|
||||
|
@ -613,14 +619,28 @@ package body System.Task_Primitives.Operations is
|
|||
Array_Item : Integer;
|
||||
Param : aliased struct_sched_param;
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Prio);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
begin
|
||||
Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
|
||||
|
||||
if Time_Slice_Val > 0 then
|
||||
if Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_RR, Param'Access);
|
||||
|
||||
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
|
||||
elsif Dispatching_Policy = 'F'
|
||||
or else Priority_Specific_Policy = 'F'
|
||||
or else Time_Slice_Val = 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
|
||||
|
||||
|
@ -631,7 +651,7 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
if Dispatching_Policy = 'F' then
|
||||
if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then
|
||||
|
||||
-- Annex D requirement [RM D.2.2 par. 9]:
|
||||
-- If the task drops its priority due to the loss of inherited
|
||||
|
|
|
@ -103,6 +103,12 @@ package body System.Task_Primitives.Operations is
|
|||
Locking_Policy : Character;
|
||||
pragma Import (C, Locking_Policy, "__gl_locking_policy");
|
||||
|
||||
Time_Slice_Val : Integer;
|
||||
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
|
||||
|
||||
Dispatching_Policy : Character;
|
||||
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
|
||||
|
||||
Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME;
|
||||
|
||||
Unblocked_Signal_Mask : aliased sigset_t;
|
||||
|
@ -301,6 +307,7 @@ package body System.Task_Primitives.Operations is
|
|||
end if;
|
||||
|
||||
Result := pthread_mutexattr_destroy (Attributes'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end Initialize_Lock;
|
||||
|
||||
-------------------
|
||||
|
@ -620,12 +627,27 @@ package body System.Task_Primitives.Operations is
|
|||
function To_Int is new Unchecked_Conversion
|
||||
(System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Prio);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
Param.sched_priority := Interfaces.C.int (Prio);
|
||||
|
||||
if T.Common.Task_Info /= null then
|
||||
Sched_Policy := To_Int (T.Common.Task_Info.Policy);
|
||||
|
||||
elsif Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0
|
||||
then
|
||||
Sched_Policy := SCHED_RR;
|
||||
|
||||
else
|
||||
Sched_Policy := SCHED_FIFO;
|
||||
end if;
|
||||
|
@ -1222,7 +1244,7 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
Interrupt_Management.Initialize;
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs
|
||||
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
|
|
|
@ -63,6 +63,9 @@ with System.Soft_Links;
|
|||
-- For example when using the restricted run time, it is replaced by
|
||||
-- System.Tasking.Restricted.Stages.
|
||||
|
||||
with System.Stack_Checking.Operations;
|
||||
-- Used for Invalidate_Stack_Cache;
|
||||
|
||||
with Ada.Exceptions;
|
||||
-- used for Raise_Exception
|
||||
-- Raise_From_Signal_Handler
|
||||
|
@ -74,6 +77,7 @@ with Unchecked_Deallocation;
|
|||
package body System.Task_Primitives.Operations is
|
||||
|
||||
package SSL renames System.Soft_Links;
|
||||
package SC renames System.Stack_Checking.Operations;
|
||||
|
||||
use System.Tasking.Debug;
|
||||
use System.Tasking;
|
||||
|
@ -144,7 +148,7 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
function Self return Task_Id;
|
||||
pragma Inline (Self);
|
||||
-- Return a pointer to the Ada Task Control Block of the calling task.
|
||||
-- Return a pointer to the Ada Task Control Block of the calling task
|
||||
|
||||
end Specific;
|
||||
|
||||
|
@ -487,14 +491,16 @@ package body System.Task_Primitives.Operations is
|
|||
-- no locks.
|
||||
|
||||
procedure Timed_Delay
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
is
|
||||
Check_Time : constant Duration := Monotonic_Clock;
|
||||
Abs_Time : Duration;
|
||||
Request : aliased timespec;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
Result : Interfaces.C.int;
|
||||
pragma Warnings (Off, Result);
|
||||
|
||||
begin
|
||||
if Single_Lock then
|
||||
|
@ -523,11 +529,15 @@ package body System.Task_Primitives.Operations is
|
|||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
|
||||
|
||||
if Single_Lock then
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access,
|
||||
Request'Access);
|
||||
else
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access,
|
||||
Request'Access);
|
||||
end if;
|
||||
|
||||
exit when Abs_Time <= Monotonic_Clock;
|
||||
|
@ -610,19 +620,33 @@ package body System.Task_Primitives.Operations is
|
|||
Result : Interfaces.C.int;
|
||||
Param : aliased struct_sched_param;
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Prio);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
|
||||
-- Priorities are in range 1 .. 99 on GNU/Linux, so we map
|
||||
-- map 0 .. 31 to 1 .. 32
|
||||
-- map 0 .. 98 to 1 .. 99
|
||||
|
||||
Param.sched_priority := Interfaces.C.int (Prio) + 1;
|
||||
|
||||
if Time_Slice_Val > 0 then
|
||||
if Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_RR, Param'Access);
|
||||
|
||||
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
|
||||
elsif Dispatching_Policy = 'F'
|
||||
or else Priority_Specific_Policy = 'F'
|
||||
or else Time_Slice_Val = 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
|
||||
|
||||
|
@ -815,7 +839,7 @@ package body System.Task_Primitives.Operations is
|
|||
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
|
||||
|
|
|
@ -539,15 +539,17 @@ package body System.Task_Primitives.Operations is
|
|||
-- the caller is abort-deferred but is holding no locks.
|
||||
|
||||
procedure Timed_Delay
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
is
|
||||
Check_Time : constant Duration := Monotonic_Clock;
|
||||
Abs_Time : Duration;
|
||||
Rel_Time : Duration;
|
||||
Request : aliased timespec;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
Result : Interfaces.C.int;
|
||||
pragma Warnings (Off, Result);
|
||||
|
||||
begin
|
||||
if Single_Lock then
|
||||
|
@ -592,11 +594,15 @@ package body System.Task_Primitives.Operations is
|
|||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
|
||||
|
||||
if Single_Lock then
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access,
|
||||
Request'Access);
|
||||
else
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access,
|
||||
Request'Access);
|
||||
end if;
|
||||
|
||||
exit when Abs_Time <= Monotonic_Clock;
|
||||
|
@ -679,14 +685,29 @@ package body System.Task_Primitives.Operations is
|
|||
Result : Interfaces.C.int;
|
||||
Param : aliased struct_sched_param;
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Prio);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
begin
|
||||
Param.sched_priority := Interfaces.C.int (Prio);
|
||||
|
||||
if Time_Slice_Supported and then Time_Slice_Val > 0 then
|
||||
if Time_Slice_Supported
|
||||
and then (Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0)
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_RR, Param'Access);
|
||||
|
||||
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
|
||||
elsif Dispatching_Policy = 'F'
|
||||
or else Priority_Specific_Policy = 'F'
|
||||
or else Time_Slice_Val = 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
|
||||
|
||||
|
|
|
@ -106,6 +106,10 @@ package body System.Task_Primitives.Operations is
|
|||
Dispatching_Policy : Character;
|
||||
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Foreign_Task_Elaborated : aliased Boolean := True;
|
||||
-- Used to identified fake tasks (i.e., non-Ada Threads)
|
||||
|
||||
|
@ -130,7 +134,7 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
procedure Set (Self_Id : Task_Id);
|
||||
pragma Inline (Set);
|
||||
-- Set the self id for the current task.
|
||||
-- Set the self id for the current task
|
||||
|
||||
end Specific;
|
||||
|
||||
|
@ -155,7 +159,7 @@ package body System.Task_Primitives.Operations is
|
|||
---------------------------------
|
||||
|
||||
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
|
||||
-- Allocate and Initialize a new ATCB for the current Thread.
|
||||
-- Allocate and Initialize a new ATCB for the current Thread
|
||||
|
||||
function Register_Foreign_Thread
|
||||
(Thread : Thread_Id) return Task_Id is separate;
|
||||
|
@ -168,7 +172,7 @@ package body System.Task_Primitives.Operations is
|
|||
-- Initialize given condition variable Cond
|
||||
|
||||
procedure Finalize_Cond (Cond : access Condition_Variable);
|
||||
-- Finalize given condition variable Cond.
|
||||
-- Finalize given condition variable Cond
|
||||
|
||||
procedure Cond_Signal (Cond : access Condition_Variable);
|
||||
-- Signal condition variable Cond
|
||||
|
@ -246,7 +250,7 @@ package body System.Task_Primitives.Operations is
|
|||
Result_Bool : BOOL;
|
||||
|
||||
begin
|
||||
-- Must reset Cond BEFORE L is unlocked.
|
||||
-- Must reset Cond BEFORE L is unlocked
|
||||
|
||||
Result_Bool := ResetEvent (HANDLE (Cond.all));
|
||||
pragma Assert (Result_Bool = True);
|
||||
|
@ -287,7 +291,7 @@ package body System.Task_Primitives.Operations is
|
|||
Wait_Result : DWORD;
|
||||
|
||||
begin
|
||||
-- Must reset Cond BEFORE L is unlocked.
|
||||
-- Must reset Cond BEFORE L is unlocked
|
||||
|
||||
Result := ResetEvent (HANDLE (Cond.all));
|
||||
pragma Assert (Result = True);
|
||||
|
@ -575,16 +579,18 @@ package body System.Task_Primitives.Operations is
|
|||
-----------------
|
||||
|
||||
procedure Timed_Delay
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
is
|
||||
Check_Time : Duration := Monotonic_Clock;
|
||||
Rel_Time : Duration;
|
||||
Abs_Time : Duration;
|
||||
Result : Integer;
|
||||
Timedout : Boolean;
|
||||
|
||||
Result : Integer;
|
||||
pragma Warnings (Off, Integer);
|
||||
|
||||
begin
|
||||
if Single_Lock then
|
||||
Lock_RTS;
|
||||
|
@ -614,10 +620,12 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
if Single_Lock then
|
||||
Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access, Rel_Time, Timedout, Result);
|
||||
Single_RTS_Lock'Access,
|
||||
Rel_Time, Timedout, Result);
|
||||
else
|
||||
Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
|
||||
Self_ID.Common.LL.L'Access,
|
||||
Rel_Time, Timedout, Result);
|
||||
end if;
|
||||
|
||||
Check_Time := Monotonic_Clock;
|
||||
|
@ -686,7 +694,7 @@ package body System.Task_Primitives.Operations is
|
|||
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
|
||||
pragma Assert (Res = True);
|
||||
|
||||
if Dispatching_Policy = 'F' then
|
||||
if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then
|
||||
|
||||
-- Annex D requirement [RM D.2.2 par. 9]:
|
||||
-- If the task drops its priority due to the loss of inherited
|
||||
|
@ -734,20 +742,19 @@ package body System.Task_Primitives.Operations is
|
|||
-- There were two paths were we needed to call Enter_Task :
|
||||
-- 1) from System.Task_Primitives.Operations.Initialize
|
||||
-- 2) from System.Tasking.Stages.Task_Wrapper
|
||||
--
|
||||
|
||||
-- The thread initialisation has to be done only for the first case.
|
||||
--
|
||||
-- This is because the GetCurrentThread NT call does not return the
|
||||
-- real thread handler but only a "pseudo" one. It is not possible to
|
||||
-- release the thread handle and free the system ressources from this
|
||||
-- "pseudo" handle. So we really want to keep the real thread handle
|
||||
-- set in System.Task_Primitives.Operations.Create_Task during the
|
||||
-- thread creation.
|
||||
|
||||
-- This is because the GetCurrentThread NT call does not return the real
|
||||
-- thread handler but only a "pseudo" one. It is not possible to release
|
||||
-- the thread handle and free the system ressources from this "pseudo"
|
||||
-- handle. So we really want to keep the real thread handle set in
|
||||
-- System.Task_Primitives.Operations.Create_Task during thread creation.
|
||||
|
||||
procedure Enter_Task (Self_ID : Task_Id) is
|
||||
procedure Init_Float;
|
||||
pragma Import (C, Init_Float, "__gnat_init_float");
|
||||
-- Properly initializes the FPU for x86 systems.
|
||||
-- Properly initializes the FPU for x86 systems
|
||||
|
||||
begin
|
||||
Specific.Set (Self_ID);
|
||||
|
@ -881,8 +888,11 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
Set_Priority (T, Priority);
|
||||
|
||||
if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
|
||||
-- Here we need Annex E semantics so we disable the NT priority
|
||||
if Time_Slice_Val = 0
|
||||
or else Dispatching_Policy = 'F'
|
||||
or else Get_Policy (Priority) = 'F'
|
||||
then
|
||||
-- Here we need Annex D semantics so we disable the NT priority
|
||||
-- boost. A priority boost is temporarily given by the system to a
|
||||
-- thread when it is taken out of a wait state.
|
||||
|
||||
|
@ -1008,7 +1018,7 @@ package body System.Task_Primitives.Operations is
|
|||
(GetCurrentProcess, High_Priority_Class);
|
||||
|
||||
-- ??? In theory it should be possible to use the priority class
|
||||
-- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler
|
||||
-- Realtime_Priority_Class but we suspect a bug in the NT scheduler
|
||||
-- which prevents (in some obscure cases) a thread to get on top of
|
||||
-- the running queue by another thread of lower priority. For
|
||||
-- example cxd8002 ACATS test freeze.
|
||||
|
@ -1016,7 +1026,7 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
TlsIndex := TlsAlloc;
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs
|
||||
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
|
@ -1175,7 +1185,7 @@ package body System.Task_Primitives.Operations is
|
|||
else
|
||||
S.Waiting := True;
|
||||
|
||||
-- Must reset CV BEFORE L is unlocked.
|
||||
-- Must reset CV BEFORE L is unlocked
|
||||
|
||||
Result_Bool := ResetEvent (S.CV);
|
||||
pragma Assert (Result_Bool = True);
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2006, 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- --
|
||||
|
@ -102,7 +102,7 @@ package body System.Task_Primitives.Operations is
|
|||
-- 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.
|
||||
-- A variable to hold Task_Id for the environment task
|
||||
|
||||
Locking_Policy : Character;
|
||||
pragma Import (C, Locking_Policy, "__gl_locking_policy");
|
||||
|
@ -114,7 +114,7 @@ package body System.Task_Primitives.Operations is
|
|||
Unblocked_Signal_Mask : aliased sigset_t;
|
||||
-- The set of signals that should unblocked in all tasks
|
||||
|
||||
-- The followings are internal configuration constants needed.
|
||||
-- The followings are internal configuration constants needed
|
||||
|
||||
Next_Serial_Number : Task_Serial_Number := 100;
|
||||
-- We start at 100, to reserve some special values for
|
||||
|
@ -127,7 +127,7 @@ package body System.Task_Primitives.Operations is
|
|||
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
|
||||
|
||||
Foreign_Task_Elaborated : aliased Boolean := True;
|
||||
-- Used to identified fake tasks (i.e., non-Ada Threads).
|
||||
-- Used to identified fake tasks (i.e., non-Ada Threads)
|
||||
|
||||
--------------------
|
||||
-- Local Packages --
|
||||
|
@ -137,7 +137,7 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
procedure Initialize (Environment_Task : Task_Id);
|
||||
pragma Inline (Initialize);
|
||||
-- Initialize various data needed by this package.
|
||||
-- Initialize various data needed by this package
|
||||
|
||||
function Is_Valid_Task return Boolean;
|
||||
pragma Inline (Is_Valid_Task);
|
||||
|
@ -145,23 +145,23 @@ package body System.Task_Primitives.Operations is
|
|||
|
||||
procedure Set (Self_Id : Task_Id);
|
||||
pragma Inline (Set);
|
||||
-- Set the self id for the current task.
|
||||
-- Set the self id for the current task
|
||||
|
||||
function Self return Task_Id;
|
||||
pragma Inline (Self);
|
||||
-- Return a pointer to the Ada Task Control Block of the calling task.
|
||||
-- Return a pointer to the Ada Task Control Block of the calling task
|
||||
|
||||
end Specific;
|
||||
|
||||
package body Specific is separate;
|
||||
-- The body of this package is target specific.
|
||||
-- The body of this package is target specific
|
||||
|
||||
---------------------------------
|
||||
-- Support for foreign threads --
|
||||
---------------------------------
|
||||
|
||||
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
|
||||
-- Allocate and Initialize a new ATCB for the current Thread.
|
||||
-- Allocate and Initialize a new ATCB for the current Thread
|
||||
|
||||
function Register_Foreign_Thread
|
||||
(Thread : Thread_Id) return Task_Id is separate;
|
||||
|
@ -489,7 +489,7 @@ package body System.Task_Primitives.Operations is
|
|||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
||||
end if;
|
||||
|
||||
-- EINTR is not considered a failure.
|
||||
-- EINTR is not considered a failure
|
||||
|
||||
pragma Assert (Result = 0 or else Result = EINTR);
|
||||
end Sleep;
|
||||
|
@ -578,20 +578,21 @@ package body System.Task_Primitives.Operations is
|
|||
-- Timed_Delay --
|
||||
-----------------
|
||||
|
||||
-- This is for use in implementing delay statements, so
|
||||
-- we assume the caller is abort-deferred but is holding
|
||||
-- no locks.
|
||||
-- This is for use in implementing delay statements, so we assume the
|
||||
-- caller is abort-deferred but is holding no locks.
|
||||
|
||||
procedure Timed_Delay
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
(Self_ID : Task_Id;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
is
|
||||
Check_Time : constant Duration := Monotonic_Clock;
|
||||
Abs_Time : Duration;
|
||||
Rel_Time : Duration;
|
||||
Request : aliased timespec;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
Result : Interfaces.C.int;
|
||||
pragma Warnings (Off, Result);
|
||||
|
||||
begin
|
||||
if Single_Lock then
|
||||
|
@ -634,11 +635,15 @@ package body System.Task_Primitives.Operations is
|
|||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
|
||||
|
||||
if Single_Lock then
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Single_RTS_Lock'Access,
|
||||
Request'Access);
|
||||
else
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access,
|
||||
Request'Access);
|
||||
end if;
|
||||
|
||||
exit when Abs_Time <= Monotonic_Clock;
|
||||
|
@ -722,15 +727,30 @@ package body System.Task_Primitives.Operations is
|
|||
Result : Interfaces.C.int;
|
||||
Param : aliased struct_sched_param;
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Prio);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
Param.sched_priority := Interfaces.C.int (Prio);
|
||||
Param.sched_priority := To_Target_Priority (Prio);
|
||||
|
||||
if Time_Slice_Supported and then Time_Slice_Val > 0 then
|
||||
if Time_Slice_Supported
|
||||
and then (Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0)
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_RR, Param'Access);
|
||||
|
||||
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
|
||||
elsif Dispatching_Policy = 'F'
|
||||
or else Priority_Specific_Policy = 'F'
|
||||
or else Time_Slice_Val = 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
|
||||
|
||||
|
@ -813,7 +833,7 @@ package body System.Task_Primitives.Operations is
|
|||
Cond_Attr : aliased pthread_condattr_t;
|
||||
|
||||
begin
|
||||
-- Give the task a unique serial number.
|
||||
-- Give the task a unique serial number
|
||||
|
||||
Self_ID.Serial_Number := Next_Serial_Number;
|
||||
Next_Serial_Number := Next_Serial_Number + 1;
|
||||
|
@ -1327,7 +1347,7 @@ package body System.Task_Primitives.Operations is
|
|||
end if;
|
||||
end loop;
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs
|
||||
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
|
|
|
@ -161,6 +161,10 @@ package body System.Task_Primitives.Operations is
|
|||
procedure Abort_Handler (Sig : Signal);
|
||||
-- Signal handler used to implement asynchronous abort
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
-------------------
|
||||
-- Abort_Handler --
|
||||
-------------------
|
||||
|
@ -635,15 +639,25 @@ package body System.Task_Primitives.Operations is
|
|||
Result : Interfaces.C.int;
|
||||
Param : aliased struct_sched_param;
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Prio);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
|
||||
|
||||
if Time_Slice_Val > 0 then
|
||||
if Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_RR, Param'Access);
|
||||
|
||||
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
|
||||
elsif Dispatching_Policy = 'F'
|
||||
or else Priority_Specific_Policy = 'F'
|
||||
or else Time_Slice_Val = 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
|
||||
|
||||
|
@ -784,6 +798,10 @@ package body System.Task_Primitives.Operations is
|
|||
Result : Interfaces.C.int;
|
||||
Param : aliased System.OS_Interface.struct_sched_param;
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Priority);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
use System.Task_Info;
|
||||
|
||||
begin
|
||||
|
@ -815,11 +833,17 @@ package body System.Task_Primitives.Operations is
|
|||
(Attributes'Access, Param'Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
if Time_Slice_Val > 0 then
|
||||
if Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0
|
||||
then
|
||||
Result := pthread_attr_setschedpolicy
|
||||
(Attributes'Access, System.OS_Interface.SCHED_RR);
|
||||
|
||||
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
|
||||
elsif Dispatching_Policy = 'F'
|
||||
or else Priority_Specific_Policy = 'F'
|
||||
or else Time_Slice_Val = 0
|
||||
then
|
||||
Result := pthread_attr_setschedpolicy
|
||||
(Attributes'Access, System.OS_Interface.SCHED_FIFO);
|
||||
|
||||
|
|
|
@ -602,15 +602,29 @@ package body System.Task_Primitives.Operations is
|
|||
Result : Interfaces.C.int;
|
||||
Param : aliased struct_sched_param;
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Priority_Specific_Policy : constant Character := Get_Policy (Prio);
|
||||
-- Upper case first character of the policy name corresponding to the
|
||||
-- task as set by a Priority_Specific_Dispatching pragma.
|
||||
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
|
||||
|
||||
if Time_Slice_Val > 0 then
|
||||
if Dispatching_Policy = 'R'
|
||||
or else Priority_Specific_Policy = 'R'
|
||||
or else Time_Slice_Val > 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_RR, Param'Access);
|
||||
|
||||
elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
|
||||
elsif Dispatching_Policy = 'F'
|
||||
or else Priority_Specific_Policy = 'F'
|
||||
or else Time_Slice_Val = 0
|
||||
then
|
||||
Result := pthread_setschedparam
|
||||
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
|
||||
|
||||
|
|
|
@ -105,6 +105,10 @@ package body System.Task_Primitives.Operations is
|
|||
Dispatching_Policy : Character;
|
||||
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
|
||||
|
||||
function Get_Policy (Prio : System.Any_Priority) return Character;
|
||||
pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
|
||||
-- Get priority specific dispatching policy
|
||||
|
||||
Mutex_Protocol : Priority_Type;
|
||||
|
||||
Foreign_Task_Elaborated : aliased Boolean := True;
|
||||
|
@ -553,9 +557,11 @@ package body System.Task_Primitives.Operations is
|
|||
Absolute : Duration;
|
||||
Ticks : int;
|
||||
Timedout : Boolean;
|
||||
Result : int;
|
||||
Aborted : Boolean := False;
|
||||
|
||||
Result : int;
|
||||
pragma Warnings (Off, Result);
|
||||
|
||||
begin
|
||||
if Mode = Relative then
|
||||
Absolute := Orig + Time;
|
||||
|
@ -727,34 +733,32 @@ package body System.Task_Primitives.Operations is
|
|||
(T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
if Dispatching_Policy = 'F' then
|
||||
|
||||
if (Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F')
|
||||
and then Loss_Of_Inheritance
|
||||
and then Prio < T.Common.Current_Priority
|
||||
then
|
||||
-- Annex D requirement [RM D.2.2 par. 9]:
|
||||
|
||||
-- If the task drops its priority due to the loss of inherited
|
||||
-- priority, it is added at the head of the ready queue for its
|
||||
-- new active priority.
|
||||
|
||||
if Loss_Of_Inheritance
|
||||
and then Prio < T.Common.Current_Priority
|
||||
then
|
||||
Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
|
||||
Prio_Array (T.Common.Base_Priority) := Array_Item;
|
||||
Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
|
||||
Prio_Array (T.Common.Base_Priority) := Array_Item;
|
||||
|
||||
loop
|
||||
-- Give some processes a chance to arrive
|
||||
loop
|
||||
-- Give some processes a chance to arrive
|
||||
|
||||
taskDelay (0);
|
||||
taskDelay (0);
|
||||
|
||||
-- Then wait for our turn to proceed
|
||||
-- Then wait for our turn to proceed
|
||||
|
||||
exit when Array_Item = Prio_Array (T.Common.Base_Priority)
|
||||
or else Prio_Array (T.Common.Base_Priority) = 1;
|
||||
end loop;
|
||||
exit when Array_Item = Prio_Array (T.Common.Base_Priority)
|
||||
or else Prio_Array (T.Common.Base_Priority) = 1;
|
||||
end loop;
|
||||
|
||||
Prio_Array (T.Common.Base_Priority) :=
|
||||
Prio_Array (T.Common.Base_Priority) - 1;
|
||||
end if;
|
||||
Prio_Array (T.Common.Base_Priority) :=
|
||||
Prio_Array (T.Common.Base_Priority) - 1;
|
||||
end if;
|
||||
|
||||
T.Common.Current_Priority := Prio;
|
||||
|
@ -779,7 +783,13 @@ package body System.Task_Primitives.Operations is
|
|||
-- Properly initializes the FPU for PPC/MIPS systems
|
||||
|
||||
begin
|
||||
-- Store the user-level task id in the Thread field (to be used
|
||||
-- internally by the run-time system) and the kernel-level task id in
|
||||
-- the LWP field (to be used by the debugger).
|
||||
|
||||
Self_ID.Common.LL.Thread := taskIdSelf;
|
||||
Self_ID.Common.LL.LWP := getpid;
|
||||
|
||||
Specific.Set (Self_ID);
|
||||
|
||||
Init_Float;
|
||||
|
@ -886,32 +896,55 @@ package body System.Task_Primitives.Operations is
|
|||
-- not need to manipulate caller's signal mask at this point. All tasks
|
||||
-- in RTS will have All_Tasks_Mask initially.
|
||||
|
||||
if T.Common.Task_Image_Len = 0 then
|
||||
T.Common.LL.Thread := taskSpawn
|
||||
(System.Null_Address,
|
||||
To_VxWorks_Priority (int (Priority)),
|
||||
VX_FP_TASK,
|
||||
Adjusted_Stack_Size,
|
||||
Wrapper,
|
||||
To_Address (T));
|
||||
else
|
||||
declare
|
||||
Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
|
||||
-- We now compute the VxWorks task name and options, then spawn ...
|
||||
|
||||
begin
|
||||
declare
|
||||
Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
|
||||
Name_Address : System.Address;
|
||||
-- Task name we are going to hand down to VxWorks
|
||||
|
||||
Task_Options : aliased int;
|
||||
-- VxWorks options we are going to set for the created task,
|
||||
-- a combination of VX_optname_TASK attributes.
|
||||
|
||||
function To_int is new Unchecked_Conversion (unsigned_int, int);
|
||||
function To_uint is new Unchecked_Conversion (int, unsigned_int);
|
||||
|
||||
begin
|
||||
-- If there is no Ada task name handy, let VxWorks choose one.
|
||||
-- Otherwise, tell VxWorks what the Ada task name is.
|
||||
|
||||
if T.Common.Task_Image_Len = 0 then
|
||||
Name_Address := System.Null_Address;
|
||||
else
|
||||
Name (1 .. Name'Last - 1) :=
|
||||
T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
|
||||
Name (Name'Last) := ASCII.NUL;
|
||||
Name_Address := Name'Address;
|
||||
end if;
|
||||
|
||||
T.Common.LL.Thread := taskSpawn
|
||||
(Name'Address,
|
||||
To_VxWorks_Priority (int (Priority)),
|
||||
VX_FP_TASK,
|
||||
Adjusted_Stack_Size,
|
||||
Wrapper,
|
||||
To_Address (T));
|
||||
end;
|
||||
end if;
|
||||
-- For task options, we fetch the options assigned to the current
|
||||
-- task, so offering some user level control over the options for a
|
||||
-- task hierarchy, and force VX_FP_TASK because it is almost always
|
||||
-- required.
|
||||
|
||||
if taskOptionsGet (taskIdSelf, Task_Options'Access) /= OK then
|
||||
Task_Options := 0;
|
||||
end if;
|
||||
|
||||
Task_Options :=
|
||||
To_int (To_uint (Task_Options) or To_uint (VX_FP_TASK));
|
||||
|
||||
-- Now spawn the VxWorks task for real
|
||||
|
||||
T.Common.LL.Thread := taskSpawn
|
||||
(Name_Address,
|
||||
To_VxWorks_Priority (int (Priority)),
|
||||
Task_Options,
|
||||
Adjusted_Stack_Size,
|
||||
Wrapper,
|
||||
To_Address (T));
|
||||
end;
|
||||
|
||||
if T.Common.LL.Thread = -1 then
|
||||
Succeeded := False;
|
||||
|
@ -1244,7 +1277,11 @@ package body System.Task_Primitives.Operations is
|
|||
if Time_Slice_Val > 0 then
|
||||
Result := Set_Time_Slice
|
||||
(To_Clock_Ticks
|
||||
(Duration (Time_Slice_Val) / Duration (1_000_000.0)));
|
||||
(Duration (Time_Slice_Val) / Duration (1_000_000.0)));
|
||||
|
||||
elsif Dispatching_Policy = 'R' then
|
||||
Result := Set_Time_Slice (To_Clock_Ticks (0.01));
|
||||
|
||||
end if;
|
||||
|
||||
Result := sigemptyset (Unblocked_Signal_Mask'Access);
|
||||
|
|
|
@ -7,7 +7,7 @@
|
|||
-- S p e c --
|
||||
-- (AIX/PPC Version) --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
|
@ -88,17 +88,18 @@ package System is
|
|||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order := High_Order_First;
|
||||
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
Max_Priority : constant Positive := 125;
|
||||
Max_Interrupt_Priority : constant Positive := 126;
|
||||
|
||||
subtype Any_Priority is Integer range 0 .. 31;
|
||||
subtype Priority is Any_Priority range 0 .. 30;
|
||||
subtype Interrupt_Priority is Any_Priority range 31 .. 31;
|
||||
subtype Any_Priority is Integer range 0 .. 126;
|
||||
subtype Priority is Any_Priority range 0 .. 125;
|
||||
subtype Interrupt_Priority is Any_Priority range 126 .. 126;
|
||||
|
||||
Default_Priority : constant Priority := 15;
|
||||
Default_Priority : constant Priority := 62;
|
||||
|
||||
private
|
||||
|
||||
|
@ -133,7 +134,7 @@ private
|
|||
Preallocated_Stacks : constant Boolean := False;
|
||||
Signed_Zeros : constant Boolean := True;
|
||||
Stack_Check_Default : constant Boolean := False;
|
||||
Stack_Check_Probes : constant Boolean := False;
|
||||
Stack_Check_Probes : constant Boolean := True;
|
||||
Support_64_Bit_Divides : constant Boolean := True;
|
||||
Support_Aggregates : constant Boolean := True;
|
||||
Support_Composite_Assign : constant Boolean := True;
|
||||
|
|
|
@ -5,9 +5,9 @@
|
|||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (GNU-Linux/ia64 Version) --
|
||||
-- (GNU-Linux/ia64 Version) --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
|
@ -88,17 +88,18 @@ package System is
|
|||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order := Low_Order_First;
|
||||
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
Max_Priority : constant Positive := 97;
|
||||
Max_Interrupt_Priority : constant Positive := 98;
|
||||
|
||||
subtype Any_Priority is Integer range 0 .. 31;
|
||||
subtype Priority is Any_Priority range 0 .. 30;
|
||||
subtype Interrupt_Priority is Any_Priority range 31 .. 31;
|
||||
subtype Any_Priority is Integer range 0 .. 98;
|
||||
subtype Priority is Any_Priority range 0 .. 97;
|
||||
subtype Interrupt_Priority is Any_Priority range 98 .. 98;
|
||||
|
||||
Default_Priority : constant Priority := 15;
|
||||
Default_Priority : constant Priority := 48;
|
||||
|
||||
private
|
||||
|
||||
|
@ -133,7 +134,7 @@ private
|
|||
Preallocated_Stacks : constant Boolean := False;
|
||||
Signed_Zeros : constant Boolean := True;
|
||||
Stack_Check_Default : constant Boolean := False;
|
||||
Stack_Check_Probes : constant Boolean := False;
|
||||
Stack_Check_Probes : constant Boolean := True;
|
||||
Support_64_Bit_Divides : constant Boolean := True;
|
||||
Support_Aggregates : constant Boolean := True;
|
||||
Support_Composite_Assign : constant Boolean := True;
|
||||
|
|
|
@ -5,9 +5,9 @@
|
|||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (GNU-Linux/x86 Version) --
|
||||
-- (GNU-Linux/x86 Version) --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
|
@ -88,17 +88,18 @@ package System is
|
|||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order := Low_Order_First;
|
||||
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
Max_Priority : constant Positive := 97;
|
||||
Max_Interrupt_Priority : constant Positive := 98;
|
||||
|
||||
subtype Any_Priority is Integer range 0 .. 31;
|
||||
subtype Priority is Any_Priority range 0 .. 30;
|
||||
subtype Interrupt_Priority is Any_Priority range 31 .. 31;
|
||||
subtype Any_Priority is Integer range 0 .. 98;
|
||||
subtype Priority is Any_Priority range 0 .. 97;
|
||||
subtype Interrupt_Priority is Any_Priority range 98 .. 98;
|
||||
|
||||
Default_Priority : constant Priority := 15;
|
||||
Default_Priority : constant Priority := 48;
|
||||
|
||||
private
|
||||
|
||||
|
|
|
@ -5,9 +5,9 @@
|
|||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (GNU-Linux/x86-64 Version) --
|
||||
-- (GNU-Linux/x86-64 Version) --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. The copyright notice above, and the license provisions that follow --
|
||||
|
@ -88,17 +88,18 @@ package System is
|
|||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order := Low_Order_First;
|
||||
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
Max_Priority : constant Positive := 97;
|
||||
Max_Interrupt_Priority : constant Positive := 98;
|
||||
|
||||
subtype Any_Priority is Integer range 0 .. 31;
|
||||
subtype Priority is Any_Priority range 0 .. 30;
|
||||
subtype Interrupt_Priority is Any_Priority range 31 .. 31;
|
||||
subtype Any_Priority is Integer range 0 .. 98;
|
||||
subtype Priority is Any_Priority range 0 .. 97;
|
||||
subtype Interrupt_Priority is Any_Priority range 98 .. 98;
|
||||
|
||||
Default_Priority : constant Priority := 15;
|
||||
Default_Priority : constant Priority := 48;
|
||||
|
||||
private
|
||||
|
||||
|
|
Loading…
Reference in New Issue