]> git.ipfire.org Git - thirdparty/gcc.git/commitdiff
2006-10-31 Arnaud Charlet <charlet@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 31 Oct 2006 17:45:11 +0000 (17:45 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 31 Oct 2006 17:45:11 +0000 (17:45 +0000)
    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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@118235 138bc75d-0d04-0410-961f-82ee72b054a4

25 files changed:
gcc/ada/s-osinte-aix.adb
gcc/ada/s-osinte-aix.ads
gcc/ada/s-osinte-darwin.adb
gcc/ada/s-osinte-darwin.ads
gcc/ada/s-osinte-freebsd.adb
gcc/ada/s-osinte-freebsd.ads
gcc/ada/s-osinte-hpux.ads
gcc/ada/s-osinte-linux.ads
gcc/ada/s-osinte-lynxos-3.adb
gcc/ada/s-osinte-lynxos-3.ads
gcc/ada/s-osinte-posix.adb
gcc/ada/s-osinte-solaris-posix.ads
gcc/ada/s-taprop-hpux-dce.adb
gcc/ada/s-taprop-irix.adb
gcc/ada/s-taprop-linux.adb
gcc/ada/s-taprop-lynxos.adb
gcc/ada/s-taprop-mingw.adb
gcc/ada/s-taprop-posix.adb
gcc/ada/s-taprop-tru64.adb
gcc/ada/s-taprop-vms.adb
gcc/ada/s-taprop-vxworks.adb
gcc/ada/system-aix.ads
gcc/ada/system-linux-ia64.ads
gcc/ada/system-linux-x86.ads
gcc/ada/system-linux-x86_64.ads

index bef7de50f993a1c164c2bba06e052e82a1a8928a..b56282b251b54e2d0e6c29b04a6fbff19b21b9b0 100644 (file)
@@ -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;
index 527c8ae95e8968b8bbc17b05b0361ab75cdd19cd..f242e73de38a386db552d0c60ab1ca6f09cc64a6 100644 (file)
@@ -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;
index 3ccd8c2741ced14436de9d3c0fb0dab92015725a..c06228e2ca23bb4087779d597096639ee69355ae 100644 (file)
@@ -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 --
    -----------------
index e2ef1f1bca55edf479a857b63d274ed38dbd8e2a..db2a74bb1984b70d0bfad4634f2e0efa8becaa79 100644 (file)
@@ -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 --
    -------------
index d7a528aa4b481d59a642d1669e09957205b5bb60..9035ff2ae047042f8fdff70341c05ba2376ae522 100644 (file)
@@ -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 --
    -----------------
index 35a3871c50acd678319ef82762dfe0c4b09f9fad..646a5783a0ca25b17cc3720c46bbd042c48a593b 100644 (file)
@@ -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 --
    -------------
index 425f8d2fbb3a0519fd4492f78af397fda8ce6fdb..7407b8bc08c7cc259b727c65a6b2295f08235b40 100644 (file)
@@ -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 --
    -------------
index 5d909fd9a4a3bc942100968b8fb69d4930dcde23..ea9b1c73fa12a8e0f0ba9ab8f3d6bfa6e905da70 100644 (file)
@@ -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 --
    -------------
index a454a23e63ad72c9d39e2026c25d4611301766b7..7c89e9ef4e01558731c90791dce4183e5004a97c 100644 (file)
@@ -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 --
    -----------------
index 99e060a5f4b64e43fd63a48a00f560bd57cc3520..cfc734865be08af59eee2939c89462e4c43c033f 100644 (file)
@@ -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 --
    -------------
index b27d4eca1e3322b7d5fa49a0323b9f84868dfdd8..c6460c2d241efce1480fe3f6a468d962f523cf49 100644 (file)
@@ -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 --
    -----------------
index b3c4be2452bec5ccafb75cd86a7d4672399d1815..ce4f7524b925caab5d30944b0a7c9f8e2770a38a 100644 (file)
@@ -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);
index 4aefcda25bce064294d6db26797a32dc4d8e8c83..f463d8f90d6f5ac1816c4d72b1ad2009530500f8 100644 (file)
@@ -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
index efae88249dde4b6eb7e9bfbe602ccfd8b6680752..a1bc9f09478aedb1bea9c8d6ff5a2f276dbe0310 100644 (file)
@@ -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);
 
index 6455748751d044945377478bc30998a12ebd2437..a41eb3f55704c3b8d576ca3fb21f7fcd12a0bb53 100644 (file)
@@ -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
index 8f53ad40a30b9c06f5437cab149e9b78b209c13c..881a0cea4ef9f0f9c5c8d9b7b5832ead7fce4647 100644 (file)
@@ -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);
 
index 953e19e101e01c73ffa0349d1181160ef19c88d6..6a6cd17a75ec572593db5a20ebb47443deb09249 100644 (file)
@@ -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);
index ebe495d79de938762836095ec9d072ced9a8b48b..f8d1f0db90d23f4f9261583807095c3a418544c7 100644 (file)
@@ -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);
 
index 120657fc47e8426dc0a941443e48790af6055e89..28e1a4a30c1a0d6eec09a8baa34fb57349c792f6 100644 (file)
@@ -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);
 
index 755a2c940518debbec44f6ee9cbe98e74bff4880..7509236e1e1691374883b89d36fac7ef766463de 100644 (file)
@@ -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);
 
index 186e8c28f409734e817bf92c4709e5a45caf9787..6874fd53c515b1cae3c430c16f8670e1fb0f1e5d 100644 (file)
@@ -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);
index 8db13afacd75f9b5bc5e6b34d4c26486e2f419a3..ba90858e77fbf272f448367713575769db9c2e7b 100644 (file)
@@ -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;
index 95f70a3f9f1fc98c944da71e2a1511374f1e8de2..105264eb6e2a401282133a6a42fe8f60f488f641 100644 (file)
@@ -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;
index fa79b5e4c925190b79bf6511500bc0327d5bcd01..62b5441140f69e4cc785b7d63781d919d3737aa2 100644 (file)
@@ -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
 
index 2867602ad7434e6babc58307f93b588a9094f6fb..c4916eeaf182674fed51992904bdadc159ce84b9 100644 (file)
@@ -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