-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- 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, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
--- Turn off subprogram alpha ordering check, since we group soft link
--- bodies and dummy soft link bodies together separately in this unit.
+-- Turn off subprogram alpha ordering check, since we group soft link bodies
+-- and dummy soft link bodies together separately in this unit.
pragma Polling (Off);
--- Turn polling off for this package. We don't need polling during any
--- of the routines in this package, and more to the point, if we try
--- to poll it can cause infinite loops.
+-- Turn polling off for this package. We don't need polling during any of the
+-- routines in this package, and more to the point, if we try to poll it can
+-- cause infinite loops.
with Ada.Exceptions;
--- Used for Exception_Occurrence_Access
with System.Task_Primitives;
--- Used for Lock
-
with System.Task_Primitives.Operations;
--- Used for Set_Priority
--- Write_Lock
--- Unlock
--- Initialize_Lock
-
with System.Soft_Links;
--- Used for the non-tasking routines (*_NT) that refer to global data.
--- They are needed here before the tasking run time has been elaborated.
-
with System.Soft_Links.Tasking;
--- Used for Init_Tasking_Soft_Links
-
with System.Tasking.Debug;
--- Used for Trace
-
-with System.Stack_Checking;
-
with System.Parameters;
--- used for Single_Lock
package body System.Tasking.Initialization is
use Task_Primitives.Operations;
Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
- -- This is a global lock; it is used to execute in mutual exclusion
- -- 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
+ -- This is a global lock; it is used to execute in mutual exclusion from
+ -- all other tasks. It is only used by Task_Lock, Task_Unlock, and
+ -- Final_Task_Unlock.
----------------------------------------------------------------------
-- Tasking versions of some services needed by non-tasking programs --
-- all nested locks must be released before other tasks competing for the
-- tasking lock are released.
- 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 Init_RTS;
- -- This procedure completes the initialization of the GNARL. The first
- -- part of the initialization is done in the body of System.Tasking.
- -- It consists of initializing global locks, and installing tasking
- -- versions of certain operations used by the compiler. Init_RTS is called
- -- during elaboration.
+ -- This procedure completes the initialization of the GNARL. The first part
+ -- of the initialization is done in the body of System.Tasking. It consists
+ -- of initializing global locks, and installing tasking versions of certain
+ -- operations used by the compiler. Init_RTS is called during elaboration.
--------------------------
-- Change_Base_Priority --
function Check_Abort_Status return Integer is
Self_ID : constant Task_Id := Self;
begin
- if Self_ID /= null and then Self_ID.Deferral_Level = 0
+ if Self_ID /= null
+ and then Self_ID.Deferral_Level = 0
and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
then
return 1;
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;
- -- pragma Assert
- -- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else
- -- Self_ID.Deferral_Level > 0));
+ -- The following assertion is by default disabled. See the comment in
+ -- Defer_Abort on the situations in which it may be useful to uncomment
+ -- this assertion and enable the test.
- -- See comment in Defer_Abort on the situations in which it may be
- -- useful to uncomment the above assertion.
+ -- pragma Assert
+ -- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else
+ -- Self_ID.Deferral_Level > 0);
Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1;
end Defer_Abort_Nestable;
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;
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
pragma Assert (not Self_ID.ATC_Hack);
elsif Self_ID.ATC_Hack then
+
-- The solution really belongs in the Abort_Signal handler
-- for async. entry calls. The present hack is very
-- fragile. It relies that the very next point after
-- Final_Task_Unlock --
-----------------------
- -- This version is only for use in Terminate_Task, when the task
- -- is relinquishing further rights to its own ATCB.
- -- There is a very interesting potential race condition there, where
- -- the old task may run concurrently with a new task that is allocated
- -- the old tasks (now reused) ATCB. The critical thing here is to
- -- not make any reference to the ATCB after the lock is released.
- -- See also comments on Terminate_Task and Unlock.
+ -- This version is only for use in Terminate_Task, when the task is
+ -- relinquishing further rights to its own ATCB.
+
+ -- There is a very interesting potential race condition there, where the
+ -- old task may run concurrently with a new task that is allocated the old
+ -- tasks (now reused) ATCB. The critical thing here is to not make any
+ -- reference to the ATCB after the lock is released. See also comments on
+ -- Terminate_Task and Unlock.
procedure Final_Task_Unlock (Self_ID : Task_Id) is
begin
- pragma Assert (Self_ID.Global_Task_Lock_Nesting = 1);
+ pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting = 1);
Unlock (Global_Task_Lock'Access, Global_Lock => True);
end Final_Task_Unlock;
Self_Id.Awake_Count := 1;
Self_Id.Alive_Count := 1;
- Self_Id.Master_Within := Library_Task_Level;
- -- Normally, a task starts out with internal master nesting level
- -- one larger than external master nesting level. It is incremented
- -- to one by Enter_Master, which is called in the task body only if
- -- the compiler thinks the task may have dependent tasks. There is no
+ -- Normally, a task starts out with internal master nesting level one
+ -- larger than external master nesting level. It is incremented to one
+ -- by Enter_Master, which is called in the task body only if the
+ -- compiler thinks the task may have dependent tasks. There is no
-- corresponding call to Enter_Master for the environment task, so we
- -- would need to increment it to 2 here. Instead, we set it to 3.
- -- By doing this we reserve the level 2 for server tasks of the runtime
+ -- would need to increment it to 2 here. Instead, we set it to 3. By
+ -- doing this we reserve the level 2 for server tasks of the runtime
-- system. The environment task does not need to wait for these server
+ Self_Id.Master_Within := Library_Task_Level;
+
-- Initialize lock used to implement mutual exclusion between all tasks
Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level);
-- 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.
SSL.Tasking.Init_Tasking_Soft_Links;
- -- Abort is deferred in a new ATCB, so we need to undefer abort
- -- at this stage to make the environment task abortable.
+ -- Abort is deferred in a new ATCB, so we need to undefer abort at this
+ -- stage to make the environment task abortable.
Undefer_Abort (Environment_Task);
end Init_RTS;
-- Abort a task to the specified ATC nesting level.
-- Call this only with T locked.
- -- An earlier version of this code contained a call to Wakeup. That
- -- should not be necessary here, if Abort_Task is implemented correctly,
- -- since Abort_Task should include the effect of Wakeup. However, the
- -- above call was in earlier versions of this file, and at least for
- -- some targets Abort_Task has not beek doing Wakeup. It should not
- -- hurt to uncomment the above call, until the error is corrected for
- -- all targets.
+ -- An earlier version of this code contained a call to Wakeup. That should
+ -- not be necessary here, if Abort_Task is implemented correctly, since
+ -- Abort_Task should include the effect of Wakeup. However, the above call
+ -- was in earlier versions of this file, and at least for some targets
+ -- Abort_Task has not been doing Wakeup. It should not hurt to uncomment
+ -- the above call, until the error is corrected for all targets.
-- See extended comments in package body System.Tasking.Abort for the
-- overall design of the implementation of task abort.
-- ??? there is no such package ???
- -- If the task is sleeping it will be in an abort-deferred region, and
- -- will not have Abort_Signal raised by Abort_Task. Such an "abort
- -- deferral" is just to protect the RTS internals, and not necessarily
- -- required to enforce Ada semantics. Abort_Task should wake the task up
- -- and let it decide if it wants to complete the aborted construct
- -- immediately.
+ -- If the task is sleeping it will be in an abort-deferred region, and will
+ -- not have Abort_Signal raised by Abort_Task. Such an "abort deferral" is
+ -- just to protect the RTS internals, and not necessarily required to
+ -- enforce Ada semantics. Abort_Task should wake the task up and let it
+ -- decide if it wants to complete the aborted construct immediately.
- -- Note that the effect of the lowl-level Abort_Task is not persistent.
+ -- Note that the effect of the low-level Abort_Task is not persistent.
-- If the target task is not blocked, this wakeup will be missed.
-- We don't bother calling Abort_Task if this task is aborting itself,
- -- since we are inside the RTS and have abort deferred. Similarly, We
- -- don't bother to call Abort_Task if T is terminated, since there is
- -- no need to abort a terminated task, and it could be dangerous to try
- -- if the task has stopped executing.
-
- -- Note that an earlier version of this code had some false reasoning
- -- about being able to reliably wake up a task that had suspended on
- -- a blocking system call that does not atomically relase the task's
- -- lock (e.g., UNIX nanosleep, which we once thought could be used to
- -- implement delays). That still left the possibility of missed
- -- wakeups.
+ -- since we are inside the RTS and have abort deferred. Similarly, We don't
+ -- bother to call Abort_Task if T is terminated, since there is no need to
+ -- abort a terminated task, and it could be dangerous to try if the task
+ -- has stopped executing.
+
+ -- Note that an earlier version of this code had some false reasoning about
+ -- being able to reliably wake up a task that had suspended on a blocking
+ -- system call that does not atomically release the task's lock (e.g., UNIX
+ -- nanosleep, which we once thought could be used to implement delays).
+ -- That still left the possibility of missed wakeups.
-- We cannot safely call Vulnerable_Complete_Activation here, since that
-- requires locking Self_ID.Parent. The anti-deadlock lock ordering rules
pragma Assert (False);
null;
- when Runnable =>
+ when Activating | Runnable =>
+
-- This is needed to cancel an asynchronous protected entry
-- call during a requeue with abort.
AST_Server_Sleep =>
Wakeup (T, T.Common.State);
- when Acceptor_Sleep =>
+ when Acceptor_Sleep | Acceptor_Delay_Sleep =>
T.Open_Accepts := null;
Wakeup (T, T.Common.State);
-- value will not be set to False except with T also locked,
-- inside Exit_One_ATC_Level, so we should not miss wakeups.
- if T.Common.State = Acceptor_Sleep then
+ if T.Common.State = Acceptor_Sleep
+ or else
+ T.Common.State = Acceptor_Delay_Sleep
+ then
T.Open_Accepts := null;
end if;
elsif T /= Self_ID and then
(T.Common.State = Runnable
- or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag)
+ or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag)
+
-- The task is blocked on a system call waiting for the
-- completion event. In this case Abort_Task may need to take
-- special action in order to succeed. Example system: VMS.
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 --
--------------------------------
Previous := Null_Task;
C := All_Tasks_List;
-
while C /= Null_Task loop
if C = T then
if Previous = Null_Task then
- All_Tasks_List :=
- All_Tasks_List.Common.All_Tasks_Link;
+ All_Tasks_List := All_Tasks_List.Common.All_Tasks_Link;
else
Previous.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
end if;
procedure Task_Lock (Self_ID : Task_Id) is
begin
- Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting + 1;
+ Self_ID.Common.Global_Task_Lock_Nesting :=
+ Self_ID.Common.Global_Task_Lock_Nesting + 1;
- if Self_ID.Global_Task_Lock_Nesting = 1 then
+ if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
Defer_Abort_Nestable (Self_ID);
Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
end if;
function Task_Name return String is
Self_Id : constant Task_Id := STPO.Self;
-
begin
return Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len);
end Task_Name;
procedure Task_Unlock (Self_ID : Task_Id) is
begin
- pragma Assert (Self_ID.Global_Task_Lock_Nesting > 0);
- Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting - 1;
+ pragma Assert (Self_ID.Common.Global_Task_Lock_Nesting > 0);
+ Self_ID.Common.Global_Task_Lock_Nesting :=
+ Self_ID.Common.Global_Task_Lock_Nesting - 1;
- if Self_ID.Global_Task_Lock_Nesting = 0 then
+ if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
Unlock (Global_Task_Lock'Access, Global_Lock => True);
Undefer_Abort_Nestable (Self_ID);
end if;
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
(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;
if Entry_Call.Mode = Asynchronous_Call then
- -- Abort the caller in his abortable part,
- -- but do so only if call has been queued abortably
+ -- Abort the caller in his abortable part, but do so only if call has
+ -- been queued abortably.
if Entry_Call.State >= Was_Abortable or else New_State = Done then
Locked_Abort_To_Level (Self_ID, Caller, Entry_Call.Level - 1);
end if;
end Wakeup_Entry_Caller;
- ----------------------
- -- Soft-Link Bodies --
- ----------------------
-
- function Get_Stack_Info return Stack_Checking.Stack_Access is
- begin
- return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
- end Get_Stack_Info;
-
-----------------------
-- Soft-Link Dummies --
-----------------------
-- These are dummies for subprograms that are only needed by certain
- -- optional run-time system packages. If they are needed, the soft
- -- links will be redirected to the real subprogram by elaboration of
- -- the subprogram body where the real subprogram is declared.
+ -- optional run-time system packages. If they are needed, the soft links
+ -- will be redirected to the real subprogram by elaboration of 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;
OSDN Git Service
