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

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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -486,7 +486,9 @@ package body System.Task_Primitives.Operations is
       Check_Time : constant Duration := Monotonic_Clock;
       Abs_Time   : Duration;
       Request    : aliased timespec;
+
       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;
 
@@ -494,7 +498,9 @@ package body System.Task_Primitives.Operations is
       Check_Time : constant Duration := Monotonic_Clock;
       Abs_Time   : Duration;
       Request    : aliased timespec;
+
       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

@@ -547,7 +547,9 @@ package body System.Task_Primitives.Operations is
       Abs_Time   : Duration;
       Rel_Time   : Duration;
       Request    : aliased timespec;
+
       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);
@@ -582,9 +586,11 @@ package body System.Task_Primitives.Operations 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

@@ -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,9 +578,8 @@ 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;
@@ -591,7 +590,9 @@ package body System.Task_Primitives.Operations is
       Abs_Time   : Duration;
       Rel_Time   : Duration;
       Request    : aliased timespec;
+
       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,17 +733,16 @@ 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;
 
@@ -755,7 +760,6 @@ package body System.Task_Primitives.Operations is
          Prio_Array (T.Common.Base_Priority) :=
            Prio_Array (T.Common.Base_Priority) - 1;
       end if;
-      end if;
 
       T.Common.Current_Priority := Prio;
    end Set_Priority;
@@ -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
+      --  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
+
+         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;
+
+         --  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,
+           (Name_Address,
             To_VxWorks_Priority (int (Priority)),
-               VX_FP_TASK,
+            Task_Options,
             Adjusted_Stack_Size,
             Wrapper,
             To_Address (T));
       end;
-      end if;
 
       if T.Common.LL.Thread = -1 then
          Succeeded := False;
@@ -1245,6 +1278,10 @@ package body System.Task_Primitives.Operations is
          Result := Set_Time_Slice
            (To_Clock_Ticks
               (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

@@ -7,7 +7,7 @@
 --                                 S p e c                                  --
 --                        (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

@@ -7,7 +7,7 @@
 --                                 S p e c                                  --
 --                         (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

@@ -7,7 +7,7 @@
 --                                 S p e c                                  --
 --                       (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