diff options
37 files changed, 1455 insertions, 1386 deletions
diff --git a/gcc/ada/a-dynpri.adb b/gcc/ada/a-dynpri.adb index 82da8155218..982c17f99b7 100644 --- a/gcc/ada/a-dynpri.adb +++ b/gcc/ada/a-dynpri.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -48,7 +48,7 @@ with System.Soft_Links; -- use for Abort_Defer -- Abort_Undefer -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package body Ada.Dynamic_Priorities is @@ -59,7 +59,7 @@ package body Ada.Dynamic_Priorities is use System.Tasking; function Convert_Ids is new - Unchecked_Conversion + Ada.Unchecked_Conversion (Task_Identification.Task_Id, System.Tasking.Task_Id); ------------------ @@ -98,9 +98,9 @@ package body Ada.Dynamic_Priorities is T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task) is - Target : constant Task_Id := Convert_Ids (T); - Self_ID : constant Task_Id := STPO.Self; + Target : constant Task_Id := Convert_Ids (T); Error_Message : constant String := "Trying to set the priority of a "; + Yield_Needed : Boolean; begin if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then @@ -119,41 +119,53 @@ package body Ada.Dynamic_Priorities is STPO.Write_Lock (Target); - if Self_ID = Target then - Target.Common.Base_Priority := Priority; - STPO.Set_Priority (Target, Priority); + Target.Common.Base_Priority := Priority; + + if Target.Common.Call /= null + and then + Target.Common.Call.Acceptor_Prev_Priority /= Priority_Not_Boosted + then + -- Target is within a rendezvous, so ensure the correct priority + -- will be reset when finishing the rendezvous, and only change the + -- priority immediately if the new priority is greater than the + -- current (inherited) priority. - STPO.Unlock (Target); + Target.Common.Call.Acceptor_Prev_Priority := Priority; - if Single_Lock then - STPO.Unlock_RTS; + if Priority >= Target.Common.Current_Priority then + Yield_Needed := True; + STPO.Set_Priority (Target, Priority); + else + Yield_Needed := False; end if; - -- Yield is needed to enforce FIFO task dispatching + else + Yield_Needed := True; + STPO.Set_Priority (Target, Priority); - -- LL Set_Priority is made while holding the RTS lock so that it - -- is inheriting high priority until it release all the RTS locks. + if Target.Common.State = Entry_Caller_Sleep then + Target.Pending_Priority_Change := True; + STPO.Wakeup (Target, Target.Common.State); + end if; + end if; - -- If this is used in a system where Ceiling Locking is - -- not enforced we may end up getting two Yield effects. + STPO.Unlock (Target); - STPO.Yield; + if Single_Lock then + STPO.Unlock_RTS; + end if; - else - Target.New_Base_Priority := Priority; - Target.Pending_Priority_Change := True; - Target.Pending_Action := True; + if STPO.Self = Target and then Yield_Needed then - STPO.Wakeup (Target, Target.Common.State); + -- Yield is needed to enforce FIFO task dispatching - -- If the task is suspended, wake it up to perform the change. - -- check for ceiling violations ??? + -- LL Set_Priority is made while holding the RTS lock so that it is + -- inheriting high priority until it release all the RTS locks. - STPO.Unlock (Target); + -- If this is used in a system where Ceiling Locking is not enforced + -- we may end up getting two Yield effects. - if Single_Lock then - STPO.Unlock_RTS; - end if; + STPO.Yield; end if; SSL.Abort_Undefer.all; diff --git a/gcc/ada/s-osinte-freebsd.adb b/gcc/ada/s-osinte-freebsd.adb index 9035ff2ae04..33daa45482a 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-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2007, 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- -- @@ -96,23 +96,4 @@ package body System.OS_Interface is ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - function To_Timeval (D : Duration) return struct_timeval is - S : long; - F : Duration; - begin - S := long (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - if F < 0.0 then S := S - 1; F := F + 1.0; end if; - return struct_timeval'(tv_sec => S, - tv_usec => long (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - end System.OS_Interface; diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads index 2e6d0e4a944..8b3530c2b49 100644 --- a/gcc/ada/s-osinte-freebsd.ads +++ b/gcc/ada/s-osinte-freebsd.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-2007, 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- -- @@ -42,7 +42,7 @@ -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; @@ -221,20 +221,6 @@ package System.OS_Interface is tz_dsttime : int; end record; pragma Convention (C, struct_timezone); - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); procedure usleep (useconds : unsigned_long); pragma Import (C, usleep, "usleep"); @@ -283,7 +269,7 @@ package System.OS_Interface is function (arg : System.Address) return System.Address; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Ada.Unchecked_Conversion (System.Address, Thread_Body); type pthread_t is private; subtype Thread_Id is pthread_t; @@ -635,12 +621,6 @@ private type clockid_t is new int; CLOCK_REALTIME : constant clockid_t := 0; - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - type pthread_t is new System.Address; type pthread_attr_t is new System.Address; type pthread_mutex_t is new System.Address; diff --git a/gcc/ada/s-osinte-lynxos-3.adb b/gcc/ada/s-osinte-lynxos-3.adb index 7c89e9ef4e0..01524c89251 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-2007, 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- -- @@ -73,11 +73,6 @@ package body System.OS_Interface is return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; end To_Duration; - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - ------------------------ -- To_Target_Priority -- ------------------------ @@ -113,30 +108,6 @@ package body System.OS_Interface is tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return struct_timeval'(tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - ------------------------- -- POSIX.1c Section 3 -- ------------------------- diff --git a/gcc/ada/s-osinte-lynxos-3.ads b/gcc/ada/s-osinte-lynxos-3.ads index 76c6ea2675a..60fcd418a89 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-2007, 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- -- @@ -41,7 +41,7 @@ -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; @@ -201,16 +201,6 @@ package System.OS_Interface is pragma Convention (C, struct_timezone); type struct_timezone_ptr is access all struct_timezone; - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - ------------------------- -- Priority Scheduling -- ------------------------- @@ -253,7 +243,7 @@ package System.OS_Interface is function (arg : System.Address) return System.Address; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Ada.Unchecked_Conversion (System.Address, Thread_Body); type pthread_t is private; subtype Thread_Id is pthread_t; @@ -525,12 +515,6 @@ private type clockid_t is new unsigned_char; CLOCK_REALTIME : constant clockid_t := 0; - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - type st_t is record stksize : int; prio : int; diff --git a/gcc/ada/s-osinte-lynxos.adb b/gcc/ada/s-osinte-lynxos.adb index ccc81a522ee..a0f48c033c6 100644 --- a/gcc/ada/s-osinte-lynxos.adb +++ b/gcc/ada/s-osinte-lynxos.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2006, AdaCore -- +-- Copyright (C) 2001-2007, 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- -- @@ -50,11 +50,6 @@ package body System.OS_Interface is return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; end To_Duration; - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - ----------------- -- To_Timespec -- ----------------- @@ -79,32 +74,6 @@ package body System.OS_Interface is tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - ------------- -- sigwait -- ------------- diff --git a/gcc/ada/s-osinte-lynxos.ads b/gcc/ada/s-osinte-lynxos.ads index 133078bc246..d092586642b 100644 --- a/gcc/ada/s-osinte-lynxos.ads +++ b/gcc/ada/s-osinte-lynxos.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-2007, 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- -- @@ -41,7 +41,7 @@ -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; @@ -220,16 +220,6 @@ package System.OS_Interface is pragma Convention (C, struct_timezone); type struct_timezone_ptr is access all struct_timezone; - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - ------------------------- -- Priority Scheduling -- ------------------------- @@ -265,7 +255,7 @@ package System.OS_Interface is function (arg : System.Address) return System.Address; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Ada.Unchecked_Conversion (System.Address, Thread_Body); type pthread_t is private; subtype Thread_Id is pthread_t; @@ -520,12 +510,6 @@ private type clockid_t is new unsigned_char; CLOCK_REALTIME : constant clockid_t := 0; - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - type st_attr_t is record stksize : int; prio : int; diff --git a/gcc/ada/s-osinte-tru64.adb b/gcc/ada/s-osinte-tru64.adb index 52987466185..3599c33495d 100644 --- a/gcc/ada/s-osinte-tru64.adb +++ b/gcc/ada/s-osinte-tru64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, 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- -- @@ -114,11 +114,6 @@ package body System.OS_Interface is return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; end To_Duration; - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - ----------------- -- To_Timespec -- ----------------- @@ -143,30 +138,4 @@ package body System.OS_Interface is tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); end To_Timespec; - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - end System.OS_Interface; diff --git a/gcc/ada/s-osinte-tru64.ads b/gcc/ada/s-osinte-tru64.ads index bac521fd54a..5fe84b2e733 100644 --- a/gcc/ada/s-osinte-tru64.ads +++ b/gcc/ada/s-osinte-tru64.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-2007, 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- -- @@ -41,7 +41,7 @@ -- Preelaborate. This package is designed to be a bottom-level (leaf) package. with Interfaces.C; -with Unchecked_Conversion; +with Ada.Unchecked_Conversion; package System.OS_Interface is pragma Preelaborate; @@ -211,15 +211,6 @@ package System.OS_Interface is tz_dsttime : int; end record; pragma Convention (C, struct_timezone); - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); ------------------------- -- Priority Scheduling -- @@ -258,7 +249,7 @@ package System.OS_Interface is function (arg : System.Address) return System.Address; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Ada.Unchecked_Conversion (System.Address, Thread_Body); type pthread_t is private; subtype Thread_Id is pthread_t; @@ -514,12 +505,6 @@ private type clockid_t is new int; CLOCK_REALTIME : constant clockid_t := 1; - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - type unsigned_long_array is array (Natural range <>) of unsigned_long; type pthread_t is new System.Address; diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index 41e3033418f..8807efffcbe 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, 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- -- @@ -79,7 +79,7 @@ package body System.OS_Primitives is -- GNU/Linker will fail to auto-import those variables when building -- libgnarl.dll. The indirection level introduced here has no measurable -- penalties. - -- + -- Note that access variables below must not be declared as constant -- otherwise the compiler optimization will remove this indirect access. @@ -179,15 +179,16 @@ package body System.OS_Primitives is ------------------- procedure Get_Base_Time is + -- The resolution for GetSystemTime is 1 millisecond. -- The time to get both base times should take less than 1 millisecond. -- Therefore, the elapsed time reported by GetSystemTime between both -- actions should be null. - Max_Elapsed : constant := 0; + Max_Elapsed : constant := 0; - Test_Now : aliased Long_Long_Integer; + Test_Now : aliased Long_Long_Integer; epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch system_time_ns : constant := 100; -- 100 ns per tick @@ -225,6 +226,7 @@ package body System.OS_Primitives is function Monotonic_Clock return Duration is Current_Ticks : aliased LARGE_INTEGER; Elap_Secs_Tick : Duration; + begin if not QueryPerformanceCounter (Current_Ticks'Access) then return 0.0; @@ -262,9 +264,17 @@ package body System.OS_Primitives is end case; end Mode_Clock; + -- Local Variables + + Base_Time : constant Duration := Mode_Clock; + -- Base_Time is used to detect clock set backward, in this case we + -- cannot ensure the delay accuracy. + Rel_Time : Duration; Abs_Time : Duration; - Check_Time : Duration := Mode_Clock; + Check_Time : Duration := Base_Time; + + -- Start of processing for Timed Delay begin if Mode = Relative then @@ -280,7 +290,7 @@ package body System.OS_Primitives is Sleep (DWORD (Rel_Time * 1000.0)); Check_Time := Mode_Clock; - exit when Abs_Time <= Check_Time; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; Rel_Time := Abs_Time - Check_Time; end loop; diff --git a/gcc/ada/s-osprim-posix.adb b/gcc/ada/s-osprim-posix.adb index 59a72374d52..dbbf839fed4 100644 --- a/gcc/ada/s-osprim-posix.adb +++ b/gcc/ada/s-osprim-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2006 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, 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- -- @@ -125,11 +125,12 @@ package body System.OS_Primitives is (Time : Duration; Mode : Integer) is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Clock; + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; Result : Integer; pragma Unreferenced (Result); @@ -149,7 +150,7 @@ package body System.OS_Primitives is Result := nanosleep (Request'Access, Remaind'Access); Check_Time := Clock; - exit when Abs_Time <= Check_Time; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; Rel_Time := Abs_Time - Check_Time; end loop; diff --git a/gcc/ada/s-osprim-solaris.adb b/gcc/ada/s-osprim-solaris.adb index b9709335782..24faae2865a 100644 --- a/gcc/ada/s-osprim-solaris.adb +++ b/gcc/ada/s-osprim-solaris.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2006 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, 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- -- @@ -88,7 +88,8 @@ package body System.OS_Primitives is is Rel_Time : Duration; Abs_Time : Duration; - Check_Time : Duration := Clock; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; timeval : aliased struct_timeval; begin @@ -114,7 +115,7 @@ package body System.OS_Primitives is C_select (timeout => timeval'Unchecked_Access); Check_Time := Clock; - exit when Abs_Time <= Check_Time; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; Rel_Time := Abs_Time - Check_Time; end loop; diff --git a/gcc/ada/s-osprim-unix.adb b/gcc/ada/s-osprim-unix.adb index 719551f9dfa..c4f7f3dcfd9 100644 --- a/gcc/ada/s-osprim-unix.adb +++ b/gcc/ada/s-osprim-unix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2006 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, 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- -- @@ -88,7 +88,8 @@ package body System.OS_Primitives is is Rel_Time : Duration; Abs_Time : Duration; - Check_Time : Duration := Clock; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; timeval : aliased struct_timeval; begin @@ -114,7 +115,7 @@ package body System.OS_Primitives is C_select (timeout => timeval'Unchecked_Access); Check_Time := Clock; - exit when Abs_Time <= Check_Time; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; Rel_Time := Abs_Time - Check_Time; end loop; diff --git a/gcc/ada/s-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb index 85a7dce94ca..6f1b50a63c7 100644 --- a/gcc/ada/s-osprim-vxworks.adb +++ b/gcc/ada/s-osprim-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2007, 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- -- @@ -121,7 +121,8 @@ package body System.OS_Primitives is is Rel_Time : Duration; Abs_Time : Duration; - Check_Time : Duration := Clock; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; Ticks : int; Result : int; @@ -151,7 +152,7 @@ package body System.OS_Primitives is Result := taskDelay (Ticks); Check_Time := Clock; - exit when Abs_Time <= Check_Time; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; Rel_Time := Abs_Time - Check_Time; end loop; diff --git a/gcc/ada/s-parame-ae653.ads b/gcc/ada/s-parame-ae653.ads index 2502c5e5bcc..d4a561caab8 100644 --- a/gcc/ada/s-parame-ae653.ads +++ b/gcc/ada/s-parame-ae653.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -171,18 +171,6 @@ package System.Parameters is -- pragma Restrictions (No_Abort_Statements); -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - --------------------- -- Task Attributes -- --------------------- @@ -200,6 +188,13 @@ package System.Parameters is -- predefined output or not (True means that traces are output). -- See System.Traces for more details. + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 32; + -- This constant specifies the maximum length of a task's image. + ------------------------------ -- Exception Message Length -- ------------------------------ diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads index f4a806faf47..2bda354c18f 100644 --- a/gcc/ada/s-parame-hpux.ads +++ b/gcc/ada/s-parame-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -169,18 +169,6 @@ package System.Parameters is -- pragma Restrictions (No_Abort_Statements); -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - --------------------- -- Task Attributes -- --------------------- @@ -198,6 +186,13 @@ package System.Parameters is -- predefined output or not (True means that traces are output). -- See System.Traces for more details. + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image. + ------------------------------ -- Exception Message Length -- ------------------------------ diff --git a/gcc/ada/s-parame-vms-alpha.ads b/gcc/ada/s-parame-vms-alpha.ads index f38f06d5d94..ee1297e2eb7 100644 --- a/gcc/ada/s-parame-vms-alpha.ads +++ b/gcc/ada/s-parame-vms-alpha.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -169,18 +169,6 @@ package System.Parameters is -- pragma Restrictions (No_Abort_Statements); -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - --------------------- -- Task Attributes -- --------------------- @@ -198,6 +186,13 @@ package System.Parameters is -- predefined output or not (True means that traces are output). -- See System.Traces for more details. + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image. + ------------------------------ -- Exception Message Length -- ------------------------------ diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads index be85db3439b..55c228d1ab0 100644 --- a/gcc/ada/s-parame-vms-ia64.ads +++ b/gcc/ada/s-parame-vms-ia64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -169,18 +169,6 @@ package System.Parameters is -- pragma Restrictions (No_Abort_Statements); -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - --------------------- -- Task Attributes -- --------------------- @@ -198,6 +186,13 @@ package System.Parameters is -- predefined output or not (True means that traces are output). -- See System.Traces for more details. + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image. + ------------------------------ -- Exception Message Length -- ------------------------------ diff --git a/gcc/ada/s-parame-vms-restrict.ads b/gcc/ada/s-parame-vms-restrict.ads index 6bb42b5444a..62ccb67944d 100644 --- a/gcc/ada/s-parame-vms-restrict.ads +++ b/gcc/ada/s-parame-vms-restrict.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -169,18 +169,6 @@ package System.Parameters is -- pragma Restrictions (No_Abort_Statements); -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := False; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - --------------------- -- Task Attributes -- --------------------- @@ -198,6 +186,13 @@ package System.Parameters is -- predefined output or not (True means that traces are output). -- See System.Traces for more details. + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image. + ------------------------------ -- Exception Message Length -- ------------------------------ diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads index f9caec5d898..b1505328904 100644 --- a/gcc/ada/s-parame-vxworks.ads +++ b/gcc/ada/s-parame-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -171,18 +171,6 @@ package System.Parameters is -- pragma Restrictions (No_Abort_Statements); -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - --------------------- -- Task Attributes -- --------------------- @@ -200,6 +188,13 @@ package System.Parameters is -- predefined output or not (True means that traces are output). -- See System.Traces for more details. + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 32; + -- This constant specifies the maximum length of a task's image. + ------------------------------ -- Exception Message Length -- ------------------------------ diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index 6a77b3596a8..bbe0b9bde1b 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007 Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -169,18 +169,6 @@ package System.Parameters is -- pragma Restrictions (No_Abort_Statements); -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - --------------------- -- Task Attributes -- --------------------- @@ -198,6 +186,13 @@ package System.Parameters is -- predefined output or not (True means that traces are output). -- See System.Traces for more details. + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image. + ------------------------------ -- Exception Message Length -- ------------------------------ diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index 7d0ca83fa26..3da82bf60ba 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -40,7 +40,6 @@ with System.Task_Primitives.Operations; with System.Tasking.Initialization; -- used for Change_Base_Priority --- Dynamic_Priority_Support -- Defer_Abort/Undefer_Abort with System.Tasking.Protected_Objects.Entries; @@ -84,24 +83,23 @@ package body System.Tasking.Entry_Calls is ----------------------- procedure Lock_Server (Entry_Call : Entry_Call_Link); - -- This locks the server targeted by Entry_Call. + + -- This locks the server targeted by Entry_Call -- - -- This may be a task or a protected object, - -- depending on the target of the original call or any subsequent - -- requeues. + -- This may be a task or a protected object, depending on the target of the + -- original call or any subsequent requeues. -- - -- This routine is needed because the field specifying the server - -- for this call must be protected by the server's mutex. If it were - -- protected by the caller's mutex, accessing the server's queues would - -- require locking the caller to get the server, locking the server, - -- and then accessing the queues. This involves holding two ATCB - -- locks at once, something which we can guarantee that it will always - -- be done in the same order, or locking a protected object while we - -- hold an ATCB lock, something which is not permitted. Since - -- the server cannot be obtained reliably, it must be obtained unreliably - -- and then checked again once it has been locked. + -- This routine is needed because the field specifying the server for this + -- call must be protected by the server's mutex. If it were protected by + -- the caller's mutex, accessing the server's queues would require locking + -- the caller to get the server, locking the server, and then accessing the + -- queues. This involves holding two ATCB locks at once, something which we + -- can guarantee that it will always be done in the same order, or locking + -- a protected object while we hold an ATCB lock, something which is not + -- permitted. Since the server cannot be obtained reliably, it must be + -- obtained unreliably and then checked again once it has been locked. -- - -- If Single_Lock and server is a PO, release RTS_Lock. + -- If Single_Lock and server is a PO, release RTS_Lock -- -- This should only be called by the Entry_Call.Self. -- It should be holding no other ATCB locks at the time. @@ -123,23 +121,22 @@ package body System.Tasking.Entry_Calls is procedure Check_Pending_Actions_For_Entry_Call (Self_ID : Task_Id; Entry_Call : Entry_Call_Link); - -- This procedure performs priority change of a queued call and - -- dequeuing of an entry call when the call is cancelled. - -- If the call is dequeued the state should be set to Cancelled. - -- Call only with abort deferred and holding lock of Self_ID. This - -- is a bit of common code for all entry calls. The effect is to do - -- any deferred base priority change operation, in case some other - -- task called STPO.Set_Priority while the current task had abort deferred, - -- and to dequeue the call if the call has been aborted. + -- This procedure performs priority change of a queued call and dequeuing + -- of an entry call when the call is cancelled. If the call is dequeued the + -- state should be set to Cancelled. Call only with abort deferred and + -- holding lock of Self_ID. This is a bit of common code for all entry + -- calls. The effect is to do any deferred base priority change operation, + -- in case some other task called STPO.Set_Priority while the current task + -- had abort deferred, and to dequeue the call if the call has been + -- aborted. procedure Poll_Base_Priority_Change_At_Entry_Call (Self_ID : Task_Id; Entry_Call : Entry_Call_Link); pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); - -- A specialized version of Poll_Base_Priority_Change, - -- that does the optional entry queue reordering. - -- Has to be called with the Self_ID's ATCB write-locked. - -- May temporariliy release the lock. + -- A specialized version of Poll_Base_Priority_Change, that does the + -- optional entry queue reordering. Has to be called with the Self_ID's + -- ATCB write-locked. May temporariliy release the lock. --------------------- -- Check_Exception -- @@ -160,6 +157,7 @@ package body System.Tasking.Entry_Calls is Entry_Call.Exception_To_Raise; begin -- pragma Assert (Self_ID.Deferral_Level = 0); + -- The above may be useful for debugging, but the Florist packages -- contain critical sections that defer abort and then do entry calls, -- which causes the above Assert to trip. @@ -175,7 +173,8 @@ package body System.Tasking.Entry_Calls is procedure Check_Pending_Actions_For_Entry_Call (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) is + Entry_Call : Entry_Call_Link) + is begin pragma Assert (Self_ID = Entry_Call.Self); @@ -224,8 +223,8 @@ package body System.Tasking.Entry_Calls is loop if Test_Task = null then - -- Entry_Call was queued on a protected object, - -- or in transition, when we last fetched Test_Task. + -- Entry_Call was queued on a protected object, or in transition, + -- when we last fetched Test_Task. Test_PO := To_Protection (Entry_Call.Called_PO); @@ -249,12 +248,12 @@ package body System.Tasking.Entry_Calls is Lock_Entries (Test_PO, Ceiling_Violation); - -- ???? - -- The following code allows Lock_Server to be called - -- when cancelling a call, to allow for the possibility - -- that the priority of the caller has been raised - -- beyond that of the protected entry call by - -- Ada.Dynamic_Priorities.Set_Priority. + -- ??? + + -- The following code allows Lock_Server to be called when + -- cancelling a call, to allow for the possibility that the + -- priority of the caller has been raised beyond that of the + -- protected entry call by Ada.Dynamic_Priorities.Set_Priority. -- If the current task has a higher priority than the ceiling -- of the protected object, temporarily lower it. It will @@ -316,52 +315,18 @@ package body System.Tasking.Entry_Calls is procedure Poll_Base_Priority_Change_At_Entry_Call (Self_ID : Task_Id; - Entry_Call : Entry_Call_Link) is + Entry_Call : Entry_Call_Link) + is begin - if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then + if Self_ID.Pending_Priority_Change then + -- Check for ceiling violations ??? Self_ID.Pending_Priority_Change := False; - if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then - if Single_Lock then - STPO.Unlock_RTS; - STPO.Yield; - STPO.Lock_RTS; - else - STPO.Unlock (Self_ID); - STPO.Yield; - STPO.Write_Lock (Self_ID); - end if; - - else - if Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then - -- Raising priority - - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - - else - -- Lowering priority - - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - - if Single_Lock then - STPO.Unlock_RTS; - STPO.Yield; - STPO.Lock_RTS; - else - STPO.Unlock (Self_ID); - STPO.Yield; - STPO.Write_Lock (Self_ID); - end if; - end if; - end if; - - -- Requeue the entry call at the new priority. - -- We need to requeue even if the new priority is the same than - -- the previous (see ACVC cxd4006). + -- Requeue the entry call at the new priority. We need to requeue + -- even if the new priority is the same than the previous (see ACATS + -- test cxd4006). STPO.Unlock (Self_ID); Lock_Server (Entry_Call); @@ -378,7 +343,8 @@ package body System.Tasking.Entry_Calls is procedure Reset_Priority (Acceptor : Task_Id; - Acceptor_Prev_Priority : Rendezvous_Priority) is + Acceptor_Prev_Priority : Rendezvous_Priority) + is begin pragma Assert (Acceptor = STPO.Self); @@ -431,26 +397,19 @@ package body System.Tasking.Entry_Calls is Succeeded := Entry_Call.State = Cancelled; - if Succeeded then - Initialization.Undefer_Abort_Nestable (Self_ID); - else - -- ??? - - Initialization.Undefer_Abort_Nestable (Self_ID); + Initialization.Undefer_Abort_Nestable (Self_ID); - -- Ideally, abort should no longer be deferred at this - -- point, so we should be able to call Check_Exception. - -- The loop below should be considered temporary, - -- to work around the possiblility that abort may be deferred - -- more than one level deep. + -- Ideally, abort should no longer be deferred at this point, so we + -- should be able to call Check_Exception. The loop below should be + -- considered temporary, to work around the possibility that abort + -- may be deferred more than one level deep ??? - if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then - while Self_ID.Deferral_Level > 0 loop - System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); - end loop; + if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then + while Self_ID.Deferral_Level > 0 loop + System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); + end loop; - Entry_Calls.Check_Exception (Self_ID, Entry_Call); - end if; + Entry_Calls.Check_Exception (Self_ID, Entry_Call); end if; end Try_To_Cancel_Entry_Call; @@ -544,6 +503,7 @@ package body System.Tasking.Entry_Calls is procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is Self_Id : constant Task_Id := Entry_Call.Self; + begin -- If this is a conditional call, it should be cancelled when it -- becomes abortable. This is checked in the loop below. @@ -552,9 +512,11 @@ package body System.Tasking.Entry_Calls is Send_Trace_Info (W_Completion); end if; + Self_Id.Common.State := Entry_Caller_Sleep; + -- Try to remove calls to Sleep in the loop below by letting the caller -- a chance of getting ready immediately, using Unlock & Yield. - -- See similar action in Wait_For_Call & Selective_Wait. + -- See similar action in Wait_For_Call & Timed_Selective_Wait. if Single_Lock then STPO.Unlock_RTS; @@ -572,8 +534,6 @@ package body System.Tasking.Entry_Calls is STPO.Write_Lock (Self_Id); end if; - Self_Id.Common.State := Entry_Caller_Sleep; - loop Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); @@ -633,12 +593,11 @@ package body System.Tasking.Entry_Calls is Yielded := False; Self_Id.Common.State := Entry_Caller_Sleep; - -- Looping is necessary in case the task wakes up early from the - -- timed sleep, due to a "spurious wakeup". Spurious wakeups are - -- a weakness of POSIX condition variables. A thread waiting for - -- a condition variable is allowed to wake up at any time, not just - -- when the condition is signaled. See the same loop in the - -- ordinary Wait_For_Completion, above. + -- Looping is necessary in case the task wakes up early from the timed + -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of + -- POSIX condition variables. A thread waiting for a condition variable + -- is allowed to wake up at any time, not just when the condition is + -- signaled. See same loop in the ordinary Wait_For_Completion, above. if Parameters.Runtime_Traces then Send_Trace_Info (WT_Completion, Wakeup_Time); @@ -700,7 +659,8 @@ package body System.Tasking.Entry_Calls is procedure Wait_Until_Abortable (Self_ID : Task_Id; - Call : Entry_Call_Link) is + Call : Entry_Call_Link) + is begin pragma Assert (Self_ID.ATC_Nesting_Level > 0); pragma Assert (Call.Mode = Asynchronous_Call); diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb index 894ec292dae..ccd1c00cd86 100644 --- a/gcc/ada/s-taprop-dummy.adb +++ b/gcc/ada/s-taprop-dummy.adb @@ -64,8 +64,6 @@ package body System.Task_Primitives.Operations is -- Check_Exit -- ---------------- - -- Dummy version - function Check_Exit (Self_ID : ST.Task_Id) return Boolean is begin return True; @@ -266,7 +264,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Ceiling_Violation := False; end Read_Lock; @@ -310,6 +310,18 @@ package body System.Task_Primitives.Operations is return Null_Task; end Self; + ----------------- + -- Set_Ceiling -- + ----------------- + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + begin + null; + end Set_Ceiling; + --------------- -- Set_False -- --------------- @@ -420,7 +432,9 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) is + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) + is begin null; end Unlock; @@ -452,7 +466,9 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Ceiling_Violation := False; end Write_Lock; diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 4b43f1cde5c..416a36f6df7 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -74,8 +74,8 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Conversion; -with Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -167,7 +167,8 @@ package body System.Task_Primitives.Operations is procedure Abort_Handler (Sig : Signal); - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); ------------------- -- Abort_Handler -- @@ -182,15 +183,18 @@ package body System.Task_Primitives.Operations is begin if Self_Id.Deferral_Level = 0 - and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then - not Self_Id.Aborting + and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level + and then not Self_Id.Aborting then Self_Id.Aborting := True; -- Make sure signals used for RTS internal purpose are unmasked - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); pragma Assert (Result = 0); raise Standard'Abort_Signal; @@ -201,8 +205,8 @@ package body System.Task_Primitives.Operations is -- Stack_Guard -- ----------------- - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is @@ -230,12 +234,11 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore rasing Storage_Error in the following + -- routines should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -266,7 +269,9 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) is + (L : not null access RTS_Lock; + Level : Lock_Level) + is pragma Unreferenced (Level); Attributes : aliased pthread_mutexattr_t; @@ -315,7 +320,8 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; @@ -333,7 +339,8 @@ package body System.Task_Primitives.Operations is end Write_Lock; procedure Write_Lock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -357,7 +364,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -374,7 +383,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -393,6 +403,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -406,11 +431,13 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure @@ -451,18 +478,21 @@ package body System.Task_Primitives.Operations is Request := To_Timespec (Abs_Time); loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + 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; @@ -514,24 +544,20 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Delay_Sleep; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - 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; @@ -581,9 +607,7 @@ package body System.Task_Primitives.Operations is procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin Result := pthread_cond_signal (T.Common.LL.CV'Access); pragma Assert (Result = 0); @@ -613,8 +637,7 @@ package body System.Task_Primitives.Operations is -- Global array containing the id of the currently running task for -- each priority. -- - -- Note: we assume that we are on a single processor with run-til-blocked - -- scheduling. + -- Note: assume we are on single processor with run-til-blocked scheduling procedure Set_Priority (T : Task_Id; @@ -640,19 +663,22 @@ package body System.Task_Primitives.Operations is or else Priority_Specific_Policy = 'R' or else Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); elsif Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); end if; pragma Assert (Result = 0); @@ -763,8 +789,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -781,8 +808,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -816,7 +845,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Ada.Unchecked_Conversion (System.Address, Thread_Body); begin Result := pthread_attr_init (Attributes'Access); @@ -865,7 +894,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -902,9 +931,8 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is begin - -- -- Interrupt Server_Tasks may be waiting on an "event" flag (signal) - -- + if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then System.Interrupt_Management.Operations.Interrupt_Self_Process (System.Interrupt_Management.Interrupt_ID @@ -921,8 +949,7 @@ package body System.Task_Primitives.Operations is Cond_Attr : aliased pthread_condattr_t; Result : Interfaces.C.int; begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (ARM D.10(6))) S.State := False; S.Waiting := False; @@ -957,6 +984,7 @@ package body System.Task_Primitives.Operations is procedure Finalize (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -987,6 +1015,7 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1007,6 +1036,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1024,6 +1054,7 @@ package body System.Task_Primitives.Operations is Result := pthread_cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1040,6 +1071,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1158,10 +1190,10 @@ package body System.Task_Primitives.Operations is ---------------- procedure Initialize (Environment_Task : Task_Id) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; function State (Int : System.Interrupt_Management.Interrupt_ID) return Character; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 4b7b170ebc1..e18320d90fa 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -68,8 +68,8 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Conversion; -with Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -157,7 +157,8 @@ package body System.Task_Primitives.Operations is -- Local Subprograms -- ----------------------- - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); procedure Abort_Handler (Sig : Signal); -- Signal handler used to implement asynchronous abort @@ -229,12 +230,11 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore rasing Storage_Error in the following + -- routines should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -252,12 +252,14 @@ package body System.Task_Primitives.Operations is end if; if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); + Result := + pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); pragma Assert (Result = 0); - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (Prio)); + Result := + pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); pragma Assert (Result = 0); end if; @@ -274,7 +276,8 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); @@ -338,6 +341,7 @@ package body System.Task_Primitives.Operations is (L : not null access Lock; Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; + begin Result := pthread_mutex_lock (L); Ceiling_Violation := Result = EINVAL; @@ -390,10 +394,10 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_unlock (L); @@ -403,7 +407,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (T : Task_Id) is Result : Interfaces.C.int; - begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); @@ -411,6 +414,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -420,16 +438,17 @@ package body System.Task_Primitives.Operations is Reason : System.Tasking.Task_States) is pragma Unreferenced (Reason); - Result : Interfaces.C.int; begin if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure @@ -451,7 +470,8 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Reason); - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; @@ -470,21 +490,23 @@ package body System.Task_Primitives.Operations is Request := To_Timespec (Abs_Time); loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + 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; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; if Result = 0 or else errno = EINTR then Timedout := False; @@ -506,7 +528,8 @@ package body System.Task_Primitives.Operations is Time : Duration; Mode : ST.Delay_Modes) is - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; @@ -529,17 +552,22 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Delay_Sleep; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - exit when Abs_Time <= Monotonic_Clock; + if Single_Lock then + 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); + end if; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; pragma Assert (Result = 0 or else Result = ETIMEDOUT @@ -631,7 +659,7 @@ package body System.Task_Primitives.Operations is use type System.Task_Info.Task_Info_Type; - function To_Int is new Unchecked_Conversion + function To_Int is new Ada.Unchecked_Conversion (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); function Get_Policy (Prio : System.Any_Priority) return Character; @@ -680,7 +708,7 @@ package body System.Task_Primitives.Operations is procedure Enter_Task (Self_ID : Task_Id) is Result : Interfaces.C.int; - function To_Int is new Unchecked_Conversion + function To_Int is new Ada.Unchecked_Conversion (System.Task_Info.CPU_Number, Interfaces.C.int); use System.Task_Info; @@ -756,8 +784,8 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); + Result := + pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -794,13 +822,12 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - function To_Int is new Unchecked_Conversion + Ada.Unchecked_Conversion (System.Address, Thread_Body); + function To_Int is new Ada.Unchecked_Conversion (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int); - function To_Int is new Unchecked_Conversion + function To_Int is new Ada.Unchecked_Conversion (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int); - function To_Int is new Unchecked_Conversion + function To_Int is new Ada.Unchecked_Conversion (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); begin @@ -812,32 +839,38 @@ package body System.Task_Primitives.Operations is return; end if; - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); - Result := pthread_attr_setstacksize - (Attributes'Access, Interfaces.C.size_t (Stack_Size)); + Result := + pthread_attr_setstacksize + (Attributes'Access, Interfaces.C.size_t (Stack_Size)); pragma Assert (Result = 0); if T.Common.Task_Info /= null then - Result := pthread_attr_setscope - (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); + Result := + pthread_attr_setscope + (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); pragma Assert (Result = 0); - Result := pthread_attr_setinheritsched - (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance)); + Result := + pthread_attr_setinheritsched + (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance)); pragma Assert (Result = 0); - Result := pthread_attr_setschedpolicy - (Attributes'Access, To_Int (T.Common.Task_Info.Policy)); + Result := + pthread_attr_setschedpolicy + (Attributes'Access, To_Int (T.Common.Task_Info.Policy)); pragma Assert (Result = 0); Sched_Param.sched_priority := Interfaces.C.int (T.Common.Task_Info.Priority); - Result := pthread_attr_setschedparam - (Attributes'Access, Sched_Param'Access); + Result := + pthread_attr_setschedparam + (Attributes'Access, Sched_Param'Access); pragma Assert (Result = 0); end if; @@ -846,21 +879,21 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); if Result /= 0 and then T.Common.Task_Info /= null and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM then - -- The pthread_create call may have failed because we - -- asked for a system scope pthread and none were - -- available (probably because the program was not executed - -- by the superuser). Let's try for a process scope pthread - -- instead of raising Tasking_Error. + -- The pthread_create call may have failed because we asked for a + -- system scope pthread and none were available (probably because + -- the program was not executed by the superuser). Let's try for + -- a process scope pthread instead of raising Tasking_Error. System.IO.Put_Line ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task"); @@ -870,15 +903,17 @@ package body System.Task_Primitives.Operations is System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS"); T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS; - Result := pthread_attr_setscope - (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); + Result := + pthread_attr_setscope + (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); pragma Assert (Result = 0); - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); end if; pragma Assert (Result = 0 or else Result = EAGAIN); @@ -908,7 +943,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -946,8 +981,10 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : Interfaces.C.int; begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; @@ -959,9 +996,9 @@ package body System.Task_Primitives.Operations is Mutex_Attr : aliased pthread_mutexattr_t; Cond_Attr : aliased pthread_condattr_t; Result : Interfaces.C.int; + begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (RM D.10(6)) S.State := False; S.Waiting := False; @@ -1012,7 +1049,6 @@ package body System.Task_Primitives.Operations is if Result = ENOMEM then Result := pthread_condattr_destroy (Cond_Attr'Access); pragma Assert (Result = 0); - raise Storage_Error; end if; end if; @@ -1026,7 +1062,8 @@ package body System.Task_Primitives.Operations is -------------- procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -1056,7 +1093,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1077,6 +1115,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1094,6 +1133,7 @@ package body System.Task_Primitives.Operations is Result := pthread_cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1110,6 +1150,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1117,9 +1158,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). + -- (RM D.10(10)). Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); @@ -1273,8 +1315,8 @@ package body System.Task_Primitives.Operations is -- Install the abort-signal handler - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default then act.sa_flags := 0; act.sa_handler := Abort_Handler'Address; @@ -1284,10 +1326,10 @@ package body System.Task_Primitives.Operations is act.sa_mask := Tmp_Set; Result := - sigaction ( - Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); pragma Assert (Result = 0); end if; end Initialize; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index c945f5c9d7e..8d149590fbc 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -71,8 +71,8 @@ with Ada.Exceptions; -- Raise_From_Signal_Handler -- Exception_Id -with Unchecked_Conversion; -with Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -110,8 +110,7 @@ package body System.Task_Primitives.Operations is -- The followings are internal configuration constants needed Next_Serial_Number : Task_Serial_Number := 100; - -- We start at 100, to reserve some special values for - -- using in error checking. + -- We start at 100 (reserve some special values for using in error checks) Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); @@ -119,8 +118,8 @@ package body System.Task_Primitives.Operations is Dispatching_Policy : Character; pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - -- The following are effectively constants, but they need to - -- be initialized by calling a pthread_ function. + -- The following are effectively constants, but they need to be initialized + -- by calling a pthread_ function. Mutex_Attr : aliased pthread_mutexattr_t; Cond_Attr : aliased pthread_condattr_t; @@ -173,7 +172,7 @@ package body System.Task_Primitives.Operations is procedure Abort_Handler (signo : Signal); - function To_pthread_t is new Unchecked_Conversion + function To_pthread_t is new Ada.Unchecked_Conversion (unsigned_long, System.OS_Interface.pthread_t); ------------------- @@ -200,8 +199,11 @@ package body System.Task_Primitives.Operations is -- Make sure signals used for RTS internal purpose are unmasked - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); pragma Assert (Result = 0); raise Standard'Abort_Signal; @@ -272,6 +274,7 @@ package body System.Task_Primitives.Operations is pragma Unreferenced (Prio); Result : Interfaces.C.int; + begin Result := pthread_mutex_init (L, Mutex_Attr'Access); @@ -284,7 +287,8 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); @@ -323,7 +327,8 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; begin @@ -361,7 +366,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -378,7 +385,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -397,6 +405,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -413,11 +436,13 @@ package body System.Task_Primitives.Operations is pragma Assert (Self_ID = Self); if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure @@ -443,7 +468,8 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Reason); - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; @@ -462,24 +488,30 @@ package body System.Task_Primitives.Operations is Request := To_Timespec (Abs_Time); loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + 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; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + if Result = 0 or else Result = EINTR then + + -- Somebody may have called Wakeup for us - if Result = 0 or Result = EINTR then - -- somebody may have called Wakeup for us Timedout := False; exit; end if; @@ -493,16 +525,16 @@ 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) is - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; @@ -527,12 +559,6 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Delay_Sleep; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then @@ -547,7 +573,8 @@ package body System.Task_Primitives.Operations is Request'Access); end if; - exit when Abs_Time <= Monotonic_Clock; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; pragma Assert (Result = 0 or else Result = ETIMEDOUT or else @@ -638,8 +665,7 @@ package body System.Task_Primitives.Operations is begin T.Common.Current_Priority := Prio; - -- Priorities are in range 1 .. 99 on GNU/Linux, so we map - -- map 0 .. 98 to 1 .. 99 + -- Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99 Param.sched_priority := Interfaces.C.int (Prio) + 1; @@ -647,20 +673,24 @@ package body System.Task_Primitives.Operations is or else Priority_Specific_Policy = 'R' or else Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); elsif Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else Param.sched_priority := 0; - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, + SCHED_OTHER, Param'Access); end if; pragma Assert (Result = 0 or else Result = EPERM); @@ -832,7 +862,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -870,8 +900,10 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : Interfaces.C.int; begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; @@ -881,9 +913,9 @@ package body System.Task_Primitives.Operations is procedure Initialize (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (RM D.10(6))) S.State := False; S.Waiting := False; @@ -919,7 +951,8 @@ package body System.Task_Primitives.Operations is -------------- procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -949,7 +982,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -970,6 +1004,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -987,6 +1022,7 @@ package body System.Task_Primitives.Operations is Result := pthread_cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1003,6 +1039,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1010,9 +1047,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). + -- (RM D.10(10)). Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); @@ -1036,7 +1074,8 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); SSL.Abort_Undefer.all; - end if; + end + if; end Suspend_Until_True; ---------------- @@ -1159,8 +1198,8 @@ package body System.Task_Primitives.Operations is -- Install the abort-signal handler - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default then act.sa_flags := 0; act.sa_handler := Abort_Handler'Address; diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb index 272d8981aa6..361d6fa67fb 100644 --- a/gcc/ada/s-taprop-lynxos.adb +++ b/gcc/ada/s-taprop-lynxos.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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,7 +67,7 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Deallocation; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -190,17 +190,18 @@ package body System.Task_Primitives.Operations is end if; if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then - not T.Aborting + and then T.Pending_ATC_Level < T.ATC_Nesting_Level + and then not T.Aborting then T.Aborting := True; -- Make sure signals used for RTS internal purpose are unmasked Result := - pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, - Old_Set'Unchecked_Access); + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); pragma Assert (Result = 0); raise Standard'Abort_Signal; @@ -285,12 +286,13 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; + Result : Interfaces.C.int; begin Result := pthread_mutexattr_init (Attributes'Access); @@ -335,10 +337,11 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; - T : constant Task_Id := Self; + T : constant Task_Id := Self; begin if Locking_Policy = 'C' then @@ -365,7 +368,8 @@ package body System.Task_Primitives.Operations is -- No tricks on RTS_Locks procedure Write_Lock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -389,7 +393,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -400,7 +406,7 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : not null access Lock) is Result : Interfaces.C.int; - T : constant Task_Id := Self; + T : constant Task_Id := Self; begin Result := pthread_mutex_unlock (L.Mutex'Access); @@ -414,7 +420,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -433,6 +440,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -446,11 +468,13 @@ package body System.Task_Primitives.Operations is begin if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure @@ -476,7 +500,8 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Reason); - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Rel_Time : Duration; Abs_Time : Duration; Request : aliased timespec; @@ -509,21 +534,23 @@ package body System.Task_Primitives.Operations is end if; loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + 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; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; if Result = 0 or Result = EINTR then @@ -550,7 +577,8 @@ package body System.Task_Primitives.Operations is Time : Duration; Mode : ST.Delay_Modes) is - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Rel_Time : Duration; Request : aliased timespec; @@ -592,31 +620,28 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Delay_Sleep; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - 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; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - pragma Assert (Result = 0 - or else Result = ETIMEDOUT - or else Result = EINTR); + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); end loop; Self_ID.Common.State := Runnable; @@ -639,8 +664,9 @@ package body System.Task_Primitives.Operations is TS : aliased timespec; Result : Interfaces.C.int; begin - Result := clock_gettime - (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); + Result := + clock_gettime + (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (TS); end Monotonic_Clock; @@ -653,8 +679,9 @@ package body System.Task_Primitives.Operations is Res : aliased timespec; Result : Interfaces.C.int; begin - Result := clock_getres - (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access); + Result := + clock_getres + (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access); pragma Assert (Result = 0); return To_Duration (Res); end RT_Resolution; @@ -705,22 +732,25 @@ package body System.Task_Primitives.Operations is if Time_Slice_Supported and then (Dispatching_Policy = 'R' - or else Priority_Specific_Policy = 'R' - or else Time_Slice_Val > 0) + or else Priority_Specific_Policy = 'R' + or else Time_Slice_Val > 0) then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); elsif Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); end if; pragma Assert (Result = 0); @@ -742,9 +772,9 @@ package body System.Task_Primitives.Operations is Set_OS_Priority (T, Prio); if Locking_Policy = 'C' then - -- Annex D requirements: loss of inheritance puts task at the - -- beginning of the queue for that prio; copied from 5ztaprop - -- (VxWorks) + + -- Annex D requirements: loss of inheritance puts task at the start + -- of the queue for that prio; copied from 5ztaprop (VxWorks). if Loss_Of_Inheritance and then Prio < T.Common.Current_Priority then @@ -848,8 +878,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -866,8 +897,8 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); + Result := + pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -909,7 +940,7 @@ package body System.Task_Primitives.Operations is if Stack_Base_Available then -- If Stack Checking is supported then allocate 2 additional pages: - -- + -- In the worst case, stack is allocated at something like -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages -- to be sure the effective stack size is greater than what @@ -926,12 +957,14 @@ package body System.Task_Primitives.Operations is return; end if; - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); if T.Common.Task_Info /= Default_Scope then @@ -939,8 +972,9 @@ package body System.Task_Primitives.Operations is -- We are assuming that Scope_Type has the same values than the -- corresponding C macros - Result := pthread_attr_setscope - (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); + Result := + pthread_attr_setscope + (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); pragma Assert (Result = 0); end if; @@ -949,11 +983,12 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); pragma Assert (Result = 0 or else Result = EAGAIN); Succeeded := Result = 0; @@ -974,7 +1009,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -995,7 +1030,6 @@ package body System.Task_Primitives.Operations is Result := st_setspecific (ATCB_Key, System.Null_Address); pragma Assert (Result = 0); end if; - end Finalize_TCB; --------------- @@ -1014,8 +1048,10 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : Interfaces.C.int; begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; @@ -1029,8 +1065,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (RM D.10(6))) S.State := False; S.Waiting := False; @@ -1095,7 +1130,8 @@ package body System.Task_Primitives.Operations is -------------- procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -1125,7 +1161,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1146,6 +1183,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1154,8 +1192,7 @@ package body System.Task_Primitives.Operations is -- If there is already a task waiting on this suspension object then -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. + -- as specified in (RM D.10(9)). Otherwise, just leave state set True. if S.Waiting then S.Waiting := False; @@ -1163,6 +1200,7 @@ package body System.Task_Primitives.Operations is Result := pthread_cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1179,6 +1217,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1186,9 +1225,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). + -- (RM D.10 (10)). Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); @@ -1196,10 +1236,11 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). + -- is set to False (RM D.10(9)). if S.State then S.State := False; @@ -1219,7 +1260,7 @@ package body System.Task_Primitives.Operations is -- Check_Exit -- ---------------- - -- Dummy versions + -- Dummy version function Check_Exit (Self_ID : ST.Task_Id) return Boolean is pragma Unreferenced (Self_ID); @@ -1343,8 +1384,8 @@ package body System.Task_Primitives.Operations is -- Install the abort-signal handler - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default then act.sa_flags := 0; act.sa_handler := Abort_Handler'Address; @@ -1355,9 +1396,9 @@ package body System.Task_Primitives.Operations is Result := sigaction - (Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); pragma Assert (Result = 0); end if; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 5656932face..1c979355b20 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -62,12 +62,12 @@ with System.Interrupt_Management; with System.Soft_Links; -- used for Abort_Defer/Undefer --- We use System.Soft_Links instead of System.Tasking.Initialization --- because the later is a higher level package that we shouldn't depend on. --- For example when using the restricted run time, it is replaced by +-- We use System.Soft_Links instead of System.Tasking.Initialization because +-- the later is a higher level package that we shouldn't depend on. For +-- example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Deallocation; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -113,6 +113,9 @@ package body System.Task_Primitives.Operations is Foreign_Task_Elaborated : aliased Boolean := True; -- Used to identified fake tasks (i.e., non-Ada Threads) + Annex_D : Boolean := False; + -- Set to True if running with Annex-D semantics + ------------------------------------ -- The thread local storage index -- ------------------------------------ @@ -200,7 +203,6 @@ package body System.Task_Primitives.Operations is procedure Initialize_Cond (Cond : not null access Condition_Variable) is hEvent : HANDLE; - begin hEvent := CreateEvent (null, True, False, Null_Ptr); pragma Assert (hEvent /= 0); @@ -236,10 +238,10 @@ package body System.Task_Primitives.Operations is -- Cond_Wait -- --------------- - -- Pre-assertion: Cond is posted + -- Pre-condition: Cond is posted -- L is locked. - -- Post-assertion: Cond is posted + -- Post-condition: Cond is posted -- L is locked. procedure Cond_Wait @@ -254,7 +256,7 @@ package body System.Task_Primitives.Operations is Result_Bool := ResetEvent (HANDLE (Cond.all)); pragma Assert (Result_Bool = True); - Unlock (L); + Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, -- WaitForSingleObject will simply not block @@ -262,17 +264,17 @@ package body System.Task_Primitives.Operations is Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite); pragma Assert (Result = 0); - Write_Lock (L); + Write_Lock (L, Global_Lock => True); end Cond_Wait; --------------------- -- Cond_Timed_Wait -- --------------------- - -- Pre-assertion: Cond is posted + -- Pre-condition: Cond is posted -- L is locked. - -- Post-assertion: Cond is posted + -- Post-condition: Cond is posted -- L is locked. procedure Cond_Timed_Wait @@ -283,19 +285,18 @@ package body System.Task_Primitives.Operations is Status : out Integer) is Time_Out_Max : constant DWORD := 16#FFFF0000#; - -- NT 4 cannot handle timeout values that are too large, - -- e.g. DWORD'Last - 1 + -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1) - Time_Out : DWORD; - Result : BOOL; - Wait_Result : DWORD; + Time_Out : DWORD; + Result : BOOL; + Wait_Result : DWORD; begin -- Must reset Cond BEFORE L is unlocked Result := ResetEvent (HANDLE (Cond.all)); pragma Assert (Result = True); - Unlock (L); + Unlock (L, Global_Lock => True); -- No problem if we are interrupted here: if the condition is signaled, -- WaitForSingleObject will simply not block @@ -321,7 +322,7 @@ package body System.Task_Primitives.Operations is end if; end if; - Write_Lock (L); + Write_Lock (L, Global_Lock => True); -- Ensure post-condition @@ -337,14 +338,12 @@ package body System.Task_Primitives.Operations is -- Stack_Guard -- ------------------ - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is - pragma Warnings (Off, T); - pragma Warnings (Off, On); - + pragma Unreferenced (T, On); begin null; end Stack_Guard; @@ -376,12 +375,11 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Intialize_TCB and the Storage_Error is handled. - -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in - -- the RTS is initialized before any status change of RTS. - -- Therefore raising Storage_Error in the following routines - -- should be able to be handled safely. + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Intialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any + -- status change of RTS. Therefore raising Storage_Error in the following + -- routines should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -487,6 +485,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -518,9 +531,8 @@ package body System.Task_Primitives.Operations is -- Timed_Sleep -- ----------------- - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. + -- This is for use within the run-time system, so abort is assumed to be + -- already deferred, and the caller should be holding its own ATCB lock. procedure Timed_Sleep (Self_ID : Task_Id; @@ -552,15 +564,18 @@ package body System.Task_Primitives.Operations is if Rel_Time > 0.0 then loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result); + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Rel_Time, Local_Timedout, Result); else - Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Rel_Time, Local_Timedout, Result); end if; Check_Time := Monotonic_Clock; @@ -615,22 +630,18 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Delay_Sleep; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Rel_Time, Timedout, Result); + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + 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); + Cond_Timed_Wait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Rel_Time, Timedout, Result); end if; Check_Time := Monotonic_Clock; @@ -668,7 +679,17 @@ package body System.Task_Primitives.Operations is procedure Yield (Do_Yield : Boolean := True) is begin if Do_Yield then - Sleep (0); + SwitchToThread; + + elsif Annex_D then + -- If running with Annex-D semantics we need a delay + -- above 0 milliseconds here otherwise processes give + -- enough time to the other tasks to have a chance to + -- run. + -- + -- This makes cxd8002 ACATS pass on Windows. + + Sleep (1); end if; end Yield; @@ -748,7 +769,7 @@ package body System.Task_Primitives.Operations is -- 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. + -- 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 @@ -923,7 +944,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -1014,19 +1035,13 @@ package body System.Task_Primitives.Operations is Interrupt_Management.Initialize; if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then - -- Here we need Annex D semantics, switch the current process to the - -- High_Priority_Class. + -- Realtime_Priority_Class. - Discard := - OS_Interface.SetPriorityClass - (GetCurrentProcess, High_Priority_Class); + Discard := OS_Interface.SetPriorityClass + (GetCurrentProcess, Realtime_Priority_Class); - -- ??? In theory it should be possible to use the priority class - -- 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. + Annex_D := True; end if; TlsIndex := TlsAlloc; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 315db0e8e56..b7a4383e76f 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-2007, 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- -- @@ -72,8 +72,8 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Conversion; -with Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -174,34 +174,34 @@ package body System.Task_Primitives.Operations is -- Signal handler used to implement asynchronous abort. -- See also comment before body, below. - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); ------------------- -- Abort_Handler -- ------------------- - -- Target-dependent binding of inter-thread Abort signal to - -- the raising of the Abort_Signal exception. + -- Target-dependent binding of inter-thread Abort signal to the raising of + -- the Abort_Signal exception. - -- The technical issues and alternatives here are essentially - -- the same as for raising exceptions in response to other - -- signals (e.g. Storage_Error). See code and comments in - -- the package body System.Interrupt_Management. + -- The technical issues and alternatives here are essentially the + -- same as for raising exceptions in response to other signals + -- (e.g. Storage_Error). See code and comments in the package body + -- System.Interrupt_Management. - -- Some implementations may not allow an exception to be propagated - -- out of a handler, and others might leave the signal or - -- interrupt that invoked this handler masked after the exceptional - -- return to the application code. + -- Some implementations may not allow an exception to be propagated out of + -- a handler, and others might leave the signal or interrupt that invoked + -- this handler masked after the exceptional return to the application + -- code. - -- GNAT exceptions are originally implemented using setjmp()/longjmp(). - -- On most UNIX systems, this will allow transfer out of a signal handler, + -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On + -- most UNIX systems, this will allow transfer out of a signal handler, -- which is usually the only mechanism available for implementing - -- asynchronous handlers of this kind. However, some - -- systems do not restore the signal mask on longjmp(), leaving the - -- abort signal masked. + -- asynchronous handlers of this kind. However, some systems do not + -- restore the signal mask on longjmp(), leaving the abort signal masked. procedure Abort_Handler (Sig : Signal) is - pragma Warnings (Off, Sig); + pragma Unreferenced (Sig); T : constant Task_Id := Self; Result : Interfaces.C.int; @@ -330,7 +330,7 @@ package body System.Task_Primitives.Operations is procedure Initialize_Lock (L : not null access RTS_Lock; Level : Lock_Level) is - pragma Warnings (Off, Level); + pragma Unreferenced (Level); Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; @@ -376,7 +376,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : not null access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); @@ -384,7 +383,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : not null access RTS_Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_destroy (L); pragma Assert (Result = 0); @@ -413,7 +411,6 @@ package body System.Task_Primitives.Operations is Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_lock (L); @@ -423,7 +420,6 @@ package body System.Task_Primitives.Operations is procedure Write_Lock (T : Task_Id) is Result : Interfaces.C.int; - begin if not Single_Lock then Result := pthread_mutex_lock (T.Common.LL.L'Access); @@ -447,7 +443,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (L : not null access Lock) is Result : Interfaces.C.int; - begin Result := pthread_mutex_unlock (L); pragma Assert (Result = 0); @@ -457,7 +452,6 @@ package body System.Task_Primitives.Operations is (L : not null access RTS_Lock; Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then Result := pthread_mutex_unlock (L); @@ -467,7 +461,6 @@ package body System.Task_Primitives.Operations is procedure Unlock (T : Task_Id) is Result : Interfaces.C.int; - begin if not Single_Lock then Result := pthread_mutex_unlock (T.Common.LL.L'Access); @@ -475,6 +468,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -483,17 +491,19 @@ package body System.Task_Primitives.Operations is (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is - pragma Warnings (Off, Reason); + pragma Unreferenced (Reason); Result : Interfaces.C.int; begin if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure @@ -517,9 +527,10 @@ package body System.Task_Primitives.Operations is Timedout : out Boolean; Yielded : out Boolean) is - pragma Warnings (Off, Reason); + pragma Unreferenced (Reason); - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Rel_Time : Duration; Abs_Time : Duration; Request : aliased timespec; @@ -552,21 +563,23 @@ package body System.Task_Primitives.Operations is end if; loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + 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; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; if Result = 0 or Result = EINTR then @@ -593,7 +606,8 @@ package body System.Task_Primitives.Operations is Time : Duration; Mode : ST.Delay_Modes) is - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Rel_Time : Duration; Request : aliased timespec; @@ -633,12 +647,6 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Delay_Sleep; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then @@ -653,7 +661,8 @@ package body System.Task_Primitives.Operations is Request'Access); end if; - exit when Abs_Time <= Monotonic_Clock; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; pragma Assert (Result = 0 or else Result = ETIMEDOUT @@ -700,7 +709,7 @@ package body System.Task_Primitives.Operations is ------------ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is - pragma Warnings (Off, Reason); + pragma Unreferenced (Reason); Result : Interfaces.C.int; begin Result := pthread_cond_signal (T.Common.LL.CV'Access); @@ -729,7 +738,7 @@ package body System.Task_Primitives.Operations is Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is - pragma Warnings (Off, Loss_Of_Inheritance); + pragma Unreferenced (Loss_Of_Inheritance); Result : Interfaces.C.int; Param : aliased struct_sched_param; @@ -852,23 +861,30 @@ package body System.Task_Primitives.Operations is if Result = 0 then if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_PROTECT); pragma Assert (Result = 0); - Result := pthread_mutexattr_setprioceiling - (Mutex_Attr'Access, - Interfaces.C.int (System.Any_Priority'Last)); + Result := + pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, + Interfaces.C.int (System.Any_Priority'Last)); pragma Assert (Result = 0); elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT); + Result := + pthread_mutexattr_setprotocol + (Mutex_Attr'Access, + PTHREAD_PRIO_INHERIT); pragma Assert (Result = 0); end if; - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -885,8 +901,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -921,7 +938,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Ada.Unchecked_Conversion (System.Address, Thread_Body); use System.Task_Info; @@ -929,8 +946,9 @@ package body System.Task_Primitives.Operations is Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); if Stack_Base_Available then + -- If Stack Checking is supported then allocate 2 additional pages: - -- + -- In the worst case, stack is allocated at something like -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages -- to be sure the effective stack size is greater than what @@ -947,23 +965,27 @@ package body System.Task_Primitives.Operations is return; end if; - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); if T.Common.Task_Info /= Default_Scope then case T.Common.Task_Info is when System.Task_Info.Process_Scope => - Result := pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_PROCESS); + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_PROCESS); when System.Task_Info.System_Scope => - Result := pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_SYSTEM); + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_SYSTEM); when System.Task_Info.Default_Scope => Result := 0; @@ -1002,7 +1024,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -1043,8 +1065,10 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : Interfaces.C.int; begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; @@ -1056,9 +1080,9 @@ package body System.Task_Primitives.Operations is Mutex_Attr : aliased pthread_mutexattr_t; Cond_Attr : aliased pthread_condattr_t; Result : Interfaces.C.int; + begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (RM D.10 (6))) S.State := False; S.Waiting := False; @@ -1109,7 +1133,6 @@ package body System.Task_Primitives.Operations is if Result = ENOMEM then Result := pthread_condattr_destroy (Cond_Attr'Access); pragma Assert (Result = 0); - raise Storage_Error; end if; end if; @@ -1123,7 +1146,8 @@ package body System.Task_Primitives.Operations is -------------- procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -1153,7 +1177,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1174,6 +1199,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1182,7 +1208,7 @@ package body System.Task_Primitives.Operations is -- If there is already a task waiting on this suspension object then -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves + -- as it is specified in (RM D.10(9)). Otherwise, it just leaves -- the state to True. if S.Waiting then @@ -1191,6 +1217,7 @@ package body System.Task_Primitives.Operations is Result := pthread_cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1207,6 +1234,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1214,9 +1242,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). + -- (RM D.10(10)). Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); @@ -1224,6 +1253,7 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object @@ -1250,7 +1280,7 @@ package body System.Task_Primitives.Operations is -- Dummy version function Check_Exit (Self_ID : ST.Task_Id) return Boolean is - pragma Warnings (Off, Self_ID); + pragma Unreferenced (Self_ID); begin return True; end Check_Exit; @@ -1260,7 +1290,7 @@ package body System.Task_Primitives.Operations is -------------------- function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is - pragma Warnings (Off, Self_ID); + pragma Unreferenced (Self_ID); begin return True; end Check_No_Locks; @@ -1300,8 +1330,7 @@ package body System.Task_Primitives.Operations is (T : ST.Task_Id; Thread_Self : Thread_Id) return Boolean is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); + pragma Unreferenced (T, Thread_Self); begin return False; end Suspend_Task; @@ -1314,8 +1343,7 @@ package body System.Task_Primitives.Operations is (T : ST.Task_Id; Thread_Self : Thread_Id) return Boolean is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); + pragma Unreferenced (T, Thread_Self); begin return False; end Resume_Task; @@ -1371,8 +1399,8 @@ package body System.Task_Primitives.Operations is -- Install the abort-signal handler - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default then act.sa_flags := 0; act.sa_handler := Abort_Handler'Address; @@ -1383,9 +1411,9 @@ package body System.Task_Primitives.Operations is Result := sigaction - (Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); pragma Assert (Result = 0); end if; end Initialize; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index c17bf6d958f..3cf44f74756 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -52,7 +52,7 @@ with System.OS_Primitives; -- used for Delay_Modes pragma Warnings (Off); -with GNAT.OS_Lib; +with System.OS_Lib; -- used for String_Access, Getenv pragma Warnings (On); @@ -72,7 +72,7 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Deallocation; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -287,8 +287,11 @@ package body System.Task_Primitives.Operations is -- Make sure signals used for RTS internal purpose are unmasked - Result := thr_sigsetmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + Result := + thr_sigsetmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); pragma Assert (Result = 0); raise Standard'Abort_Signal; @@ -346,8 +349,8 @@ package body System.Task_Primitives.Operations is -- _SC_NPROCESSORS_CONF, minus one. procedure Configure_Processors is - Proc_Acc : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR"); + Proc_Acc : constant System.OS_Lib.String_Access := + System.OS_Lib.Getenv ("GNAT_PROCESSOR"); Proc : aliased processorid_t; -- User processor # Last_Proc : processorid_t; -- Last processor # @@ -362,13 +365,16 @@ package body System.Task_Primitives.Operations is Proc := processorid_t'Value (Proc_Acc.all); if Proc <= -2 or else Proc > Last_Proc then + -- Use the default configuration + null; + elsif Proc = -1 then + -- Choose a processor Result := 0; - while Proc < Last_Proc loop Proc := Proc + 1; Result := p_online (Proc, PR_STATUS); @@ -440,8 +446,7 @@ package body System.Task_Primitives.Operations is if Time_Slice_Val > 0 then - -- Convert Time_Slice_Val (microseconds) into seconds and - -- nanoseconds + -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000); Nsecs := @@ -470,8 +475,9 @@ package body System.Task_Primitives.Operations is Prio_Param.rt_tqsecs := Secs; Prio_Param.rt_tqnsecs := Nsecs; - Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, - Prio_Param'Address); + Result := + priocntl + (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address); Using_Real_Time_Class := Result /= -1; end; @@ -493,8 +499,8 @@ package body System.Task_Primitives.Operations is -- Install the abort-signal handler - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default then -- Set sa_flags to SA_NODEFER so that during the handler execution -- we do not change the Signal_Mask to be masked for the Abort_Signal @@ -512,10 +518,10 @@ package body System.Task_Primitives.Operations is act.sa_mask := Tmp_Set; Result := - sigaction ( - Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); pragma Assert (Result = 0); end if; @@ -526,12 +532,11 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore rasing Storage_Error in the following + -- routines should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -561,8 +566,8 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin - pragma Assert (Check_Initialize_Lock - (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level)); + pragma Assert + (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level)); Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -577,7 +582,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : not null access Lock) is Result : Interfaces.C.int; - begin pragma Assert (Check_Finalize_Lock (Lock_Ptr (L))); Result := mutex_destroy (L.L'Access); @@ -586,7 +590,6 @@ package body System.Task_Primitives.Operations is procedure Finalize_Lock (L : not null access RTS_Lock) is Result : Interfaces.C.int; - begin pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); Result := mutex_destroy (L.L'Access); @@ -598,7 +601,8 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; @@ -643,7 +647,6 @@ package body System.Task_Primitives.Operations is Global_Lock : Boolean := False) is Result : Interfaces.C.int; - begin if not Single_Lock or else Global_Lock then pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); @@ -655,7 +658,6 @@ package body System.Task_Primitives.Operations is procedure Write_Lock (T : Task_Id) is Result : Interfaces.C.int; - begin if not Single_Lock then pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); @@ -670,7 +672,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -680,7 +683,7 @@ package body System.Task_Primitives.Operations is ------------ procedure Unlock (L : not null access Lock) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; begin pragma Assert (Check_Unlock (Lock_Ptr (L))); @@ -704,7 +707,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -725,6 +729,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + -- For the time delay implementation, we need to make sure we -- achieve following criteria: @@ -795,7 +814,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; pragma Unreferenced (Result); - Param : aliased struct_pcparms; + Param : aliased struct_pcparms; use Task_Info; @@ -867,7 +886,6 @@ package body System.Task_Primitives.Operations is if Self_ID.Common.Task_Info.CPU = ANY_CPU then Result := 0; Proc := 0; - while Proc < Last_Proc loop Result := p_online (Proc, PR_STATUS); exit when Result = PR_ONLINE; @@ -886,8 +904,9 @@ package body System.Task_Primitives.Operations is raise Invalid_CPU_Number; end if; - Result := processor_bind - (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); + Result := + processor_bind + (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); pragma Assert (Result = 0); end if; end if; @@ -956,8 +975,9 @@ package body System.Task_Primitives.Operations is Self_ID.Common.LL.Thread := To_thread_t (-1); if not Single_Lock then - Result := mutex_init - (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); + Result := + mutex_init + (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); Self_ID.Common.LL.L.Level := Private_Task_Serial_Number (Self_ID.Serial_Number); pragma Assert (Result = 0 or else Result = ENOMEM); @@ -1027,13 +1047,14 @@ package body System.Task_Primitives.Operations is Opts := THR_DETACHED + THR_BOUND; end if; - Result := thr_create - (System.Null_Address, - Adjusted_Stack_Size, - Thread_Body_Access (Wrapper), - To_Address (T), - Opts, - T.Common.LL.Thread'Access); + Result := + thr_create + (System.Null_Address, + Adjusted_Stack_Size, + Thread_Body_Access (Wrapper), + To_Address (T), + Opts, + T.Common.LL.Thread'Access); Succeeded := Result = 0; pragma Assert @@ -1047,12 +1068,12 @@ package body System.Task_Primitives.Operations is ------------------ procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - Tmp : Task_Id := T; + Result : Interfaces.C.int; + Tmp : Task_Id := T; Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin T.Common.LL.Thread := To_thread_t (0); @@ -1080,9 +1101,9 @@ package body System.Task_Primitives.Operations is -- Exit_Task -- --------------- - -- This procedure must be called with abort deferred. - -- It can no longer call Self or access - -- the current task's ATCB, since the ATCB has been deallocated. + -- This procedure must be called with abort deferred. It can no longer + -- call Self or access the current task's ATCB, since the ATCB has been + -- deallocated. procedure Exit_Task is begin @@ -1097,9 +1118,10 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; begin pragma Assert (T /= Self); - - Result := thr_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + Result := + thr_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; @@ -1116,24 +1138,18 @@ package body System.Task_Primitives.Operations is begin pragma Assert (Check_Sleep (Reason)); - if Dynamic_Priority_Support - and then Self_ID.Pending_Priority_Change - then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - if Single_Lock then - Result := cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); + Result := + cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); else - Result := cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); + Result := + cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); end if; - pragma Assert (Record_Wakeup - (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); + pragma Assert + (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); pragma Assert (Result = 0 or else Result = EINTR); end Sleep; @@ -1214,7 +1230,8 @@ package body System.Task_Primitives.Operations is Timedout : out Boolean; Yielded : out Boolean) is - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; @@ -1234,21 +1251,24 @@ package body System.Task_Primitives.Operations is Request := To_Timespec (Abs_Time); loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else (Dynamic_Priority_Support and then - Self_ID.Pending_Priority_Change); + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock.L'Access, Request'Access); + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock.L'Access, Request'Access); else - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L.L'Access, Request'Access); + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L.L'Access, Request'Access); end if; Yielded := True; - exit when Abs_Time <= Monotonic_Clock; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; if Result = 0 or Result = EINTR then @@ -1262,8 +1282,8 @@ package body System.Task_Primitives.Operations is end loop; end if; - pragma Assert (Record_Wakeup - (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); + pragma Assert + (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); end Timed_Sleep; ----------------- @@ -1275,7 +1295,8 @@ package body System.Task_Primitives.Operations is Time : Duration; Mode : ST.Delay_Modes) is - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; @@ -1301,38 +1322,36 @@ package body System.Task_Primitives.Operations is pragma Assert (Check_Sleep (Delay_Sleep)); loop - if Dynamic_Priority_Support and then - Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; if Single_Lock then - Result := cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock.L'Access, - Request'Access); + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock.L'Access, + Request'Access); else - Result := cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L.L'Access, - Request'Access); + Result := + cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L.L'Access, + Request'Access); end if; Yielded := True; - exit when Abs_Time <= Monotonic_Clock; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - pragma Assert (Result = 0 or else - Result = ETIME or else - Result = EINTR); + pragma Assert + (Result = 0 or else + Result = ETIME or else + Result = EINTR); end loop; - pragma Assert (Record_Wakeup - (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep)); + pragma Assert + (Record_Wakeup + (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep)); Self_ID.Common.State := Runnable; end if; @@ -1357,7 +1376,6 @@ package body System.Task_Primitives.Operations is Reason : Task_States) is Result : Interfaces.C.int; - begin pragma Assert (Check_Wakeup (T, Reason)); Result := cond_signal (T.Common.LL.CV'Access); @@ -1368,8 +1386,8 @@ package body System.Task_Primitives.Operations is -- Check_Initialize_Lock -- --------------------------- - -- The following code is intended to check some of the invariant - -- assertions related to lock usage, on which we depend. + -- The following code is intended to check some of the invariant assertions + -- related to lock usage, on which we depend. function Check_Initialize_Lock (L : Lock_Ptr; @@ -1605,10 +1623,14 @@ package body System.Task_Primitives.Operations is return False; end if; + -- Magic constant 4??? + if L.Level = 4 then Check_Count := Unlock_Count; end if; + -- Magic constant 1000??? + if Unlock_Count - Check_Count > 1000 then Check_Count := Unlock_Count; end if; @@ -1664,9 +1686,9 @@ package body System.Task_Primitives.Operations is procedure Initialize (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to zero (RM D.10(6))) S.State := False; S.Waiting := False; @@ -1701,6 +1723,7 @@ package body System.Task_Primitives.Operations is procedure Finalize (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -1731,6 +1754,7 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1751,6 +1775,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1768,6 +1793,7 @@ package body System.Task_Primitives.Operations is Result := cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1784,6 +1810,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1791,9 +1818,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). + -- (RM D.10(10)). Result := mutex_unlock (S.L'Access); pragma Assert (Result = 0); @@ -1801,6 +1829,7 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index cf959e35e12..c778b992b0d 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -69,7 +69,7 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Deallocation; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -185,15 +185,18 @@ package body System.Task_Primitives.Operations is end if; if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then - not T.Aborting + and then T.Pending_ATC_Level < T.ATC_Nesting_Level + and then not T.Aborting then T.Aborting := True; -- Make sure signals used for RTS internal purpose are unmasked - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); pragma Assert (Result = 0); raise Standard'Abort_Signal; @@ -204,8 +207,8 @@ package body System.Task_Primitives.Operations is -- Stack_Guard -- ------------------ - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is pragma Unreferenced (T); @@ -233,12 +236,11 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore rasing Storage_Error in the following + -- routines should be able to be handled safely. procedure Initialize_Lock (Prio : System.Any_Priority; @@ -272,7 +274,8 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); @@ -322,7 +325,8 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Result : Interfaces.C.int; Self_ID : Task_Id; @@ -354,7 +358,8 @@ package body System.Task_Primitives.Operations is end Write_Lock; procedure Write_Lock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -378,7 +383,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -395,7 +402,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -414,6 +422,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -428,11 +451,13 @@ package body System.Task_Primitives.Operations is begin if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure @@ -444,9 +469,8 @@ package body System.Task_Primitives.Operations is -- Timed_Sleep -- ----------------- - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. + -- This is for use within the run-time system, so abort is assumed to be + -- already deferred, and the caller should be holding its own ATCB lock. procedure Timed_Sleep (Self_ID : Task_Id; @@ -458,7 +482,8 @@ package body System.Task_Primitives.Operations is is pragma Unreferenced (Reason); - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; @@ -477,23 +502,25 @@ package body System.Task_Primitives.Operations is Request := To_Timespec (Abs_Time); loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; + 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; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; if Result = 0 or Result = EINTR then @@ -512,16 +539,16 @@ 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) is - Check_Time : constant Duration := Monotonic_Clock; + Base_Time : constant Duration := Monotonic_Clock; + Check_Time : Duration := Base_Time; Abs_Time : Duration; Request : aliased timespec; Result : Interfaces.C.int; @@ -544,29 +571,28 @@ package body System.Task_Primitives.Operations is Self_ID.Common.State := Delay_Sleep; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - 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; + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - pragma Assert (Result = 0 or else - Result = ETIMEDOUT or else - Result = EINTR); + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); end loop; Self_ID.Common.State := Runnable; @@ -658,19 +684,22 @@ package body System.Task_Primitives.Operations is or else Priority_Specific_Policy = 'R' or else Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); elsif Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); end if; pragma Assert (Result = 0); @@ -751,8 +780,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_mutex_init - (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -769,8 +799,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_cond_init - (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -826,47 +857,54 @@ package body System.Task_Primitives.Operations is return; end if; - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); pragma Assert (Result = 0); - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); pragma Assert (Result = 0); Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Priority)); - Result := pthread_attr_setschedparam - (Attributes'Access, Param'Access); + Result := + pthread_attr_setschedparam + (Attributes'Access, Param'Access); pragma Assert (Result = 0); 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); + Result := + pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_RR); elsif Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' or else Time_Slice_Val = 0 then - Result := pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_FIFO); + Result := + pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_FIFO); else - Result := pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_OTHER); + Result := + pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_OTHER); end if; pragma Assert (Result = 0); - -- Set the scheduling parameters explicitly, since this is the - -- only way to force the OS to take e.g. the sched policy and scope - -- attributes into account. + -- Set the scheduling parameters explicitly, since this is the only way + -- to force the OS to take e.g. the sched policy and scope attributes + -- into account. - Result := pthread_attr_setinheritsched - (Attributes'Access, PTHREAD_EXPLICIT_SCHED); + Result := + pthread_attr_setinheritsched + (Attributes'Access, PTHREAD_EXPLICIT_SCHED); pragma Assert (Result = 0); T.Common.Current_Priority := Priority; @@ -874,12 +912,14 @@ package body System.Task_Primitives.Operations is if T.Common.Task_Info /= null then case T.Common.Task_Info.Contention_Scope is when System.Task_Info.Process_Scope => - Result := pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_PROCESS); + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_PROCESS); when System.Task_Info.System_Scope => - Result := pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_SYSTEM); + Result := + pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_SYSTEM); when System.Task_Info.Default_Scope => Result := 0; @@ -893,11 +933,12 @@ package body System.Task_Primitives.Operations is -- do not need to manipulate caller's signal mask at this point. -- All tasks in RTS will have All_Tasks_Mask initially. - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); pragma Assert (Result = 0 or else Result = EAGAIN); Succeeded := Result = 0; @@ -906,18 +947,21 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if T.Common.Task_Info /= null then + -- ??? We're using a process-wide function to implement a task -- specific characteristic. if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then Result := bind_to_cpu (Curpid, 0); + elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then - Result := bind_to_cpu - (Curpid, - Interfaces.C.unsigned_long ( - Interfaces.Shift_Left - (Interfaces.Unsigned_64'(1), - T.Common.Task_Info.Bind_To_Cpu_Number - 1))); + Result := + bind_to_cpu + (Curpid, + Interfaces.C.unsigned_long ( + Interfaces.Shift_Left + (Interfaces.Unsigned_64'(1), + T.Common.Task_Info.Bind_To_Cpu_Number - 1))); pragma Assert (Result = 0); end if; end if; @@ -933,7 +977,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -984,9 +1028,9 @@ package body System.Task_Primitives.Operations is Mutex_Attr : aliased pthread_mutexattr_t; Cond_Attr : aliased pthread_condattr_t; Result : Interfaces.C.int; + begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (RM D.10(6))) S.State := False; S.Waiting := False; @@ -1036,6 +1080,7 @@ package body System.Task_Primitives.Operations is procedure Finalize (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -1066,6 +1111,7 @@ package body System.Task_Primitives.Operations is procedure Set_False (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1086,16 +1132,16 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; Result := pthread_mutex_lock (S.L'Access); pragma Assert (Result = 0); - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. + -- If there is already a task waiting on this suspension object then we + -- resume it, leaving the state of the suspension object to False, as + -- specified in (RM D.10(9)). Otherwise, leave the state set to True. if S.Waiting then S.Waiting := False; @@ -1103,6 +1149,7 @@ package body System.Task_Primitives.Operations is Result := pthread_cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1119,6 +1166,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1126,9 +1174,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). + -- (AM D.10(10)). Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); @@ -1136,10 +1185,11 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). + -- is set to False (RM D.10(9)). if S.State then S.State := False; @@ -1212,8 +1262,7 @@ package body System.Task_Primitives.Operations is (T : ST.Task_Id; Thread_Self : Thread_Id) return Boolean is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); + pragma Unreferenced (T, Thread_Self); begin return False; end Suspend_Task; @@ -1226,8 +1275,7 @@ package body System.Task_Primitives.Operations is (T : ST.Task_Id; Thread_Self : Thread_Id) return Boolean is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); + pragma Unreferenced (T, Thread_Self); begin return False; end Resume_Task; @@ -1284,8 +1332,8 @@ package body System.Task_Primitives.Operations is -- Install the abort-signal handler - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default + if State + (System.Interrupt_Management.Abort_Task_Interrupt) /= Default then act.sa_flags := 0; act.sa_handler := Abort_Handler'Address; @@ -1296,9 +1344,9 @@ package body System.Task_Primitives.Operations is Result := sigaction - (Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); pragma Assert (Result = 0); end if; end Initialize; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index f96534b45eb..5cade02b277 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -54,8 +54,8 @@ with System.Soft_Links; -- used for Get_Exc_Stack_Addr -- Abort_Defer/Undefer -with Unchecked_Conversion; -with Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -85,7 +85,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 Time_Slice_Val : Integer; pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); @@ -94,7 +94,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 -- @@ -104,7 +104,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); @@ -121,7 +121,7 @@ package body System.Task_Primitives.Operations is 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 -- @@ -137,15 +137,17 @@ package body System.Task_Primitives.Operations is -- Local Subprograms -- ----------------------- - function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id); + function To_Task_Id is + new Ada.Unchecked_Conversion (System.Address, Task_Id); - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); function Get_Exc_Stack_Addr return Address; -- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT procedure Timer_Sleep_AST (ID : Address); - -- Signal the condition variable when AST fires. + -- Signal the condition variable when AST fires procedure Timer_Sleep_AST (ID : Address) is Result : Interfaces.C.int; @@ -160,8 +162,8 @@ package body System.Task_Primitives.Operations is -- Stack_Guard -- ----------------- - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. + -- The underlying thread system sets a guard page at the bottom of a thread + -- stack, so nothing is needed. -- ??? Check the comment above procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is @@ -190,15 +192,15 @@ package body System.Task_Primitives.Operations is -- Initialize_Lock -- --------------------- - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. + -- Note: mutexes and cond_variables needed per-task basis are initialized + -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such + -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any + -- status change of RTS. Therefore rasing Storage_Error in the following + -- routines should be able to be handled safely. procedure Initialize_Lock - (Prio : System.Any_Priority; L : not null access Lock) + (Prio : System.Any_Priority; + L : not null access Lock) is Attributes : aliased pthread_mutexattr_t; Result : Interfaces.C.int; @@ -226,7 +228,8 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); @@ -289,7 +292,8 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Self_ID : constant Task_Id := Self; All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link; @@ -343,7 +347,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -360,7 +366,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : Interfaces.C.int; begin @@ -379,6 +386,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -392,11 +414,13 @@ package body System.Task_Primitives.Operations is begin if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); end if; -- EINTR is not considered a failure @@ -437,9 +461,7 @@ package body System.Task_Primitives.Operations is Sleep_Time := To_OS_Time (Time, Mode); - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change - then + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then return; end if; @@ -454,13 +476,15 @@ package body System.Task_Primitives.Operations is end if; if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); pragma Assert (Result = 0); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); pragma Assert (Result = 0); end if; @@ -508,17 +532,13 @@ package body System.Task_Primitives.Operations is (Status, 0, Sleep_Time, Timer_Sleep_AST'Access, To_Address (Self_ID), 0); + -- Comment following test + if (Status and 1) /= 1 then raise Storage_Error; end if; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then Sys_Cantim (Status, To_Address (Self_ID), 0); pragma Assert ((Status and 1) = 1); @@ -526,12 +546,16 @@ package body System.Task_Primitives.Operations is end if; if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access); pragma Assert (Result = 0); else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + Result := + pthread_cond_wait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access); pragma Assert (Result = 0); end if; @@ -569,6 +593,7 @@ package body System.Task_Primitives.Operations is function RT_Resolution return Duration is begin + -- Document origin of this magic constant ??? return 10#1.0#E-3; end RT_Resolution; @@ -627,15 +652,17 @@ package body System.Task_Primitives.Operations is or else Priority_Specific_Policy = 'R' or else Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); elsif Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); else -- SCHED_OTHER priorities are restricted to the range 8 - 15. @@ -643,8 +670,9 @@ package body System.Task_Primitives.Operations is -- in a range of 16 - 31, dividing by 2 gives the correct result. Param.sched_priority := Param.sched_priority / 2; - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + Result := + pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); end if; pragma Assert (Result = 0); @@ -727,8 +755,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); + Result := + pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -745,8 +774,9 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0 or else Result = ENOMEM); if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); + Result := + pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); pragma Assert (Result = 0 or else Result = ENOMEM); end if; @@ -791,7 +821,7 @@ package body System.Task_Primitives.Operations is Result : Interfaces.C.int; function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); + Ada.Unchecked_Conversion (System.Address, Thread_Body); begin -- Since the initial signal mask of a thread is inherited from the @@ -822,13 +852,14 @@ package body System.Task_Primitives.Operations is (Attributes'Access, PTHREAD_EXPLICIT_SCHED); pragma Assert (Result = 0); - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); + Result := + pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); - -- ENOMEM is a valid run-time error. Don't shut down. + -- ENOMEM is a valid run-time error -- do not shut down pragma Assert (Result = 0 or else Result = EAGAIN or else Result = ENOMEM); @@ -853,9 +884,9 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := T = Self; procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - procedure Free is new Unchecked_Deallocation + procedure Free is new Ada.Unchecked_Deallocation (Exc_Stack_T, Exc_Stack_Ptr_T); begin @@ -872,7 +903,6 @@ package body System.Task_Primitives.Operations is end if; Free (T.Common.LL.Exc_Stack_Ptr); - Free (Tmp); if Is_Self then @@ -911,8 +941,7 @@ package body System.Task_Primitives.Operations is Cond_Attr : aliased pthread_condattr_t; Result : Interfaces.C.int; begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (D.10 (6))) S.State := False; S.Waiting := False; @@ -977,7 +1006,8 @@ package body System.Task_Primitives.Operations is -------------- procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin -- Destroy internal mutex @@ -1007,7 +1037,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; + Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1028,6 +1059,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1036,8 +1068,7 @@ package body System.Task_Primitives.Operations is -- If there is already a task waiting on this suspension object then -- we resume it, leaving the state of the suspension object to False, - -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves - -- the state to True. + -- as specified in (RM D.10(9)), otherwise leave state set to True. if S.Waiting then S.Waiting := False; @@ -1045,6 +1076,7 @@ package body System.Task_Primitives.Operations is Result := pthread_cond_signal (S.CV'Access); pragma Assert (Result = 0); + else S.State := True; end if; @@ -1061,6 +1093,7 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : Interfaces.C.int; + begin SSL.Abort_Defer.all; @@ -1068,9 +1101,10 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object - -- (ARM D.10 par. 10). + -- (RM D.10(10)). Result := pthread_mutex_unlock (S.L'Access); pragma Assert (Result = 0); @@ -1078,6 +1112,7 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 2621c60a0b7..b0974a63486 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -45,7 +45,7 @@ with System.Tasking.Debug; with System.Interrupt_Management; -- used for Keep_Unmasked --- Abort_Task_Signal +-- Abort_Task_Interrupt -- Signal_ID -- Initialize_Interrupts @@ -59,8 +59,8 @@ with System.Soft_Links; -- For example when using the restricted run time, it is replaced by -- System.Tasking.Restricted.Stages. -with Unchecked_Conversion; -with Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; package body System.Task_Primitives.Operations is @@ -165,7 +165,8 @@ package body System.Task_Primitives.Operations is procedure Install_Signal_Handlers; -- Install the default signal handlers for the current task - function To_Address is new Unchecked_Conversion (Task_Id, System.Address); + function To_Address is + new Ada.Unchecked_Conversion (Task_Id, System.Address); ------------------- -- Abort_Handler -- @@ -194,8 +195,11 @@ package body System.Task_Primitives.Operations is -- Make sure signals used for RTS internal purpose are unmasked - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + Result := + pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); pragma Assert (Result = 0); raise Standard'Abort_Signal; @@ -251,7 +255,7 @@ package body System.Task_Primitives.Operations is Result := sigaction - (Signal (Interrupt_Management.Abort_Task_Signal), + (Signal (Interrupt_Management.Abort_Task_Interrupt), act'Unchecked_Access, old_act'Unchecked_Access); pragma Assert (Result = 0); @@ -264,7 +268,9 @@ package body System.Task_Primitives.Operations is --------------------- procedure Initialize_Lock - (Prio : System.Any_Priority; L : not null access Lock) is + (Prio : System.Any_Priority; + L : not null access Lock) + is begin L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); L.Prio_Ceiling := int (Prio); @@ -273,10 +279,10 @@ package body System.Task_Primitives.Operations is end Initialize_Lock; procedure Initialize_Lock - (L : not null access RTS_Lock; Level : Lock_Level) + (L : not null access RTS_Lock; + Level : Lock_Level) is pragma Unreferenced (Level); - begin L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); L.Prio_Ceiling := int (System.Any_Priority'Last); @@ -307,9 +313,11 @@ package body System.Task_Primitives.Operations is ---------------- procedure Write_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) + (L : not null access Lock; + Ceiling_Violation : out Boolean) is Result : int; + begin if L.Protocol = Prio_Protect and then int (Self.Common.Current_Priority) > L.Prio_Ceiling @@ -350,7 +358,9 @@ package body System.Task_Primitives.Operations is --------------- procedure Read_Lock - (L : not null access Lock; Ceiling_Violation : out Boolean) is + (L : not null access Lock; + Ceiling_Violation : out Boolean) + is begin Write_Lock (L, Ceiling_Violation); end Read_Lock; @@ -367,7 +377,8 @@ package body System.Task_Primitives.Operations is end Unlock; procedure Unlock - (L : not null access RTS_Lock; Global_Lock : Boolean := False) + (L : not null access RTS_Lock; + Global_Lock : Boolean := False) is Result : int; begin @@ -386,6 +397,21 @@ package body System.Task_Primitives.Operations is end if; end Unlock; + ----------------- + -- Set_Ceiling -- + ----------------- + + -- Dynamic priority ceilings are not supported by the underlying system + + procedure Set_Ceiling + (L : not null access Lock; + Prio : System.Any_Priority) + is + pragma Unreferenced (L, Prio); + begin + null; + end Set_Ceiling; + ----------- -- Sleep -- ----------- @@ -508,6 +534,7 @@ package body System.Task_Primitives.Operations is if Ticks /= int'Last then Timedout := True; + else Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); @@ -590,7 +617,7 @@ package body System.Task_Primitives.Operations is if Ticks > 0 then - -- Modifying State and Pending_Priority_Change, locking the TCB + -- Modifying State, locking the TCB if Single_Lock then Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); @@ -604,12 +631,6 @@ package body System.Task_Primitives.Operations is Timedout := False; loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; -- Release the TCB before sleeping @@ -745,7 +766,7 @@ package body System.Task_Primitives.Operations is and then Loss_Of_Inheritance and then Prio < T.Common.Current_Priority then - -- Annex D requirement [RM D.2.2 par. 9]: + -- Annex D requirement (RM D.2.2(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 @@ -861,6 +882,7 @@ package body System.Task_Primitives.Operations is if Self_ID.Common.LL.CV = 0 then Succeeded := False; + else Succeeded := True; @@ -934,13 +956,14 @@ package body System.Task_Primitives.Operations is -- Now spawn the VxWorks task for real - T.Common.LL.Thread := taskSpawn - (Name_Address, - To_VxWorks_Priority (int (Priority)), - Get_Task_Options, - Adjusted_Stack_Size, - Wrapper, - To_Address (T)); + T.Common.LL.Thread := + taskSpawn + (Name_Address, + To_VxWorks_Priority (int (Priority)), + Get_Task_Options, + Adjusted_Stack_Size, + Wrapper, + To_Address (T)); end; if T.Common.LL.Thread = -1 then @@ -963,7 +986,7 @@ package body System.Task_Primitives.Operations is Is_Self : constant Boolean := (T = Self); procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); begin if not Single_Lock then @@ -1003,8 +1026,10 @@ package body System.Task_Primitives.Operations is procedure Abort_Task (T : Task_Id) is Result : int; begin - Result := kill (T.Common.LL.Thread, - Signal (Interrupt_Management.Abort_Task_Signal)); + Result := + kill + (T.Common.LL.Thread, + Signal (Interrupt_Management.Abort_Task_Interrupt)); pragma Assert (Result = 0); end Abort_Task; @@ -1014,8 +1039,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (S : in out Suspension_Object) is begin - -- Initialize internal state. It is always initialized to False (ARM - -- D.10 par. 6). + -- Initialize internal state (always to False (RM D.10(6))) S.State := False; S.Waiting := False; @@ -1039,6 +1063,7 @@ package body System.Task_Primitives.Operations is procedure Finalize (S : in out Suspension_Object) is Result : STATUS; + begin -- Destroy internal mutex @@ -1068,7 +1093,8 @@ package body System.Task_Primitives.Operations is --------------- procedure Set_False (S : in out Suspension_Object) is - Result : STATUS; + Result : STATUS; + begin SSL.Abort_Defer.all; @@ -1089,6 +1115,7 @@ package body System.Task_Primitives.Operations is procedure Set_True (S : in out Suspension_Object) is Result : STATUS; + begin SSL.Abort_Defer.all; @@ -1122,12 +1149,14 @@ package body System.Task_Primitives.Operations is procedure Suspend_Until_True (S : in out Suspension_Object) is Result : STATUS; + begin SSL.Abort_Defer.all; Result := semTake (S.L, WAIT_FOREVER); if S.Waiting then + -- Program_Error must be raised upon calling Suspend_Until_True -- if another task is already waiting on that suspension object -- (ARM D.10 par. 10). @@ -1138,6 +1167,7 @@ package body System.Task_Primitives.Operations is SSL.Abort_Undefer.all; raise Program_Error; + else -- Suspend the task if the state is False. Otherwise, the task -- continues its execution, and the state of the suspension object @@ -1150,6 +1180,7 @@ package body System.Task_Primitives.Operations is pragma Assert (Result = 0); SSL.Abort_Undefer.all; + else S.Waiting := True; @@ -1257,6 +1288,7 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id) is Result : int; + begin Environment_Task_Id := Environment_Task; @@ -1272,9 +1304,10 @@ package body System.Task_Primitives.Operations is end if; if Time_Slice_Val > 0 then - Result := Set_Time_Slice - (To_Clock_Ticks - (Duration (Time_Slice_Val) / Duration (1_000_000.0))); + Result := + Set_Time_Slice + (To_Clock_Ticks + (Duration (Time_Slice_Val) / Duration (1_000_000.0))); elsif Dispatching_Policy = 'R' then Result := Set_Time_Slice (To_Clock_Ticks (0.01)); diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 318e4bdaaa8..b22a1b5794d 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -81,11 +81,6 @@ package body System.Tasking.Initialization is -- from all other tasks. It is only used by Task_Lock, -- Task_Unlock, and Final_Task_Unlock. - function Current_Target_Exception return AE.Exception_Occurrence; - pragma Import - (Ada, Current_Target_Exception, "__gnat_current_target_exception"); - -- Import this subprogram from the private part of Ada.Exceptions - ---------------------------------------------------------------------- -- Tasking versions of some services needed by non-tasking programs -- ---------------------------------------------------------------------- @@ -112,8 +107,11 @@ package body System.Tasking.Initialization is function Get_Stack_Info return Stack_Checking.Stack_Access; -- Get access to the current task's Stack_Info + function Get_Current_Excep return SSL.EOA; + -- Task-safe version of SSL.Get_Current_Excep + procedure Update_Exception - (X : AE.Exception_Occurrence := Current_Target_Exception); + (X : AE.Exception_Occurrence := SSL.Current_Target_Exception); -- Handle exception setting and check for pending actions function Task_Name return String; @@ -170,7 +168,7 @@ package body System.Tasking.Initialization is procedure Defer_Abort (Self_ID : Task_Id) is begin - if No_Abort and then not Dynamic_Priority_Support then + if No_Abort then return; end if; @@ -211,7 +209,7 @@ package body System.Tasking.Initialization is procedure Defer_Abort_Nestable (Self_ID : Task_Id) is begin - if No_Abort and then not Dynamic_Priority_Support then + if No_Abort then return; end if; @@ -232,7 +230,7 @@ package body System.Tasking.Initialization is procedure Abort_Defer is Self_ID : Task_Id; begin - if No_Abort and then not Dynamic_Priority_Support then + if No_Abort then return; end if; @@ -241,6 +239,15 @@ package body System.Tasking.Initialization is end Abort_Defer; ----------------------- + -- Get_Current_Excep -- + ----------------------- + + function Get_Current_Excep return SSL.EOA is + begin + return STPO.Self.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + + ----------------------- -- Do_Pending_Action -- ----------------------- @@ -266,7 +273,6 @@ package body System.Tasking.Initialization is Write_Lock (Self_ID); Self_ID.Pending_Action := False; - Poll_Base_Priority_Change (Self_ID); Unlock (Self_ID); if Single_Lock then @@ -368,17 +374,18 @@ package body System.Tasking.Initialization is -- Notify that the tasking run time has been elaborated so that -- the tasking version of the soft links can be used. - if not No_Abort or else Dynamic_Priority_Support then + if not No_Abort then SSL.Abort_Defer := Abort_Defer'Access; SSL.Abort_Undefer := Abort_Undefer'Access; end if; - SSL.Update_Exception := Update_Exception'Access; SSL.Lock_Task := Task_Lock'Access; SSL.Unlock_Task := Task_Unlock'Access; SSL.Check_Abort_Status := Check_Abort_Status'Access; SSL.Get_Stack_Info := Get_Stack_Info'Access; SSL.Task_Name := Task_Name'Access; + SSL.Update_Exception := Update_Exception'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; -- Initialize the tasking soft links (if not done yet) that are common -- to the full and the restricted run times. @@ -522,68 +529,6 @@ package body System.Tasking.Initialization is end if; end Locked_Abort_To_Level; - ------------------------------- - -- Poll_Base_Priority_Change -- - ------------------------------- - - -- Poll for pending base priority change and for held tasks. - -- This should always be called with (only) Self_ID locked. - -- It may temporarily release Self_ID's lock. - - -- The call to Yield is to force enqueuing at the - -- tail of the dispatching queue. - - -- We must unlock Self_ID for this to take effect, - -- since we are inheriting high active priority from the lock. - - -- See also Poll_Base_Priority_Change_At_Entry_Call, - -- in package System.Tasking.Entry_Calls. - - -- In this version, we check if the task is held too because - -- doing this only in Do_Pending_Action is not enough. - - procedure Poll_Base_Priority_Change (Self_ID : Task_Id) is - begin - if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then - - -- Check for ceiling violations ??? - - Self_ID.Pending_Priority_Change := False; - - if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then - if Single_Lock then - Unlock_RTS; - Yield; - Lock_RTS; - else - Unlock (Self_ID); - Yield; - Write_Lock (Self_ID); - end if; - - elsif Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - - else - -- Lowering priority - - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - - if Single_Lock then - Unlock_RTS; - Yield; - Lock_RTS; - else - Unlock (Self_ID); - Yield; - Write_Lock (Self_ID); - end if; - end if; - end if; - end Poll_Base_Priority_Change; - -------------------------------- -- Remove_From_All_Tasks_List -- -------------------------------- @@ -685,7 +630,7 @@ package body System.Tasking.Initialization is procedure Undefer_Abort (Self_ID : Task_Id) is begin - if No_Abort and then not Dynamic_Priority_Support then + if No_Abort then return; end if; @@ -721,7 +666,7 @@ package body System.Tasking.Initialization is procedure Undefer_Abort_Nestable (Self_ID : Task_Id) is begin - if No_Abort and then not Dynamic_Priority_Support then + if No_Abort then return; end if; @@ -746,7 +691,7 @@ package body System.Tasking.Initialization is procedure Abort_Undefer is Self_ID : Task_Id; begin - if No_Abort and then not Dynamic_Priority_Support then + if No_Abort then return; end if; @@ -787,7 +732,7 @@ package body System.Tasking.Initialization is -- Call only when holding no locks procedure Update_Exception - (X : AE.Exception_Occurrence := Current_Target_Exception) + (X : AE.Exception_Occurrence := SSL.Current_Target_Exception) is Self_Id : constant Task_Id := Self; use Ada.Exceptions; @@ -806,7 +751,6 @@ package body System.Tasking.Initialization is Write_Lock (Self_Id); Self_Id.Pending_Action := False; - Poll_Base_Priority_Change (Self_Id); Unlock (Self_Id); if Single_Lock then @@ -856,15 +800,12 @@ package body System.Tasking.Initialization is New_State : Entry_Call_State) is Caller : constant Task_Id := Entry_Call.Self; - begin pragma Debug (Debug.Trace (Self_ID, "Wakeup_Entry_Caller", 'E', Caller)); pragma Assert (New_State = Done or else New_State = Cancelled); - pragma Assert - (Caller.Common.State /= Terminated - and then Caller.Common.State /= Unactivated); + pragma Assert (Caller.Common.State /= Unactivated); Entry_Call.State := New_State; @@ -901,15 +842,13 @@ package body System.Tasking.Initialization is -- the subprogram body where the real subprogram is declared. procedure Finalize_Attributes (T : Task_Id) is - pragma Warnings (Off, T); - + pragma Unreferenced (T); begin null; end Finalize_Attributes; procedure Initialize_Attributes (T : Task_Id) is - pragma Warnings (Off, T); - + pragma Unreferenced (T); begin null; end Initialize_Attributes; diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads index bacde3c19d5..41dbc218fb2 100644 --- a/gcc/ada/s-tasini.ads +++ b/gcc/ada/s-tasini.ads @@ -139,11 +139,6 @@ package System.Tasking.Initialization is -- Change the base priority of T. Has to be called with the affected -- task's ATCB write-locked. May temporariliy release the lock. - procedure Poll_Base_Priority_Change (Self_ID : Task_Id); - -- Has to be called with Self_ID's ATCB write-locked. - -- May temporariliy release the lock. - pragma Inline (Poll_Base_Priority_Change); - ---------------------- -- Task Lock/Unlock -- ---------------------- diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 6fafb39f3c3..d448b82de26 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -48,7 +48,6 @@ with System.Tasking.Entry_Calls; with System.Tasking.Initialization; -- used for Defer_Abort -- Undefer_Abort --- Poll_Base_Priority_Change -- Do_Pending_Action with System.Tasking.Queuing; @@ -71,6 +70,9 @@ with System.Tasking.Protected_Objects.Operations; with System.Tasking.Debug; -- used for Trace +with System.Restrictions; +-- used for Abort_Allowed + with System.Parameters; -- used for Single_Lock -- Runtime_Traces @@ -476,7 +478,7 @@ package body System.Tasking.Rendezvous is Send_Trace_Info (E_Missed, Acceptor); end if; - Initialization.Undefer_Abort (Self_Id); + Local_Undefer_Abort (Self_Id); raise Tasking_Error; end if; @@ -506,7 +508,7 @@ package body System.Tasking.Rendezvous is Self_Id : constant Task_Id := STPO.Self; begin - Initialization.Defer_Abort (Self_Id); + Initialization.Defer_Abort_Nestable (Self_Id); if Single_Lock then Lock_RTS; @@ -520,7 +522,7 @@ package body System.Tasking.Rendezvous is Unlock_RTS; end if; - Initialization.Undefer_Abort (Self_Id); + Initialization.Undefer_Abort_Nestable (Self_Id); return Result; end Callable; @@ -923,7 +925,11 @@ package body System.Tasking.Rendezvous is then Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; - pragma Assert (Self_Id.Deferral_Level = 1); + pragma Assert + (Self_Id.Deferral_Level = 1 + or else + (Self_Id.Deferral_Level = 0 + and then not Restrictions.Abort_Allowed)); Initialization.Defer_Abort_Nestable (Self_Id); @@ -1019,7 +1025,6 @@ package body System.Tasking.Rendezvous is Self_Id.Common.State := Delay_Sleep; loop - Initialization.Poll_Base_Priority_Change (Self_Id); exit when Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; Sleep (Self_Id, Delay_Sleep); @@ -1097,6 +1102,11 @@ package body System.Tasking.Rendezvous is Unlock_RTS; end if; + -- Call Yield to let other tasks get a chance to run as this is a + -- potential dispatching point. + + Yield (Do_Yield => False); + Initialization.Undefer_Abort (Self_Id); return Return_Count; end Task_Count; @@ -1111,7 +1121,7 @@ package body System.Tasking.Rendezvous is With_Abort : Boolean) return Boolean is E : constant Task_Entry_Index := - Task_Entry_Index (Entry_Call.E); + Task_Entry_Index (Entry_Call.E); Old_State : constant Entry_Call_State := Entry_Call.State; Acceptor : constant Task_Id := Entry_Call.Called_Task; Parent : constant Task_Id := Acceptor.Common.Parent; @@ -1119,7 +1129,8 @@ package body System.Tasking.Rendezvous is Null_Body : Boolean; begin - -- Find out whether Entry_Call can be accepted immediately. + -- Find out whether Entry_Call can be accepted immediately + -- If the Acceptor is not callable, return False. -- If the rendezvous can start, initiate it. -- If the accept-body is trivial, also complete the rendezvous. @@ -1562,6 +1573,8 @@ package body System.Tasking.Rendezvous is -- Wait for a normal call and a pending action until the -- Wakeup_Time is reached. + Self_Id.Common.State := Acceptor_Sleep; + -- Try to remove calls to Sleep in the loop below by letting the -- caller a chance of getting ready immediately, using Unlock -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. @@ -1588,10 +1601,7 @@ package body System.Tasking.Rendezvous is Self_Id.Open_Accepts := null; end if; - Self_Id.Common.State := Acceptor_Sleep; - loop - Initialization.Poll_Base_Priority_Change (Self_Id); exit when Self_Id.Open_Accepts = null; if Timedout then @@ -1653,8 +1663,6 @@ package body System.Tasking.Rendezvous is Self_Id.Open_Accepts := null; Self_Id.Common.State := Acceptor_Sleep; - Initialization.Poll_Base_Priority_Change (Self_Id); - STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep, Timedout, Yielded); @@ -1799,9 +1807,11 @@ package body System.Tasking.Rendezvous is procedure Wait_For_Call (Self_Id : Task_Id) is begin + Self_Id.Common.State := Acceptor_Sleep; + -- Try to remove calls to Sleep in the loop below by letting the caller -- a chance of getting ready immediately, using Unlock & Yield. - -- See similar action in Wait_For_Completion & Selective_Wait. + -- See similar action in Wait_For_Completion & Timed_Selective_Wait. if Single_Lock then Unlock_RTS; @@ -1825,13 +1835,8 @@ package body System.Tasking.Rendezvous is Self_Id.Open_Accepts := null; end if; - Self_Id.Common.State := Acceptor_Sleep; - loop - Initialization.Poll_Base_Priority_Change (Self_Id); - exit when Self_Id.Open_Accepts = null; - Sleep (Self_Id, Acceptor_Sleep); end loop; diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb index 0d765df600e..6767f29c9e5 100644 --- a/gcc/ada/s-tasuti.adb +++ b/gcc/ada/s-tasuti.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -43,7 +43,6 @@ with System.Tasking.Debug; with System.Task_Primitives.Operations; -- used for Write_Lock --- Set_Priority -- Wakeup -- Unlock -- Sleep @@ -382,7 +381,7 @@ package body System.Tasking.Utilities is -- Our parent should wait in Phase 1 of Complete_Master. Master_Completion_Phase := 1; - pragma Assert (Self_ID.Awake_Count = 1); + pragma Assert (Self_ID.Awake_Count >= 1); end if; -- We are accepting with a terminate alternative @@ -454,8 +453,6 @@ package body System.Tasking.Utilities is Write_Lock (C); end loop; - pragma Assert (P.Awake_Count /= 0); - if P.Common.State = Master_Phase_2_Sleep and then C.Master_of_Task = P.Master_Within then @@ -478,7 +475,6 @@ package body System.Tasking.Utilities is C.Awake_Count := C.Awake_Count - 1; if Task_Completed then - pragma Assert (Self_ID.Awake_Count = 0); C.Alive_Count := C.Alive_Count - 1; end if; @@ -499,7 +495,9 @@ package body System.Tasking.Utilities is loop -- Notify P that C has gone passive - P.Awake_Count := P.Awake_Count - 1; + if P.Awake_Count > 0 then + P.Awake_Count := P.Awake_Count - 1; + end if; if Task_Completed and then C.Alive_Count = 0 then P.Alive_Count := P.Alive_Count - 1; |