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 --
-----------------
-- 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;
-- 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- --
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
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;
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 --
-------------
-- 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;
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 --
-----------------
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 --
-------------
-- --
-- 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- --
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 --
-----------------
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 --
-------------
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 --
-------------
-- 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- --
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 --
-------------
-- --
-- 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- --
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 --
-----------------
-- 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- --
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 --
-------------
-- 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- --
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 --
-----------------
-- 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- --
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;
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 --
-------------
-----------
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);
-----------------
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
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;
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);
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
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;
end if;
Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
end Initialize_Lock;
-------------------
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;
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);
-- 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
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;
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;
-- 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
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;
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);
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
-- 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
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;
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);
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)
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;
---------------------------------
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;
-- 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
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);
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);
-----------------
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;
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;
(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
-- 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);
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.
(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.
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);
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);
-- --
-- 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- --
-- 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");
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
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 --
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);
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;
(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;
-- 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
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;
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);
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;
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);
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 --
-------------------
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);
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
(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);
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);
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;
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;
(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;
-- 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;
-- 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 ...
+
+ 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
- begin
+ 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;
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);
-- 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 --
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
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;
-- 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 --
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
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;
-- 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 --
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
-- 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 --
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