Skip to content

R
riscv-gcc-1
Commit dae22b53 by Arnaud Charlet
Options

s-taprop-vms.adb, [...] (Timed_Delay, [...]): Register the base time when… 

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

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