gcc/ada/s-soflin.ads

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                    S Y S T E M . S O F T _ L I N K S                     --
   6 --                                                                          --
   7 --                                 S p e c                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This package contains a set of subprogram access variables that access
  36 --  some low-level primitives that are called different depending wether
  37 --  tasking is involved or not (e.g. the Get/Set_Jmpbuf_Address that needs
  38 --  to provide a different value for each task). To avoid dragging in the
  39 --  tasking all the time, we use a system of soft links where the links are
  40 --  initialized to non-tasking versions, and then if the tasking is
  41 --  initialized, they are reset to the real tasking versions.
  42
  43 with Ada.Exceptions;
  44 with System.Stack_Checking;
  45
  46 package System.Soft_Links is
  47    pragma Elaborate_Body;
  48
  49    subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
  50    subtype EO is Ada.Exceptions.Exception_Occurrence;
  51
  52    function Current_Target_Exception return EO;
  53    pragma Import
  54      (Ada, Current_Target_Exception,
  55       "__gnat_current_target_exception");
  56    --  Import this subprogram from the private part of Ada.Exceptions.
  57
  58    --  First we have the access subprogram types used to establish the links.
  59    --  The approach is to establish variables containing access subprogram
  60    --  values which by default point to dummy no tasking versions of routines.
  61
  62    type No_Param_Proc     is access procedure;
  63    type Addr_Param_Proc   is access procedure (Addr : Address);
  64
  65    type Get_Address_Call  is access function return Address;
  66    type Set_Address_Call  is access procedure (Addr : Address);
  67    type Set_Address_Call2 is access procedure
  68      (Self_ID : Address; Addr : Address);
  69
  70    type Get_Integer_Call  is access function return Integer;
  71    type Set_Integer_Call  is access procedure (Len : Integer);
  72
  73    type Get_EOA_Call      is access function return EOA;
  74    type Set_EOA_Call      is access procedure (Excep : EOA);
  75    type Set_EO_Call       is access procedure (Excep : EO);
  76
  77    type Special_EO_Call   is access
  78      procedure (Excep : EO := Current_Target_Exception);
  79
  80    type Timed_Delay_Call  is access
  81      procedure (Time : Duration; Mode : Integer);
  82
  83    type Get_Stack_Access_Call is access
  84      function return Stack_Checking.Stack_Access;
  85
  86    type Task_Name_Call is access
  87      function return String;
  88
  89    --  Suppress checks on all these types, since we know corrresponding
  90    --  values can never be null (the soft links are always initialized).
  91
  92    pragma Suppress (Access_Check, No_Param_Proc);
  93    pragma Suppress (Access_Check, Addr_Param_Proc);
  94    pragma Suppress (Access_Check, Get_Address_Call);
  95    pragma Suppress (Access_Check, Set_Address_Call);
  96    pragma Suppress (Access_Check, Set_Address_Call2);
  97    pragma Suppress (Access_Check, Get_Integer_Call);
  98    pragma Suppress (Access_Check, Set_Integer_Call);
  99    pragma Suppress (Access_Check, Get_EOA_Call);
 100    pragma Suppress (Access_Check, Set_EOA_Call);
 101    pragma Suppress (Access_Check, Timed_Delay_Call);
 102    pragma Suppress (Access_Check, Get_Stack_Access_Call);
 103    pragma Suppress (Access_Check, Task_Name_Call);
 104
 105    --  The following one is not related to tasking/no-tasking but to the
 106    --  traceback decorators for exceptions.
 107
 108    type Traceback_Decorator_Wrapper_Call is access
 109      function (Traceback : System.Address;
 110                Len       : Natural)
 111                return      String;
 112
 113    --  Declarations for the no tasking versions of the required routines
 114
 115    procedure Abort_Defer_NT;
 116    --  Defer task abortion (non-tasking case, does nothing)
 117
 118    procedure Abort_Undefer_NT;
 119    --  Undefer task abortion (non-tasking case, does nothing)
 120
 121    procedure Abort_Handler_NT;
 122    --  Handle task abortion (non-tasking case, does nothing). Currently,
 123    --  only VMS uses this.
 124
 125    procedure Update_Exception_NT
 126      (X : EO := Current_Target_Exception);
 127    --  Handle exception setting. This routine is provided for targets
 128    --  which have built-in exception handling such as the Java Virtual
 129    --  Machine. Currently, only JGNAT uses this. See 4jexcept.ads for
 130    --  an explanation on how this routine is used.
 131
 132    function Check_Abort_Status_NT return Integer;
 133    --  Returns Boolean'Pos (True) iff abort signal should raise
 134    --  Standard.Abort_Signal.
 135
 136    procedure Task_Lock_NT;
 137    --  Lock out other tasks (non-tasking case, does nothing)
 138
 139    procedure Task_Unlock_NT;
 140    --  Release lock set by Task_Lock (non-tasking case, does nothing)
 141
 142    procedure Null_Adafinal;
 143    --  Shuts down the runtime system (non-tasking no-finalization case,
 144    --  does nothing)
 145
 146    Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access;
 147    pragma Suppress (Access_Check, Abort_Defer);
 148    --  Defer task abortion (task/non-task case as appropriate)
 149
 150    Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access;
 151    pragma Suppress (Access_Check, Abort_Undefer);
 152    --  Undefer task abortion (task/non-task case as appropriate)
 153
 154    Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
 155    --  Handle task abortion (task/non-task case as appropriate)
 156
 157    Update_Exception : Special_EO_Call := Update_Exception_NT'Access;
 158    --  Handle exception setting and tasking polling when appropriate
 159
 160    Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access;
 161    --  Called when Abort_Signal is delivered to the process.  Checks to
 162    --  see if signal should result in raising Standard.Abort_Signal.
 163
 164    Lock_Task : No_Param_Proc := Task_Lock_NT'Access;
 165    --  Locks out other tasks. Preceding a section of code by Task_Lock and
 166    --  following it by Task_Unlock creates a critical region. This is used
 167    --  for ensuring that a region of non-tasking code (such as code used to
 168    --  allocate memory) is tasking safe. Note that it is valid for calls to
 169    --  Task_Lock/Task_Unlock to be nested, and this must work properly, i.e.
 170    --  only the corresponding outer level Task_Unlock will actually unlock.
 171    --  This routine also prevents against asynchronous aborts (abort is
 172    --  deferred).
 173
 174    Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access;
 175    --  Releases lock previously set by call to Lock_Task. In the nested case,
 176    --  all nested locks must be released before other tasks competing for the
 177    --  tasking lock are released.
 178    --
 179    --  In the non nested case, this routine terminates the protection against
 180    --  asynchronous aborts introduced by Lock_Task (unless abort was already
 181    --  deferred before the call to Lock_Task (e.g in a protected procedures).
 182    --
 183    --  Note: the recommended protocol for using Lock_Task and Unlock_Task
 184    --  is as follows:
 185    --
 186    --    Locked_Processing : begin
 187    --       System.Soft_Links.Lock_Task.all;
 188    --       ...
 189    --       System.Soft_Links..Unlock_Task.all;
 190    --
 191    --    exception
 192    --       when others =>
 193    --          System.Soft_Links..Unlock_Task.all;
 194    --          raise;
 195    --    end Locked_Processing;
 196    --
 197    --  This ensures that the lock is not left set if an exception is raised
 198    --  explicitly or implicitly during the critical locked region.
 199
 200    Adafinal : No_Param_Proc := Null_Adafinal'Access;
 201    --  Performs the finalization of the Ada Runtime.
 202
 203    function  Get_Jmpbuf_Address_NT return  Address;
 204    procedure Set_Jmpbuf_Address_NT (Addr : Address);
 205
 206    Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access;
 207    Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access;
 208
 209    function  Get_Sec_Stack_Addr_NT return  Address;
 210    procedure Set_Sec_Stack_Addr_NT (Addr : Address);
 211
 212    Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access;
 213    Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access;
 214
 215    function  Get_Machine_State_Addr_NT return  Address;
 216    procedure Set_Machine_State_Addr_NT (Addr : Address);
 217
 218    Get_Machine_State_Addr : Get_Address_Call
 219      := Get_Machine_State_Addr_NT'Access;
 220    Set_Machine_State_Addr : Set_Address_Call
 221      := Set_Machine_State_Addr_NT'Access;
 222
 223    function  Get_Exc_Stack_Addr_NT return Address;
 224    procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address);
 225    --  Self_ID is a Task_ID, but in the non-tasking case there is no
 226    --  Task_ID type available, so make do with Address.
 227
 228    Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
 229    Set_Exc_Stack_Addr : Set_Address_Call2 := Set_Exc_Stack_Addr_NT'Access;
 230
 231    function  Get_Current_Excep_NT return EOA;
 232
 233    Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
 234
 235    function Get_Stack_Info_NT return Stack_Checking.Stack_Access;
 236
 237    Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access;
 238
 239    --------------------------
 240    -- Master_Id Soft-Links --
 241    --------------------------
 242
 243    --  Soft-Links are used for procedures that manipulate  Master_Ids because
 244    --  a Master_Id must be generated for access to limited class-wide types,
 245    --  whose root may be extended with task components.
 246
 247    function Current_Master_NT return Integer;
 248    procedure Enter_Master_NT;
 249    procedure Complete_Master_NT;
 250
 251    Current_Master  : Get_Integer_Call :=  Current_Master_NT'Access;
 252    Enter_Master    : No_Param_Proc    :=  Enter_Master_NT'Access;
 253    Complete_Master : No_Param_Proc    :=  Complete_Master_NT'Access;
 254
 255    ----------------------
 256    -- Delay Soft-Links --
 257    ----------------------
 258
 259    --  Soft-Links are used for procedures that manipulate time to avoid
 260    --  dragging the tasking run time when using delay statements.
 261
 262    Timed_Delay : Timed_Delay_Call;
 263
 264    --------------------------
 265    -- Task Name Soft-Links --
 266    --------------------------
 267
 268    function Task_Name_NT return String;
 269
 270    Task_Name : Task_Name_Call := Task_Name_NT'Access;
 271
 272    -------------------------------------
 273    -- Exception Tracebacks Soft-Links --
 274    -------------------------------------
 275
 276    Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call;
 277    --  Wrapper to the possible user specified traceback decorator to be
 278    --  called during automatic output of exception data.
 279
 280    --  The nullity of this wrapper shall correspond to the nullity of the
 281    --  current actual decorator. This is ensured first by the null initial
 282    --  value of the corresponding variables, and then by Set_Trace_Decorator
 283    --  in g-exctra.adb.
 284
 285    pragma Atomic (Traceback_Decorator_Wrapper);
 286    --  Since concurrent read/write operations may occur on this variable.
 287    --  See the body of Tailored_Exception_Traceback in Ada.Exceptions for
 288    --  a more detailed description of the potential problems.
 289
 290    ------------------------
 291    -- Task Specific Data --
 292    ------------------------
 293
 294    --  Here we define a single type that encapsulates the various task
 295    --  specific data. This type is used to store the necessary data into
 296    --  the Task_Control_Block or into a global variable in the non tasking
 297    --  case.
 298
 299    type TSD is record
 300       Pri_Stack_Info : aliased Stack_Checking.Stack_Info;
 301       --  Information on stack (Base/Limit/Size) that is used
 302       --  by System.Stack_Checking. If this TSD does not belong to
 303       --  the environment task, the Size field must be initialized
 304       --  to the tasks requested stack size before the task can do
 305       --  its first stack check.
 306
 307       Jmpbuf_Address : Address := Null_Address;
 308       --  Address of jump buffer used to store the address of the
 309       --  current longjmp/setjmp buffer for exception management.
 310       --  These buffers are threaded into a stack, and the address
 311       --  here is the top of the stack. A null address means that
 312       --  no exception handler is currently active.
 313
 314       Sec_Stack_Addr : Address := Null_Address;
 315       --  Address of currently allocated secondary stack
 316
 317       Exc_Stack_Addr : Address := Null_Address;
 318       --  Address of a task-specific stack used for the propagation of
 319       --  exceptions in response to synchronous faults. This alternate
 320       --  stack is necessary when propagating Storage_Error resulting
 321       --  from a stack overflow, as the task's primary stack is full.
 322       --  This is currently only used on the SGI, and this value stays
 323       --  null on other platforms.
 324
 325       Current_Excep : aliased EO;
 326       --  Exception occurrence that contains the information for the
 327       --  current exception. Note that any exception in the same task
 328       --  destroys this information, so the data in this variable must
 329       --  be copied out before another exception can occur.
 330
 331       Machine_State_Addr : Address := Null_Address;
 332       --
 333    end record;
 334
 335    procedure Create_TSD (New_TSD : in out TSD);
 336    pragma Inline (Create_TSD);
 337    --  Called from s-tassta when a new thread is created to perform
 338    --  any required initialization of the TSD.
 339
 340    procedure Destroy_TSD (Old_TSD : in out TSD);
 341    pragma Inline (Destroy_TSD);
 342    --  Called from s-tassta  just before a thread is destroyed to perform
 343    --  any required finalization.
 344
 345    function Get_GNAT_Exception return Ada.Exceptions.Exception_Id;
 346    pragma Inline (Get_GNAT_Exception);
 347    --  This function obtains the Exception_Id from the Exception_Occurrence
 348    --  referenced by the Current_Excep field of the task specific data, i.e.
 349    --  the call is equivalent to
 350    --  Exception_Identity (Get_Current_Exception.all)
 351
 352    --  Export the Get/Set routines for the various Task Specific Data (TSD)
 353    --  elements as callable subprograms instead of objects of access to
 354    --  subprogram types.
 355
 356    function  Get_Jmpbuf_Address_Soft return  Address;
 357    procedure Set_Jmpbuf_Address_Soft (Addr : Address);
 358    pragma Inline (Get_Jmpbuf_Address_Soft);
 359    pragma Inline (Set_Jmpbuf_Address_Soft);
 360
 361    function  Get_Sec_Stack_Addr_Soft return  Address;
 362    procedure Set_Sec_Stack_Addr_Soft (Addr : Address);
 363    pragma Inline (Get_Sec_Stack_Addr_Soft);
 364    pragma Inline (Set_Sec_Stack_Addr_Soft);
 365
 366    function  Get_Exc_Stack_Addr_Soft return Address;
 367    procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address);
 368    pragma Inline (Get_Exc_Stack_Addr_Soft);
 369    pragma Inline (Set_Exc_Stack_Addr_Soft);
 370
 371    function  Get_Machine_State_Addr_Soft return Address;
 372    procedure Set_Machine_State_Addr_Soft (Addr : Address);
 373    pragma Inline (Get_Machine_State_Addr_Soft);
 374    pragma Inline (Set_Machine_State_Addr_Soft);
 375
 376 end System.Soft_Links;