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 376 additions and 561 deletions
gcc/ada/a-dynpri.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -48,7 +48,7 @@ with System.Soft_Links;
-- use for Abort_Defer
-- Abort_Undefer
with Unchecked_Conversion;
with Ada.Unchecked_Conversion;
package body Ada.Dynamic_Priorities is
......@@ -59,7 +59,7 @@ package body Ada.Dynamic_Priorities is
use System.Tasking;
function Convert_Ids is new
Unchecked_Conversion
Ada.Unchecked_Conversion
(Task_Identification.Task_Id, System.Tasking.Task_Id);
------------------
......@@ -98,9 +98,9 @@ package body Ada.Dynamic_Priorities is
T : Ada.Task_Identification.Task_Id :=
Ada.Task_Identification.Current_Task)
is
Target : constant Task_Id := Convert_Ids (T);
Self_ID : constant Task_Id := STPO.Self;
Target : constant Task_Id := Convert_Ids (T);
Error_Message : constant String := "Trying to set the priority of a ";
Yield_Needed : Boolean;
begin
if Target = Convert_Ids (Ada.Task_Identification.Null_Task_Id) then
......@@ -119,41 +119,53 @@ package body Ada.Dynamic_Priorities is
STPO.Write_Lock (Target);
if Self_ID = Target then
Target.Common.Base_Priority := Priority;
STPO.Set_Priority (Target, Priority);
Target.Common.Base_Priority := Priority;
if Target.Common.Call /= null
and then
Target.Common.Call.Acceptor_Prev_Priority /= Priority_Not_Boosted
then
-- Target is within a rendezvous, so ensure the correct priority
-- will be reset when finishing the rendezvous, and only change the
-- priority immediately if the new priority is greater than the
-- current (inherited) priority.
STPO.Unlock (Target);
Target.Common.Call.Acceptor_Prev_Priority := Priority;
if Single_Lock then
STPO.Unlock_RTS;
if Priority >= Target.Common.Current_Priority then
Yield_Needed := True;
STPO.Set_Priority (Target, Priority);
else
Yield_Needed := False;
end if;
-- Yield is needed to enforce FIFO task dispatching
else
Yield_Needed := True;
STPO.Set_Priority (Target, Priority);
-- LL Set_Priority is made while holding the RTS lock so that it
-- is inheriting high priority until it release all the RTS locks.
if Target.Common.State = Entry_Caller_Sleep then
Target.Pending_Priority_Change := True;
STPO.Wakeup (Target, Target.Common.State);
end if;
end if;
-- If this is used in a system where Ceiling Locking is
-- not enforced we may end up getting two Yield effects.
STPO.Unlock (Target);
STPO.Yield;
if Single_Lock then
STPO.Unlock_RTS;
end if;
else
Target.New_Base_Priority := Priority;
Target.Pending_Priority_Change := True;
Target.Pending_Action := True;
if STPO.Self = Target and then Yield_Needed then
STPO.Wakeup (Target, Target.Common.State);
-- Yield is needed to enforce FIFO task dispatching
-- If the task is suspended, wake it up to perform the change.
-- check for ceiling violations ???
-- LL Set_Priority is made while holding the RTS lock so that it is
-- inheriting high priority until it release all the RTS locks.
STPO.Unlock (Target);
-- If this is used in a system where Ceiling Locking is not enforced
-- we may end up getting two Yield effects.
if Single_Lock then
STPO.Unlock_RTS;
end if;
STPO.Yield;
end if;
SSL.Abort_Undefer.all;
......
gcc/ada/s-osinte-freebsd.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1991-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -96,23 +96,4 @@ package body System.OS_Interface is
ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
function To_Timeval (D : Duration) return struct_timeval is
S : long;
F : Duration;
begin
S := long (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then S := S - 1; F := F + 1.0; end if;
return struct_timeval'(tv_sec => S,
tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
end System.OS_Interface;
gcc/ada/s-osinte-freebsd.ads
......@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -42,7 +42,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
with Unchecked_Conversion;
with Ada.Unchecked_Conversion;
package System.OS_Interface is
pragma Preelaborate;
......@@ -221,20 +221,6 @@ package System.OS_Interface is
tz_dsttime : int;
end record;
pragma Convention (C, struct_timezone);
type struct_timeval is private;
-- This is needed on systems that do not have clock_gettime()
-- but do have gettimeofday().
function To_Duration (TV : struct_timeval) return Duration;
pragma Inline (To_Duration);
function To_Timeval (D : Duration) return struct_timeval;
pragma Inline (To_Timeval);
function gettimeofday
(tv : access struct_timeval;
tz : System.Address) return int;
pragma Import (C, gettimeofday, "gettimeofday");
procedure usleep (useconds : unsigned_long);
pragma Import (C, usleep, "usleep");
......@@ -283,7 +269,7 @@ package System.OS_Interface is
function (arg : System.Address) return System.Address;
function Thread_Body_Access is new
Unchecked_Conversion (System.Address, Thread_Body);
Ada.Unchecked_Conversion (System.Address, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
......@@ -635,12 +621,6 @@ private
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 0;
type struct_timeval is record
tv_sec : long;
tv_usec : long;
end record;
pragma Convention (C, struct_timeval);
type pthread_t is new System.Address;
type pthread_attr_t is new System.Address;
type pthread_mutex_t is new System.Address;
......
gcc/ada/s-osinte-lynxos-3.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -73,11 +73,6 @@ package body System.OS_Interface is
return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
end To_Duration;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
------------------------
-- To_Target_Priority --
------------------------
......@@ -113,30 +108,6 @@ package body System.OS_Interface is
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return struct_timeval is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return struct_timeval'(tv_sec => S,
tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
-------------------------
-- POSIX.1c Section 3 --
-------------------------
......
gcc/ada/s-osinte-lynxos-3.ads
......@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -41,7 +41,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
with Unchecked_Conversion;
with Ada.Unchecked_Conversion;
package System.OS_Interface is
pragma Preelaborate;
......@@ -201,16 +201,6 @@ package System.OS_Interface is
pragma Convention (C, struct_timezone);
type struct_timezone_ptr is access all struct_timezone;
type struct_timeval is private;
-- This is needed on systems that do not have clock_gettime()
-- but do have gettimeofday().
function To_Duration (TV : struct_timeval) return Duration;
pragma Inline (To_Duration);
function To_Timeval (D : Duration) return struct_timeval;
pragma Inline (To_Timeval);
-------------------------
-- Priority Scheduling --
-------------------------
......@@ -253,7 +243,7 @@ package System.OS_Interface is
function (arg : System.Address) return System.Address;
function Thread_Body_Access is new
Unchecked_Conversion (System.Address, Thread_Body);
Ada.Unchecked_Conversion (System.Address, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
......@@ -525,12 +515,6 @@ private
type clockid_t is new unsigned_char;
CLOCK_REALTIME : constant clockid_t := 0;
type struct_timeval is record
tv_sec : time_t;
tv_usec : time_t;
end record;
pragma Convention (C, struct_timeval);
type st_t is record
stksize : int;
prio : int;
......
gcc/ada/s-osinte-lynxos.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2006, AdaCore --
-- Copyright (C) 2001-2007, AdaCore --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -50,11 +50,6 @@ package body System.OS_Interface is
return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
end To_Duration;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
-----------------
-- To_Timespec --
-----------------
......@@ -79,32 +74,6 @@ package body System.OS_Interface is
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return struct_timeval is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return
struct_timeval'
(tv_sec => S,
tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
-------------
-- sigwait --
-------------
......
gcc/ada/s-osinte-lynxos.ads
......@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -41,7 +41,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
with Unchecked_Conversion;
with Ada.Unchecked_Conversion;
package System.OS_Interface is
pragma Preelaborate;
......@@ -220,16 +220,6 @@ package System.OS_Interface is
pragma Convention (C, struct_timezone);
type struct_timezone_ptr is access all struct_timezone;
type struct_timeval is private;
-- This is needed on systems that do not have clock_gettime()
-- but do have gettimeofday().
function To_Duration (TV : struct_timeval) return Duration;
pragma Inline (To_Duration);
function To_Timeval (D : Duration) return struct_timeval;
pragma Inline (To_Timeval);
-------------------------
-- Priority Scheduling --
-------------------------
......@@ -265,7 +255,7 @@ package System.OS_Interface is
function (arg : System.Address) return System.Address;
function Thread_Body_Access is new
Unchecked_Conversion (System.Address, Thread_Body);
Ada.Unchecked_Conversion (System.Address, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
......@@ -520,12 +510,6 @@ private
type clockid_t is new unsigned_char;
CLOCK_REALTIME : constant clockid_t := 0;
type struct_timeval is record
tv_sec : time_t;
tv_usec : time_t;
end record;
pragma Convention (C, struct_timeval);
type st_attr_t is record
stksize : int;
prio : int;
......
gcc/ada/s-osinte-tru64.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -114,11 +114,6 @@ package body System.OS_Interface is
return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
end To_Duration;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
-----------------
-- To_Timespec --
-----------------
......@@ -143,30 +138,4 @@ package body System.OS_Interface is
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return struct_timeval is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return
struct_timeval'
(tv_sec => S,
tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
end System.OS_Interface;
gcc/ada/s-osinte-tru64.ads
......@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1995-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -41,7 +41,7 @@
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
with Unchecked_Conversion;
with Ada.Unchecked_Conversion;
package System.OS_Interface is
pragma Preelaborate;
......@@ -211,15 +211,6 @@ package System.OS_Interface is
tz_dsttime : int;
end record;
pragma Convention (C, struct_timezone);
type struct_timeval is private;
-- This is needed on systems that do not have clock_gettime()
-- but do have gettimeofday().
function To_Duration (TV : struct_timeval) return Duration;
pragma Inline (To_Duration);
function To_Timeval (D : Duration) return struct_timeval;
pragma Inline (To_Timeval);
-------------------------
-- Priority Scheduling --
......@@ -258,7 +249,7 @@ package System.OS_Interface is
function (arg : System.Address) return System.Address;
function Thread_Body_Access is new
Unchecked_Conversion (System.Address, Thread_Body);
Ada.Unchecked_Conversion (System.Address, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
......@@ -514,12 +505,6 @@ private
type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t := 1;
type struct_timeval is record
tv_sec : time_t;
tv_usec : time_t;
end record;
pragma Convention (C, struct_timeval);
type unsigned_long_array is array (Natural range <>) of unsigned_long;
type pthread_t is new System.Address;
......
gcc/ada/s-osprim-mingw.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -79,7 +79,7 @@ package body System.OS_Primitives is
-- GNU/Linker will fail to auto-import those variables when building
-- libgnarl.dll. The indirection level introduced here has no measurable
-- penalties.
--
-- Note that access variables below must not be declared as constant
-- otherwise the compiler optimization will remove this indirect access.
......@@ -179,15 +179,16 @@ package body System.OS_Primitives is
-------------------
procedure Get_Base_Time is
-- The resolution for GetSystemTime is 1 millisecond.
-- The time to get both base times should take less than 1 millisecond.
-- Therefore, the elapsed time reported by GetSystemTime between both
-- actions should be null.
Max_Elapsed : constant := 0;
Max_Elapsed : constant := 0;
Test_Now : aliased Long_Long_Integer;
Test_Now : aliased Long_Long_Integer;
epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
system_time_ns : constant := 100; -- 100 ns per tick
......@@ -225,6 +226,7 @@ package body System.OS_Primitives is
function Monotonic_Clock return Duration is
Current_Ticks : aliased LARGE_INTEGER;
Elap_Secs_Tick : Duration;
begin
if not QueryPerformanceCounter (Current_Ticks'Access) then
return 0.0;
......@@ -262,9 +264,17 @@ package body System.OS_Primitives is
end case;
end Mode_Clock;
-- Local Variables
Base_Time : constant Duration := Mode_Clock;
-- Base_Time is used to detect clock set backward, in this case we
-- cannot ensure the delay accuracy.
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Mode_Clock;
Check_Time : Duration := Base_Time;
-- Start of processing for Timed Delay
begin
if Mode = Relative then
......@@ -280,7 +290,7 @@ package body System.OS_Primitives is
Sleep (DWORD (Rel_Time * 1000.0));
Check_Time := Mode_Clock;
exit when Abs_Time <= Check_Time;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
Rel_Time := Abs_Time - Check_Time;
end loop;
......
gcc/ada/s-osprim-posix.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2006 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -125,11 +125,12 @@ package body System.OS_Primitives is
(Time : Duration;
Mode : Integer)
is
Request : aliased timespec;
Remaind : aliased timespec;
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
Request : aliased timespec;
Remaind : aliased timespec;
Rel_Time : Duration;
Abs_Time : Duration;
Base_Time : constant Duration := Clock;
Check_Time : Duration := Base_Time;
Result : Integer;
pragma Unreferenced (Result);
......@@ -149,7 +150,7 @@ package body System.OS_Primitives is
Result := nanosleep (Request'Access, Remaind'Access);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
Rel_Time := Abs_Time - Check_Time;
end loop;
......
gcc/ada/s-osprim-solaris.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2006 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -88,7 +88,8 @@ package body System.OS_Primitives is
is
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
Base_Time : constant Duration := Clock;
Check_Time : Duration := Base_Time;
timeval : aliased struct_timeval;
begin
......@@ -114,7 +115,7 @@ package body System.OS_Primitives is
C_select (timeout => timeval'Unchecked_Access);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
Rel_Time := Abs_Time - Check_Time;
end loop;
......
gcc/ada/s-osprim-unix.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2006 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -88,7 +88,8 @@ package body System.OS_Primitives is
is
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
Base_Time : constant Duration := Clock;
Check_Time : Duration := Base_Time;
timeval : aliased struct_timeval;
begin
......@@ -114,7 +115,7 @@ package body System.OS_Primitives is
C_select (timeout => timeval'Unchecked_Access);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
Rel_Time := Abs_Time - Check_Time;
end loop;
......
gcc/ada/s-osprim-vxworks.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -121,7 +121,8 @@ package body System.OS_Primitives is
is
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
Base_Time : constant Duration := Clock;
Check_Time : Duration := Base_Time;
Ticks : int;
Result : int;
......@@ -151,7 +152,7 @@ package body System.OS_Primitives is
Result := taskDelay (Ticks);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
Rel_Time := Abs_Time - Check_Time;
end loop;
......
gcc/ada/s-parame-ae653.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -171,18 +171,6 @@ package System.Parameters is
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
----------------------
-- Dynamic Priority --
----------------------
Dynamic_Priority_Support : constant Boolean := True;
-- This constant indicates whether dynamic changes of task priorities
-- are allowed (True means normal RM mode in which such changes are
-- allowed). In particular, if this is False, then we do not need to
-- poll for pending base priority changes at every abort completion
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
---------------------
-- Task Attributes --
---------------------
......@@ -200,6 +188,13 @@ package System.Parameters is
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 32;
-- This constant specifies the maximum length of a task's image.
------------------------------
-- Exception Message Length --
------------------------------
......
gcc/ada/s-parame-hpux.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -169,18 +169,6 @@ package System.Parameters is
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
----------------------
-- Dynamic Priority --
----------------------
Dynamic_Priority_Support : constant Boolean := True;
-- This constant indicates whether dynamic changes of task priorities
-- are allowed (True means normal RM mode in which such changes are
-- allowed). In particular, if this is False, then we do not need to
-- poll for pending base priority changes at every abort completion
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
---------------------
-- Task Attributes --
---------------------
......@@ -198,6 +186,13 @@ package System.Parameters is
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 256;
-- This constant specifies the maximum length of a task's image.
------------------------------
-- Exception Message Length --
------------------------------
......
gcc/ada/s-parame-vms-alpha.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -169,18 +169,6 @@ package System.Parameters is
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
----------------------
-- Dynamic Priority --
----------------------
Dynamic_Priority_Support : constant Boolean := True;
-- This constant indicates whether dynamic changes of task priorities
-- are allowed (True means normal RM mode in which such changes are
-- allowed). In particular, if this is False, then we do not need to
-- poll for pending base priority changes at every abort completion
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
---------------------
-- Task Attributes --
---------------------
......@@ -198,6 +186,13 @@ package System.Parameters is
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 256;
-- This constant specifies the maximum length of a task's image.
------------------------------
-- Exception Message Length --
------------------------------
......
gcc/ada/s-parame-vms-ia64.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -169,18 +169,6 @@ package System.Parameters is
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
----------------------
-- Dynamic Priority --
----------------------
Dynamic_Priority_Support : constant Boolean := True;
-- This constant indicates whether dynamic changes of task priorities
-- are allowed (True means normal RM mode in which such changes are
-- allowed). In particular, if this is False, then we do not need to
-- poll for pending base priority changes at every abort completion
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
---------------------
-- Task Attributes --
---------------------
......@@ -198,6 +186,13 @@ package System.Parameters is
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 256;
-- This constant specifies the maximum length of a task's image.
------------------------------
-- Exception Message Length --
------------------------------
......
gcc/ada/s-parame-vms-restrict.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -169,18 +169,6 @@ package System.Parameters is
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
----------------------
-- Dynamic Priority --
----------------------
Dynamic_Priority_Support : constant Boolean := False;
-- This constant indicates whether dynamic changes of task priorities
-- are allowed (True means normal RM mode in which such changes are
-- allowed). In particular, if this is False, then we do not need to
-- poll for pending base priority changes at every abort completion
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
---------------------
-- Task Attributes --
---------------------
......@@ -198,6 +186,13 @@ package System.Parameters is
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 256;
-- This constant specifies the maximum length of a task's image.
------------------------------
-- Exception Message Length --
------------------------------
......
gcc/ada/s-parame-vxworks.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -171,18 +171,6 @@ package System.Parameters is
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
----------------------
-- Dynamic Priority --
----------------------
Dynamic_Priority_Support : constant Boolean := True;
-- This constant indicates whether dynamic changes of task priorities
-- are allowed (True means normal RM mode in which such changes are
-- allowed). In particular, if this is False, then we do not need to
-- poll for pending base priority changes at every abort completion
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
---------------------
-- Task Attributes --
---------------------
......@@ -200,6 +188,13 @@ package System.Parameters is
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 32;
-- This constant specifies the maximum length of a task's image.
------------------------------
-- Exception Message Length --
------------------------------
......
gcc/ada/s-parame.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -169,18 +169,6 @@ package System.Parameters is
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
----------------------
-- Dynamic Priority --
----------------------
Dynamic_Priority_Support : constant Boolean := True;
-- This constant indicates whether dynamic changes of task priorities
-- are allowed (True means normal RM mode in which such changes are
-- allowed). In particular, if this is False, then we do not need to
-- poll for pending base priority changes at every abort completion
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
---------------------
-- Task Attributes --
---------------------
......@@ -198,6 +186,13 @@ package System.Parameters is
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 256;
-- This constant specifies the maximum length of a task's image.
------------------------------
-- Exception Message Length --
------------------------------
......
gcc/ada/s-taprop-dummy.adb
......@@ -64,8 +64,6 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
-- Dummy version
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
begin
return True;
......@@ -266,7 +264,9 @@ package body System.Task_Primitives.Operations is
---------------
procedure Read_Lock
(L : not null access Lock; Ceiling_Violation : out Boolean) is
(L : not null access Lock;
Ceiling_Violation : out Boolean)
is
begin
Ceiling_Violation := False;
end Read_Lock;
......@@ -310,6 +310,18 @@ package body System.Task_Primitives.Operations is
return Null_Task;
end Self;
-----------------
-- Set_Ceiling --
-----------------
procedure Set_Ceiling
(L : not null access Lock;
Prio : System.Any_Priority)
is
begin
null;
end Set_Ceiling;
---------------
-- Set_False --
---------------
......@@ -420,7 +432,9 @@ package body System.Task_Primitives.Operations is
end Unlock;
procedure Unlock
(L : not null access RTS_Lock; Global_Lock : Boolean := False) is
(L : not null access RTS_Lock;
Global_Lock : Boolean := False)
is
begin
null;
end Unlock;
......@@ -452,7 +466,9 @@ package body System.Task_Primitives.Operations is
----------------
procedure Write_Lock
(L : not null access Lock; Ceiling_Violation : out Boolean) is
(L : not null access Lock;
Ceiling_Violation : out Boolean)
is
begin
Ceiling_Violation := False;
end Write_Lock;
......
gcc/ada/s-tasini.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -81,11 +81,6 @@ package body System.Tasking.Initialization is
-- from all other tasks. It is only used by Task_Lock,
-- Task_Unlock, and Final_Task_Unlock.
function Current_Target_Exception return AE.Exception_Occurrence;
pragma Import
(Ada, Current_Target_Exception, "__gnat_current_target_exception");
-- Import this subprogram from the private part of Ada.Exceptions
----------------------------------------------------------------------
-- Tasking versions of some services needed by non-tasking programs --
----------------------------------------------------------------------
......@@ -112,8 +107,11 @@ package body System.Tasking.Initialization is
function Get_Stack_Info return Stack_Checking.Stack_Access;
-- Get access to the current task's Stack_Info
function Get_Current_Excep return SSL.EOA;
-- Task-safe version of SSL.Get_Current_Excep
procedure Update_Exception
(X : AE.Exception_Occurrence := Current_Target_Exception);
(X : AE.Exception_Occurrence := SSL.Current_Target_Exception);
-- Handle exception setting and check for pending actions
function Task_Name return String;
......@@ -170,7 +168,7 @@ package body System.Tasking.Initialization is
procedure Defer_Abort (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
if No_Abort then
return;
end if;
......@@ -211,7 +209,7 @@ package body System.Tasking.Initialization is
procedure Defer_Abort_Nestable (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
if No_Abort then
return;
end if;
......@@ -232,7 +230,7 @@ package body System.Tasking.Initialization is
procedure Abort_Defer is
Self_ID : Task_Id;
begin
if No_Abort and then not Dynamic_Priority_Support then
if No_Abort then
return;
end if;
......@@ -241,6 +239,15 @@ package body System.Tasking.Initialization is
end Abort_Defer;
-----------------------
-- Get_Current_Excep --
-----------------------
function Get_Current_Excep return SSL.EOA is
begin
return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
end Get_Current_Excep;
-----------------------
-- Do_Pending_Action --
-----------------------
......@@ -266,7 +273,6 @@ package body System.Tasking.Initialization is
Write_Lock (Self_ID);
Self_ID.Pending_Action := False;
Poll_Base_Priority_Change (Self_ID);
Unlock (Self_ID);
if Single_Lock then
......@@ -368,17 +374,18 @@ package body System.Tasking.Initialization is
-- Notify that the tasking run time has been elaborated so that
-- the tasking version of the soft links can be used.
if not No_Abort or else Dynamic_Priority_Support then
if not No_Abort then
SSL.Abort_Defer := Abort_Defer'Access;
SSL.Abort_Undefer := Abort_Undefer'Access;
end if;
SSL.Update_Exception := Update_Exception'Access;
SSL.Lock_Task := Task_Lock'Access;
SSL.Unlock_Task := Task_Unlock'Access;
SSL.Check_Abort_Status := Check_Abort_Status'Access;
SSL.Get_Stack_Info := Get_Stack_Info'Access;
SSL.Task_Name := Task_Name'Access;
SSL.Update_Exception := Update_Exception'Access;
SSL.Get_Current_Excep := Get_Current_Excep'Access;
-- Initialize the tasking soft links (if not done yet) that are common
-- to the full and the restricted run times.
......@@ -522,68 +529,6 @@ package body System.Tasking.Initialization is
end if;
end Locked_Abort_To_Level;
-------------------------------
-- Poll_Base_Priority_Change --
-------------------------------
-- Poll for pending base priority change and for held tasks.
-- This should always be called with (only) Self_ID locked.
-- It may temporarily release Self_ID's lock.
-- The call to Yield is to force enqueuing at the
-- tail of the dispatching queue.
-- We must unlock Self_ID for this to take effect,
-- since we are inheriting high active priority from the lock.
-- See also Poll_Base_Priority_Change_At_Entry_Call,
-- in package System.Tasking.Entry_Calls.
-- In this version, we check if the task is held too because
-- doing this only in Do_Pending_Action is not enough.
procedure Poll_Base_Priority_Change (Self_ID : Task_Id) is
begin
if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then
-- Check for ceiling violations ???
Self_ID.Pending_Priority_Change := False;
if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then
if Single_Lock then
Unlock_RTS;
Yield;
Lock_RTS;
else
Unlock (Self_ID);
Yield;
Write_Lock (Self_ID);
end if;
elsif Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then
Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
else
-- Lowering priority
Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
if Single_Lock then
Unlock_RTS;
Yield;
Lock_RTS;
else
Unlock (Self_ID);
Yield;
Write_Lock (Self_ID);
end if;
end if;
end if;
end Poll_Base_Priority_Change;
--------------------------------
-- Remove_From_All_Tasks_List --
--------------------------------
......@@ -685,7 +630,7 @@ package body System.Tasking.Initialization is
procedure Undefer_Abort (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
if No_Abort then
return;
end if;
......@@ -721,7 +666,7 @@ package body System.Tasking.Initialization is
procedure Undefer_Abort_Nestable (Self_ID : Task_Id) is
begin
if No_Abort and then not Dynamic_Priority_Support then
if No_Abort then
return;
end if;
......@@ -746,7 +691,7 @@ package body System.Tasking.Initialization is
procedure Abort_Undefer is
Self_ID : Task_Id;
begin
if No_Abort and then not Dynamic_Priority_Support then
if No_Abort then
return;
end if;
......@@ -787,7 +732,7 @@ package body System.Tasking.Initialization is
-- Call only when holding no locks
procedure Update_Exception
(X : AE.Exception_Occurrence := Current_Target_Exception)
(X : AE.Exception_Occurrence := SSL.Current_Target_Exception)
is
Self_Id : constant Task_Id := Self;
use Ada.Exceptions;
......@@ -806,7 +751,6 @@ package body System.Tasking.Initialization is
Write_Lock (Self_Id);
Self_Id.Pending_Action := False;
Poll_Base_Priority_Change (Self_Id);
Unlock (Self_Id);
if Single_Lock then
......@@ -856,15 +800,12 @@ package body System.Tasking.Initialization is
New_State : Entry_Call_State)
is
Caller : constant Task_Id := Entry_Call.Self;
begin
pragma Debug (Debug.Trace
(Self_ID, "Wakeup_Entry_Caller", 'E', Caller));
pragma Assert (New_State = Done or else New_State = Cancelled);
pragma Assert
(Caller.Common.State /= Terminated
and then Caller.Common.State /= Unactivated);
pragma Assert (Caller.Common.State /= Unactivated);
Entry_Call.State := New_State;
......@@ -901,15 +842,13 @@ package body System.Tasking.Initialization is
-- the subprogram body where the real subprogram is declared.
procedure Finalize_Attributes (T : Task_Id) is
pragma Warnings (Off, T);
pragma Unreferenced (T);
begin
null;
end Finalize_Attributes;
procedure Initialize_Attributes (T : Task_Id) is
pragma Warnings (Off, T);
pragma Unreferenced (T);
begin
null;
end Initialize_Attributes;
......
gcc/ada/s-tasini.ads
......@@ -139,11 +139,6 @@ package System.Tasking.Initialization is
-- Change the base priority of T. Has to be called with the affected
-- task's ATCB write-locked. May temporariliy release the lock.
procedure Poll_Base_Priority_Change (Self_ID : Task_Id);
-- Has to be called with Self_ID's ATCB write-locked.
-- May temporariliy release the lock.
pragma Inline (Poll_Base_Priority_Change);
----------------------
-- Task Lock/Unlock --
----------------------
......
gcc/ada/s-tasren.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -48,7 +48,6 @@ with System.Tasking.Entry_Calls;
with System.Tasking.Initialization;
-- used for Defer_Abort
-- Undefer_Abort
-- Poll_Base_Priority_Change
-- Do_Pending_Action
with System.Tasking.Queuing;
......@@ -71,6 +70,9 @@ with System.Tasking.Protected_Objects.Operations;
with System.Tasking.Debug;
-- used for Trace
with System.Restrictions;
-- used for Abort_Allowed
with System.Parameters;
-- used for Single_Lock
-- Runtime_Traces
......@@ -476,7 +478,7 @@ package body System.Tasking.Rendezvous is
Send_Trace_Info (E_Missed, Acceptor);
end if;
Initialization.Undefer_Abort (Self_Id);
Local_Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
......@@ -506,7 +508,7 @@ package body System.Tasking.Rendezvous is
Self_Id : constant Task_Id := STPO.Self;
begin
Initialization.Defer_Abort (Self_Id);
Initialization.Defer_Abort_Nestable (Self_Id);
if Single_Lock then
Lock_RTS;
......@@ -520,7 +522,7 @@ package body System.Tasking.Rendezvous is
Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
Initialization.Undefer_Abort_Nestable (Self_Id);
return Result;
end Callable;
......@@ -923,7 +925,11 @@ package body System.Tasking.Rendezvous is
then
Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
pragma Assert (Self_Id.Deferral_Level = 1);
pragma Assert
(Self_Id.Deferral_Level = 1
or else
(Self_Id.Deferral_Level = 0
and then not Restrictions.Abort_Allowed));
Initialization.Defer_Abort_Nestable (Self_Id);
......@@ -1019,7 +1025,6 @@ package body System.Tasking.Rendezvous is
Self_Id.Common.State := Delay_Sleep;
loop
Initialization.Poll_Base_Priority_Change (Self_Id);
exit when
Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
Sleep (Self_Id, Delay_Sleep);
......@@ -1097,6 +1102,11 @@ package body System.Tasking.Rendezvous is
Unlock_RTS;
end if;
-- Call Yield to let other tasks get a chance to run as this is a
-- potential dispatching point.
Yield (Do_Yield => False);
Initialization.Undefer_Abort (Self_Id);
return Return_Count;
end Task_Count;
......@@ -1111,7 +1121,7 @@ package body System.Tasking.Rendezvous is
With_Abort : Boolean) return Boolean
is
E : constant Task_Entry_Index :=
Task_Entry_Index (Entry_Call.E);
Task_Entry_Index (Entry_Call.E);
Old_State : constant Entry_Call_State := Entry_Call.State;
Acceptor : constant Task_Id := Entry_Call.Called_Task;
Parent : constant Task_Id := Acceptor.Common.Parent;
......@@ -1119,7 +1129,8 @@ package body System.Tasking.Rendezvous is
Null_Body : Boolean;
begin
-- Find out whether Entry_Call can be accepted immediately.
-- Find out whether Entry_Call can be accepted immediately
-- If the Acceptor is not callable, return False.
-- If the rendezvous can start, initiate it.
-- If the accept-body is trivial, also complete the rendezvous.
......@@ -1562,6 +1573,8 @@ package body System.Tasking.Rendezvous is
-- Wait for a normal call and a pending action until the
-- Wakeup_Time is reached.
Self_Id.Common.State := Acceptor_Sleep;
-- Try to remove calls to Sleep in the loop below by letting the
-- caller a chance of getting ready immediately, using Unlock
-- Yield. See similar action in Wait_For_Completion/Wait_For_Call.
......@@ -1588,10 +1601,7 @@ package body System.Tasking.Rendezvous is
Self_Id.Open_Accepts := null;
end if;
Self_Id.Common.State := Acceptor_Sleep;
loop
Initialization.Poll_Base_Priority_Change (Self_Id);
exit when Self_Id.Open_Accepts = null;
if Timedout then
......@@ -1653,8 +1663,6 @@ package body System.Tasking.Rendezvous is
Self_Id.Open_Accepts := null;
Self_Id.Common.State := Acceptor_Sleep;
Initialization.Poll_Base_Priority_Change (Self_Id);
STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
Timedout, Yielded);
......@@ -1799,9 +1807,11 @@ package body System.Tasking.Rendezvous is
procedure Wait_For_Call (Self_Id : Task_Id) is
begin
Self_Id.Common.State := Acceptor_Sleep;
-- Try to remove calls to Sleep in the loop below by letting the caller
-- a chance of getting ready immediately, using Unlock & Yield.
-- See similar action in Wait_For_Completion & Selective_Wait.
-- See similar action in Wait_For_Completion & Timed_Selective_Wait.
if Single_Lock then
Unlock_RTS;
......@@ -1825,13 +1835,8 @@ package body System.Tasking.Rendezvous is
Self_Id.Open_Accepts := null;
end if;
Self_Id.Common.State := Acceptor_Sleep;
loop
Initialization.Poll_Base_Priority_Change (Self_Id);
exit when Self_Id.Open_Accepts = null;
Sleep (Self_Id, Acceptor_Sleep);
end loop;
......
gcc/ada/s-tasuti.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -43,7 +43,6 @@ with System.Tasking.Debug;
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Set_Priority
-- Wakeup
-- Unlock
-- Sleep
......@@ -382,7 +381,7 @@ package body System.Tasking.Utilities is
-- Our parent should wait in Phase 1 of Complete_Master.
Master_Completion_Phase := 1;
pragma Assert (Self_ID.Awake_Count = 1);
pragma Assert (Self_ID.Awake_Count >= 1);
end if;
-- We are accepting with a terminate alternative
......@@ -454,8 +453,6 @@ package body System.Tasking.Utilities is
Write_Lock (C);
end loop;
pragma Assert (P.Awake_Count /= 0);
if P.Common.State = Master_Phase_2_Sleep
and then C.Master_of_Task = P.Master_Within
then
......@@ -478,7 +475,6 @@ package body System.Tasking.Utilities is
C.Awake_Count := C.Awake_Count - 1;
if Task_Completed then
pragma Assert (Self_ID.Awake_Count = 0);
C.Alive_Count := C.Alive_Count - 1;
end if;
......@@ -499,7 +495,9 @@ package body System.Tasking.Utilities is
loop
-- Notify P that C has gone passive
P.Awake_Count := P.Awake_Count - 1;
if P.Awake_Count > 0 then
P.Awake_Count := P.Awake_Count - 1;
end if;
if Task_Completed and then C.Alive_Count = 0 then
P.Alive_Count := P.Alive_Count - 1;
......
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