------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M . S O F T _ L I N K S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- This package contains a set of subprogram access variables that access -- some low-level primitives that are different depending whether tasking is -- involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a -- different value for each task). To avoid dragging in the tasking runtimes -- all the time, we use a system of soft links where the links are -- initialized to non-tasking versions, and then if the tasking support is -- initialized, they are set to the real tasking versions. pragma Compiler_Unit_Warning; with Ada.Exceptions; with System.Stack_Checking; package System.Soft_Links is pragma Preelaborate; subtype EOA is Ada.Exceptions.Exception_Occurrence_Access; subtype EO is Ada.Exceptions.Exception_Occurrence; function Current_Target_Exception return EO; pragma Import (Ada, Current_Target_Exception, "__gnat_current_target_exception"); -- Import this subprogram from the private part of Ada.Exceptions -- First we have the access subprogram types used to establish the links. -- The approach is to establish variables containing access subprogram -- values, which by default point to dummy no tasking versions of routines. type No_Param_Proc is access procedure; pragma Favor_Top_Level (No_Param_Proc); pragma Suppress_Initialization (No_Param_Proc); -- Some uninitialized objects of that type are initialized by the Binder -- so it is important that such objects are not reset to null during -- elaboration. type Addr_Param_Proc is access procedure (Addr : Address); pragma Favor_Top_Level (Addr_Param_Proc); type EO_Param_Proc is access procedure (Excep : EO); pragma Favor_Top_Level (EO_Param_Proc); type Get_Address_Call is access function return Address; pragma Favor_Top_Level (Get_Address_Call); type Set_Address_Call is access procedure (Addr : Address); pragma Favor_Top_Level (Set_Address_Call); type Set_Address_Call2 is access procedure (Self_ID : Address; Addr : Address); pragma Favor_Top_Level (Set_Address_Call2); type Get_Integer_Call is access function return Integer; pragma Favor_Top_Level (Get_Integer_Call); type Set_Integer_Call is access procedure (Len : Integer); pragma Favor_Top_Level (Set_Integer_Call); type Get_EOA_Call is access function return EOA; pragma Favor_Top_Level (Get_EOA_Call); type Set_EOA_Call is access procedure (Excep : EOA); pragma Favor_Top_Level (Set_EOA_Call); type Set_EO_Call is access procedure (Excep : EO); pragma Favor_Top_Level (Set_EO_Call); type Special_EO_Call is access procedure (Excep : EO := Current_Target_Exception); pragma Favor_Top_Level (Special_EO_Call); type Timed_Delay_Call is access procedure (Time : Duration; Mode : Integer); pragma Favor_Top_Level (Timed_Delay_Call); type Get_Stack_Access_Call is access function return Stack_Checking.Stack_Access; pragma Favor_Top_Level (Get_Stack_Access_Call); type Task_Name_Call is access function return String; pragma Favor_Top_Level (Task_Name_Call); -- Suppress checks on all these types, since we know the corresponding -- values can never be null (the soft links are always initialized). pragma Suppress (Access_Check, No_Param_Proc); pragma Suppress (Access_Check, Addr_Param_Proc); pragma Suppress (Access_Check, EO_Param_Proc); pragma Suppress (Access_Check, Get_Address_Call); pragma Suppress (Access_Check, Set_Address_Call); pragma Suppress (Access_Check, Set_Address_Call2); pragma Suppress (Access_Check, Get_Integer_Call); pragma Suppress (Access_Check, Set_Integer_Call); pragma Suppress (Access_Check, Get_EOA_Call); pragma Suppress (Access_Check, Set_EOA_Call); pragma Suppress (Access_Check, Timed_Delay_Call); pragma Suppress (Access_Check, Get_Stack_Access_Call); pragma Suppress (Access_Check, Task_Name_Call); -- The following one is not related to tasking/no-tasking but to the -- traceback decorators for exceptions. type Traceback_Decorator_Wrapper_Call is access function (Traceback : System.Address; Len : Natural) return String; pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call); -- Declarations for the no tasking versions of the required routines procedure Abort_Defer_NT; -- Defer task abort (non-tasking case, does nothing) procedure Abort_Undefer_NT; -- Undefer task abort (non-tasking case, does nothing) procedure Abort_Handler_NT; -- Handle task abort (non-tasking case, does nothing). Currently, no port -- makes use of this, but we retain the interface for possible future use. procedure Update_Exception_NT (X : EO := Current_Target_Exception); -- Handle exception setting. This routine is provided for targets that -- have built-in exception handling such as the Java Virtual Machine. -- Currently, only JGNAT uses this. See 4jexcept.ads for an explanation on -- how this routine is used. function Check_Abort_Status_NT return Integer; -- Returns Boolean'Pos (True) iff abort signal should raise -- Standard'Abort_Signal. procedure Task_Lock_NT; -- Lock out other tasks (non-tasking case, does nothing) procedure Task_Unlock_NT; -- Release lock set by Task_Lock (non-tasking case, does nothing) procedure Task_Termination_NT (Excep : EO); -- Handle task termination routines for the environment task (non-tasking -- case, does nothing). procedure Adafinal_NT; -- Shuts down the runtime system (non-tasking case) Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; pragma Suppress (Access_Check, Abort_Defer); -- Defer task abort (task/non-task case as appropriate) Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; pragma Suppress (Access_Check, Abort_Undefer); -- Undefer task abort (task/non-task case as appropriate) Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; -- Handle task abort (task/non-task case as appropriate) Update_Exception : Special_EO_Call := Update_Exception_NT'Access; -- Handle exception setting and tasking polling when appropriate Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; -- Called when Abort_Signal is delivered to the process. Checks to -- see if signal should result in raising Standard'Abort_Signal. Lock_Task : No_Param_Proc := Task_Lock_NT'Access; -- Locks out other tasks. Preceding a section of code by Task_Lock and -- following it by Task_Unlock creates a critical region. This is used -- for ensuring that a region of non-tasking code (such as code used to -- allocate memory) is tasking safe. Note that it is valid for calls to -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. -- only the corresponding outer level Task_Unlock will actually unlock. -- This routine also prevents against asynchronous aborts (abort is -- deferred). Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access; -- Releases lock previously set by call to Lock_Task. In the nested case, -- all nested locks must be released before other tasks competing for the -- tasking lock are released. -- -- In the non nested case, this routine terminates the protection against -- asynchronous aborts introduced by Lock_Task (unless abort was already -- deferred before the call to Lock_Task (e.g in a protected procedures). -- -- Note: the recommended protocol for using Lock_Task and Unlock_Task -- is as follows: -- -- Locked_Processing : begin -- System.Soft_Links.Lock_Task.all; -- ... -- System.Soft_Links.Unlock_Task.all; -- -- exception -- when others => -- System.Soft_Links.Unlock_Task.all; -- raise; -- end Locked_Processing; -- -- This ensures that the lock is not left set if an exception is raised -- explicitly or implicitly during the critical locked region. Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access; -- Handle task termination routines (task/non-task case as appropriate) Finalize_Library_Objects : No_Param_Proc; pragma Export (C, Finalize_Library_Objects, "__gnat_finalize_library_objects"); -- Will be initialized by the binder Adafinal : No_Param_Proc := Adafinal_NT'Access; -- Performs the finalization of the Ada Runtime function Get_Jmpbuf_Address_NT return Address; procedure Set_Jmpbuf_Address_NT (Addr : Address); Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access; Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access; function Get_Sec_Stack_Addr_NT return Address; procedure Set_Sec_Stack_Addr_NT (Addr : Address); Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; function Get_Current_Excep_NT return EOA; Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access; function Get_Stack_Info_NT return Stack_Checking.Stack_Access; Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access; -------------------------- -- Master_Id Soft-Links -- -------------------------- -- Soft-Links are used for procedures that manipulate Master_Ids because -- a Master_Id must be generated for access to limited class-wide types, -- whose root may be extended with task components. function Current_Master_NT return Integer; procedure Enter_Master_NT; procedure Complete_Master_NT; Current_Master : Get_Integer_Call := Current_Master_NT'Access; Enter_Master : No_Param_Proc := Enter_Master_NT'Access; Complete_Master : No_Param_Proc := Complete_Master_NT'Access; ---------------------- -- Delay Soft-Links -- ---------------------- -- Soft-Links are used for procedures that manipulate time to avoid -- dragging the tasking run time when using delay statements. Timed_Delay : Timed_Delay_Call; -------------------------- -- Task Name Soft-Links -- -------------------------- function Task_Name_NT return String; Task_Name : Task_Name_Call := Task_Name_NT'Access; ------------------------------------- -- Exception Tracebacks Soft-Links -- ------------------------------------- Library_Exception : EO; -- Library-level finalization routines use this common reference to store -- the first library-level exception which occurs during finalization. Library_Exception_Set : Boolean := False; -- Used in conjunction with Library_Exception, set when an exception has -- been stored. Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call; -- Wrapper to the possible user specified traceback decorator to be -- called during automatic output of exception data. -- The null value of this wrapper correspond sto the null value of the -- current actual decorator. This is ensured first by the null initial -- value of the corresponding variables, and then by Set_Trace_Decorator -- in g-exctra.adb. pragma Atomic (Traceback_Decorator_Wrapper); -- Since concurrent read/write operations may occur on this variable. -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for -- a more detailed description of the potential problems. procedure Save_Library_Occurrence (E : EOA); -- When invoked, this routine saves an exception occurrence into a hidden -- reference. Subsequent calls will have no effect. ------------------------ -- Task Specific Data -- ------------------------ -- Here we define a single type that encapsulates the various task -- specific data. This type is used to store the necessary data into the -- Task_Control_Block or into a global variable in the non tasking case. type TSD is record Pri_Stack_Info : aliased Stack_Checking.Stack_Info; -- Information on stack (Base/Limit/Size) used by System.Stack_Checking. -- If this TSD does not belong to the environment task, the Size field -- must be initialized to the tasks requested stack size before the task -- can do its first stack check. pragma Warnings (Off); -- Needed because we are giving a non-static default to an object in -- a preelaborated unit, which is formally not permitted, but OK here. Jmpbuf_Address : System.Address := System.Null_Address; -- Address of jump buffer used to store the address of the current -- longjmp/setjmp buffer for exception management. These buffers are -- threaded into a stack, and the address here is the top of the stack. -- A null address means that no exception handler is currently active. Sec_Stack_Addr : System.Address := System.Null_Address; pragma Warnings (On); -- Address of currently allocated secondary stack Current_Excep : aliased EO; -- Exception occurrence that contains the information for the current -- exception. Note that any exception in the same task destroys this -- information, so the data in this variable must be copied out before -- another exception can occur. -- -- Also act as a list of the active exceptions in the case of the GCC -- exception mechanism, organized as a stack with the most recent first. end record; procedure Create_TSD (New_TSD : in out TSD); pragma Inline (Create_TSD); -- Called from s-tassta when a new thread is created to perform -- any required initialization of the TSD. procedure Destroy_TSD (Old_TSD : in out TSD); pragma Inline (Destroy_TSD); -- Called from s-tassta just before a thread is destroyed to perform -- any required finalization. function Get_GNAT_Exception return Ada.Exceptions.Exception_Id; pragma Inline (Get_GNAT_Exception); -- This function obtains the Exception_Id from the Exception_Occurrence -- referenced by the Current_Excep field of the task specific data, i.e. -- the call is equivalent to -- Exception_Identity (Get_Current_Exception.all) -- Export the Get/Set routines for the various Task Specific Data (TSD) -- elements as callable subprograms instead of objects of access to -- subprogram types. function Get_Jmpbuf_Address_Soft return Address; procedure Set_Jmpbuf_Address_Soft (Addr : Address); pragma Inline (Get_Jmpbuf_Address_Soft); pragma Inline (Set_Jmpbuf_Address_Soft); function Get_Sec_Stack_Addr_Soft return Address; procedure Set_Sec_Stack_Addr_Soft (Addr : Address); pragma Inline (Get_Sec_Stack_Addr_Soft); pragma Inline (Set_Sec_Stack_Addr_Soft); -- The following is a dummy record designed to mimic Communication_Block as -- defined in s-tpobop.ads: -- type Communication_Block is record -- Self : Task_Id; -- An access type -- Enqueued : Boolean := True; -- Cancelled : Boolean := False; -- end record; -- The record is used in the construction of the predefined dispatching -- primitive _disp_asynchronous_select in order to avoid the import of -- System.Tasking.Protected_Objects.Operations. Note that this package -- is always imported in the presence of interfaces since the dispatch -- table uses entities from here. type Dummy_Communication_Block is record Comp_1 : Address; -- Address and access have the same size Comp_2 : Boolean; Comp_3 : Boolean; end record; end System.Soft_Links;