-- --
-- 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- --
-- use for Abort_Defer
-- Abort_Undefer
-with Unchecked_Conversion;
+with Ada.Unchecked_Conversion;
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);
------------------
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
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;
-- --
-- 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- --
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;
-- 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- --
-- 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;
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");
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;
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;
-- --
-- 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- --
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 --
------------------------
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 --
-------------------------
-- 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- --
-- 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;
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 --
-------------------------
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;
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;
-- --
-- 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- --
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 --
-----------------
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 --
-------------
-- 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- --
-- 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;
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 --
-------------------------
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;
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;
-- --
-- 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- --
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 --
-----------------
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;
-- 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- --
-- 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;
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 --
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;
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;
-- --
-- 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- --
-- 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.
-------------------
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
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;
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
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;
-- --
-- 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- --
(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);
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;
-- --
-- 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- --
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
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;
-- --
-- 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- --
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
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;
-- --
-- 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- --
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;
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;
-- --
-- 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- --
-- 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 --
---------------------
-- 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 --
------------------------------
-- --
-- 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- --
-- 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 --
---------------------
-- 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 --
------------------------------
-- --
-- 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- --
-- 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 --
---------------------
-- 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 --
------------------------------
-- --
-- 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- --
-- 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 --
---------------------
-- 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 --
------------------------------
-- --
-- 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- --
-- 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 --
---------------------
-- 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 --
------------------------------
-- --
-- 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- --
-- 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 --
---------------------
-- 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 --
------------------------------
-- --
-- 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- --
-- 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 --
---------------------
-- 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 --
------------------------------
-- --
-- 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- --
with System.Tasking.Initialization;
-- used for Change_Base_Priority
--- Dynamic_Priority_Support
-- Defer_Abort/Undefer_Abort
with System.Tasking.Protected_Objects.Entries;
-----------------------
procedure Lock_Server (Entry_Call : Entry_Call_Link);
- -- This locks the server targeted by Entry_Call.
+
+ -- This locks the server targeted by Entry_Call
--
- -- This may be a task or a protected object,
- -- depending on the target of the original call or any subsequent
- -- requeues.
+ -- This may be a task or a protected object, depending on the target of the
+ -- original call or any subsequent requeues.
--
- -- This routine is needed because the field specifying the server
- -- for this call must be protected by the server's mutex. If it were
- -- protected by the caller's mutex, accessing the server's queues would
- -- require locking the caller to get the server, locking the server,
- -- and then accessing the queues. This involves holding two ATCB
- -- locks at once, something which we can guarantee that it will always
- -- be done in the same order, or locking a protected object while we
- -- hold an ATCB lock, something which is not permitted. Since
- -- the server cannot be obtained reliably, it must be obtained unreliably
- -- and then checked again once it has been locked.
+ -- This routine is needed because the field specifying the server for this
+ -- call must be protected by the server's mutex. If it were protected by
+ -- the caller's mutex, accessing the server's queues would require locking
+ -- the caller to get the server, locking the server, and then accessing the
+ -- queues. This involves holding two ATCB locks at once, something which we
+ -- can guarantee that it will always be done in the same order, or locking
+ -- a protected object while we hold an ATCB lock, something which is not
+ -- permitted. Since the server cannot be obtained reliably, it must be
+ -- obtained unreliably and then checked again once it has been locked.
--
- -- If Single_Lock and server is a PO, release RTS_Lock.
+ -- If Single_Lock and server is a PO, release RTS_Lock
--
-- This should only be called by the Entry_Call.Self.
-- It should be holding no other ATCB locks at the time.
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
- -- This procedure performs priority change of a queued call and
- -- dequeuing of an entry call when the call is cancelled.
- -- If the call is dequeued the state should be set to Cancelled.
- -- Call only with abort deferred and holding lock of Self_ID. This
- -- is a bit of common code for all entry calls. The effect is to do
- -- any deferred base priority change operation, in case some other
- -- task called STPO.Set_Priority while the current task had abort deferred,
- -- and to dequeue the call if the call has been aborted.
+ -- This procedure performs priority change of a queued call and dequeuing
+ -- of an entry call when the call is cancelled. If the call is dequeued the
+ -- state should be set to Cancelled. Call only with abort deferred and
+ -- holding lock of Self_ID. This is a bit of common code for all entry
+ -- calls. The effect is to do any deferred base priority change operation,
+ -- in case some other task called STPO.Set_Priority while the current task
+ -- had abort deferred, and to dequeue the call if the call has been
+ -- aborted.
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
pragma Inline (Poll_Base_Priority_Change_At_Entry_Call);
- -- A specialized version of Poll_Base_Priority_Change,
- -- that does the optional entry queue reordering.
- -- Has to be called with the Self_ID's ATCB write-locked.
- -- May temporariliy release the lock.
+ -- A specialized version of Poll_Base_Priority_Change, that does the
+ -- optional entry queue reordering. Has to be called with the Self_ID's
+ -- ATCB write-locked. May temporariliy release the lock.
---------------------
-- Check_Exception --
Entry_Call.Exception_To_Raise;
begin
-- pragma Assert (Self_ID.Deferral_Level = 0);
+
-- The above may be useful for debugging, but the Florist packages
-- contain critical sections that defer abort and then do entry calls,
-- which causes the above Assert to trip.
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_Id;
- Entry_Call : Entry_Call_Link) is
+ Entry_Call : Entry_Call_Link)
+ is
begin
pragma Assert (Self_ID = Entry_Call.Self);
loop
if Test_Task = null then
- -- Entry_Call was queued on a protected object,
- -- or in transition, when we last fetched Test_Task.
+ -- Entry_Call was queued on a protected object, or in transition,
+ -- when we last fetched Test_Task.
Test_PO := To_Protection (Entry_Call.Called_PO);
Lock_Entries (Test_PO, Ceiling_Violation);
- -- ????
- -- The following code allows Lock_Server to be called
- -- when cancelling a call, to allow for the possibility
- -- that the priority of the caller has been raised
- -- beyond that of the protected entry call by
- -- Ada.Dynamic_Priorities.Set_Priority.
+ -- ???
+
+ -- The following code allows Lock_Server to be called when
+ -- cancelling a call, to allow for the possibility that the
+ -- priority of the caller has been raised beyond that of the
+ -- protected entry call by Ada.Dynamic_Priorities.Set_Priority.
-- If the current task has a higher priority than the ceiling
-- of the protected object, temporarily lower it. It will
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_Id;
- Entry_Call : Entry_Call_Link) is
+ Entry_Call : Entry_Call_Link)
+ is
begin
- if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then
+ if Self_ID.Pending_Priority_Change then
+
-- Check for ceiling violations ???
Self_ID.Pending_Priority_Change := False;
- if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then
- if Single_Lock then
- STPO.Unlock_RTS;
- STPO.Yield;
- STPO.Lock_RTS;
- else
- STPO.Unlock (Self_ID);
- STPO.Yield;
- STPO.Write_Lock (Self_ID);
- end if;
-
- else
- if Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then
- -- Raising priority
-
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
-
- else
- -- Lowering priority
-
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- STPO.Yield;
- STPO.Lock_RTS;
- else
- STPO.Unlock (Self_ID);
- STPO.Yield;
- STPO.Write_Lock (Self_ID);
- end if;
- end if;
- end if;
-
- -- Requeue the entry call at the new priority.
- -- We need to requeue even if the new priority is the same than
- -- the previous (see ACVC cxd4006).
+ -- Requeue the entry call at the new priority. We need to requeue
+ -- even if the new priority is the same than the previous (see ACATS
+ -- test cxd4006).
STPO.Unlock (Self_ID);
Lock_Server (Entry_Call);
procedure Reset_Priority
(Acceptor : Task_Id;
- Acceptor_Prev_Priority : Rendezvous_Priority) is
+ Acceptor_Prev_Priority : Rendezvous_Priority)
+ is
begin
pragma Assert (Acceptor = STPO.Self);
Succeeded := Entry_Call.State = Cancelled;
- if Succeeded then
- Initialization.Undefer_Abort_Nestable (Self_ID);
- else
- -- ???
-
- Initialization.Undefer_Abort_Nestable (Self_ID);
+ Initialization.Undefer_Abort_Nestable (Self_ID);
- -- Ideally, abort should no longer be deferred at this
- -- point, so we should be able to call Check_Exception.
- -- The loop below should be considered temporary,
- -- to work around the possiblility that abort may be deferred
- -- more than one level deep.
+ -- Ideally, abort should no longer be deferred at this point, so we
+ -- should be able to call Check_Exception. The loop below should be
+ -- considered temporary, to work around the possibility that abort
+ -- may be deferred more than one level deep ???
- if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then
- while Self_ID.Deferral_Level > 0 loop
- System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID);
- end loop;
+ if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then
+ while Self_ID.Deferral_Level > 0 loop
+ System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID);
+ end loop;
- Entry_Calls.Check_Exception (Self_ID, Entry_Call);
- end if;
+ Entry_Calls.Check_Exception (Self_ID, Entry_Call);
end if;
end Try_To_Cancel_Entry_Call;
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
Self_Id : constant Task_Id := Entry_Call.Self;
+
begin
-- If this is a conditional call, it should be cancelled when it
-- becomes abortable. This is checked in the loop below.
Send_Trace_Info (W_Completion);
end if;
+ Self_Id.Common.State := Entry_Caller_Sleep;
+
-- Try to remove calls to Sleep in the loop below by letting the caller
-- a chance of getting ready immediately, using Unlock & Yield.
- -- See similar action in Wait_For_Call & Selective_Wait.
+ -- See similar action in Wait_For_Call & Timed_Selective_Wait.
if Single_Lock then
STPO.Unlock_RTS;
STPO.Write_Lock (Self_Id);
end if;
- Self_Id.Common.State := Entry_Caller_Sleep;
-
loop
Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
Yielded := False;
Self_Id.Common.State := Entry_Caller_Sleep;
- -- Looping is necessary in case the task wakes up early from the
- -- timed sleep, due to a "spurious wakeup". Spurious wakeups are
- -- a weakness of POSIX condition variables. A thread waiting for
- -- a condition variable is allowed to wake up at any time, not just
- -- when the condition is signaled. See the same loop in the
- -- ordinary Wait_For_Completion, above.
+ -- Looping is necessary in case the task wakes up early from the timed
+ -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of
+ -- POSIX condition variables. A thread waiting for a condition variable
+ -- is allowed to wake up at any time, not just when the condition is
+ -- signaled. See same loop in the ordinary Wait_For_Completion, above.
if Parameters.Runtime_Traces then
Send_Trace_Info (WT_Completion, Wakeup_Time);
procedure Wait_Until_Abortable
(Self_ID : Task_Id;
- Call : Entry_Call_Link) is
+ Call : Entry_Call_Link)
+ is
begin
pragma Assert (Self_ID.ATC_Nesting_Level > 0);
pragma Assert (Call.Mode = Asynchronous_Call);
-- Check_Exit --
----------------
- -- Dummy version
-
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
begin
return True;
---------------
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;
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 --
---------------
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;
----------------
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;
-- --
-- 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- --
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
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 --
begin
if Self_Id.Deferral_Level = 0
- and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then
- not Self_Id.Aborting
+ and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
+ and then not Self_Id.Aborting
then
Self_Id.Aborting := True;
-- Make sure signals used for RTS internal purpose are unmasked
- Result := pthread_sigmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
-- Stack_Guard --
-----------------
- -- The underlying thread system sets a guard page at the
- -- bottom of a thread stack, so nothing is needed.
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
-- Initialize_Lock --
---------------------
- -- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is
- -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
- -- used in RTS is initialized before any status change of RTS.
- -- Therefore rasing Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore rasing Storage_Error in the following
+ -- routines should be able to be handled safely.
procedure Initialize_Lock
(Prio : System.Any_Priority;
end Initialize_Lock;
procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level) is
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
+ is
pragma Unreferenced (Level);
Attributes : aliased pthread_mutexattr_t;
----------------
procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
is
Result : Interfaces.C.int;
end Write_Lock;
procedure Write_Lock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
---------------
procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
Result : Interfaces.C.int;
begin
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure
Request := To_Timespec (Abs_Time);
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
exit when Abs_Time <= Monotonic_Clock;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
exit when Abs_Time <= Monotonic_Clock;
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
-
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
-- Global array containing the id of the currently running task for
-- each priority.
--
- -- Note: we assume that we are on a single processor with run-til-blocked
- -- scheduling.
+ -- Note: assume we are on single processor with run-til-blocked scheduling
procedure Set_Priority
(T : Task_Id;
or else Priority_Specific_Policy = 'R'
or else Time_Slice_Val > 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif Dispatching_Policy = 'F'
or else Priority_Specific_Policy = 'F'
or else Time_Slice_Val = 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
end if;
pragma Assert (Result = 0);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
+ Result :=
+ pthread_cond_init
+ (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
Result : Interfaces.C.int;
function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
begin
Result := pthread_attr_init (Attributes'Access);
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
procedure Abort_Task (T : Task_Id) is
begin
- --
-- Interrupt Server_Tasks may be waiting on an "event" flag (signal)
- --
+
if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
System.Interrupt_Management.Operations.Interrupt_Self_Process
(System.Interrupt_Management.Interrupt_ID
Cond_Attr : aliased pthread_condattr_t;
Result : Interfaces.C.int;
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (ARM D.10(6)))
S.State := False;
S.Waiting := False;
procedure Finalize (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
procedure Set_False (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
Result := pthread_cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
----------------
procedure Initialize (Environment_Task : Task_Id) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
function State
(Int : System.Interrupt_Management.Interrupt_ID) return Character;
-- --
-- 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- --
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
-- Local Subprograms --
-----------------------
- function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
procedure Abort_Handler (Sig : Signal);
-- Signal handler used to implement asynchronous abort
-- Initialize_Lock --
---------------------
- -- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is
- -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
- -- used in RTS is initialized before any status change of RTS.
- -- Therefore rasing Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore rasing Storage_Error in the following
+ -- routines should be able to be handled safely.
procedure Initialize_Lock
(Prio : System.Any_Priority;
end if;
if Locking_Policy = 'C' then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_PROTECT);
+ Result :=
+ pthread_mutexattr_setprotocol
+ (Attributes'Access, PTHREAD_PRIO_PROTECT);
pragma Assert (Result = 0);
- Result := pthread_mutexattr_setprioceiling
- (Attributes'Access, Interfaces.C.int (Prio));
+ Result :=
+ pthread_mutexattr_setprioceiling
+ (Attributes'Access, Interfaces.C.int (Prio));
pragma Assert (Result = 0);
end if;
end Initialize_Lock;
procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
is
pragma Unreferenced (Level);
(L : not null access Lock; Ceiling_Violation : out Boolean)
is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_lock (L);
Ceiling_Violation := Result = EINVAL;
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
Reason : System.Tasking.Task_States)
is
pragma Unreferenced (Reason);
-
Result : Interfaces.C.int;
begin
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure
is
pragma Unreferenced (Reason);
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
Request := To_Timespec (Abs_Time);
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
if Result = 0 or else errno = EINTR then
Timedout := False;
Time : Duration;
Mode : ST.Delay_Modes)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Request'Access);
- exit when Abs_Time <= Monotonic_Clock;
+ if Single_Lock then
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
+ else
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
+ end if;
+
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
pragma Assert (Result = 0
or else Result = ETIMEDOUT
use type System.Task_Info.Task_Info_Type;
- function To_Int is new Unchecked_Conversion
+ function To_Int is new Ada.Unchecked_Conversion
(System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
function Get_Policy (Prio : System.Any_Priority) return Character;
procedure Enter_Task (Self_ID : Task_Id) is
Result : Interfaces.C.int;
- function To_Int is new Unchecked_Conversion
+ function To_Int is new Ada.Unchecked_Conversion
(System.Task_Info.CPU_Number, Interfaces.C.int);
use System.Task_Info;
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
+ Result :=
+ pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
Result : Interfaces.C.int;
function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
-
- function To_Int is new Unchecked_Conversion
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
+ function To_Int is new Ada.Unchecked_Conversion
(System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int);
- function To_Int is new Unchecked_Conversion
+ function To_Int is new Ada.Unchecked_Conversion
(System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int);
- function To_Int is new Unchecked_Conversion
+ function To_Int is new Ada.Unchecked_Conversion
(System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
begin
return;
end if;
- Result := pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ Result :=
+ pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
pragma Assert (Result = 0);
- Result := pthread_attr_setstacksize
- (Attributes'Access, Interfaces.C.size_t (Stack_Size));
+ Result :=
+ pthread_attr_setstacksize
+ (Attributes'Access, Interfaces.C.size_t (Stack_Size));
pragma Assert (Result = 0);
if T.Common.Task_Info /= null then
- Result := pthread_attr_setscope
- (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
pragma Assert (Result = 0);
- Result := pthread_attr_setinheritsched
- (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance));
+ Result :=
+ pthread_attr_setinheritsched
+ (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance));
pragma Assert (Result = 0);
- Result := pthread_attr_setschedpolicy
- (Attributes'Access, To_Int (T.Common.Task_Info.Policy));
+ Result :=
+ pthread_attr_setschedpolicy
+ (Attributes'Access, To_Int (T.Common.Task_Info.Policy));
pragma Assert (Result = 0);
Sched_Param.sched_priority :=
Interfaces.C.int (T.Common.Task_Info.Priority);
- Result := pthread_attr_setschedparam
- (Attributes'Access, Sched_Param'Access);
+ Result :=
+ pthread_attr_setschedparam
+ (Attributes'Access, Sched_Param'Access);
pragma Assert (Result = 0);
end if;
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ Result :=
+ pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
if Result /= 0
and then T.Common.Task_Info /= null
and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
then
- -- The pthread_create call may have failed because we
- -- asked for a system scope pthread and none were
- -- available (probably because the program was not executed
- -- by the superuser). Let's try for a process scope pthread
- -- instead of raising Tasking_Error.
+ -- The pthread_create call may have failed because we asked for a
+ -- system scope pthread and none were available (probably because
+ -- the program was not executed by the superuser). Let's try for
+ -- a process scope pthread instead of raising Tasking_Error.
System.IO.Put_Line
("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS");
T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS;
- Result := pthread_attr_setscope
- (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
pragma Assert (Result = 0);
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ Result :=
+ pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
end if;
pragma Assert (Result = 0 or else Result = EAGAIN);
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
Mutex_Attr : aliased pthread_mutexattr_t;
Cond_Attr : aliased pthread_condattr_t;
Result : Interfaces.C.int;
+
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (RM D.10(6))
S.State := False;
S.Waiting := False;
if Result = ENOMEM then
Result := pthread_condattr_destroy (Cond_Attr'Access);
pragma Assert (Result = 0);
-
raise Storage_Error;
end if;
end if;
--------------
procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
---------------
procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
Result := pthread_cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
pragma Assert (Result = 0);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
+ -- (RM D.10(10)).
Result := pthread_mutex_unlock (S.L'Access);
pragma Assert (Result = 0);
-- Install the abort-signal handler
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then
act.sa_flags := 0;
act.sa_handler := Abort_Handler'Address;
act.sa_mask := Tmp_Set;
Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
+ sigaction
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end Initialize;
-- --
-- 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- --
-- Raise_From_Signal_Handler
-- Exception_Id
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
-- The followings are internal configuration constants needed
Next_Serial_Number : Task_Serial_Number := 100;
- -- We start at 100, to reserve some special values for
- -- using in error checking.
+ -- We start at 100 (reserve some special values for using in error checks)
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
- -- The following are effectively constants, but they need to
- -- be initialized by calling a pthread_ function.
+ -- The following are effectively constants, but they need to be initialized
+ -- by calling a pthread_ function.
Mutex_Attr : aliased pthread_mutexattr_t;
Cond_Attr : aliased pthread_condattr_t;
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);
-------------------
-- Make sure signals used for RTS internal purpose are unmasked
- Result := pthread_sigmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
pragma Unreferenced (Prio);
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_init (L, Mutex_Attr'Access);
end Initialize_Lock;
procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
is
pragma Unreferenced (Level);
----------------
procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
is
Result : Interfaces.C.int;
begin
---------------
procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
pragma Assert (Self_ID = Self);
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure
is
pragma Unreferenced (Reason);
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
Request := To_Timespec (Abs_Time);
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ if Result = 0 or else Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
- if Result = 0 or Result = EINTR then
- -- somebody may have called Wakeup for us
Timedout := False;
exit;
end if;
-- Timed_Delay --
-----------------
- -- This is for use in implementing delay statements, so
- -- we assume the caller is abort-deferred but is holding
- -- no locks.
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is abort-deferred but is holding no locks.
procedure Timed_Delay
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
pragma Assert (Result = 0 or else
Result = ETIMEDOUT or else
begin
T.Common.Current_Priority := Prio;
- -- Priorities are in range 1 .. 99 on GNU/Linux, so we map
- -- map 0 .. 98 to 1 .. 99
+ -- Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99
Param.sched_priority := Interfaces.C.int (Prio) + 1;
or else Priority_Specific_Policy = 'R'
or else Time_Slice_Val > 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif Dispatching_Policy = 'F'
or else Priority_Specific_Policy = 'F'
or else Time_Slice_Val = 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
Param.sched_priority := 0;
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread,
+ SCHED_OTHER, Param'Access);
end if;
pragma Assert (Result = 0 or else Result = EPERM);
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
procedure Initialize (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (RM D.10(6)))
S.State := False;
S.Waiting := False;
--------------
procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
---------------
procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
Result := pthread_cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
pragma Assert (Result = 0);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
+ -- (RM D.10(10)).
Result := pthread_mutex_unlock (S.L'Access);
pragma Assert (Result = 0);
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
- end if;
+ end
+ if;
end Suspend_Until_True;
----------------
-- Install the abort-signal handler
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then
act.sa_flags := 0;
act.sa_handler := Abort_Handler'Address;
-- --
-- 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- --
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Deallocation;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
end if;
if T.Deferral_Level = 0
- and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
- not T.Aborting
+ and then T.Pending_ATC_Level < T.ATC_Nesting_Level
+ and then not T.Aborting
then
T.Aborting := True;
-- Make sure signals used for RTS internal purpose are unmasked
Result :=
- pthread_sigmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access,
- Old_Set'Unchecked_Access);
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
end Initialize_Lock;
procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
is
pragma Unreferenced (Level);
Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
begin
Result := pthread_mutexattr_init (Attributes'Access);
----------------
procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
is
Result : Interfaces.C.int;
- T : constant Task_Id := Self;
+ T : constant Task_Id := Self;
begin
if Locking_Policy = 'C' then
-- No tricks on RTS_Locks
procedure Write_Lock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
---------------
procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
procedure Unlock (L : not null access Lock) is
Result : Interfaces.C.int;
- T : constant Task_Id := Self;
+ T : constant Task_Id := Self;
begin
Result := pthread_mutex_unlock (L.Mutex'Access);
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
begin
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure
is
pragma Unreferenced (Reason);
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Rel_Time : Duration;
Abs_Time : Duration;
Request : aliased timespec;
end if;
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
if Result = 0 or Result = EINTR then
Time : Duration;
Mode : ST.Delay_Modes)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Rel_Time : Duration;
Request : aliased timespec;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
- pragma Assert (Result = 0
- or else Result = ETIMEDOUT
- or else Result = EINTR);
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ Result = EINTR);
end loop;
Self_ID.Common.State := Runnable;
TS : aliased timespec;
Result : Interfaces.C.int;
begin
- Result := clock_gettime
- (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
+ Result :=
+ clock_gettime
+ (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
Res : aliased timespec;
Result : Interfaces.C.int;
begin
- Result := clock_getres
- (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access);
+ Result :=
+ clock_getres
+ (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (Res);
end RT_Resolution;
if Time_Slice_Supported
and then (Dispatching_Policy = 'R'
- or else Priority_Specific_Policy = 'R'
- or else Time_Slice_Val > 0)
+ or else Priority_Specific_Policy = 'R'
+ or else Time_Slice_Val > 0)
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif Dispatching_Policy = 'F'
or else Priority_Specific_Policy = 'F'
or else Time_Slice_Val = 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
end if;
pragma Assert (Result = 0);
Set_OS_Priority (T, Prio);
if Locking_Policy = 'C' then
- -- Annex D requirements: loss of inheritance puts task at the
- -- beginning of the queue for that prio; copied from 5ztaprop
- -- (VxWorks)
+
+ -- Annex D requirements: loss of inheritance puts task at the start
+ -- of the queue for that prio; copied from 5ztaprop (VxWorks).
if Loss_Of_Inheritance
and then Prio < T.Common.Current_Priority then
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
+ Result :=
+ pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
if Stack_Base_Available then
-- If Stack Checking is supported then allocate 2 additional pages:
- --
+
-- In the worst case, stack is allocated at something like
-- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
-- to be sure the effective stack size is greater than what
return;
end if;
- Result := pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ Result :=
+ pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
pragma Assert (Result = 0);
- Result := pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
+ Result :=
+ pthread_attr_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
if T.Common.Task_Info /= Default_Scope then
-- We are assuming that Scope_Type has the same values than the
-- corresponding C macros
- Result := pthread_attr_setscope
- (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info));
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info));
pragma Assert (Result = 0);
end if;
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ Result :=
+ pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
pragma Assert (Result = 0 or else Result = EAGAIN);
Succeeded := Result = 0;
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
Result := st_setspecific (ATCB_Key, System.Null_Address);
pragma Assert (Result = 0);
end if;
-
end Finalize_TCB;
---------------
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
Result : Interfaces.C.int;
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (RM D.10(6)))
S.State := False;
S.Waiting := False;
--------------
procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
---------------
procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
-- If there is already a task waiting on this suspension object then
-- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
+ -- as specified in (RM D.10(9)). Otherwise, just leave state set True.
if S.Waiting then
S.Waiting := False;
Result := pthread_cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
pragma Assert (Result = 0);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
+ -- (RM D.10 (10)).
Result := pthread_mutex_unlock (S.L'Access);
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
raise Program_Error;
+
else
-- Suspend the task if the state is False. Otherwise, the task
-- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
+ -- is set to False (RM D.10(9)).
if S.State then
S.State := False;
-- Check_Exit --
----------------
- -- Dummy versions
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-- Install the abort-signal handler
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then
act.sa_flags := 0;
act.sa_handler := Abort_Handler'Address;
Result :=
sigaction
- (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
-- --
-- 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- --
with System.Soft_Links;
-- used for Abort_Defer/Undefer
--- We use System.Soft_Links instead of System.Tasking.Initialization
--- because the later is a higher level package that we shouldn't depend on.
--- For example when using the restricted run time, it is replaced by
+-- We use System.Soft_Links instead of System.Tasking.Initialization because
+-- the later is a higher level package that we shouldn't depend on. For
+-- example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Deallocation;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads)
+ Annex_D : Boolean := False;
+ -- Set to True if running with Annex-D semantics
+
------------------------------------
-- The thread local storage index --
------------------------------------
procedure Initialize_Cond (Cond : not null access Condition_Variable) is
hEvent : HANDLE;
-
begin
hEvent := CreateEvent (null, True, False, Null_Ptr);
pragma Assert (hEvent /= 0);
-- Cond_Wait --
---------------
- -- Pre-assertion: Cond is posted
+ -- Pre-condition: Cond is posted
-- L is locked.
- -- Post-assertion: Cond is posted
+ -- Post-condition: Cond is posted
-- L is locked.
procedure Cond_Wait
Result_Bool := ResetEvent (HANDLE (Cond.all));
pragma Assert (Result_Bool = True);
- Unlock (L);
+ Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block
Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
pragma Assert (Result = 0);
- Write_Lock (L);
+ Write_Lock (L, Global_Lock => True);
end Cond_Wait;
---------------------
-- Cond_Timed_Wait --
---------------------
- -- Pre-assertion: Cond is posted
+ -- Pre-condition: Cond is posted
-- L is locked.
- -- Post-assertion: Cond is posted
+ -- Post-condition: Cond is posted
-- L is locked.
procedure Cond_Timed_Wait
Status : out Integer)
is
Time_Out_Max : constant DWORD := 16#FFFF0000#;
- -- NT 4 cannot handle timeout values that are too large,
- -- e.g. DWORD'Last - 1
+ -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1)
- Time_Out : DWORD;
- Result : BOOL;
- Wait_Result : DWORD;
+ Time_Out : DWORD;
+ Result : BOOL;
+ Wait_Result : DWORD;
begin
-- Must reset Cond BEFORE L is unlocked
Result := ResetEvent (HANDLE (Cond.all));
pragma Assert (Result = True);
- Unlock (L);
+ Unlock (L, Global_Lock => True);
-- No problem if we are interrupted here: if the condition is signaled,
-- WaitForSingleObject will simply not block
end if;
end if;
- Write_Lock (L);
+ Write_Lock (L, Global_Lock => True);
-- Ensure post-condition
-- Stack_Guard --
------------------
- -- The underlying thread system sets a guard page at the
- -- bottom of a thread stack, so nothing is needed.
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
- pragma Warnings (Off, T);
- pragma Warnings (Off, On);
-
+ pragma Unreferenced (T, On);
begin
null;
end Stack_Guard;
-- Initialize_Lock --
---------------------
- -- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Intialize_TCB and the Storage_Error is handled.
- -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in
- -- the RTS is initialized before any status change of RTS.
- -- Therefore raising Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Intialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any
+ -- status change of RTS. Therefore raising Storage_Error in the following
+ -- routines should be able to be handled safely.
procedure Initialize_Lock
(Prio : System.Any_Priority;
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
-- Timed_Sleep --
-----------------
- -- This is for use within the run-time system, so abort is
- -- assumed to be already deferred, and the caller should be
- -- holding its own ATCB lock.
+ -- This is for use within the run-time system, so abort is assumed to be
+ -- already deferred, and the caller should be holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_Id;
if Rel_Time > 0.0 then
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Local_Timedout, Result);
else
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Local_Timedout, Result);
end if;
Check_Time := Monotonic_Clock;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Rel_Time, Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Rel_Time, Timedout, Result);
else
- Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Rel_Time, Timedout, Result);
+ Cond_Timed_Wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Rel_Time, Timedout, Result);
end if;
Check_Time := Monotonic_Clock;
procedure Yield (Do_Yield : Boolean := True) is
begin
if Do_Yield then
- Sleep (0);
+ SwitchToThread;
+
+ elsif Annex_D then
+ -- If running with Annex-D semantics we need a delay
+ -- above 0 milliseconds here otherwise processes give
+ -- enough time to the other tasks to have a chance to
+ -- run.
+ --
+ -- This makes cxd8002 ACATS pass on Windows.
+
+ Sleep (1);
end if;
end Yield;
-- 1) from System.Task_Primitives.Operations.Initialize
-- 2) from System.Tasking.Stages.Task_Wrapper
- -- The thread initialisation has to be done only for the first case.
+ -- The thread initialisation has to be done only for the first case
-- This is because the GetCurrentThread NT call does not return the real
-- thread handler but only a "pseudo" one. It is not possible to release
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
Interrupt_Management.Initialize;
if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then
-
-- Here we need Annex D semantics, switch the current process to the
- -- High_Priority_Class.
+ -- Realtime_Priority_Class.
- Discard :=
- OS_Interface.SetPriorityClass
- (GetCurrentProcess, High_Priority_Class);
+ Discard := OS_Interface.SetPriorityClass
+ (GetCurrentProcess, Realtime_Priority_Class);
- -- ??? In theory it should be possible to use the priority class
- -- Realtime_Priority_Class but we suspect a bug in the NT scheduler
- -- which prevents (in some obscure cases) a thread to get on top of
- -- the running queue by another thread of lower priority. For
- -- example cxd8002 ACATS test freeze.
+ Annex_D := True;
end if;
TlsIndex := TlsAlloc;
-- --
-- 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- --
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
-- Signal handler used to implement asynchronous abort.
-- See also comment before body, below.
- function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Abort_Handler --
-------------------
- -- Target-dependent binding of inter-thread Abort signal to
- -- the raising of the Abort_Signal exception.
+ -- Target-dependent binding of inter-thread Abort signal to the raising of
+ -- the Abort_Signal exception.
- -- The technical issues and alternatives here are essentially
- -- the same as for raising exceptions in response to other
- -- signals (e.g. Storage_Error). See code and comments in
- -- the package body System.Interrupt_Management.
+ -- The technical issues and alternatives here are essentially the
+ -- same as for raising exceptions in response to other signals
+ -- (e.g. Storage_Error). See code and comments in the package body
+ -- System.Interrupt_Management.
- -- Some implementations may not allow an exception to be propagated
- -- out of a handler, and others might leave the signal or
- -- interrupt that invoked this handler masked after the exceptional
- -- return to the application code.
+ -- Some implementations may not allow an exception to be propagated out of
+ -- a handler, and others might leave the signal or interrupt that invoked
+ -- this handler masked after the exceptional return to the application
+ -- code.
- -- GNAT exceptions are originally implemented using setjmp()/longjmp().
- -- On most UNIX systems, this will allow transfer out of a signal handler,
+ -- GNAT exceptions are originally implemented using setjmp()/longjmp(). On
+ -- most UNIX systems, this will allow transfer out of a signal handler,
-- which is usually the only mechanism available for implementing
- -- asynchronous handlers of this kind. However, some
- -- systems do not restore the signal mask on longjmp(), leaving the
- -- abort signal masked.
+ -- asynchronous handlers of this kind. However, some systems do not
+ -- restore the signal mask on longjmp(), leaving the abort signal masked.
procedure Abort_Handler (Sig : Signal) is
- pragma Warnings (Off, Sig);
+ pragma Unreferenced (Sig);
T : constant Task_Id := Self;
Result : Interfaces.C.int;
procedure Initialize_Lock
(L : not null access RTS_Lock; Level : Lock_Level)
is
- pragma Warnings (Off, Level);
+ pragma Unreferenced (Level);
Attributes : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
procedure Finalize_Lock (L : not null access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
procedure Finalize_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
procedure Unlock (L : not null access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
(L : not null access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
procedure Unlock (T : Task_Id) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
(Self_ID : Task_Id;
Reason : System.Tasking.Task_States)
is
- pragma Warnings (Off, Reason);
+ pragma Unreferenced (Reason);
Result : Interfaces.C.int;
begin
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure
Timedout : out Boolean;
Yielded : out Boolean)
is
- pragma Warnings (Off, Reason);
+ pragma Unreferenced (Reason);
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Rel_Time : Duration;
Abs_Time : Duration;
Request : aliased timespec;
end if;
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
if Result = 0 or Result = EINTR then
Time : Duration;
Mode : ST.Delay_Modes)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Rel_Time : Duration;
Request : aliased timespec;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
pragma Assert (Result = 0
or else Result = ETIMEDOUT
------------
procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
- pragma Warnings (Off, Reason);
+ pragma Unreferenced (Reason);
Result : Interfaces.C.int;
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
- pragma Warnings (Off, Loss_Of_Inheritance);
+ pragma Unreferenced (Loss_Of_Inheritance);
Result : Interfaces.C.int;
Param : aliased struct_sched_param;
if Result = 0 then
if Locking_Policy = 'C' then
- Result := pthread_mutexattr_setprotocol
- (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ Result :=
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_PROTECT);
pragma Assert (Result = 0);
- Result := pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access,
- Interfaces.C.int (System.Any_Priority'Last));
+ Result :=
+ pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access,
+ Interfaces.C.int (System.Any_Priority'Last));
pragma Assert (Result = 0);
elsif Locking_Policy = 'I' then
- Result := pthread_mutexattr_setprotocol
- (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT);
+ Result :=
+ pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access,
+ PTHREAD_PRIO_INHERIT);
pragma Assert (Result = 0);
end if;
- Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
+ Result :=
+ pthread_cond_init
+ (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
Result : Interfaces.C.int;
function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
use System.Task_Info;
Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
if Stack_Base_Available then
+
-- If Stack Checking is supported then allocate 2 additional pages:
- --
+
-- In the worst case, stack is allocated at something like
-- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
-- to be sure the effective stack size is greater than what
return;
end if;
- Result := pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ Result :=
+ pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
pragma Assert (Result = 0);
- Result := pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
+ Result :=
+ pthread_attr_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
if T.Common.Task_Info /= Default_Scope then
case T.Common.Task_Info is
when System.Task_Info.Process_Scope =>
- Result := pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_PROCESS);
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_PROCESS);
when System.Task_Info.System_Scope =>
- Result := pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
when System.Task_Info.Default_Scope =>
Result := 0;
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
Mutex_Attr : aliased pthread_mutexattr_t;
Cond_Attr : aliased pthread_condattr_t;
Result : Interfaces.C.int;
+
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (RM D.10 (6)))
S.State := False;
S.Waiting := False;
if Result = ENOMEM then
Result := pthread_condattr_destroy (Cond_Attr'Access);
pragma Assert (Result = 0);
-
raise Storage_Error;
end if;
end if;
--------------
procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
---------------
procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
-- If there is already a task waiting on this suspension object then
-- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
+ -- as it is specified in (RM D.10(9)). Otherwise, it just leaves
-- the state to True.
if S.Waiting then
Result := pthread_cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
pragma Assert (Result = 0);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
+ -- (RM D.10(10)).
Result := pthread_mutex_unlock (S.L'Access);
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
raise Program_Error;
+
else
-- Suspend the task if the state is False. Otherwise, the task
-- continues its execution, and the state of the suspension object
-- Dummy version
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
- pragma Warnings (Off, Self_ID);
+ pragma Unreferenced (Self_ID);
begin
return True;
end Check_Exit;
--------------------
function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
- pragma Warnings (Off, Self_ID);
+ pragma Unreferenced (Self_ID);
begin
return True;
end Check_No_Locks;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
- pragma Warnings (Off, T);
- pragma Warnings (Off, Thread_Self);
+ pragma Unreferenced (T, Thread_Self);
begin
return False;
end Suspend_Task;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
- pragma Warnings (Off, T);
- pragma Warnings (Off, Thread_Self);
+ pragma Unreferenced (T, Thread_Self);
begin
return False;
end Resume_Task;
-- Install the abort-signal handler
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then
act.sa_flags := 0;
act.sa_handler := Abort_Handler'Address;
Result :=
sigaction
- (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end Initialize;
-- --
-- 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- --
-- used for Delay_Modes
pragma Warnings (Off);
-with GNAT.OS_Lib;
+with System.OS_Lib;
-- used for String_Access, Getenv
pragma Warnings (On);
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Deallocation;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
-- Make sure signals used for RTS internal purpose are unmasked
- Result := thr_sigsetmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ Result :=
+ thr_sigsetmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
-- _SC_NPROCESSORS_CONF, minus one.
procedure Configure_Processors is
- Proc_Acc : constant GNAT.OS_Lib.String_Access :=
- GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR");
+ Proc_Acc : constant System.OS_Lib.String_Access :=
+ System.OS_Lib.Getenv ("GNAT_PROCESSOR");
Proc : aliased processorid_t; -- User processor #
Last_Proc : processorid_t; -- Last processor #
Proc := processorid_t'Value (Proc_Acc.all);
if Proc <= -2 or else Proc > Last_Proc then
+
-- Use the default configuration
+
null;
+
elsif Proc = -1 then
+
-- Choose a processor
Result := 0;
-
while Proc < Last_Proc loop
Proc := Proc + 1;
Result := p_online (Proc, PR_STATUS);
if Time_Slice_Val > 0 then
- -- Convert Time_Slice_Val (microseconds) into seconds and
- -- nanoseconds
+ -- Convert Time_Slice_Val (microseconds) to seconds/nanosecs
Secs := Interfaces.C.long (Time_Slice_Val / 1_000_000);
Nsecs :=
Prio_Param.rt_tqsecs := Secs;
Prio_Param.rt_tqnsecs := Nsecs;
- Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS,
- Prio_Param'Address);
+ Result :=
+ priocntl
+ (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, Prio_Param'Address);
Using_Real_Time_Class := Result /= -1;
end;
-- Install the abort-signal handler
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then
-- Set sa_flags to SA_NODEFER so that during the handler execution
-- we do not change the Signal_Mask to be masked for the Abort_Signal
act.sa_mask := Tmp_Set;
Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
+ sigaction
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
-- Initialize_Lock --
---------------------
- -- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is
- -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
- -- used in RTS is initialized before any status change of RTS.
- -- Therefore rasing Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore rasing Storage_Error in the following
+ -- routines should be able to be handled safely.
procedure Initialize_Lock
(Prio : System.Any_Priority;
Result : Interfaces.C.int;
begin
- pragma Assert (Check_Initialize_Lock
- (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
+ pragma Assert
+ (Check_Initialize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
pragma Assert (Result = 0 or else Result = ENOMEM);
procedure Finalize_Lock (L : not null access Lock) is
Result : Interfaces.C.int;
-
begin
pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
Result := mutex_destroy (L.L'Access);
procedure Finalize_Lock (L : not null access RTS_Lock) is
Result : Interfaces.C.int;
-
begin
pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
Result := mutex_destroy (L.L'Access);
----------------
procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
is
Result : Interfaces.C.int;
Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
-
begin
if not Single_Lock or else Global_Lock then
pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
procedure Write_Lock (T : Task_Id) is
Result : Interfaces.C.int;
-
begin
if not Single_Lock then
pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
---------------
procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean) is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
------------
procedure Unlock (L : not null access Lock) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
begin
pragma Assert (Check_Unlock (Lock_Ptr (L)));
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-- For the time delay implementation, we need to make sure we
-- achieve following criteria:
Result : Interfaces.C.int;
pragma Unreferenced (Result);
- Param : aliased struct_pcparms;
+ Param : aliased struct_pcparms;
use Task_Info;
if Self_ID.Common.Task_Info.CPU = ANY_CPU then
Result := 0;
Proc := 0;
-
while Proc < Last_Proc loop
Result := p_online (Proc, PR_STATUS);
exit when Result = PR_ONLINE;
raise Invalid_CPU_Number;
end if;
- Result := processor_bind
- (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null);
+ Result :=
+ processor_bind
+ (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null);
pragma Assert (Result = 0);
end if;
end if;
Self_ID.Common.LL.Thread := To_thread_t (-1);
if not Single_Lock then
- Result := mutex_init
- (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
+ Result :=
+ mutex_init
+ (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
Self_ID.Common.LL.L.Level :=
Private_Task_Serial_Number (Self_ID.Serial_Number);
pragma Assert (Result = 0 or else Result = ENOMEM);
Opts := THR_DETACHED + THR_BOUND;
end if;
- Result := thr_create
- (System.Null_Address,
- Adjusted_Stack_Size,
- Thread_Body_Access (Wrapper),
- To_Address (T),
- Opts,
- T.Common.LL.Thread'Access);
+ Result :=
+ thr_create
+ (System.Null_Address,
+ Adjusted_Stack_Size,
+ Thread_Body_Access (Wrapper),
+ To_Address (T),
+ Opts,
+ T.Common.LL.Thread'Access);
Succeeded := Result = 0;
pragma Assert
------------------
procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
- Tmp : Task_Id := T;
+ Result : Interfaces.C.int;
+ Tmp : Task_Id := T;
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
T.Common.LL.Thread := To_thread_t (0);
-- Exit_Task --
---------------
- -- This procedure must be called with abort deferred.
- -- It can no longer call Self or access
- -- the current task's ATCB, since the ATCB has been deallocated.
+ -- This procedure must be called with abort deferred. It can no longer
+ -- call Self or access the current task's ATCB, since the ATCB has been
+ -- deallocated.
procedure Exit_Task is
begin
Result : Interfaces.C.int;
begin
pragma Assert (T /= Self);
-
- Result := thr_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ thr_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
begin
pragma Assert (Check_Sleep (Reason));
- if Dynamic_Priority_Support
- and then Self_ID.Pending_Priority_Change
- then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
if Single_Lock then
- Result := cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
+ Result :=
+ cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
else
- Result := cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
+ Result :=
+ cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
end if;
- pragma Assert (Record_Wakeup
- (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ pragma Assert
+ (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
pragma Assert (Result = 0 or else Result = EINTR);
end Sleep;
Timedout : out Boolean;
Yielded : out Boolean)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
Request := To_Timespec (Abs_Time);
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else (Dynamic_Priority_Support and then
- Self_ID.Pending_Priority_Change);
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access, Request'Access);
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock.L'Access, Request'Access);
else
- Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access, Request'Access);
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access, Request'Access);
end if;
Yielded := True;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
if Result = 0 or Result = EINTR then
end loop;
end if;
- pragma Assert (Record_Wakeup
- (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
+ pragma Assert
+ (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
end Timed_Sleep;
-----------------
Time : Duration;
Mode : ST.Delay_Modes)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
pragma Assert (Check_Sleep (Delay_Sleep));
loop
- if Dynamic_Priority_Support and then
- Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock.L'Access,
- Request'Access);
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock.L'Access,
+ Request'Access);
else
- Result := cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L.L'Access,
- Request'Access);
+ Result :=
+ cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L.L'Access,
+ Request'Access);
end if;
Yielded := True;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
- pragma Assert (Result = 0 or else
- Result = ETIME or else
- Result = EINTR);
+ pragma Assert
+ (Result = 0 or else
+ Result = ETIME or else
+ Result = EINTR);
end loop;
- pragma Assert (Record_Wakeup
- (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
+ pragma Assert
+ (Record_Wakeup
+ (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
Self_ID.Common.State := Runnable;
end if;
Reason : Task_States)
is
Result : Interfaces.C.int;
-
begin
pragma Assert (Check_Wakeup (T, Reason));
Result := cond_signal (T.Common.LL.CV'Access);
-- Check_Initialize_Lock --
---------------------------
- -- The following code is intended to check some of the invariant
- -- assertions related to lock usage, on which we depend.
+ -- The following code is intended to check some of the invariant assertions
+ -- related to lock usage, on which we depend.
function Check_Initialize_Lock
(L : Lock_Ptr;
return False;
end if;
+ -- Magic constant 4???
+
if L.Level = 4 then
Check_Count := Unlock_Count;
end if;
+ -- Magic constant 1000???
+
if Unlock_Count - Check_Count > 1000 then
Check_Count := Unlock_Count;
end if;
procedure Initialize (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to zero (RM D.10(6)))
S.State := False;
S.Waiting := False;
procedure Finalize (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
procedure Set_False (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
Result := cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
pragma Assert (Result = 0);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
+ -- (RM D.10(10)).
Result := mutex_unlock (S.L'Access);
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
raise Program_Error;
+
else
-- Suspend the task if the state is False. Otherwise, the task
-- continues its execution, and the state of the suspension object
-- --
-- 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- --
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Deallocation;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
end if;
if T.Deferral_Level = 0
- and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
- not T.Aborting
+ and then T.Pending_ATC_Level < T.ATC_Nesting_Level
+ and then not T.Aborting
then
T.Aborting := True;
-- Make sure signals used for RTS internal purpose are unmasked
- Result := pthread_sigmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
-- Stack_Guard --
------------------
- -- The underlying thread system sets a guard page at the
- -- bottom of a thread stack, so nothing is needed.
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
-- Initialize_Lock --
---------------------
- -- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is
- -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
- -- used in RTS is initialized before any status change of RTS.
- -- Therefore rasing Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore rasing Storage_Error in the following
+ -- routines should be able to be handled safely.
procedure Initialize_Lock
(Prio : System.Any_Priority;
end Initialize_Lock;
procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
is
pragma Unreferenced (Level);
----------------
procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
is
Result : Interfaces.C.int;
Self_ID : Task_Id;
end Write_Lock;
procedure Write_Lock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
---------------
procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
begin
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure
-- Timed_Sleep --
-----------------
- -- This is for use within the run-time system, so abort is
- -- assumed to be already deferred, and the caller should be
- -- holding its own ATCB lock.
+ -- This is for use within the run-time system, so abort is assumed to be
+ -- already deferred, and the caller should be holding its own ATCB lock.
procedure Timed_Sleep
(Self_ID : Task_Id;
is
pragma Unreferenced (Reason);
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
Request := To_Timespec (Abs_Time);
loop
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change;
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
if Result = 0 or Result = EINTR then
-- Timed_Delay --
-----------------
- -- This is for use in implementing delay statements, so
- -- we assume the caller is abort-deferred but is holding
- -- no locks.
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is abort-deferred but is holding no locks.
procedure Timed_Delay
(Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Base_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Base_Time;
Abs_Time : Duration;
Request : aliased timespec;
Result : Interfaces.C.int;
Self_ID.Common.State := Delay_Sleep;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
- Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access, Request'Access);
+ Result :=
+ pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
- pragma Assert (Result = 0 or else
- Result = ETIMEDOUT or else
- Result = EINTR);
+ pragma Assert (Result = 0 or else
+ Result = ETIMEDOUT or else
+ Result = EINTR);
end loop;
Self_ID.Common.State := Runnable;
or else Priority_Specific_Policy = 'R'
or else Time_Slice_Val > 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif Dispatching_Policy = 'F'
or else Priority_Specific_Policy = 'F'
or else Time_Slice_Val = 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
end if;
pragma Assert (Result = 0);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_mutex_init
- (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_cond_init
- (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
+ Result :=
+ pthread_cond_init
+ (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
return;
end if;
- Result := pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ Result :=
+ pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
pragma Assert (Result = 0);
- Result := pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
+ Result :=
+ pthread_attr_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
Param.sched_priority :=
Interfaces.C.int (Underlying_Priorities (Priority));
- Result := pthread_attr_setschedparam
- (Attributes'Access, Param'Access);
+ Result :=
+ pthread_attr_setschedparam
+ (Attributes'Access, Param'Access);
pragma Assert (Result = 0);
if Dispatching_Policy = 'R'
or else Priority_Specific_Policy = 'R'
or else Time_Slice_Val > 0
then
- Result := pthread_attr_setschedpolicy
- (Attributes'Access, System.OS_Interface.SCHED_RR);
+ Result :=
+ pthread_attr_setschedpolicy
+ (Attributes'Access, System.OS_Interface.SCHED_RR);
elsif Dispatching_Policy = 'F'
or else Priority_Specific_Policy = 'F'
or else Time_Slice_Val = 0
then
- Result := pthread_attr_setschedpolicy
- (Attributes'Access, System.OS_Interface.SCHED_FIFO);
+ Result :=
+ pthread_attr_setschedpolicy
+ (Attributes'Access, System.OS_Interface.SCHED_FIFO);
else
- Result := pthread_attr_setschedpolicy
- (Attributes'Access, System.OS_Interface.SCHED_OTHER);
+ Result :=
+ pthread_attr_setschedpolicy
+ (Attributes'Access, System.OS_Interface.SCHED_OTHER);
end if;
pragma Assert (Result = 0);
- -- Set the scheduling parameters explicitly, since this is the
- -- only way to force the OS to take e.g. the sched policy and scope
- -- attributes into account.
+ -- Set the scheduling parameters explicitly, since this is the only way
+ -- to force the OS to take e.g. the sched policy and scope attributes
+ -- into account.
- Result := pthread_attr_setinheritsched
- (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
+ Result :=
+ pthread_attr_setinheritsched
+ (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
pragma Assert (Result = 0);
T.Common.Current_Priority := Priority;
if T.Common.Task_Info /= null then
case T.Common.Task_Info.Contention_Scope is
when System.Task_Info.Process_Scope =>
- Result := pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_PROCESS);
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_PROCESS);
when System.Task_Info.System_Scope =>
- Result := pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
+ Result :=
+ pthread_attr_setscope
+ (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
when System.Task_Info.Default_Scope =>
Result := 0;
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ Result :=
+ pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
pragma Assert (Result = 0 or else Result = EAGAIN);
Succeeded := Result = 0;
pragma Assert (Result = 0);
if T.Common.Task_Info /= null then
+
-- ??? We're using a process-wide function to implement a task
-- specific characteristic.
if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then
Result := bind_to_cpu (Curpid, 0);
+
elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then
- Result := bind_to_cpu
- (Curpid,
- Interfaces.C.unsigned_long (
- Interfaces.Shift_Left
- (Interfaces.Unsigned_64'(1),
- T.Common.Task_Info.Bind_To_Cpu_Number - 1)));
+ Result :=
+ bind_to_cpu
+ (Curpid,
+ Interfaces.C.unsigned_long (
+ Interfaces.Shift_Left
+ (Interfaces.Unsigned_64'(1),
+ T.Common.Task_Info.Bind_To_Cpu_Number - 1)));
pragma Assert (Result = 0);
end if;
end if;
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
Mutex_Attr : aliased pthread_mutexattr_t;
Cond_Attr : aliased pthread_condattr_t;
Result : Interfaces.C.int;
+
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (RM D.10(6)))
S.State := False;
S.Waiting := False;
procedure Finalize (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
procedure Set_False (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
Result := pthread_mutex_lock (S.L'Access);
pragma Assert (Result = 0);
- -- If there is already a task waiting on this suspension object then
- -- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
+ -- If there is already a task waiting on this suspension object then we
+ -- resume it, leaving the state of the suspension object to False, as
+ -- specified in (RM D.10(9)). Otherwise, leave the state set to True.
if S.Waiting then
S.Waiting := False;
Result := pthread_cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
pragma Assert (Result = 0);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
+ -- (AM D.10(10)).
Result := pthread_mutex_unlock (S.L'Access);
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
raise Program_Error;
+
else
-- Suspend the task if the state is False. Otherwise, the task
-- continues its execution, and the state of the suspension object
- -- is set to False (ARM D.10 par. 9).
+ -- is set to False (RM D.10(9)).
if S.State then
S.State := False;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
- pragma Warnings (Off, T);
- pragma Warnings (Off, Thread_Self);
+ pragma Unreferenced (T, Thread_Self);
begin
return False;
end Suspend_Task;
(T : ST.Task_Id;
Thread_Self : Thread_Id) return Boolean
is
- pragma Warnings (Off, T);
- pragma Warnings (Off, Thread_Self);
+ pragma Unreferenced (T, Thread_Self);
begin
return False;
end Resume_Task;
-- Install the abort-signal handler
- if State (System.Interrupt_Management.Abort_Task_Interrupt)
- /= Default
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
then
act.sa_flags := 0;
act.sa_handler := Abort_Handler'Address;
Result :=
sigaction
- (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end Initialize;
-- --
-- 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- --
-- used for Get_Exc_Stack_Addr
-- Abort_Defer/Undefer
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
-- Key used to find the Ada Task_Id associated with a thread
Environment_Task_Id : Task_Id;
- -- A variable to hold Task_Id for the environment task.
+ -- A variable to hold Task_Id for the environment task
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
Foreign_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads).
+ -- Used to identified fake tasks (i.e., non-Ada Threads)
--------------------
-- Local Packages --
procedure Initialize (Environment_Task : Task_Id);
pragma Inline (Initialize);
- -- Initialize various data needed by this package.
+ -- Initialize various data needed by this package
function Is_Valid_Task return Boolean;
pragma Inline (Is_Valid_Task);
end Specific;
package body Specific is separate;
- -- The body of this package is target specific.
+ -- The body of this package is target specific
---------------------------------
-- Support for foreign threads --
-- Local Subprograms --
-----------------------
- function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
+ function To_Task_Id is
+ new Ada.Unchecked_Conversion (System.Address, Task_Id);
- function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
function Get_Exc_Stack_Addr return Address;
-- Replace System.Soft_Links.Get_Exc_Stack_Addr_NT
procedure Timer_Sleep_AST (ID : Address);
- -- Signal the condition variable when AST fires.
+ -- Signal the condition variable when AST fires
procedure Timer_Sleep_AST (ID : Address) is
Result : Interfaces.C.int;
-- Stack_Guard --
-----------------
- -- The underlying thread system sets a guard page at the
- -- bottom of a thread stack, so nothing is needed.
+ -- The underlying thread system sets a guard page at the bottom of a thread
+ -- stack, so nothing is needed.
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
-- Initialize_Lock --
---------------------
- -- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is
- -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
- -- used in RTS is initialized before any status change of RTS.
- -- Therefore rasing Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- Note: mutexes and cond_variables needed per-task basis are initialized
+ -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
+ -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
+ -- status change of RTS. Therefore rasing Storage_Error in the following
+ -- routines should be able to be handled safely.
procedure Initialize_Lock
- (Prio : System.Any_Priority; L : not null access Lock)
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
is
Attributes : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
end Initialize_Lock;
procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
is
pragma Unreferenced (Level);
----------------
procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
is
Self_ID : constant Task_Id := Self;
All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link;
---------------
procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
begin
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
begin
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure
Sleep_Time := To_OS_Time (Time, Mode);
- if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
- or else Self_ID.Pending_Priority_Change
- then
+ if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
return;
end if;
end if;
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
pragma Assert (Result = 0);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
(Status, 0, Sleep_Time,
Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
+ -- Comment following test
+
if (Status and 1) /= 1 then
raise Storage_Error;
end if;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
Sys_Cantim (Status, To_Address (Self_ID), 0);
pragma Assert ((Status and 1) = 1);
end if;
if Single_Lock then
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access);
pragma Assert (Result = 0);
else
- Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ Result :=
+ pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access);
pragma Assert (Result = 0);
end if;
function RT_Resolution return Duration is
begin
+ -- Document origin of this magic constant ???
return 10#1.0#E-3;
end RT_Resolution;
or else Priority_Specific_Policy = 'R'
or else Time_Slice_Val > 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif Dispatching_Policy = 'F'
or else Priority_Specific_Policy = 'F'
or else Time_Slice_Val = 0
then
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
-- SCHED_OTHER priorities are restricted to the range 8 - 15.
-- in a range of 16 - 31, dividing by 2 gives the correct result.
Param.sched_priority := Param.sched_priority / 2;
- Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ Result :=
+ pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
end if;
pragma Assert (Result = 0);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
+ Result :=
+ pthread_mutex_init
+ (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
+ Result :=
+ pthread_cond_init
+ (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
Result : Interfaces.C.int;
function Thread_Body_Access is new
- Unchecked_Conversion (System.Address, Thread_Body);
+ Ada.Unchecked_Conversion (System.Address, Thread_Body);
begin
-- Since the initial signal mask of a thread is inherited from the
(Attributes'Access, PTHREAD_EXPLICIT_SCHED);
pragma Assert (Result = 0);
- Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ Result :=
+ pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
- -- ENOMEM is a valid run-time error. Don't shut down.
+ -- ENOMEM is a valid run-time error -- do not shut down
pragma Assert (Result = 0
or else Result = EAGAIN or else Result = ENOMEM);
Is_Self : constant Boolean := T = Self;
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
- procedure Free is new Unchecked_Deallocation
+ procedure Free is new Ada.Unchecked_Deallocation
(Exc_Stack_T, Exc_Stack_Ptr_T);
begin
end if;
Free (T.Common.LL.Exc_Stack_Ptr);
-
Free (Tmp);
if Is_Self then
Cond_Attr : aliased pthread_condattr_t;
Result : Interfaces.C.int;
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (D.10 (6)))
S.State := False;
S.Waiting := False;
--------------
procedure Finalize (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
-- Destroy internal mutex
---------------
procedure Set_False (S : in out Suspension_Object) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
-- If there is already a task waiting on this suspension object then
-- we resume it, leaving the state of the suspension object to False,
- -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
- -- the state to True.
+ -- as specified in (RM D.10(9)), otherwise leave state set to True.
if S.Waiting then
S.Waiting := False;
Result := pthread_cond_signal (S.CV'Access);
pragma Assert (Result = 0);
+
else
S.State := True;
end if;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : Interfaces.C.int;
+
begin
SSL.Abort_Defer.all;
pragma Assert (Result = 0);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
- -- (ARM D.10 par. 10).
+ -- (RM D.10(10)).
Result := pthread_mutex_unlock (S.L'Access);
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
raise Program_Error;
+
else
-- Suspend the task if the state is False. Otherwise, the task
-- continues its execution, and the state of the suspension object
-- --
-- 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- --
with System.Interrupt_Management;
-- used for Keep_Unmasked
--- Abort_Task_Signal
+-- Abort_Task_Interrupt
-- Signal_ID
-- Initialize_Interrupts
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
procedure Install_Signal_Handlers;
-- Install the default signal handlers for the current task
- function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
+ function To_Address is
+ new Ada.Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Abort_Handler --
-- Make sure signals used for RTS internal purpose are unmasked
- Result := pthread_sigmask (SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ Result :=
+ pthread_sigmask
+ (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access,
+ Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
Result :=
sigaction
- (Signal (Interrupt_Management.Abort_Task_Signal),
+ (Signal (Interrupt_Management.Abort_Task_Interrupt),
act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
---------------------
procedure Initialize_Lock
- (Prio : System.Any_Priority; L : not null access Lock) is
+ (Prio : System.Any_Priority;
+ L : not null access Lock)
+ is
begin
L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
L.Prio_Ceiling := int (Prio);
end Initialize_Lock;
procedure Initialize_Lock
- (L : not null access RTS_Lock; Level : Lock_Level)
+ (L : not null access RTS_Lock;
+ Level : Lock_Level)
is
pragma Unreferenced (Level);
-
begin
L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
L.Prio_Ceiling := int (System.Any_Priority'Last);
----------------
procedure Write_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean)
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
is
Result : int;
+
begin
if L.Protocol = Prio_Protect
and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
---------------
procedure Read_Lock
- (L : not null access Lock; Ceiling_Violation : out Boolean) is
+ (L : not null access Lock;
+ Ceiling_Violation : out Boolean)
+ is
begin
Write_Lock (L, Ceiling_Violation);
end Read_Lock;
end Unlock;
procedure Unlock
- (L : not null access RTS_Lock; Global_Lock : Boolean := False)
+ (L : not null access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : int;
begin
end if;
end Unlock;
+ -----------------
+ -- Set_Ceiling --
+ -----------------
+
+ -- Dynamic priority ceilings are not supported by the underlying system
+
+ procedure Set_Ceiling
+ (L : not null access Lock;
+ Prio : System.Any_Priority)
+ is
+ pragma Unreferenced (L, Prio);
+ begin
+ null;
+ end Set_Ceiling;
+
-----------
-- Sleep --
-----------
if Ticks /= int'Last then
Timedout := True;
+
else
Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
if Ticks > 0 then
- -- Modifying State and Pending_Priority_Change, locking the TCB
+ -- Modifying State, locking the TCB
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
Timedout := False;
loop
- if Self_ID.Pending_Priority_Change then
- Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
- Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
- end if;
-
Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
-- Release the TCB before sleeping
and then Loss_Of_Inheritance
and then Prio < T.Common.Current_Priority
then
- -- Annex D requirement [RM D.2.2 par. 9]:
+ -- Annex D requirement (RM D.2.2(9))
-- If the task drops its priority due to the loss of inherited
-- priority, it is added at the head of the ready queue for its
if Self_ID.Common.LL.CV = 0 then
Succeeded := False;
+
else
Succeeded := True;
-- Now spawn the VxWorks task for real
- T.Common.LL.Thread := taskSpawn
- (Name_Address,
- To_VxWorks_Priority (int (Priority)),
- Get_Task_Options,
- Adjusted_Stack_Size,
- Wrapper,
- To_Address (T));
+ T.Common.LL.Thread :=
+ taskSpawn
+ (Name_Address,
+ To_VxWorks_Priority (int (Priority)),
+ Get_Task_Options,
+ Adjusted_Stack_Size,
+ Wrapper,
+ To_Address (T));
end;
if T.Common.LL.Thread = -1 then
Is_Self : constant Boolean := (T = Self);
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
procedure Abort_Task (T : Task_Id) is
Result : int;
begin
- Result := kill (T.Common.LL.Thread,
- Signal (Interrupt_Management.Abort_Task_Signal));
+ Result :=
+ kill
+ (T.Common.LL.Thread,
+ Signal (Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
procedure Initialize (S : in out Suspension_Object) is
begin
- -- Initialize internal state. It is always initialized to False (ARM
- -- D.10 par. 6).
+ -- Initialize internal state (always to False (RM D.10(6)))
S.State := False;
S.Waiting := False;
procedure Finalize (S : in out Suspension_Object) is
Result : STATUS;
+
begin
-- Destroy internal mutex
---------------
procedure Set_False (S : in out Suspension_Object) is
- Result : STATUS;
+ Result : STATUS;
+
begin
SSL.Abort_Defer.all;
procedure Set_True (S : in out Suspension_Object) is
Result : STATUS;
+
begin
SSL.Abort_Defer.all;
procedure Suspend_Until_True (S : in out Suspension_Object) is
Result : STATUS;
+
begin
SSL.Abort_Defer.all;
Result := semTake (S.L, WAIT_FOREVER);
if S.Waiting then
+
-- Program_Error must be raised upon calling Suspend_Until_True
-- if another task is already waiting on that suspension object
-- (ARM D.10 par. 10).
SSL.Abort_Undefer.all;
raise Program_Error;
+
else
-- Suspend the task if the state is False. Otherwise, the task
-- continues its execution, and the state of the suspension object
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
+
else
S.Waiting := True;
procedure Initialize (Environment_Task : Task_Id) is
Result : int;
+
begin
Environment_Task_Id := Environment_Task;
end if;
if Time_Slice_Val > 0 then
- Result := Set_Time_Slice
- (To_Clock_Ticks
- (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
+ Result :=
+ Set_Time_Slice
+ (To_Clock_Ticks
+ (Duration (Time_Slice_Val) / Duration (1_000_000.0)));
elsif Dispatching_Policy = 'R' then
Result := Set_Time_Slice (To_Clock_Ticks (0.01));
-- --
-- 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- --
-- 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 --
----------------------------------------------------------------------
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;
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;
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;
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;
Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
end Abort_Defer;
+ -----------------------
+ -- Get_Current_Excep --
+ -----------------------
+
+ function Get_Current_Excep return SSL.EOA is
+ begin
+ return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
+ end Get_Current_Excep;
+
-----------------------
-- Do_Pending_Action --
-----------------------
Write_Lock (Self_ID);
Self_ID.Pending_Action := False;
- Poll_Base_Priority_Change (Self_ID);
Unlock (Self_ID);
if Single_Lock then
-- 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.
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 --
--------------------------------
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;
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;
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;
-- 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;
Write_Lock (Self_Id);
Self_Id.Pending_Action := False;
- Poll_Base_Priority_Change (Self_Id);
Unlock (Self_Id);
if Single_Lock then
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;
-- 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;
-- 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 --
----------------------
-- --
-- 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- --
with System.Tasking.Initialization;
-- used for Defer_Abort
-- Undefer_Abort
--- Poll_Base_Priority_Change
-- Do_Pending_Action
with System.Tasking.Queuing;
with System.Tasking.Debug;
-- used for Trace
+with System.Restrictions;
+-- used for Abort_Allowed
+
with System.Parameters;
-- used for Single_Lock
-- Runtime_Traces
Send_Trace_Info (E_Missed, Acceptor);
end if;
- Initialization.Undefer_Abort (Self_Id);
+ Local_Undefer_Abort (Self_Id);
raise Tasking_Error;
end if;
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;
Unlock_RTS;
end if;
- Initialization.Undefer_Abort (Self_Id);
+ Initialization.Undefer_Abort_Nestable (Self_Id);
return Result;
end Callable;
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);
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);
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;
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;
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.
-- 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.
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
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);
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;
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;
-- --
-- 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- --
with System.Task_Primitives.Operations;
-- used for Write_Lock
--- Set_Priority
-- Wakeup
-- Unlock
-- Sleep
-- 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
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
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;
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;
projects / gcc.git / commitdiff