-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
-- 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
+-- System.Tasking.Restricted.Stages.
with System.OS_Interface;
-- used for various type, constant, and operations
with System.Tasking;
-- used for Ada_Task_Control_Block
--- Task_ID
+-- Task_Id
-- ATCB components and types
with Interfaces.C;
-- Local Data --
----------------
- -- The followings are logically constants, but need to be initialized
- -- at run time.
+ -- The followings are logically constants, but need to be initialized at
+ -- run time.
Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
+ -- This is a lock to allow only one thread of control in the RTS at a
+ -- time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
ATCB_Key : aliased System.Address := System.Null_Address;
- -- Key used to find the Ada Task_ID associated with a thread
+ -- Key used to find the Ada Task_Id associated with a thread
ATCB_Key_Addr : System.Address := ATCB_Key'Address;
pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
-- implementation. This mechanism is used to minimize impact on other
-- targets.
- Environment_Task_ID : Task_ID;
- -- A variable to hold Task_ID for the environment task.
+ Environment_Task_Id : Task_Id;
+ -- 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
- -- The followings are internal configuration constants needed.
+ -- The followings are internal configuration constants needed
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
- -- Indicates whether FIFO_Within_Priorities is set.
+ -- Indicates whether FIFO_Within_Priorities is set
Mutex_Protocol : Priority_Type;
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 --
pragma Inline (Is_Valid_Task);
-- Does executing thread have a TCB?
- procedure Set (Self_Id : Task_ID);
+ 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;
+ 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.
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
+ -- Allocate and Initialize a new ATCB for the current Thread
function Register_Foreign_Thread
- (Thread : Thread_Id) return Task_ID is separate;
+ (Thread : Thread_Id) return Task_Id is separate;
-----------------------
-- Local Subprograms --
-----------------------
procedure Abort_Handler (signo : Signal);
- -- Handler for the abort (SIGABRT) signal to handle asynchronous abortion.
+ -- Handler for the abort (SIGABRT) signal to handle asynchronous abort
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 Unchecked_Conversion (Task_Id, System.Address);
-------------------
-- Abort_Handler --
procedure Abort_Handler (signo : Signal) is
pragma Unreferenced (signo);
- Self_ID : constant Task_ID := Self;
+ Self_ID : constant Task_Id := Self;
Result : int;
Old_Set : aliased sigset_t;
-- Stack_Guard --
-----------------
- procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
pragma Unreferenced (T);
pragma Unreferenced (On);
-- Get_Thread_Id --
-------------------
- function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
begin
return T.Common.LL.Thread;
end Get_Thread_Id;
-- Self --
----------
- function Self return Task_ID renames Specific.Self;
+ function Self return Task_Id renames Specific.Self;
-----------------------------
-- Install_Signal_Handlers --
end if;
end Write_Lock;
- procedure Write_Lock (T : Task_ID) is
+ procedure Write_Lock (T : Task_Id) is
Result : int;
begin
end if;
end Unlock;
- procedure Unlock (T : Task_ID) is
+ procedure Unlock (T : Task_Id) is
Result : int;
begin
-- Sleep --
-----------
- procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is
+ procedure Sleep (Self_ID : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
Result : int;
begin
pragma Assert (Self_ID = Self);
- -- Release the mutex before sleeping.
+ -- Release the mutex before sleeping
+
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
else
pragma Assert (Result = 0);
- -- Perform a blocking operation to take the CV semaphore.
- -- Note that a blocking operation in VxWorks will reenable
- -- task scheduling. When we are no longer blocked and control
- -- is returned, task scheduling will again be disabled.
+ -- Perform a blocking operation to take the CV semaphore. Note that a
+ -- blocking operation in VxWorks will reenable task scheduling. When we
+ -- are no longer blocked and control is returned, task scheduling will
+ -- again be disabled.
Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
pragma Assert (Result = 0);
- -- Take the mutex back.
+ -- Take the mutex back
+
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
-- 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;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes;
Reason : System.Tasking.Task_States;
if Mode = Relative then
Absolute := Orig + Time;
- -- Systematically add one since the first tick will delay
- -- *at most* 1 / Rate_Duration seconds, so we need to add one to
- -- be on the safe side.
+ -- Systematically add one since the first tick will delay *at most*
+ -- 1 / Rate_Duration seconds, so we need to add one to be on the
+ -- safe side.
Ticks := To_Clock_Ticks (Time);
if Ticks > 0 then
loop
- -- Release the mutex before sleeping.
+ -- Release the mutex before sleeping
+
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
else
pragma Assert (Result = 0);
- -- Perform a blocking operation to take the CV semaphore.
- -- Note that a blocking operation in VxWorks will reenable
- -- task scheduling. When we are no longer blocked and control
- -- is returned, task scheduling will again be disabled.
+ -- Perform a blocking operation to take the CV semaphore. Note
+ -- that a blocking operation in VxWorks will reenable task
+ -- scheduling. When we are no longer blocked and control is
+ -- returned, task scheduling will again be disabled.
Result := semTake (Self_ID.Common.LL.CV, Ticks);
if Result = 0 then
+
-- Somebody may have called Wakeup for us
Wakeup := True;
else
if errno /= S_objLib_OBJ_TIMEOUT then
Wakeup := True;
+
else
- -- If Ticks = int'last, it was most probably truncated
- -- so let's make another round after recomputing Ticks
- -- from the the absolute time.
+ -- If Ticks = int'last, it was most probably truncated so
+ -- let's make another round after recomputing Ticks from
+ -- the the absolute time.
if Ticks /= int'Last then
Timedout := True;
end if;
end if;
- -- Take the mutex back.
+ -- Take the mutex back
+
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
else
Timedout := True;
- -- Should never hold a lock while yielding.
+ -- Should never hold a lock while yielding
+
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
taskDelay (0);
-- Timed_Delay --
-----------------
- -- This is for use in implementing delay statements, so
- -- we assume the caller is holding no locks.
+ -- This is for use in implementing delay statements, so we assume the
+ -- caller is holding no locks.
procedure Timed_Delay
- (Self_ID : Task_ID;
+ (Self_ID : Task_Id;
Time : Duration;
Mode : ST.Delay_Modes)
is
if Ticks > 0 and then Ticks < int'Last then
- -- The first tick will delay anytime between 0 and
- -- 1 / sysClkRateGet seconds, so we need to add one to
- -- be on the safe side.
+ -- First tick will delay anytime between 0 and 1 / sysClkRateGet
+ -- seconds, so we need to add one to be on the safe side.
Ticks := Ticks + 1;
end if;
end if;
if Ticks > 0 then
- -- Modifying State and Pending_Priority_Change, locking the TCB.
+
+ -- Modifying State and Pending_Priority_Change, locking the TCB
+
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
Result := semTake (Self_ID.Common.LL.CV, Ticks);
if Result /= 0 then
+
-- If Ticks = int'last, it was most probably truncated
-- so let's make another round after recomputing Ticks
-- from the the absolute time.
function Monotonic_Clock return Duration is
TS : aliased timespec;
Result : int;
-
begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0);
-- Wakeup --
------------
- procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
pragma Unreferenced (Reason);
-
Result : int;
-
begin
Result := semGive (T.Common.LL.CV);
pragma Assert (Result = 0);
-- with run-till-blocked scheduling.
procedure Set_Priority
- (T : Task_ID;
+ (T : Task_Id;
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
if FIFO_Within_Priorities then
-- Annex D requirement [RM D.2.2 par. 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
-- new active priority.
-- Get_Priority --
------------------
- function Get_Priority (T : Task_ID) return System.Any_Priority is
+ function Get_Priority (T : Task_Id) return System.Any_Priority is
begin
return T.Common.Current_Priority;
end Get_Priority;
-- Enter_Task --
----------------
- procedure Enter_Task (Self_ID : Task_ID) is
+ procedure Enter_Task (Self_ID : Task_Id) is
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
- -- Properly initializes the FPU for PPC/MIPS systems.
+ -- Properly initializes the FPU for PPC/MIPS systems
begin
Self_ID.Common.LL.Thread := taskIdSelf;
Init_Float;
- -- Install the signal handlers.
+ -- Install the signal handlers
+
-- This is called for each task since there is no signal inheritance
-- between VxWorks tasks.
-- New_ATCB --
--------------
- function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
+ function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
begin
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
-- Register_Foreign_Thread --
-----------------------------
- function Register_Foreign_Thread return Task_ID is
+ function Register_Foreign_Thread return Task_Id is
begin
if Is_Valid_Task then
return Self;
-- Initialize_TCB --
--------------------
- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
begin
Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
Self_ID.Common.LL.Thread := 0;
-----------------
procedure Create_Task
- (T : Task_ID;
+ (T : Task_Id;
Wrapper : System.Address;
Stack_Size : System.Parameters.Size_Type;
Priority : System.Any_Priority;
Adjusted_Stack_Size := size_t (Stack_Size);
end if;
- -- Ask for 4 extra bytes of stack space so that the ATCB
- -- pointer can be stored below the stack limit, plus extra
- -- space for the frame of Task_Wrapper. This is so the user
- -- gets the amount of stack requested exclusive of the needs
- -- of the runtime.
+ -- Ask for four extra bytes of stack space so that the ATCB pointer can
+ -- be stored below the stack limit, plus extra space for the frame of
+ -- Task_Wrapper. This is so the user gets the amount of stack requested
+ -- exclusive of the needs
--
- -- We also have to allocate n more bytes for the task name
- -- storage and enough space for the Wind Task Control Block
- -- which is around 0x778 bytes. VxWorks also seems to carve out
- -- additional space, so use 2048 as a nice round number.
- -- We might want to increment to the nearest page size in
- -- case we ever support VxVMI.
+ -- We also have to allocate n more bytes for the task name storage and
+ -- enough space for the Wind Task Control Block which is around 0x778
+ -- bytes. VxWorks also seems to carve out additional space, so use 2048
+ -- as a nice round number. We might want to increment to the nearest
+ -- page size in case we ever support VxVMI.
--
- -- XXX - we should come back and visit this so we can
- -- set the task name to something appropriate.
+ -- XXX - we should come back and visit this so we can set the task name
+ -- to something appropriate.
Adjusted_Stack_Size := Adjusted_Stack_Size + 2048;
-- Since the initial signal mask of a thread is inherited from the
- -- creator, and the Environment task has all its signals masked, we
- -- do not need to manipulate caller's signal mask at this point.
- -- All tasks in RTS will have All_Tasks_Mask initially.
+ -- creator, and the Environment task has all its signals masked, we do
+ -- not need to manipulate caller's signal mask at this point. All tasks
+ -- in RTS will have All_Tasks_Mask initially.
if T.Common.Task_Image_Len = 0 then
T.Common.LL.Thread := taskSpawn
else
declare
Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
+
begin
Name (1 .. Name'Last - 1) :=
T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
-- Finalize_TCB --
------------------
- procedure Finalize_TCB (T : Task_ID) is
+ procedure Finalize_TCB (T : Task_Id) is
Result : int;
- Tmp : Task_ID := T;
+ Tmp : Task_Id := T;
Is_Self : constant Boolean := (T = Self);
procedure Free is new
- Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
begin
if not Single_Lock then
-- Abort_Task --
----------------
- procedure Abort_Task (T : Task_ID) is
+ procedure Abort_Task (T : Task_Id) is
Result : int;
begin
Result := kill (T.Common.LL.Thread,
- Signal (Interrupt_Management.Abort_Task_Signal));
+ Signal (Interrupt_Management.Abort_Task_Signal));
pragma Assert (Result = 0);
end Abort_Task;
-- Dummy version
- function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_Exit;
-- Check_No_Locks --
--------------------
- function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
pragma Unreferenced (Self_ID);
-
begin
return True;
end Check_No_Locks;
-- Environment_Task --
----------------------
- function Environment_Task return Task_ID is
+ function Environment_Task return Task_Id is
begin
- return Environment_Task_ID;
+ return Environment_Task_Id;
end Environment_Task;
--------------
------------------
function Suspend_Task
- (T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= 0
-----------------
function Resume_Task
- (T : ST.Task_ID;
- Thread_Self : Thread_Id)
- return Boolean
+ (T : ST.Task_Id;
+ Thread_Self : Thread_Id) return Boolean
is
begin
if T.Common.LL.Thread /= 0
-- Initialize --
----------------
- procedure Initialize (Environment_Task : Task_ID) is
+ procedure Initialize (Environment_Task : Task_Id) is
Result : int;
begin
end if;
end loop;
- Environment_Task_ID := Environment_Task;
+ Environment_Task_Id := Environment_Task;
- -- Initialize the lock used to synchronize chain of all ATCBs.
+ -- Initialize the lock used to synchronize chain of all ATCBs
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
projects / thirdparty / gcc.git / blobdiff