From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/s-tarest.adb | 643 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 643 insertions(+) create mode 100644 gcc/ada/s-tarest.adb (limited to 'gcc/ada/s-tarest.adb') diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb new file mode 100644 index 000000000..5c8341243 --- /dev/null +++ b/gcc/ada/s-tarest.adb @@ -0,0 +1,643 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2010, 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 -- +-- . -- +-- -- +-- 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; + 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 + 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)); + + 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 + 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 + + Initialize_ATCB + (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, + Base_CPU, 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; -- cgit v1.2.3