diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/s-tarest.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/s-tarest.adb | 629 |
1 files changed, 0 insertions, 629 deletions
diff --git a/gcc-4.2.1/gcc/ada/s-tarest.adb b/gcc-4.2.1/gcc/ada/s-tarest.adb deleted file mode 100644 index 6c43d7ce9..000000000 --- a/gcc-4.2.1/gcc/ada/s-tarest.adb +++ /dev/null @@ -1,629 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-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- -- --- 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, 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, -- --- 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. -- --- 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; --- used for Exception_Occurrence - -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.Soft_Links.Tasking; --- Used for Init_Tasking_Soft_Links - -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 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 - -- 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. - - ----------------------- - -- 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 - 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 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); - - 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 - 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. 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. - - -- 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. - - 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); - - 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_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); - - if Single_Lock then - Unlock_RTS; - end if; - - -- 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 - 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; - State : Task_Procedure_Access; - Discriminants : System.Address; - Elaborated : Access_Boolean; - Chain : in out Activation_Chain; - Task_Image : String; - Created_Task : Task_Id) - is - Self_ID : constant Task_Id := STPO.Self; - Base_Priority : System.Any_Priority; - Success : Boolean; - - 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; - - 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 - - Initialize_ATCB - (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, - 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; - - Created_Task.Common.Task_Image_Len := - Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length); - Created_Task.Common.Task_Image - (1 .. Created_Task.Common.Task_Image_Len) := Task_Image; - - 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); - Created_Task.Common.Activation_Link := Chain.T_ID; - Chain.T_ID := Created_Task; - 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); - - 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; - - -- 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; |