diff options
Diffstat (limited to 'gcc/ada/s-tarest.adb')
| -rw-r--r-- | gcc/ada/s-tarest.adb | 548 |
1 files changed, 548 insertions, 0 deletions
diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb new file mode 100644 index 00000000000..a6cf274c8ef --- /dev/null +++ b/gcc/ada/s-tarest.adb @@ -0,0 +1,548 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA 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 -- +-- -- +-- 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- -- +-- 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, 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, -- +-- 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. -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +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 System.Parameters; +-- used for Size_Type + +with System.Task_Info; +-- used for Task_Info_Type +-- Task_Image_Type + +with System.Task_Primitives.Operations; +-- used for Enter_Task +-- Write_Lock +-- Unlock +-- Wakeup +-- Get_Priority + +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. + +with System.Secondary_Stack; +-- used for SS_Init; + +with System.Storage_Elements; +-- used for Storage_Array; + +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 System.Task_Primitives; + use System.Task_Primitives.Operations; + use System.Task_Info; + + 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 -- + ----------------------------------------------------------------- + + 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. + + 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 -- + ------------------------ + + 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 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. + + --------------- + -- Task_Lock -- + --------------- + + procedure Task_Lock is + begin + STPO.Write_Lock (Global_Task_Lock'Access); + end Task_Lock; + + ----------------- + -- Task_Unlock -- + ----------------- + + procedure Task_Unlock is + begin + STPO.Unlock (Global_Task_Lock'Access); + end Task_Unlock; + + ---------------------- + -- 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; + + 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; + + ------------------ + -- 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); + + -- Do not delete this variable. + -- In some targets, we need this variable to implement a fast Self. + + 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); + Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + + 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); + 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 + end; + end Task_Wrapper; + + ------------------- + -- Timed_Delay_T -- + ------------------- + + procedure Timed_Delay_T (Time : Duration; Mode : Integer) is + begin + STPO.Timed_Delay (STPO.Self, Time, Mode); + end Timed_Delay_T; + + ----------------------- + -- 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. + + 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; + + 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. + + 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_Access.T_ID; + + while C /= null loop + if C.Common.State /= Terminated then + pragma Assert (C.Common.State = Unactivated); + + Write_Lock (C); + + if C.Common.Base_Priority < Get_Priority (Self_ID) then + Activate_Prio := Get_Priority (Self_ID); + else + Activate_Prio := C.Common.Base_Priority; + end if; + + 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); + + -- Remove the tasks from the chain. + + Chain_Access.T_ID := null; + end Activate_Restricted_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 + 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); + + -- 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; + 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) + is + T : Task_ID; + Self_ID : constant Task_ID := STPO.Self; + Base_Priority : System.Any_Priority; + Success : Boolean; + + begin + 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); + Write_Lock (Self_ID); + + -- With no task hierarchy, the parent of all non-Environment tasks that + -- are created must be the Environment task + + Initialize_ATCB + (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, + Task_Info, Size, T, 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); + raise Program_Error; + end if; + + T.Entry_Calls (1).Self := T; + T.Common.Task_Image := Task_Image; + Unlock (Self_ID); + + -- 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; + end Create_Restricted_Task; + + --------------------------- + -- 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); + + Write_Lock (Self_ID); + Sleep (Self_ID, Master_Completion_Sleep); + Unlock (Self_ID); + + -- 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 + -- 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); + end Init_RTS; + +begin + Init_RTS; +end System.Tasking.Restricted.Stages; |