Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                 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-2011, 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_Percentage) / 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. Dispatching domains are

      --  not allowed in Ravenscar, so the dispatching domain parameter will

      --  always be null.

      Initialize_ATCB

        (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,

         Base_CPU, null, 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;