------------------------------------------------------------------------------
-- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S --
-- --
-- B o d y --
-- --
--- $Revision: 1.13 $
--- --
--- Copyright (C) 1999-2001 Ada Core Technologies --
+-- Copyright (C) 1999-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, --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
-with System.Parameters;
--- used for Size_Type
-
-with System.Task_Info;
--- used for Task_Info_Type
--- Task_Image_Type
+with Ada.Exceptions;
+-- used for Exception_Occurrence
with System.Task_Primitives.Operations;
-- used for Enter_Task
-- The GNARL must call these to be sure that all non-tasking
-- Ada constructs will work.
+with System.Soft_Links.Tasking;
+-- Used for Init_Tasking_Soft_Links
+
with System.Secondary_Stack;
-- used for SS_Init;
package SSE renames System.Storage_Elements;
package SST renames System.Secondary_Stack;
- use System.Task_Primitives;
- use System.Task_Primitives.Operations;
- use System.Task_Info;
+ use Ada.Exceptions;
+
+ use Parameters;
+ use Task_Primitives.Operations;
+ use Task_Info;
Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock;
-- This is a global lock; it is used to execute in mutual exclusion
-- Tasking versions of services needed by non-tasking programs --
-----------------------------------------------------------------
+ function Get_Current_Excep return SSL.EOA;
+ -- Task-safe version of SSL.Get_Current_Excep
+
procedure Task_Lock;
-- Locks out other tasks. Preceding a section of code by Task_Lock and
-- following it by Task_Unlock creates a critical region. This is used
-- all nested locks must be released before other tasks competing for the
-- tasking lock are released.
- function Get_Jmpbuf_Address return Address;
- procedure Set_Jmpbuf_Address (Addr : Address);
-
- function Get_Sec_Stack_Addr return Address;
- procedure Set_Sec_Stack_Addr (Addr : Address);
-
- function Get_Machine_State_Addr return Address;
- procedure Set_Machine_State_Addr (Addr : Address);
-
- function Get_Current_Excep return SSL.EOA;
-
- procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-
- ------------------------
- -- Local Subprograms --
- ------------------------
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- procedure Task_Wrapper (Self_ID : Task_ID);
+ procedure Task_Wrapper (Self_ID : Task_Id);
-- This is the procedure that is called by the GNULL from the
-- new context when a task is created. It waits for activation
-- and then calls the task body procedure. When the task body
-- procedure completes, it terminates the task.
- procedure Terminate_Task (Self_ID : Task_ID);
+ procedure Terminate_Task (Self_ID : Task_Id);
-- Terminate the calling task.
-- This should only be called by the Task_Wrapper procedure.
-- installing tasking versions of certain operations used by the compiler.
-- Init_RTS is called during elaboration.
+ -----------------------
+ -- 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;
+
---------------
-- Task_Lock --
---------------
procedure Task_Lock is
+ Self_ID : constant Task_Id := STPO.Self;
+
begin
- STPO.Write_Lock (Global_Task_Lock'Access);
+ Self_ID.Common.Global_Task_Lock_Nesting :=
+ Self_ID.Common.Global_Task_Lock_Nesting + 1;
+
+ if Self_ID.Common.Global_Task_Lock_Nesting = 1 then
+ STPO.Write_Lock (Global_Task_Lock'Access, Global_Lock => True);
+ end if;
end Task_Lock;
-----------------
-----------------
procedure Task_Unlock is
- begin
- STPO.Unlock (Global_Task_Lock'Access);
- end Task_Unlock;
+ Self_ID : constant Task_Id := STPO.Self;
- ----------------------
- -- Soft-Link Bodies --
- ----------------------
-
- function Get_Current_Excep return SSL.EOA is
begin
- return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
- end Get_Current_Excep;
+ 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;
- function Get_Jmpbuf_Address return Address is
- begin
- return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
- end Get_Jmpbuf_Address;
-
- function Get_Machine_State_Addr return Address is
- begin
- return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
- end Get_Machine_State_Addr;
-
- function Get_Sec_Stack_Addr return Address is
- begin
- return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
- end Get_Sec_Stack_Addr;
-
- procedure Set_Jmpbuf_Address (Addr : Address) is
- begin
- STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
- end Set_Jmpbuf_Address;
-
- procedure Set_Machine_State_Addr (Addr : Address) is
- begin
- STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
- end Set_Machine_State_Addr;
-
- procedure Set_Sec_Stack_Addr (Addr : Address) is
- begin
- STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
- end Set_Sec_Stack_Addr;
+ if Self_ID.Common.Global_Task_Lock_Nesting = 0 then
+ STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
+ end if;
+ end Task_Unlock;
------------------
-- Task_Wrapper --
-- of the current thread, since it should be at a fixed offset from the
-- stack base.
- procedure Task_Wrapper (Self_ID : Task_ID) is
- ID : Task_ID := Self_ID;
+ procedure Task_Wrapper (Self_ID : Task_Id) is
+ ID : Task_Id := Self_ID;
pragma Volatile (ID);
-
- -- Do not delete this variable.
- -- In some targets, we need this variable to implement a fast Self.
+ pragma Warnings (Off, ID);
+ -- Variable used on some targets to implement a fast self. We turn off
+ -- warnings because a stand alone volatile constant has to be imported,
+ -- so we don't want warnings about ID not being referenced, and volatile
+ -- having no effect.
+ --
+ -- DO NOT delete ID. As noted, it is needed on some targets.
use type System.Parameters.Size_Type;
use type SSE.Storage_Offset;
Secondary_Stack : aliased SSE.Storage_Array
(1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
- SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
+ SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
+
+ pragma Warnings (Off);
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
+ pragma Warnings (On);
+ -- Address of secondary stack. In the fixed secondary stack case, this
+ -- value is not modified, causing a warning, hence the bracketing with
+ -- Warnings (Off/On).
+
+ Cause : Cause_Of_Termination := Normal;
+ -- Indicates the reason why this task terminates. Normal corresponds to
+ -- a task terminating due to completing the last statement of its body.
+ -- If the task terminates because of an exception raised by the
+ -- execution of its task body, then Cause is set to Unhandled_Exception.
+ -- Aborts are not allowed in the restriced profile to which this file
+ -- belongs.
+
+ EO : Exception_Occurrence;
+ -- If the task terminates because of an exception raised by the
+ -- execution of its task body, then EO will contain the associated
+ -- exception occurrence. Otherwise, it will contain Null_Occurrence.
begin
if not Parameters.Sec_Stack_Dynamic then
Enter_Task (Self_ID);
- -- Call the task body procedure.
+ -- Call the task body procedure
begin
-- We are separating the following portion of the code in order to
- -- place the exception handlers in a different block.
- -- In this way we do not call Set_Jmpbuf_Address (which needs
- -- Self) before we set Self in Enter_Task.
+ -- place the exception handlers in a different block. In this way we
+ -- do not call Set_Jmpbuf_Address (which needs Self) before we set
+ -- Self in Enter_Task.
+
-- Note that in the case of Ravenscar HI-E where there are no
-- exception handlers, the exception handler is suppressed.
- -- Call the task body procedure.
+ -- Call the task body procedure
Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
- Terminate_Task (Self_ID);
- exception -- not needed in no exc mode
- when others => -- not needed in no exc mode
- Terminate_Task (Self_ID); -- not needed in no exc mode
+ -- Normal task termination
+
+ Cause := Normal;
+ Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
+
+ exception
+ when E : others =>
+
+ -- Task terminating because of an unhandled exception
+
+ Cause := Unhandled_Exception;
+ Save_Occurrence (EO, E);
end;
- end Task_Wrapper;
- -------------------
- -- Timed_Delay_T --
- -------------------
+ -- Look for a fall-back handler. It can be either in the task itself
+ -- or in the environment task. Note that this code is always executed
+ -- by a task whose master is the environment task. The task termination
+ -- code for the environment task is executed by
+ -- SSL.Task_Termination_Handler.
- procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
- begin
- STPO.Timed_Delay (STPO.Self, Time, Mode);
- end Timed_Delay_T;
+ -- This package is part of the restricted run time which supports
+ -- neither task hierarchies (No_Task_Hierarchy) nor specific task
+ -- termination handlers (No_Specific_Termination_Handlers).
+
+ -- There is no need for explicit protection against race conditions
+ -- for Self_ID.Common.Fall_Back_Handler because this procedure can
+ -- only be executed by Self, and the Fall_Back_Handler can only be
+ -- modified by Self.
+
+ if Self_ID.Common.Fall_Back_Handler /= null then
+ Self_ID.Common.Fall_Back_Handler (Cause, Self_ID, EO);
+ else
+ declare
+ TH : Termination_Handler := null;
+
+ begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID.Common.Parent);
+
+ TH := Self_ID.Common.Parent.Common.Fall_Back_Handler;
+
+ Unlock (Self_ID.Common.Parent);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ -- Execute the task termination handler if we found it
+
+ if TH /= null then
+ TH.all (Cause, Self_ID, EO);
+ end if;
+ end;
+ end if;
+
+ Terminate_Task (Self_ID);
+ end Task_Wrapper;
-----------------------
-- Restricted GNARLI --
-- Activate_Restricted_Tasks --
-------------------------------
- -- Note that locks of activator and activated task are both locked
- -- here. This is necessary because C.State and Self.Wait_Count
- -- have to be synchronized. This is safe from deadlock because
- -- the activator is always created before the activated task.
- -- That satisfies our in-order-of-creation ATCB locking policy.
+ -- Note that locks of activator and activated task are both locked here.
+ -- This is necessary because C.State and Self.Wait_Count have to be
+ -- synchronized. This is safe from deadlock because the activator is always
+ -- created before the activated task. That satisfies our
+ -- in-order-of-creation ATCB locking policy.
procedure Activate_Restricted_Tasks
(Chain_Access : Activation_Chain_Access)
is
- Self_ID : constant Task_ID := STPO.Self;
- C : Task_ID;
- Activate_Prio : System.Any_Priority;
- Success : Boolean;
+ Self_ID : constant Task_Id := STPO.Self;
+ C : Task_Id;
+ Activate_Prio : System.Any_Priority;
+ Success : Boolean;
begin
pragma Assert (Self_ID = Environment_Task);
pragma Assert (Self_ID.Common.Wait_Count = 0);
- -- Lock self, to prevent activated tasks
- -- from racing ahead before we finish activating the chain.
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ -- Lock self, to prevent activated tasks from racing ahead before we
+ -- finish activating the chain.
Write_Lock (Self_ID);
- -- Activate all the tasks in the chain.
- -- Creation of the thread of control was deferred until
- -- activation. So create it now.
+ -- Activate all the tasks in the chain. Creation of the thread of
+ -- control was deferred until activation. So create it now.
C := Chain_Access.T_ID;
Self_ID.Common.State := Activator_Sleep;
- -- Wait for the activated tasks to complete activation.
- -- It is unsafe to abort any of these tasks until the count goes to
- -- zero.
+ -- Wait for the activated tasks to complete activation. It is unsafe to
+ -- abort any of these tasks until the count goes to zero.
loop
exit when Self_ID.Common.Wait_Count = 0;
Self_ID.Common.State := Runnable;
Unlock (Self_ID);
- -- Remove the tasks from the chain.
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ -- Remove the tasks from the chain
Chain_Access.T_ID := null;
end Activate_Restricted_Tasks;
-- activator.
procedure Complete_Restricted_Activation is
- Self_ID : constant Task_ID := STPO.Self;
- Activator : constant Task_ID := Self_ID.Common.Activator;
+ Self_ID : constant Task_Id := STPO.Self;
+ Activator : constant Task_Id := Self_ID.Common.Activator;
begin
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
Write_Lock (Activator);
Write_Lock (Self_ID);
- -- Remove dangling reference to Activator,
- -- since a task may outlive its activator.
+ -- Remove dangling reference to Activator, since a task may outlive its
+ -- activator.
Self_ID.Common.Activator := null;
- -- Wake up the activator, if it is waiting for a chain
- -- of tasks to activate, and we are the last in the chain
- -- to complete activation
+ -- Wake up the activator, if it is waiting for a chain of tasks to
+ -- activate, and we are the last in the chain to complete activation
if Activator.Common.State = Activator_Sleep then
Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
Unlock (Self_ID);
Unlock (Activator);
- -- After the activation, active priority should be the same
- -- as base priority. We must unlock the Activator first,
- -- though, since it should not wait if we have lower priority.
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ -- After the activation, active priority should be the same as base
+ -- priority. We must unlock the Activator first, though, since it should
+ -- not wait if we have lower priority.
if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
procedure Create_Restricted_Task
(Priority : Integer;
+ Stack_Address : System.Address;
Size : System.Parameters.Size_Type;
Task_Info : System.Task_Info.Task_Info_Type;
State : Task_Procedure_Access;
Discriminants : System.Address;
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
- Task_Image : System.Task_Info.Task_Image_Type;
- Created_Task : out Task_ID)
+ Task_Image : String;
+ Created_Task : Task_Id)
is
- T : Task_ID;
- Self_ID : constant Task_ID := STPO.Self;
+ Self_ID : constant Task_Id := STPO.Self;
Base_Priority : System.Any_Priority;
Success : Boolean;
+ Len : Integer;
begin
+ -- Stack is not preallocated on this target, so that Stack_Address must
+ -- be null.
+
+ pragma Assert (Stack_Address = Null_Address);
+
if Priority = Unspecified_Priority then
Base_Priority := Self_ID.Common.Base_Priority;
else
Base_Priority := System.Any_Priority (Priority);
end if;
- T := New_ATCB (0);
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
Write_Lock (Self_ID);
-- With no task hierarchy, the parent of all non-Environment tasks that
Initialize_ATCB
(Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
- Task_Info, Size, T, Success);
+ Task_Info, Size, Created_Task, Success);
- -- If we do our job right then there should never be any failures,
- -- which was probably said about the Titanic; so just to be safe,
- -- let's retain this code for now
+ -- If we do our job right then there should never be any failures, which
+ -- was probably said about the Titanic; so just to be safe, let's retain
+ -- this code for now
if not Success then
Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
raise Program_Error;
end if;
- T.Entry_Calls (1).Self := T;
- T.Common.Task_Image := Task_Image;
+ Created_Task.Entry_Calls (1).Self := Created_Task;
+
+ Len :=
+ Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length);
+ Created_Task.Common.Task_Image_Len := Len;
+ Created_Task.Common.Task_Image (1 .. Len) :=
+ Task_Image (Task_Image'First .. Task_Image'First + Len - 1);
+
Unlock (Self_ID);
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
-- Create TSD as early as possible in the creation of a task, since it
-- may be used by the operation of Ada code within the task.
- SSL.Create_TSD (T.Common.Compiler_Data);
- T.Common.Activation_Link := Chain.T_ID;
- Chain.T_ID := T;
- Created_Task := T;
+ SSL.Create_TSD (Created_Task.Common.Compiler_Data);
+ Created_Task.Common.Activation_Link := Chain.T_ID;
+ Chain.T_ID := Created_Task;
end Create_Restricted_Task;
---------------------------
-- forever, since none of the dependent tasks are expected to terminate
procedure Finalize_Global_Tasks is
- Self_ID : constant Task_ID := STPO.Self;
+ Self_ID : constant Task_Id := STPO.Self;
+
begin
pragma Assert (Self_ID = STPO.Environment_Task);
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ -- Handle normal task termination by the environment task, but only for
+ -- the normal task termination. In the case of Abnormal and
+ -- Unhandled_Exception they must have been handled before, and the task
+ -- termination soft link must have been changed so the task termination
+ -- routine is not executed twice.
+
+ -- Note that in the "normal" implementation in s-tassta.adb the task
+ -- termination procedure for the environment task should be executed
+ -- after termination of library-level tasks. However, this
+ -- implementation is to be used when the Ravenscar restrictions are in
+ -- effect, and AI-394 says that if there is a fall-back handler set for
+ -- the partition it should be called when the first task (including the
+ -- environment task) attempts to terminate.
+
+ SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
+
Write_Lock (Self_ID);
Sleep (Self_ID, Master_Completion_Sleep);
Unlock (Self_ID);
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
-- Should never return from Master Completion Sleep
raise Program_Error;
-- Restricted_Terminated --
---------------------------
- function Restricted_Terminated (T : Task_ID) return Boolean is
+ function Restricted_Terminated (T : Task_Id) return Boolean is
begin
return T.Common.State = Terminated;
end Restricted_Terminated;
-- Terminate_Task --
--------------------
- procedure Terminate_Task (Self_ID : Task_ID) is
+ procedure Terminate_Task (Self_ID : Task_Id) is
begin
Self_ID.Common.State := Terminated;
end Terminate_Task;
procedure Init_RTS is
begin
+ Tasking.Initialize;
+
-- Initialize lock used to implement mutual exclusion between all tasks
STPO.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.
- SSL.Lock_Task := Task_Lock'Access;
- SSL.Unlock_Task := Task_Unlock'Access;
- SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
- SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
- SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
- SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
- SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
- SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
- SSL.Get_Current_Excep := Get_Current_Excep'Access;
- SSL.Timed_Delay := Timed_Delay_T'Access;
- SSL.Adafinal := Finalize_Global_Tasks'Access;
-
- -- No need to create a new Secondary Stack, since we will use the
- -- default one created in s-secsta.adb
-
- SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
- SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
- SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+ SSL.Lock_Task := Task_Lock'Access;
+ SSL.Unlock_Task := Task_Unlock'Access;
+ SSL.Adafinal := Finalize_Global_Tasks'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;
end Init_RTS;
begin
OSDN Git Service
