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