aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/s-tarest.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/s-tarest.adb')
-rw-r--r--gcc-4.9/gcc/ada/s-tarest.adb762
1 files changed, 762 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/s-tarest.adb b/gcc-4.9/gcc/ada/s-tarest.adb
new file mode 100644
index 000000000..71b116cd0
--- /dev/null
+++ b/gcc-4.9/gcc/ada/s-tarest.adb
@@ -0,0 +1,762 @@
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- --
+-- Copyright (C) 1999-2013, 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 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. --
+-- --
+-- 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 order check, since we group soft link
+-- bodies and also separate off subprograms for restricted GNARLI.
+
+-- This is a simplified version of the System.Tasking.Stages package,
+-- intended to be used in a restricted run time.
+
+-- This package represents the high level tasking interface used by the
+-- compiler to expand Ada 95 tasking constructs into simpler run time calls.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with Ada.Exceptions;
+
+with System.Task_Primitives.Operations;
+with System.Soft_Links.Tasking;
+with System.Secondary_Stack;
+with System.Storage_Elements;
+
+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. used for
+-- Create_TSD This package also provides initialization routines for task
+-- specific data. The GNARL must call these to be sure that all non-tasking
+-- Ada constructs will work.
+
+package body System.Tasking.Restricted.Stages is
+
+ package STPO renames System.Task_Primitives.Operations;
+ package SSL renames System.Soft_Links;
+ package SSE renames System.Storage_Elements;
+ package SST renames System.Secondary_Stack;
+
+ use Ada.Exceptions;
+
+ use Parameters;
+ use Task_Primitives.Operations;
+ use Task_Info;
+
+ Tasks_Activation_Chain : Task_Id;
+ -- Chain of all the tasks to activate
+
+ 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 and Task_Unlock.
+
+ -----------------------------------------------------------------
+ -- 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
+ -- for ensuring that a region of non-tasking code (such as code used to
+ -- allocate memory) is tasking safe. Note that it is valid for calls to
+ -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
+ -- only the corresponding outer level Task_Unlock will actually unlock.
+
+ procedure Task_Unlock;
+ -- Releases lock previously set by call to Task_Lock. In the nested case,
+ -- all nested locks must be released before other tasks competing for the
+ -- tasking lock are released.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ 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);
+ -- Terminate the calling task.
+ -- This should only be called by the Task_Wrapper procedure.
+
+ procedure Create_Restricted_Task
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Task_Image : String;
+ Created_Task : Task_Id);
+ -- Code shared between Create_Restricted_Task_Concurrent and
+ -- Create_Restricted_Task_Sequential. See comment of the former in the
+ -- specification of this package.
+
+ procedure Activate_Tasks (Chain : Task_Id);
+ -- Activate the list of tasks started by Chain
+
+ procedure Init_RTS;
+ -- This procedure performs the initialization of the GNARL.
+ -- It consists of initializing the environment task, global locks, and
+ -- 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
+ 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;
+
+ -----------------
+ -- Task_Unlock --
+ -----------------
+
+ procedure Task_Unlock is
+ Self_ID : constant Task_Id := STPO.Self;
+
+ begin
+ 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.Common.Global_Task_Lock_Nesting = 0 then
+ STPO.Unlock (Global_Task_Lock'Access, Global_Lock => True);
+ end if;
+ end Task_Unlock;
+
+ ------------------
+ -- Task_Wrapper --
+ ------------------
+
+ -- The task wrapper is a procedure that is called first for each task
+ -- task body, and which in turn calls the compiler-generated task body
+ -- procedure. The wrapper's main job is to do initialization for the task.
+
+ -- The variable ID in the task wrapper is used to implement the Self
+ -- function on targets where there is a fast way to find the stack base
+ -- 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;
+ pragma Volatile (ID);
+ 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 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_Percentage) / 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 restricted 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
+ Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
+ Secondary_Stack'Address;
+ SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
+ end if;
+
+ -- Initialize low-level TCB components, that
+ -- cannot be initialized by the creator.
+
+ Enter_Task (Self_ID);
+
+ -- 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.
+
+ -- 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
+
+ Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
+
+ -- 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;
+
+ -- Look for a fall-back handler
+
+ -- 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).
+
+ -- As specified in ARM C.7.3 par. 9/2, "the fall-back handler applies
+ -- only to the dependent tasks of the task". Hence, if the terminating
+ -- tasks (Self_ID) had a fall-back handler, it would not apply to
+ -- itself. 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), so the fall-back
+ -- handler to execute for this task can only be defined by its parent
+ -- (there is no grandparent).
+
+ 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;
+
+ Terminate_Task (Self_ID);
+ end Task_Wrapper;
+
+ -----------------------
+ -- Restricted GNARLI --
+ -----------------------
+
+ -----------------------------------
+ -- Activate_All_Tasks_Sequential --
+ -----------------------------------
+
+ procedure Activate_All_Tasks_Sequential is
+ begin
+ pragma Assert (Partition_Elaboration_Policy = 'S');
+
+ Activate_Tasks (Tasks_Activation_Chain);
+ Tasks_Activation_Chain := Null_Task;
+ end Activate_All_Tasks_Sequential;
+
+ -------------------------------
+ -- Activate_Restricted_Tasks --
+ -------------------------------
+
+ procedure Activate_Restricted_Tasks
+ (Chain_Access : Activation_Chain_Access) is
+ begin
+ if Partition_Elaboration_Policy = 'S' then
+
+ -- In sequential elaboration policy, the chain must be empty. This
+ -- procedure can be called if the unit has been compiled without
+ -- partition elaboration policy, but the partition has a sequential
+ -- elaboration policy.
+
+ pragma Assert (Chain_Access.T_ID = Null_Task);
+ null;
+ else
+ Activate_Tasks (Chain_Access.T_ID);
+ Chain_Access.T_ID := Null_Task;
+ end if;
+ end Activate_Restricted_Tasks;
+
+ --------------------
+ -- Activate_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.
+
+ procedure Activate_Tasks (Chain : Task_Id) is
+ 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);
+
+ 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.
+
+ C := Chain;
+ while C /= null loop
+ if C.Common.State /= Terminated then
+ pragma Assert (C.Common.State = Unactivated);
+
+ Write_Lock (C);
+
+ Activate_Prio :=
+ (if C.Common.Base_Priority < Get_Priority (Self_ID)
+ then Get_Priority (Self_ID)
+ else C.Common.Base_Priority);
+
+ STPO.Create_Task
+ (C, Task_Wrapper'Address,
+ Parameters.Size_Type
+ (C.Common.Compiler_Data.Pri_Stack_Info.Size),
+ Activate_Prio, Success);
+
+ Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
+
+ if Success then
+ C.Common.State := Runnable;
+ else
+ raise Program_Error;
+ end if;
+
+ Unlock (C);
+ end if;
+
+ C := C.Common.Activation_Link;
+ end loop;
+
+ 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.
+
+ loop
+ exit when Self_ID.Common.Wait_Count = 0;
+ Sleep (Self_ID, Activator_Sleep);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+ end Activate_Tasks;
+
+ ------------------------------------
+ -- Complete_Restricted_Activation --
+ ------------------------------------
+
+ -- As in several other places, the locks of the activator and activated
+ -- task are both locked here. This follows our deadlock prevention lock
+ -- ordering policy, since the activated task must be created after the
+ -- activator.
+
+ procedure Complete_Restricted_Activation is
+ 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.
+
+ 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
+
+ if Activator.Common.State = Activator_Sleep then
+ Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
+
+ if Activator.Common.Wait_Count = 0 then
+ Wakeup (Activator, Activator_Sleep);
+ end if;
+ end if;
+
+ Unlock (Self_ID);
+ Unlock (Activator);
+
+ 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);
+ end if;
+ end Complete_Restricted_Activation;
+
+ ------------------------------
+ -- Complete_Restricted_Task --
+ ------------------------------
+
+ procedure Complete_Restricted_Task is
+ begin
+ STPO.Self.Common.State := Terminated;
+ end Complete_Restricted_Task;
+
+ ----------------------------
+ -- Create_Restricted_Task --
+ ----------------------------
+
+ procedure Create_Restricted_Task
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Task_Image : String;
+ Created_Task : Task_Id)
+ is
+ Self_ID : constant Task_Id := STPO.Self;
+ Base_Priority : System.Any_Priority;
+ Base_CPU : System.Multiprocessors.CPU_Range;
+ 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);
+
+ Base_Priority :=
+ (if Priority = Unspecified_Priority
+ then Self_ID.Common.Base_Priority
+ else System.Any_Priority (Priority));
+
+ -- Legal values of CPU are the special Unspecified_CPU value which is
+ -- inserted by the compiler for tasks without CPU aspect, and those in
+ -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
+ -- the task is defined to have failed, and it becomes a completed task
+ -- (RM D.16(14/3)).
+
+ if CPU /= Unspecified_CPU
+ and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
+ or else CPU > Integer (System.Multiprocessors.CPU_Range'Last)
+ or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
+ then
+ raise Tasking_Error with "CPU not in range";
+
+ -- Normal CPU affinity
+ else
+ -- When the application code says nothing about the task affinity
+ -- (task without CPU aspect) then the compiler inserts the
+ -- Unspecified_CPU value which indicates to the run-time library that
+ -- the task will activate and execute on the same processor as its
+ -- activating task if the activating task is assigned a processor
+ -- (RM D.16(14/3)).
+
+ Base_CPU :=
+ (if CPU = Unspecified_CPU
+ then Self_ID.Common.Base_CPU
+ else System.Multiprocessors.CPU_Range (CPU));
+ end if;
+
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ Write_Lock (Self_ID);
+
+ -- With no task hierarchy, the parent of all non-Environment tasks that
+ -- are created must be the Environment task. Dispatching domains are
+ -- not allowed in Ravenscar, so the dispatching domain parameter will
+ -- always be null.
+
+ Initialize_ATCB
+ (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
+ Base_CPU, null, 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 not Success then
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ raise Program_Error;
+ end if;
+
+ 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 (Created_Task.Common.Compiler_Data);
+ end Create_Restricted_Task;
+
+ procedure Create_Restricted_Task
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : String;
+ Created_Task : Task_Id)
+ is
+ begin
+ if Partition_Elaboration_Policy = 'S' then
+
+ -- A unit may have been compiled without partition elaboration
+ -- policy, and in this case the compiler will emit calls for the
+ -- default policy (concurrent). But if the partition policy is
+ -- sequential, activation must be deferred.
+
+ Create_Restricted_Task_Sequential
+ (Priority, Stack_Address, Size, Task_Info, CPU, State,
+ Discriminants, Elaborated, Task_Image, Created_Task);
+
+ else
+ Create_Restricted_Task
+ (Priority, Stack_Address, Size, Task_Info, CPU, State,
+ Discriminants, Elaborated, Task_Image, Created_Task);
+
+ -- Append this task to the activation chain
+
+ Created_Task.Common.Activation_Link := Chain.T_ID;
+ Chain.T_ID := Created_Task;
+ end if;
+ end Create_Restricted_Task;
+
+ ---------------------------------------
+ -- Create_Restricted_Task_Sequential --
+ ---------------------------------------
+
+ procedure Create_Restricted_Task_Sequential
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Task_Image : String;
+ Created_Task : Task_Id) is
+ begin
+ Create_Restricted_Task (Priority, Stack_Address, Size, Task_Info,
+ CPU, State, Discriminants, Elaborated,
+ Task_Image, Created_Task);
+
+ -- Append this task to the activation chain
+
+ Created_Task.Common.Activation_Link := Tasks_Activation_Chain;
+ Tasks_Activation_Chain := Created_Task;
+ end Create_Restricted_Task_Sequential;
+
+ ---------------------------
+ -- Finalize_Global_Tasks --
+ ---------------------------
+
+ -- This is needed to support the compiler interface; it will only be called
+ -- by the Environment task. Instead, it will cause the Environment to block
+ -- forever, since none of the dependent tasks are expected to terminate
+
+ procedure Finalize_Global_Tasks is
+ 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;
+ end Finalize_Global_Tasks;
+
+ ---------------------------
+ -- Restricted_Terminated --
+ ---------------------------
+
+ 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
+ begin
+ Self_ID.Common.State := Terminated;
+ end Terminate_Task;
+
+ --------------
+ -- Init_RTS --
+ --------------
+
+ 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.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
+ Init_RTS;
+end System.Tasking.Restricted.Stages;