X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fs-tarest.adb;h=cfe075835398a9690e2dc14fda9307392febbf2d;hb=0c1fe26b5f780a30fd26e3e3075764f99322dbbf;hp=a6cf274c8ef21f5a652cc2c16e32675eb636ef37;hpb=c32d045231e086867f117700fbe01dbbbce3ea14;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index a6cf274c8ef..cfe07583539 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -1,14 +1,12 @@ ------------------------------------------------------------------------------ -- -- --- 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- -- @@ -18,8 +16,8 @@ -- 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, -- @@ -28,9 +26,8 @@ -- 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. -- -- -- ------------------------------------------------------------------------------ @@ -48,12 +45,8 @@ 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 Ada.Exceptions; +-- used for Exception_Occurrence with System.Task_Primitives.Operations; -- used for Enter_Task @@ -70,6 +63,9 @@ with System.Soft_Links; -- 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; @@ -83,9 +79,11 @@ package body System.Tasking.Restricted.Stages is 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 @@ -95,6 +93,9 @@ package body System.Tasking.Restricted.Stages is -- 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 @@ -108,30 +109,17 @@ package body System.Tasking.Restricted.Stages is -- 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. @@ -141,13 +129,29 @@ package body System.Tasking.Restricted.Stages is -- 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; ----------------- @@ -155,48 +159,17 @@ package body System.Tasking.Restricted.Stages is ----------------- 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 -- @@ -211,20 +184,43 @@ package body System.Tasking.Restricted.Stages is -- 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 @@ -238,35 +234,81 @@ package body System.Tasking.Restricted.Stages is 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 -- @@ -276,32 +318,35 @@ package body System.Tasking.Restricted.Stages is -- 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; @@ -339,9 +384,8 @@ package body System.Tasking.Restricted.Stages is 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; @@ -351,7 +395,11 @@ package body System.Tasking.Restricted.Stages is 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; @@ -366,21 +414,24 @@ package body System.Tasking.Restricted.Stages is -- 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; @@ -393,9 +444,13 @@ package body System.Tasking.Restricted.Stages is 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); @@ -417,28 +472,37 @@ package body System.Tasking.Restricted.Stages is 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 @@ -446,28 +510,42 @@ package body System.Tasking.Restricted.Stages is 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; --------------------------- @@ -479,14 +557,39 @@ package body System.Tasking.Restricted.Stages is -- 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; @@ -496,7 +599,7 @@ package body System.Tasking.Restricted.Stages is -- 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; @@ -505,7 +608,7 @@ package body System.Tasking.Restricted.Stages is -- 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; @@ -516,6 +619,8 @@ package body System.Tasking.Restricted.Stages is 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); @@ -523,24 +628,15 @@ package body System.Tasking.Restricted.Stages is -- 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