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