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-2014, 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 procedure Update_Exception_NT (X : EO := Current_Target_Exception); 147 -- Handle exception setting. This routine is provided for targets that 148 -- have built-in exception handling such as the Java Virtual Machine. 149 -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on 150 -- how this routine is used. 151 152 function Check_Abort_Status_NT return Integer; 153 -- Returns Boolean'Pos (True) iff abort signal should raise 154 -- Standard'Abort_Signal. 155 156 procedure Task_Lock_NT; 157 -- Lock out other tasks (non-tasking case, does nothing) 158 159 procedure Task_Unlock_NT; 160 -- Release lock set by Task_Lock (non-tasking case, does nothing) 161 162 procedure Task_Termination_NT (Excep : EO); 163 -- Handle task termination routines for the environment task (non-tasking 164 -- case, does nothing). 165 166 procedure Adafinal_NT; 167 -- Shuts down the runtime system (non-tasking case) 168 169 Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; 170 pragma Suppress (Access_Check, Abort_Defer); 171 -- Defer task abort (task/non-task case as appropriate) 172 173 Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; 174 pragma Suppress (Access_Check, Abort_Undefer); 175 -- Undefer task abort (task/non-task case as appropriate) 176 177 Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; 178 -- Handle task abort (task/non-task case as appropriate) 179 180 Update_Exception : Special_EO_Call := Update_Exception_NT'Access; 181 -- Handle exception setting and tasking polling when appropriate 182 183 Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; 184 -- Called when Abort_Signal is delivered to the process. Checks to 185 -- see if signal should result in raising Standard'Abort_Signal. 186 187 Lock_Task : No_Param_Proc := Task_Lock_NT'Access; 188 -- Locks out other tasks. Preceding a section of code by Task_Lock and 189 -- following it by Task_Unlock creates a critical region. This is used 190 -- for ensuring that a region of non-tasking code (such as code used to 191 -- allocate memory) is tasking safe. Note that it is valid for calls to 192 -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. 193 -- only the corresponding outer level Task_Unlock will actually unlock. 194 -- This routine also prevents against asynchronous aborts (abort is 195 -- deferred). 196 197 Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access; 198 -- Releases lock previously set by call to Lock_Task. In the nested case, 199 -- all nested locks must be released before other tasks competing for the 200 -- tasking lock are released. 201 -- 202 -- In the non nested case, this routine terminates the protection against 203 -- asynchronous aborts introduced by Lock_Task (unless abort was already 204 -- deferred before the call to Lock_Task (e.g in a protected procedures). 205 -- 206 -- Note: the recommended protocol for using Lock_Task and Unlock_Task 207 -- is as follows: 208 -- 209 -- Locked_Processing : begin 210 -- System.Soft_Links.Lock_Task.all; 211 -- ... 212 -- System.Soft_Links.Unlock_Task.all; 213 -- 214 -- exception 215 -- when others => 216 -- System.Soft_Links.Unlock_Task.all; 217 -- raise; 218 -- end Locked_Processing; 219 -- 220 -- This ensures that the lock is not left set if an exception is raised 221 -- explicitly or implicitly during the critical locked region. 222 223 Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access; 224 -- Handle task termination routines (task/non-task case as appropriate) 225 226 Finalize_Library_Objects : No_Param_Proc; 227 pragma Export (C, Finalize_Library_Objects, 228 "__gnat_finalize_library_objects"); 229 -- Will be initialized by the binder 230 231 Adafinal : No_Param_Proc := Adafinal_NT'Access; 232 -- Performs the finalization of the Ada Runtime 233 234 function Get_Jmpbuf_Address_NT return Address; 235 procedure Set_Jmpbuf_Address_NT (Addr : Address); 236 237 Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access; 238 Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access; 239 240 function Get_Sec_Stack_Addr_NT return Address; 241 procedure Set_Sec_Stack_Addr_NT (Addr : Address); 242 243 Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; 244 Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; 245 246 function Get_Current_Excep_NT return EOA; 247 248 Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access; 249 250 function Get_Stack_Info_NT return Stack_Checking.Stack_Access; 251 252 Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access; 253 254 -------------------------- 255 -- Master_Id Soft-Links -- 256 -------------------------- 257 258 -- Soft-Links are used for procedures that manipulate Master_Ids because 259 -- a Master_Id must be generated for access to limited class-wide types, 260 -- whose root may be extended with task components. 261 262 function Current_Master_NT return Integer; 263 procedure Enter_Master_NT; 264 procedure Complete_Master_NT; 265 266 Current_Master : Get_Integer_Call := Current_Master_NT'Access; 267 Enter_Master : No_Param_Proc := Enter_Master_NT'Access; 268 Complete_Master : No_Param_Proc := Complete_Master_NT'Access; 269 270 ---------------------- 271 -- Delay Soft-Links -- 272 ---------------------- 273 274 -- Soft-Links are used for procedures that manipulate time to avoid 275 -- dragging the tasking run time when using delay statements. 276 277 Timed_Delay : Timed_Delay_Call; 278 279 -------------------------- 280 -- Task Name Soft-Links -- 281 -------------------------- 282 283 function Task_Name_NT return String; 284 285 Task_Name : Task_Name_Call := Task_Name_NT'Access; 286 287 ------------------------------------- 288 -- Exception Tracebacks Soft-Links -- 289 ------------------------------------- 290 291 Library_Exception : EO; 292 -- Library-level finalization routines use this common reference to store 293 -- the first library-level exception which occurs during finalization. 294 295 Library_Exception_Set : Boolean := False; 296 -- Used in conjunction with Library_Exception, set when an exception has 297 -- been stored. 298 299 Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call; 300 -- Wrapper to the possible user specified traceback decorator to be 301 -- called during automatic output of exception data. 302 303 -- The null value of this wrapper correspond sto the null value of the 304 -- current actual decorator. This is ensured first by the null initial 305 -- value of the corresponding variables, and then by Set_Trace_Decorator 306 -- in g-exctra.adb. 307 308 pragma Atomic (Traceback_Decorator_Wrapper); 309 -- Since concurrent read/write operations may occur on this variable. 310 -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for 311 -- a more detailed description of the potential problems. 312 313 procedure Save_Library_Occurrence (E : EOA); 314 -- When invoked, this routine saves an exception occurrence into a hidden 315 -- reference. Subsequent calls will have no effect. 316 317 ------------------------ 318 -- Task Specific Data -- 319 ------------------------ 320 321 -- Here we define a single type that encapsulates the various task 322 -- specific data. This type is used to store the necessary data into the 323 -- Task_Control_Block or into a global variable in the non tasking case. 324 325 type TSD is record 326 Pri_Stack_Info : aliased Stack_Checking.Stack_Info; 327 -- Information on stack (Base/Limit/Size) used by System.Stack_Checking. 328 -- If this TSD does not belong to the environment task, the Size field 329 -- must be initialized to the tasks requested stack size before the task 330 -- can do its first stack check. 331 332 pragma Warnings (Off); 333 -- Needed because we are giving a non-static default to an object in 334 -- a preelaborated unit, which is formally not permitted, but OK here. 335 336 Jmpbuf_Address : System.Address := System.Null_Address; 337 -- Address of jump buffer used to store the address of the current 338 -- longjmp/setjmp buffer for exception management. These buffers are 339 -- threaded into a stack, and the address here is the top of the stack. 340 -- A null address means that no exception handler is currently active. 341 342 Sec_Stack_Addr : System.Address := System.Null_Address; 343 pragma Warnings (On); 344 -- Address of currently allocated secondary stack 345 346 Current_Excep : aliased EO; 347 -- Exception occurrence that contains the information for the current 348 -- exception. Note that any exception in the same task destroys this 349 -- information, so the data in this variable must be copied out before 350 -- another exception can occur. 351 -- 352 -- Also act as a list of the active exceptions in the case of the GCC 353 -- exception mechanism, organized as a stack with the most recent first. 354 end record; 355 356 procedure Create_TSD (New_TSD : in out TSD); 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_Addr_Soft return Address; 383 procedure Set_Sec_Stack_Addr_Soft (Addr : Address); 384 pragma Inline (Get_Sec_Stack_Addr_Soft); 385 pragma Inline (Set_Sec_Stack_Addr_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 408end System.Soft_Links; 409