------------------------------------------------------------------------------
-- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
with System.Tasking.Debug;
-- used for Known_Tasks
-with Interfaces.C;
--- used for int
--- size_t
-
with System.Interrupt_Management;
-- used for Keep_Unmasked
-- Abort_Task_Interrupt
-- Interrupt_ID
+pragma Warnings (Off);
with System.Interrupt_Management.Operations;
-- used for Set_Interrupt_Mask
-- All_Tasks_Mask
pragma Elaborate_All (System.Interrupt_Management.Operations);
-with System.Parameters;
--- used for Size_Type
+pragma Warnings (On);
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Interfaces.C;
+-- used for int
+-- size_t
with System.Task_Primitives.Interrupt_Operations;
-- used for Get_Interrupt_ID
-with System.Tasking;
--- used for Ada_Task_Control_Block
--- Task_Id
-
with System.Soft_Links;
-- used for Defer/Undefer_Abort
--- Note that we do not use System.Tasking.Initialization directly since
--- this 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.Initialization
-
-with System.OS_Primitives;
--- used for Delay_Modes
+-- 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_Conversion;
with Unchecked_Deallocation;
package body System.Task_Primitives.Operations is
+ package SSL renames System.Soft_Links;
+
use System.Tasking.Debug;
use System.Tasking;
use Interfaces.C;
use System.OS_Primitives;
package PIO renames System.Task_Primitives.Interrupt_Operations;
- package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
-- 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
Unblocked_Signal_Mask : aliased sigset_t;
-- The set of signals that should unblocked in all tasks
-- is not implemented for DCE threads. The HPUX 10 port is at this
-- stage considered dead, and no further work is planned on it.
- FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
- -- Indicates whether FIFO_Within_Priorities is set.
-
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);
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
- -- Set the self id for the current task.
+ -- Set the self id for the current task
function Self return Task_Id;
pragma Inline (Self);
- -- Return a pointer to the Ada Task Control Block of the calling task.
+ -- Return a pointer to the Ada Task Control Block of the calling 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 --
---------------------------------
function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
- -- Allocate and Initialize a new ATCB for the current Thread.
+ -- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
(Thread : Thread_Id) return Task_Id is separate;
(L : 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_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 : access Lock) is
Result : Interfaces.C.int;
-
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
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);
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
- -- EINTR is not considered a failure.
+ -- EINTR is not considered a failure
+
pragma Assert (Result = 0 or else Result = EINTR);
end Sleep;
Result : Interfaces.C.int;
begin
- -- Only the little window between deferring abort and
- -- locking Self_ID is the reason we need to
- -- check for pending abort and priority change below! :(
-
- SSL.Abort_Defer.all;
-
if Single_Lock then
Lock_RTS;
end if;
end if;
Result := sched_yield;
- SSL.Abort_Undefer.all;
end Timed_Delay;
---------------------
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : Interfaces.C.int;
-
begin
Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0);
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_RR, Param'Access);
- elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
+ elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
pragma Assert (Result = 0);
- if FIFO_Within_Priorities then
+ if Dispatching_Policy = 'F' then
-- Annex D requirement [RM D.2.2 par. 9]:
-- If the task drops its priority due to the loss of inherited
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
- Attributes : aliased pthread_attr_t;
- Adjusted_Stack_Size : Interfaces.C.size_t;
- Result : Interfaces.C.int;
+ Attributes : aliased pthread_attr_t;
+ Result : Interfaces.C.int;
function Thread_Body_Access is new
Unchecked_Conversion (System.Address, Thread_Body);
begin
- if Stack_Size = Unspecified_Size then
- Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
-
- elsif Stack_Size < Minimum_Stack_Size then
- Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
-
- else
- Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
- end if;
-
Result := pthread_attr_init (Attributes'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
Result := pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
+ (Attributes'Access, Interfaces.C.size_t (Stack_Size));
pragma Assert (Result = 0);
-- Since the initial signal mask of a thread is inherited from the
end Abort_Task;
----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Suspension_Object) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Cond_Attr : aliased pthread_condattr_t;
+ Result : Interfaces.C.int;
+ begin
+ -- Initialize internal state. It is always initialized to False (ARM
+ -- D.10 par. 6).
+
+ S.State := False;
+ S.Waiting := False;
+
+ -- Initialize internal mutex
+
+ Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ -- Initialize internal condition variable
+
+ Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+ end if;
+ end Initialize;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Suspension_Object) is
+ Result : Interfaces.C.int;
+ begin
+ -- Destroy internal mutex
+
+ Result := pthread_mutex_destroy (S.L'Access);
+ pragma Assert (Result = 0);
+
+ -- Destroy internal condition variable
+
+ Result := pthread_cond_destroy (S.CV'Access);
+ pragma Assert (Result = 0);
+ end Finalize;
+
+ -------------------
+ -- Current_State --
+ -------------------
+
+ function Current_State (S : Suspension_Object) return Boolean is
+ begin
+ -- We do not want to use lock on this read operation. State is marked
+ -- as Atomic so that we ensure that the value retrieved is correct.
+
+ return S.State;
+ end Current_State;
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False (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);
+
+ S.State := False;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ 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 S.Waiting then
+ S.Waiting := False;
+ S.State := False;
+
+ Result := pthread_cond_signal (S.CV'Access);
+ pragma Assert (Result = 0);
+ else
+ S.State := True;
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end Set_True;
+
+ ------------------------
+ -- Suspend_Until_True --
+ ------------------------
+
+ procedure Suspend_Until_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 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).
+
+ 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).
+
+ if S.State then
+ S.State := False;
+ else
+ S.Waiting := True;
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ end if;
+
+ Result := pthread_mutex_unlock (S.L'Access);
+ pragma Assert (Result = 0);
+
+ SSL.Abort_Undefer.all;
+ end if;
+ end Suspend_Until_True;
+
+ ----------------
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
function Suspend_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Suspend_Task;
function Resume_Task
(T : ST.Task_Id;
- Thread_Self : Thread_Id)
- return Boolean
+ Thread_Self : Thread_Id) return Boolean
is
pragma Unreferenced (T);
pragma Unreferenced (Thread_Self);
-
begin
return False;
end Resume_Task;
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
- function State (Int : System.Interrupt_Management.Interrupt_ID)
- return Character;
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
- -- Get interrupt state. Defined in a-init.c
- -- The input argument is the interrupt number,
- -- and the result is one of the following:
+ -- Get interrupt state. Defined in a-init.c. The input argument is
+ -- the interrupt number, and the result is one of the following:
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
begin
Environment_Task_Id := Environment_Task;
- -- Initialize the lock used to synchronize chain of all ATCBs.
+ Interrupt_Management.Initialize;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
OSDN Git Service
