mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-15 17:50:51 +08:00
Code Issues Packages Projects Releases Wiki Activity

s-taprop-vms.adb, [...] (Timed_Delay, [...]): Register the base time when entering this routine to detect a backward clock...

Browse Source 
2007-04-20  Arnaud Charlet  <charlet@adacore.com>

	* s-taprop-vms.adb, s-taprop-hpux-dce.adb, s-taprop-vxworks.adb, 
	s-osprim-posix.adb, s-taprop-posix.adb, s-osprim-vxworks.adb, 
	s-taprop-solaris.adb, s-osprim-solaris.adb, s-taprop-dummy.adb, 
	s-osprim-unix.adb, s-osinte-freebsd.adb, s-osinte-freebsd.ads, 
	s-osinte-lynxos.adb, s-osinte-lynxos.ads, s-taprop-tru64.adb, 
	s-taprop-lynxos.adb, s-taprop-irix.adb, s-osinte-tru64.adb, 
	s-osinte-tru64.ads, s-taprop-linux.adb, s-parame.ads, 
	s-parame-vms-alpha.ads, s-parame-vms-ia64.ads, s-parame-hpux.ads, 
	s-parame-vms-restrict.ads, s-parame-ae653.ads, s-parame-vxworks.ads, 
	s-taprop-mingw.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos-3.adb,
        s-osprim-mingw.adb (Timed_Delay, Timed_Sleep): Register the base
	time when entering this routine to detect a backward clock setting
	(manual setting or DST adjustment), to avoid waiting for a longer delay
	than needed.
	(Time_Duration, To_Timeval, struct_timeval): Removed when not relevant.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.
	Update comments.
	(Max_Task_Image_Length): New constant.
	Replace Warnings (Off) by Unreferenced pragma, cleaner.
	(Dynamic_Priority_Support): Removed, no longer needed.
	(Poll_Base_Priority_Change): Ditto.
	(Set_Ceiling): Add this procedure to change the ceiling priority
	associated to a lock. This is a dummy implementation because dynamic
	priority ceilings are not supported by the underlying system.

	* a-dynpri.adb (Set_Priority): Take into account case where Target is
	accepting a RV with its priority boosted.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.

	* s-taenca.adb (Try_To_Cancel_Entry_Call): Remove special case for
	Succeeded = True.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.
	(Wait_For_Completion, Wait_For_Call, Timed_Selective_Wait): Change state
	of Self_Id earlier.

	* s-tasini.ads, s-tasini.adb (Wakeup_Entry_Caller): Relax assertion.
	(Poll_Base_Priority_Change): Removed.
	Code clean up: use SSL.Current_Target_Exception.

	* s-tasren.adb (Task_Count): Call Yield to let a chance to other tasks
	to run as this is a potentially dispatching point.
	(Call_Synchronous): Use Local_Defer_Abort.
	(Callable): Relax assertion.
	(Selective_Wait): Relax assertion in case abort is not allowed.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.

	* s-tasuti.adb (Make_Passive): Adjust assertions.
	Remove handling of deferred priority change, and replace by setting the
	task priority directly, as required by AI-188.

From-SVN: r125364
This commit is contained in:
Arnaud Charlet 2007-06-06 12:14:59 +02:00
parent 984d7dd399
commit dae22b5339
37 changed files with 1458 additions and 1389 deletions

74
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;
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.
Target.Common.Call.Acceptor_Prev_Priority := Priority;
if Priority >= Target.Common.Current_Priority then
Yield_Needed := True;
STPO.Set_Priority (Target, Priority);
else
Yield_Needed := False;
end if;
else
Yield_Needed := True;
STPO.Set_Priority (Target, Priority);
STPO.Unlock (Target);
if Single_Lock then
STPO.Unlock_RTS;
if Target.Common.State = Entry_Caller_Sleep then
Target.Pending_Priority_Change := True;
STPO.Wakeup (Target, Target.Common.State);
end if;
end if;
STPO.Unlock (Target);
if Single_Lock then
STPO.Unlock_RTS;
end if;
if STPO.Self = Target and then Yield_Needed then
-- Yield is needed to enforce FIFO task dispatching
-- LL Set_Priority is made while holding the RTS lock so that it
-- is inheriting high priority until it release all the RTS locks.
-- 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 this is used in a system where Ceiling Locking is
-- not enforced we may end up getting two Yield effects.
-- If this is used in a system where Ceiling Locking is not enforced
-- we may end up getting two Yield effects.
STPO.Yield;
else
Target.New_Base_Priority := Priority;
Target.Pending_Priority_Change := True;
Target.Pending_Action := True;
STPO.Wakeup (Target, Target.Common.State);
-- If the task is suspended, wake it up to perform the change.
-- check for ceiling violations ???
STPO.Unlock (Target);
if Single_Lock then
STPO.Unlock_RTS;
end if;
end if;
SSL.Abort_Undefer.all;

21
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;

26
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;

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

22
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;

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

22
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;

33
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;

21
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;

22
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;

15
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;

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

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

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

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

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

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

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

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

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

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

174
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 possibility 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 possiblility 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);

26
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;

174
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;

234
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;

159
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;

235
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;

143
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;

220
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;

247
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

284
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;

177
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

109
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));

115
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;
@ -240,6 +238,15 @@ package body System.Tasking.Initialization is
Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
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;

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

45
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;

12
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;