path: root/gcc-4.3.1/gcc/ada/s-soflin.ads

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                    S Y S T E M . S O F T _ L I N K S                     --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT 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.  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.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  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.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This package contains a set of subprogram access variables that access
--  some low-level primitives that are different depending whether tasking is
--  involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a
--  different value for each task). To avoid dragging in the tasking runtimes
--  all the time, we use a system of soft links where the links are
--  initialized to non-tasking versions, and then if the tasking support is
--  initialized, they are set to the real tasking versions.

pragma Warnings (Off);
--  When compiling this package with older compilers, there are many warnings,
--  so we suppress them throughout most of this file. Pragmas Compiler_Unit,
--  Preelaborate_05, and Favor_Top_Level are not supported by older compilers.

pragma Compiler_Unit;

with Ada.Exceptions;
with System.Stack_Checking;

package System.Soft_Links is
   pragma Preelaborate_05;

   subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
   subtype EO is Ada.Exceptions.Exception_Occurrence;

   function Current_Target_Exception return EO;
   pragma Import
     (Ada, Current_Target_Exception, "__gnat_current_target_exception");
   --  Import this subprogram from the private part of Ada.Exceptions

   --  First we have the access subprogram types used to establish the links.
   --  The approach is to establish variables containing access subprogram
   --  values, which by default point to dummy no tasking versions of routines.

   type No_Param_Proc     is access procedure;
   pragma Favor_Top_Level (No_Param_Proc);
   type Addr_Param_Proc   is access procedure (Addr : Address);
   pragma Favor_Top_Level (Addr_Param_Proc);
   type EO_Param_Proc     is access procedure (Excep : EO);
   pragma Favor_Top_Level (EO_Param_Proc);

   type Get_Address_Call  is access function return Address;
   pragma Favor_Top_Level (Get_Address_Call);
   type Set_Address_Call  is access procedure (Addr : Address);
   pragma Favor_Top_Level (Set_Address_Call);
   type Set_Address_Call2 is access procedure
     (Self_ID : Address; Addr : Address);
   pragma Favor_Top_Level (Set_Address_Call2);

   type Get_Integer_Call  is access function return Integer;
   pragma Favor_Top_Level (Get_Integer_Call);
   type Set_Integer_Call  is access procedure (Len : Integer);
   pragma Favor_Top_Level (Set_Integer_Call);

   type Get_EOA_Call      is access function return EOA;
   pragma Favor_Top_Level (Get_EOA_Call);
   type Set_EOA_Call      is access procedure (Excep : EOA);
   pragma Favor_Top_Level (Set_EOA_Call);
   type Set_EO_Call       is access procedure (Excep : EO);
   pragma Favor_Top_Level (Set_EO_Call);

   type Special_EO_Call   is access
     procedure (Excep : EO := Current_Target_Exception);
   pragma Favor_Top_Level (Special_EO_Call);

   type Timed_Delay_Call  is access
     procedure (Time : Duration; Mode : Integer);
   pragma Favor_Top_Level (Timed_Delay_Call);

   type Get_Stack_Access_Call is access
     function return Stack_Checking.Stack_Access;
   pragma Favor_Top_Level (Get_Stack_Access_Call);

   type Task_Name_Call is access
     function return String;
   pragma Favor_Top_Level (Task_Name_Call);

   --  Suppress checks on all these types, since we know the corrresponding
   --  values can never be null (the soft links are always initialized).

   pragma Suppress (Access_Check, No_Param_Proc);
   pragma Suppress (Access_Check, Addr_Param_Proc);
   pragma Suppress (Access_Check, EO_Param_Proc);
   pragma Suppress (Access_Check, Get_Address_Call);
   pragma Suppress (Access_Check, Set_Address_Call);
   pragma Suppress (Access_Check, Set_Address_Call2);
   pragma Suppress (Access_Check, Get_Integer_Call);
   pragma Suppress (Access_Check, Set_Integer_Call);
   pragma Suppress (Access_Check, Get_EOA_Call);
   pragma Suppress (Access_Check, Set_EOA_Call);
   pragma Suppress (Access_Check, Timed_Delay_Call);
   pragma Suppress (Access_Check, Get_Stack_Access_Call);
   pragma Suppress (Access_Check, Task_Name_Call);

   --  The following one is not related to tasking/no-tasking but to the
   --  traceback decorators for exceptions.

   type Traceback_Decorator_Wrapper_Call is access
     function (Traceback : System.Address;
               Len       : Natural)
               return      String;
   pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call);
   pragma Warnings (On);

   --  Declarations for the no tasking versions of the required routines

   procedure Abort_Defer_NT;
   --  Defer task abort (non-tasking case, does nothing)

   procedure Abort_Undefer_NT;
   --  Undefer task abort (non-tasking case, does nothing)

   procedure Abort_Handler_NT;
   --  Handle task abort (non-tasking case, does nothing). Currently, only VMS
   --  uses this.

   procedure Update_Exception_NT (X : EO := Current_Target_Exception);
   --  Handle exception setting. This routine is provided for targets that
   --  have built-in exception handling such as the Java Virtual Machine.
   --  Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on
   --  how this routine is used.

   function Check_Abort_Status_NT return Integer;
   --  Returns Boolean'Pos (True) iff abort signal should raise
   --  Standard.Abort_Signal.

   procedure Task_Lock_NT;
   --  Lock out other tasks (non-tasking case, does nothing)

   procedure Task_Unlock_NT;
   --  Release lock set by Task_Lock (non-tasking case, does nothing)

   procedure Task_Termination_NT (Excep : EO);
   --  Handle task termination routines for the environment task (non-tasking
   --  case, does nothing).

   procedure Null_Finalize_Global_List;
   --  Finalize global list for controlled objects (does nothing)

   procedure Adafinal_NT;
   --  Shuts down the runtime system (non-tasking case)

   Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
   pragma Suppress (Access_Check, Abort_Defer);
   --  Defer task abort (task/non-task case as appropriate)

   Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
   pragma Suppress (Access_Check, Abort_Undefer);
   --  Undefer task abort (task/non-task case as appropriate)

   Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
   --  Handle task abort (task/non-task case as appropriate)

   Update_Exception : Special_EO_Call := Update_Exception_NT'Access;
   --  Handle exception setting and tasking polling when appropriate

   Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access;
   --  Called when Abort_Signal is delivered to the process.  Checks to
   --  see if signal should result in raising Standard.Abort_Signal.

   Lock_Task : No_Param_Proc := Task_Lock_NT'Access;
   --  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.
   --  This routine also prevents against asynchronous aborts (abort is
   --  deferred).

   Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access;
   --  Releases lock previously set by call to Lock_Task. In the nested case,
   --  all nested locks must be released before other tasks competing for the
   --  tasking lock are released.
   --
   --  In the non nested case, this routine terminates the protection against
   --  asynchronous aborts introduced by Lock_Task (unless abort was already
   --  deferred before the call to Lock_Task (e.g in a protected procedures).
   --
   --  Note: the recommended protocol for using Lock_Task and Unlock_Task
   --  is as follows:
   --
   --    Locked_Processing : begin
   --       System.Soft_Links.Lock_Task.all;
   --       ...
   --       System.Soft_Links..Unlock_Task.all;
   --
   --    exception
   --       when others =>
   --          System.Soft_Links..Unlock_Task.all;
   --          raise;
   --    end Locked_Processing;
   --
   --  This ensures that the lock is not left set if an exception is raised
   --  explicitly or implicitly during the critical locked region.

   Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
   --  Handle task termination routines (task/non-task case as appropriate)

   Finalize_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access;
   --  Performs finalization of global list for controlled objects

   Adafinal : No_Param_Proc := Adafinal_NT'Access;
   --  Performs the finalization of the Ada Runtime

   function  Get_Jmpbuf_Address_NT return  Address;
   procedure Set_Jmpbuf_Address_NT (Addr : Address);

   Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access;
   Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access;

   function  Get_Sec_Stack_Addr_NT return  Address;
   procedure Set_Sec_Stack_Addr_NT (Addr : Address);

   Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access;
   Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access;

   function Get_Exc_Stack_Addr_NT return Address;
   Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;

   function  Get_Current_Excep_NT return EOA;

   Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;

   function Get_Stack_Info_NT return Stack_Checking.Stack_Access;

   Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;

   --------------------------
   -- Master_Id Soft-Links --
   --------------------------

   --  Soft-Links are used for procedures that manipulate Master_Ids because
   --  a Master_Id must be generated for access to limited class-wide types,
   --  whose root may be extended with task components.

   function Current_Master_NT return Integer;
   procedure Enter_Master_NT;
   procedure Complete_Master_NT;

   Current_Master  : Get_Integer_Call :=  Current_Master_NT'Access;
   Enter_Master    : No_Param_Proc    :=  Enter_Master_NT'Access;
   Complete_Master : No_Param_Proc    :=  Complete_Master_NT'Access;

   ----------------------
   -- Delay Soft-Links --
   ----------------------

   --  Soft-Links are used for procedures that manipulate time to avoid
   --  dragging the tasking run time when using delay statements.

   Timed_Delay : Timed_Delay_Call;

   --------------------------
   -- Task Name Soft-Links --
   --------------------------

   function Task_Name_NT return String;

   Task_Name : Task_Name_Call := Task_Name_NT'Access;

   -------------------------------------
   -- Exception Tracebacks Soft-Links --
   -------------------------------------

   Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call;
   --  Wrapper to the possible user specified traceback decorator to be
   --  called during automatic output of exception data.

   --  The nullity of this wrapper shall correspond to the nullity of the
   --  current actual decorator. This is ensured first by the null initial
   --  value of the corresponding variables, and then by Set_Trace_Decorator
   --  in g-exctra.adb.

   pragma Atomic (Traceback_Decorator_Wrapper);
   --  Since concurrent read/write operations may occur on this variable.
   --  See the body of Tailored_Exception_Traceback in Ada.Exceptions for
   --  a more detailed description of the potential problems.

   ------------------------
   -- Task Specific Data --
   ------------------------

   --  Here we define a single type that encapsulates the various task
   --  specific data. This type is used to store the necessary data into
   --  the Task_Control_Block or into a global variable in the non tasking
   --  case.

   type TSD is record
      Pri_Stack_Info : aliased Stack_Checking.Stack_Info;
      --  Information on stack (Base/Limit/Size) that is used
      --  by System.Stack_Checking. If this TSD does not belong to
      --  the environment task, the Size field must be initialized
      --  to the tasks requested stack size before the task can do
      --  its first stack check.

      pragma Warnings (Off);
      Jmpbuf_Address : System.Address := System.Null_Address;
      --  Address of jump buffer used to store the address of the
      --  current longjmp/setjmp buffer for exception management.
      --  These buffers are threaded into a stack, and the address
      --  here is the top of the stack. A null address means that
      --  no exception handler is currently active.

      Sec_Stack_Addr : System.Address := System.Null_Address;
      pragma Warnings (On);
      --  Address of currently allocated secondary stack

      Current_Excep : aliased EO;
      --  Exception occurrence that contains the information for the
      --  current exception. Note that any exception in the same task
      --  destroys this information, so the data in this variable must
      --  be copied out before another exception can occur.
      --
      --  Also act as a list of the active exceptions in the case of the GCC
      --  exception mechanism, organized as a stack with the most recent first.
   end record;

   procedure Create_TSD (New_TSD : in out TSD);
   pragma Inline (Create_TSD);
   --  Called from s-tassta when a new thread is created to perform
   --  any required initialization of the TSD.

   procedure Destroy_TSD (Old_TSD : in out TSD);
   pragma Inline (Destroy_TSD);
   --  Called from s-tassta just before a thread is destroyed to perform
   --  any required finalization.

   function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
   pragma Inline (Get_GNAT_Exception);
   --  This function obtains the Exception_Id from the Exception_Occurrence
   --  referenced by the Current_Excep field of the task specific data, i.e.
   --  the call is equivalent to
   --  Exception_Identity (Get_Current_Exception.all)

   --  Export the Get/Set routines for the various Task Specific Data (TSD)
   --  elements as callable subprograms instead of objects of access to
   --  subprogram types.

   function  Get_Jmpbuf_Address_Soft return  Address;
   procedure Set_Jmpbuf_Address_Soft (Addr : Address);
   pragma Inline (Get_Jmpbuf_Address_Soft);
   pragma Inline (Set_Jmpbuf_Address_Soft);

   function  Get_Sec_Stack_Addr_Soft return  Address;
   procedure Set_Sec_Stack_Addr_Soft (Addr : Address);
   pragma Inline (Get_Sec_Stack_Addr_Soft);
   pragma Inline (Set_Sec_Stack_Addr_Soft);

   function Get_Exc_Stack_Addr_Soft return Address;

end System.Soft_Links;