diff options
| -rw-r--r-- | gcc/ada/s-osinte-aix.adb | 85 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-aix.ads | 21 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-darwin.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-darwin.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-freebsd.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-freebsd.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-hpux.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-linux.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-lynxos-3.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-lynxos-3.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-posix.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-solaris-posix.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-hpux-dce.adb | 42 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-irix.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-linux.adb | 50 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-lynxos.adb | 41 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-mingw.adb | 62 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-posix.adb | 72 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-tru64.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-vms.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-vxworks.adb | 117 | ||||
| -rw-r--r-- | gcc/ada/system-aix.ads | 17 | ||||
| -rw-r--r-- | gcc/ada/system-linux-ia64.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/system-linux-x86.ads | 17 | ||||
| -rw-r--r-- | gcc/ada/system-linux-x86_64.ads | 17 |
25 files changed, 538 insertions, 182 deletions
diff --git a/gcc/ada/s-osinte-aix.adb b/gcc/ada/s-osinte-aix.adb index bef7de50f99..b56282b251b 100644 --- a/gcc/ada/s-osinte-aix.adb +++ b/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; diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads index 527c8ae95e8..f242e73de38 100644 --- a/gcc/ada/s-osinte-aix.ads +++ b/gcc/ada/s-osinte-aix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -116,13 +116,15 @@ package System.OS_Interface is SIGXFSZ : constant := 25; -- filesize limit exceeded SIGWAITING : constant := 39; -- m:n scheduling - -- the following signals are AIX specific + -- The following signals are AIX specific + SIGMSG : constant := 27; -- input data is in the ring buffer SIGDANGER : constant := 33; -- system crash imminent SIGMIGRATE : constant := 35; -- migrate process SIGPRE : constant := 36; -- programming exception SIGVIRT : constant := 37; -- AIX virtual time alarm SIGALRM1 : constant := 38; -- m:n condition variables + SIGCPUFAIL : constant := 59; -- Predictive De-configuration of Processors SIGKAP : constant := 60; -- keep alive poll from native keyboard SIGGRANT : constant := SIGKAP; -- monitor mode granted SIGRETRACT : constant := 61; -- monitor mode should be relinguished @@ -137,7 +139,8 @@ package System.OS_Interface is Unmasked : constant Signal_Set := (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP); + Reserved : constant Signal_Set := + (SIGABRT, SIGKILL, SIGSTOP, SIGALRM1, SIGWAITING, SIGCPUFAIL); type sigset_t is private; @@ -229,6 +232,10 @@ package System.OS_Interface is SCHED_RR : constant := 2; SCHED_OTHER : constant := 0; + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority. + ------------- -- Process -- ------------- @@ -393,9 +400,11 @@ package System.OS_Interface is -- POSIX.1c Section 13 -- -------------------------- - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 0; - PTHREAD_PRIO_INHERIT : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + + function PTHREAD_PRIO_INHERIT return int; + -- Return value of C macro PTHREAD_PRIO_INHERIT. This function is needed + -- since the value is different between AIX versions. function pthread_mutexattr_setprotocol (attr : access pthread_mutexattr_t; diff --git a/gcc/ada/s-osinte-darwin.adb b/gcc/ada/s-osinte-darwin.adb index 3ccd8c2741c..c06228e2ca2 100644 --- a/gcc/ada/s-osinte-darwin.adb +++ b/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 -- ----------------- diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index e2ef1f1bca5..db2a74bb198 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/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 -- ------------- diff --git a/gcc/ada/s-osinte-freebsd.adb b/gcc/ada/s-osinte-freebsd.adb index d7a528aa4b4..9035ff2ae04 100644 --- a/gcc/ada/s-osinte-freebsd.adb +++ b/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 -- ----------------- diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads index 35a3871c50a..646a5783a0c 100644 --- a/gcc/ada/s-osinte-freebsd.ads +++ b/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 -- ------------- diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads index 425f8d2fbb3..7407b8bc08c 100644 --- a/gcc/ada/s-osinte-hpux.ads +++ b/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 -- ------------- diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads index 5d909fd9a4a..ea9b1c73fa1 100644 --- a/gcc/ada/s-osinte-linux.ads +++ b/gcc/ada/s-osinte-linux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -251,6 +251,10 @@ package System.OS_Interface is SCHED_FIFO : constant := 1; SCHED_RR : constant := 2; + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority. + ------------- -- Process -- ------------- diff --git a/gcc/ada/s-osinte-lynxos-3.adb b/gcc/ada/s-osinte-lynxos-3.adb index a454a23e63a..7c89e9ef4e0 100644 --- a/gcc/ada/s-osinte-lynxos-3.adb +++ b/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 -- ----------------- diff --git a/gcc/ada/s-osinte-lynxos-3.ads b/gcc/ada/s-osinte-lynxos-3.ads index 99e060a5f4b..cfc734865be 100644 --- a/gcc/ada/s-osinte-lynxos-3.ads +++ b/gcc/ada/s-osinte-lynxos-3.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -219,6 +219,10 @@ package System.OS_Interface is SCHED_RR : constant := 16#00100000#; SCHED_OTHER : constant := 16#00400000#; + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority. + ------------- -- Process -- ------------- diff --git a/gcc/ada/s-osinte-posix.adb b/gcc/ada/s-osinte-posix.adb index b27d4eca1e3..c6460c2d241 100644 --- a/gcc/ada/s-osinte-posix.adb +++ b/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 -- ----------------- diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads index b3c4be2452b..ce4f7524b92 100644 --- a/gcc/ada/s-osinte-solaris-posix.ads +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -49,6 +49,10 @@ package System.OS_Interface is pragma Linker_Options ("-lposix4"); pragma Linker_Options ("-lpthread"); + -- The following is needed to allow --enable-threads=solaris + + pragma Linker_Options ("-lthread"); + subtype int is Interfaces.C.int; subtype short is Interfaces.C.short; subtype long is Interfaces.C.long; @@ -214,6 +218,10 @@ package System.OS_Interface is SCHED_RR : constant := 2; SCHED_OTHER : constant := 0; + function To_Target_Priority + (Prio : System.Any_Priority) return Interfaces.C.int; + -- Maps System.Any_Priority to a POSIX priority. + ------------- -- Process -- ------------- @@ -260,7 +268,7 @@ package System.OS_Interface is ----------- Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. + -- Indicates whether the stack base is available on this target. function Get_Stack_Base (thread : pthread_t) return Address; pragma Inline (Get_Stack_Base); diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 4aefcda25bc..f463d8f90d6 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -479,14 +479,16 @@ package body System.Task_Primitives.Operations is ----------------- procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) is Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Request : aliased timespec; - Result : Interfaces.C.int; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); begin if Single_Lock then @@ -515,11 +517,15 @@ package body System.Task_Primitives.Operations is exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Request'Access); else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Request'Access); end if; exit when Abs_Time <= Monotonic_Clock; @@ -613,14 +619,28 @@ package body System.Task_Primitives.Operations is Array_Item : Integer; Param : aliased struct_sched_param; + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + begin Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - if Time_Slice_Val > 0 then + if Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_RR, Param'Access); - elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_FIFO, Param'Access); @@ -631,7 +651,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); - if Dispatching_Policy = 'F' then + if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then -- Annex D requirement [RM D.2.2 par. 9]: -- If the task drops its priority due to the loss of inherited diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index efae88249dd..a1bc9f09478 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/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); diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index 6455748751d..a41eb3f5570 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -63,6 +63,9 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. +with System.Stack_Checking.Operations; +-- Used for Invalidate_Stack_Cache; + with Ada.Exceptions; -- used for Raise_Exception -- Raise_From_Signal_Handler @@ -74,6 +77,7 @@ with Unchecked_Deallocation; package body System.Task_Primitives.Operations is package SSL renames System.Soft_Links; + package SC renames System.Stack_Checking.Operations; use System.Tasking.Debug; use System.Tasking; @@ -144,7 +148,7 @@ package body System.Task_Primitives.Operations is function Self return Task_Id; pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. + -- Return a pointer to the Ada Task Control Block of the calling task end Specific; @@ -487,14 +491,16 @@ package body System.Task_Primitives.Operations is -- no locks. procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) is Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Request : aliased timespec; - Result : Interfaces.C.int; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); begin if Single_Lock then @@ -523,11 +529,15 @@ package body System.Task_Primitives.Operations is exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Request'Access); else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Request'Access); end if; exit when Abs_Time <= Monotonic_Clock; @@ -610,19 +620,33 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; Param : aliased struct_sched_param; + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + begin T.Common.Current_Priority := Prio; -- Priorities are in range 1 .. 99 on GNU/Linux, so we map - -- map 0 .. 31 to 1 .. 32 + -- map 0 .. 98 to 1 .. 99 Param.sched_priority := Interfaces.C.int (Prio) + 1; - if Time_Slice_Val > 0 then + if Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0 + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_RR, Param'Access); - elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_FIFO, Param'Access); @@ -815,7 +839,7 @@ package body System.Task_Primitives.Operations is if T.Known_Tasks_Index /= -1 then Known_Tasks (T.Known_Tasks_Index) := null; end if; - + SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access); Free (Tmp); if Is_Self then diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb index 8f53ad40a30..881a0cea4ef 100644 --- a/gcc/ada/s-taprop-lynxos.adb +++ b/gcc/ada/s-taprop-lynxos.adb @@ -539,15 +539,17 @@ package body System.Task_Primitives.Operations is -- the caller is abort-deferred but is holding no locks. procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) is Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Rel_Time : Duration; Request : aliased timespec; - Result : Interfaces.C.int; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); begin if Single_Lock then @@ -592,11 +594,15 @@ package body System.Task_Primitives.Operations is exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Request'Access); else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Request'Access); end if; exit when Abs_Time <= Monotonic_Clock; @@ -679,14 +685,29 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; Param : aliased struct_sched_param; + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + begin Param.sched_priority := Interfaces.C.int (Prio); - if Time_Slice_Supported and then Time_Slice_Val > 0 then + if Time_Slice_Supported + and then (Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0) + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_RR, Param'Access); - elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_FIFO, Param'Access); diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 953e19e101e..6a6cd17a75e 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -106,6 +106,10 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + Foreign_Task_Elaborated : aliased Boolean := True; -- Used to identified fake tasks (i.e., non-Ada Threads) @@ -130,7 +134,7 @@ package body System.Task_Primitives.Operations is procedure Set (Self_Id : Task_Id); pragma Inline (Set); - -- Set the self id for the current task. + -- Set the self id for the current task end Specific; @@ -155,7 +159,7 @@ package body System.Task_Primitives.Operations is --------------------------------- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread. + -- Allocate and Initialize a new ATCB for the current Thread function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is separate; @@ -168,7 +172,7 @@ package body System.Task_Primitives.Operations is -- Initialize given condition variable Cond procedure Finalize_Cond (Cond : access Condition_Variable); - -- Finalize given condition variable Cond. + -- Finalize given condition variable Cond procedure Cond_Signal (Cond : access Condition_Variable); -- Signal condition variable Cond @@ -246,7 +250,7 @@ package body System.Task_Primitives.Operations is Result_Bool : BOOL; begin - -- Must reset Cond BEFORE L is unlocked. + -- Must reset Cond BEFORE L is unlocked Result_Bool := ResetEvent (HANDLE (Cond.all)); pragma Assert (Result_Bool = True); @@ -287,7 +291,7 @@ package body System.Task_Primitives.Operations is Wait_Result : DWORD; begin - -- Must reset Cond BEFORE L is unlocked. + -- Must reset Cond BEFORE L is unlocked Result := ResetEvent (HANDLE (Cond.all)); pragma Assert (Result = True); @@ -575,16 +579,18 @@ package body System.Task_Primitives.Operations is ----------------- procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) is Check_Time : Duration := Monotonic_Clock; Rel_Time : Duration; Abs_Time : Duration; - Result : Integer; Timedout : Boolean; + Result : Integer; + pragma Warnings (Off, Integer); + begin if Single_Lock then Lock_RTS; @@ -614,10 +620,12 @@ package body System.Task_Primitives.Operations is if Single_Lock then Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Rel_Time, Timedout, Result); + Single_RTS_Lock'Access, + Rel_Time, Timedout, Result); else Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); + Self_ID.Common.LL.L'Access, + Rel_Time, Timedout, Result); end if; Check_Time := Monotonic_Clock; @@ -686,7 +694,7 @@ package body System.Task_Primitives.Operations is (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); pragma Assert (Res = True); - if Dispatching_Policy = 'F' then + if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then -- Annex D requirement [RM D.2.2 par. 9]: -- If the task drops its priority due to the loss of inherited @@ -734,20 +742,19 @@ package body System.Task_Primitives.Operations is -- There were two paths were we needed to call Enter_Task : -- 1) from System.Task_Primitives.Operations.Initialize -- 2) from System.Tasking.Stages.Task_Wrapper - -- + -- The thread initialisation has to be done only for the first case. - -- - -- This is because the GetCurrentThread NT call does not return the - -- real thread handler but only a "pseudo" one. It is not possible to - -- release the thread handle and free the system ressources from this - -- "pseudo" handle. So we really want to keep the real thread handle - -- set in System.Task_Primitives.Operations.Create_Task during the - -- thread creation. + + -- This is because the GetCurrentThread NT call does not return the real + -- thread handler but only a "pseudo" one. It is not possible to release + -- the thread handle and free the system ressources from this "pseudo" + -- handle. So we really want to keep the real thread handle set in + -- System.Task_Primitives.Operations.Create_Task during thread creation. procedure Enter_Task (Self_ID : Task_Id) is procedure Init_Float; pragma Import (C, Init_Float, "__gnat_init_float"); - -- Properly initializes the FPU for x86 systems. + -- Properly initializes the FPU for x86 systems begin Specific.Set (Self_ID); @@ -881,8 +888,11 @@ package body System.Task_Primitives.Operations is Set_Priority (T, Priority); - if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then - -- Here we need Annex E semantics so we disable the NT priority + if Time_Slice_Val = 0 + or else Dispatching_Policy = 'F' + or else Get_Policy (Priority) = 'F' + then + -- Here we need Annex D semantics so we disable the NT priority -- boost. A priority boost is temporarily given by the system to a -- thread when it is taken out of a wait state. @@ -1008,7 +1018,7 @@ package body System.Task_Primitives.Operations is (GetCurrentProcess, High_Priority_Class); -- ??? In theory it should be possible to use the priority class - -- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler + -- Realtime_Priority_Class but we suspect a bug in the NT scheduler -- which prevents (in some obscure cases) a thread to get on top of -- the running queue by another thread of lower priority. For -- example cxd8002 ACATS test freeze. @@ -1016,7 +1026,7 @@ package body System.Task_Primitives.Operations is TlsIndex := TlsAlloc; - -- Initialize the lock used to synchronize chain of all ATCBs. + -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); @@ -1175,7 +1185,7 @@ package body System.Task_Primitives.Operations is else S.Waiting := True; - -- Must reset CV BEFORE L is unlocked. + -- Must reset CV BEFORE L is unlocked Result_Bool := ResetEvent (S.CV); pragma Assert (Result_Bool = True); diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index ebe495d79de..f8d1f0db90d 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -102,7 +102,7 @@ package body System.Task_Primitives.Operations is -- Key used to find the Ada Task_Id associated with a thread Environment_Task_Id : Task_Id; - -- A variable to hold Task_Id for the environment task. + -- A variable to hold Task_Id for the environment task Locking_Policy : Character; pragma Import (C, Locking_Policy, "__gl_locking_policy"); @@ -114,7 +114,7 @@ package body System.Task_Primitives.Operations is Unblocked_Signal_Mask : aliased sigset_t; -- The set of signals that should unblocked in all tasks - -- The followings are internal configuration constants needed. + -- The followings are internal configuration constants needed Next_Serial_Number : Task_Serial_Number := 100; -- We start at 100, to reserve some special values for @@ -127,7 +127,7 @@ package body System.Task_Primitives.Operations is pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). + -- Used to identified fake tasks (i.e., non-Ada Threads) -------------------- -- Local Packages -- @@ -137,7 +137,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id); pragma Inline (Initialize); - -- Initialize various data needed by this package. + -- Initialize various data needed by this package function Is_Valid_Task return Boolean; pragma Inline (Is_Valid_Task); @@ -145,23 +145,23 @@ package body System.Task_Primitives.Operations is procedure Set (Self_Id : Task_Id); pragma Inline (Set); - -- Set the self id for the current task. + -- Set the self id for the current task function Self return Task_Id; pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. + -- Return a pointer to the Ada Task Control Block of the calling task end Specific; package body Specific is separate; - -- The body of this package is target specific. + -- The body of this package is target specific --------------------------------- -- Support for foreign threads -- --------------------------------- function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread. + -- Allocate and Initialize a new ATCB for the current Thread function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id is separate; @@ -489,7 +489,7 @@ package body System.Task_Primitives.Operations is (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; - -- EINTR is not considered a failure. + -- EINTR is not considered a failure pragma Assert (Result = 0 or else Result = EINTR); end Sleep; @@ -578,20 +578,21 @@ package body System.Task_Primitives.Operations is -- Timed_Delay -- ----------------- - -- This is for use in implementing delay statements, so - -- we assume the caller is abort-deferred but is holding - -- no locks. + -- This is for use in implementing delay statements, so we assume the + -- caller is abort-deferred but is holding no locks. procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) + (Self_ID : Task_Id; + Time : Duration; + Mode : ST.Delay_Modes) is Check_Time : constant Duration := Monotonic_Clock; Abs_Time : Duration; Rel_Time : Duration; Request : aliased timespec; - Result : Interfaces.C.int; + + Result : Interfaces.C.int; + pragma Warnings (Off, Result); begin if Single_Lock then @@ -634,11 +635,15 @@ package body System.Task_Primitives.Operations is exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Request'Access); else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Request'Access); end if; exit when Abs_Time <= Monotonic_Clock; @@ -722,15 +727,30 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; Param : aliased struct_sched_param; + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + + Priority_Specific_Policy : constant Character := Get_Policy (Prio); + -- Upper case first character of the policy name corresponding to the + -- task as set by a Priority_Specific_Dispatching pragma. + begin T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Prio); + Param.sched_priority := To_Target_Priority (Prio); - if Time_Slice_Supported and then Time_Slice_Val > 0 then + if Time_Slice_Supported + and then (Dispatching_Policy = 'R' + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0) + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_RR, Param'Access); - elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then + elsif Dispatching_Policy = 'F' + or else Priority_Specific_Policy = 'F' + or else Time_Slice_Val = 0 + then Result := pthread_setschedparam (T.Common.LL.Thread, SCHED_FIFO, Param'Access); @@ -813,7 +833,7 @@ package body System.Task_Primitives.Operations is Cond_Attr : aliased pthread_condattr_t; begin - -- Give the task a unique serial number. + -- Give the task a unique serial number Self_ID.Serial_Number := Next_Serial_Number; Next_Serial_Number := Next_Serial_Number + 1; @@ -1327,7 +1347,7 @@ package body System.Task_Primitives.Operations is end if; end loop; - -- Initialize the lock used to synchronize chain of all ATCBs. + -- Initialize the lock used to synchronize chain of all ATCBs Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 120657fc47e..28e1a4a30c1 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/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); diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index 755a2c94051..7509236e1e1 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/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); diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 186e8c28f40..6874fd53c51 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -105,6 +105,10 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + function Get_Policy (Prio : System.Any_Priority) return Character; + pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); + -- Get priority specific dispatching policy + Mutex_Protocol : Priority_Type; Foreign_Task_Elaborated : aliased Boolean := True; @@ -553,9 +557,11 @@ package body System.Task_Primitives.Operations is Absolute : Duration; Ticks : int; Timedout : Boolean; - Result : int; Aborted : Boolean := False; + Result : int; + pragma Warnings (Off, Result); + begin if Mode = Relative then Absolute := Orig + Time; @@ -727,34 +733,32 @@ package body System.Task_Primitives.Operations is (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); pragma Assert (Result = 0); - if Dispatching_Policy = 'F' then - + if (Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F') + and then Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority + then -- Annex D requirement [RM D.2.2 par. 9]: -- If the task drops its priority due to the loss of inherited -- priority, it is added at the head of the ready queue for its -- new active priority. - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; - loop - -- Give some processes a chance to arrive + loop + -- Give some processes a chance to arrive - taskDelay (0); + taskDelay (0); - -- Then wait for our turn to proceed + -- Then wait for our turn to proceed - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; end if; T.Common.Current_Priority := Prio; @@ -779,7 +783,13 @@ package body System.Task_Primitives.Operations is -- Properly initializes the FPU for PPC/MIPS systems begin + -- Store the user-level task id in the Thread field (to be used + -- internally by the run-time system) and the kernel-level task id in + -- the LWP field (to be used by the debugger). + Self_ID.Common.LL.Thread := taskIdSelf; + Self_ID.Common.LL.LWP := getpid; + Specific.Set (Self_ID); Init_Float; @@ -886,32 +896,55 @@ package body System.Task_Primitives.Operations is -- not need to manipulate caller's signal mask at this point. All tasks -- in RTS will have All_Tasks_Mask initially. - if T.Common.Task_Image_Len = 0 then - T.Common.LL.Thread := taskSpawn - (System.Null_Address, - To_VxWorks_Priority (int (Priority)), - VX_FP_TASK, - Adjusted_Stack_Size, - Wrapper, - To_Address (T)); - else - declare - Name : aliased String (1 .. T.Common.Task_Image_Len + 1); + -- We now compute the VxWorks task name and options, then spawn ... + + declare + Name : aliased String (1 .. T.Common.Task_Image_Len + 1); + Name_Address : System.Address; + -- Task name we are going to hand down to VxWorks - begin + Task_Options : aliased int; + -- VxWorks options we are going to set for the created task, + -- a combination of VX_optname_TASK attributes. + + function To_int is new Unchecked_Conversion (unsigned_int, int); + function To_uint is new Unchecked_Conversion (int, unsigned_int); + + begin + -- If there is no Ada task name handy, let VxWorks choose one. + -- Otherwise, tell VxWorks what the Ada task name is. + + if T.Common.Task_Image_Len = 0 then + Name_Address := System.Null_Address; + else Name (1 .. Name'Last - 1) := T.Common.Task_Image (1 .. T.Common.Task_Image_Len); Name (Name'Last) := ASCII.NUL; + Name_Address := Name'Address; + end if; - T.Common.LL.Thread := taskSpawn - (Name'Address, - To_VxWorks_Priority (int (Priority)), - VX_FP_TASK, - Adjusted_Stack_Size, - Wrapper, - To_Address (T)); - end; - end if; + -- For task options, we fetch the options assigned to the current + -- task, so offering some user level control over the options for a + -- task hierarchy, and force VX_FP_TASK because it is almost always + -- required. + + if taskOptionsGet (taskIdSelf, Task_Options'Access) /= OK then + Task_Options := 0; + end if; + + Task_Options := + To_int (To_uint (Task_Options) or To_uint (VX_FP_TASK)); + + -- Now spawn the VxWorks task for real + + T.Common.LL.Thread := taskSpawn + (Name_Address, + To_VxWorks_Priority (int (Priority)), + Task_Options, + Adjusted_Stack_Size, + Wrapper, + To_Address (T)); + end; if T.Common.LL.Thread = -1 then Succeeded := False; @@ -1244,7 +1277,11 @@ package body System.Task_Primitives.Operations is if Time_Slice_Val > 0 then Result := Set_Time_Slice (To_Clock_Ticks - (Duration (Time_Slice_Val) / Duration (1_000_000.0))); + (Duration (Time_Slice_Val) / Duration (1_000_000.0))); + + elsif Dispatching_Policy = 'R' then + Result := Set_Time_Slice (To_Clock_Ticks (0.01)); + end if; Result := sigemptyset (Unblocked_Signal_Mask'Access); diff --git a/gcc/ada/system-aix.ads b/gcc/ada/system-aix.ads index 8db13afacd7..ba90858e77f 100644 --- a/gcc/ada/system-aix.ads +++ b/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; diff --git a/gcc/ada/system-linux-ia64.ads b/gcc/ada/system-linux-ia64.ads index 95f70a3f9f1..105264eb6e2 100644 --- a/gcc/ada/system-linux-ia64.ads +++ b/gcc/ada/system-linux-ia64.ads @@ -5,9 +5,9 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (GNU-Linux/ia64 Version) -- +-- (GNU-Linux/ia64 Version) -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -88,17 +88,18 @@ package System is type Bit_Order is (High_Order_First, Low_Order_First); Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning -- Priority-related Declarations (RM D.1) - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; - Default_Priority : constant Priority := 15; + Default_Priority : constant Priority := 48; private @@ -133,7 +134,7 @@ private Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; Support_64_Bit_Divides : constant Boolean := True; Support_Aggregates : constant Boolean := True; Support_Composite_Assign : constant Boolean := True; diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads index fa79b5e4c92..62b5441140f 100644 --- a/gcc/ada/system-linux-x86.ads +++ b/gcc/ada/system-linux-x86.ads @@ -5,9 +5,9 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (GNU-Linux/x86 Version) -- +-- (GNU-Linux/x86 Version) -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -88,17 +88,18 @@ package System is type Bit_Order is (High_Order_First, Low_Order_First); Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning -- Priority-related Declarations (RM D.1) - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; - Default_Priority : constant Priority := 15; + Default_Priority : constant Priority := 48; private diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-x86_64.ads index 2867602ad74..c4916eeaf18 100644 --- a/gcc/ada/system-linux-x86_64.ads +++ b/gcc/ada/system-linux-x86_64.ads @@ -5,9 +5,9 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (GNU-Linux/x86-64 Version) -- +-- (GNU-Linux/x86-64 Version) -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -88,17 +88,18 @@ package System is type Bit_Order is (High_Order_First, Low_Order_First); Default_Bit_Order : constant Bit_Order := Low_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning -- Priority-related Declarations (RM D.1) - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; - Default_Priority : constant Priority := 15; + Default_Priority : constant Priority := 48; private |