URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc1/] [gcc/] [ada/] [s-tarest.adb] - Rev 338
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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-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 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; 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 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_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 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. 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); 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; -- 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; 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)); 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; 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); 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; 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;