Skip to content

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

s-osinte-posix.adb, [...] (To_Target_Priority): New function maps from… 

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
parent 6e451134
Showing with 538 additions and 182 deletions
gcc/ada/s-osinte-aix.adb
......@@ -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;
gcc/ada/s-osinte-aix.ads
......@@ -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;
......
gcc/ada/s-osinte-darwin.adb
......@@ -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 --
-----------------
......
gcc/ada/s-osinte-darwin.ads
......@@ -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 --
-------------
......
gcc/ada/s-osinte-freebsd.adb
......@@ -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 --
-----------------
......
gcc/ada/s-osinte-freebsd.ads
......@@ -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 --
-------------
......
gcc/ada/s-osinte-hpux.ads
......@@ -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 --
-------------
......
gcc/ada/s-osinte-linux.ads
......@@ -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 --
-------------
......
gcc/ada/s-osinte-lynxos-3.adb
......@@ -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 --
-----------------
......
gcc/ada/s-osinte-lynxos-3.ads
......@@ -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 --
-------------
......
gcc/ada/s-osinte-posix.adb
......@@ -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 --
-----------------
......
gcc/ada/s-osinte-solaris-posix.ads
......@@ -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);
......
gcc/ada/s-taprop-hpux-dce.adb
......@@ -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
......
gcc/ada/s-taprop-irix.adb
......@@ -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);
......
gcc/ada/s-taprop-linux.adb
......@@ -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
......
gcc/ada/s-taprop-lynxos.adb
......@@ -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);
......
gcc/ada/s-taprop-mingw.adb
......@@ -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);
......
gcc/ada/s-taprop-posix.adb
......@@ -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);
......
gcc/ada/s-taprop-tru64.adb
......@@ -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);
......
gcc/ada/s-taprop-vms.adb
......@@ -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);
......
gcc/ada/s-taprop-vxworks.adb
......@@ -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 ...
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;
......@@ -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);
......
gcc/ada/system-aix.ads
......@@ -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;
......
gcc/ada/system-linux-ia64.ads
......@@ -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;
......
gcc/ada/system-linux-x86.ads
......@@ -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
......
gcc/ada/system-linux-x86_64.ads
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment