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