-- --
-- S p e c --
-- --
--- $Revision: 1.15 $
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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 2, or (at your option) any later ver- --
+-- 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- 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 called different depending wether
--- 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 all the time, we use a system of soft links where the links are
--- initialized to non-tasking versions, and then if the tasking is
--- initialized, they are reset to the real tasking versions.
+-- 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;
with Ada.Exceptions;
with System.Stack_Checking;
package System.Soft_Links is
- pragma Elaborate_Body;
+ pragma Preelaborate_05;
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.
+ (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.
+ -- 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);
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);
- -- Suppress checks on all these types, since we know corrresponding
+ 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, 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.
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 abortion (non-tasking case, does nothing)
+ -- Defer task abort (non-tasking case, does nothing)
procedure Abort_Undefer_NT;
- -- Undefer task abortion (non-tasking case, does nothing)
+ -- Undefer task abort (non-tasking case, does nothing)
procedure Abort_Handler_NT;
- -- Handle task abortion (non-tasking case, does nothing). Currently,
- -- only VMS uses this.
+ -- Handle task abort (non-tasking case, does nothing). Currently, only VMS
+ -- uses this.
- procedure Update_Exception_NT
- (X : EO := Current_Target_Exception);
- -- Handle exception setting. This routine is provided for targets
- -- which 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.
+ 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
procedure Task_Unlock_NT;
-- Release lock set by Task_Lock (non-tasking case, does nothing)
- procedure Null_Adafinal;
- -- Shuts down the runtime system (non-tasking no-finalization case,
- -- does nothing)
+ procedure Task_Termination_NT (Excep : EO);
+ -- Handle task termination routines for the environment task (non-tasking
+ -- case, does nothing).
+
+ procedure Null_Finalize_Global_List;
+ -- Finalize global list for controlled objects (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 abortion (task/non-task case as appropriate)
+ -- 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 abortion (task/non-task case as appropriate)
+ -- Undefer task abort (task/non-task case as appropriate)
Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access;
- -- Handle task abortion (task/non-task case as appropriate)
+ -- 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
-- Locked_Processing : begin
-- System.Soft_Links.Lock_Task.all;
-- ...
- -- System.Soft_Links..Unlock_Task.all;
+ -- System.Soft_Links.Unlock_Task.all;
--
-- exception
-- when others =>
- -- System.Soft_Links..Unlock_Task.all;
+ -- 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.
- Adafinal : No_Param_Proc := Null_Adafinal'Access;
- -- Performs the finalization of the Ada Runtime.
+ Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access;
+ -- Handle task termination routines (task/non-task case as appropriate)
+
+ Finalize_Global_List : No_Param_Proc := Null_Finalize_Global_List'Access;
+ -- Performs finalization of global list for controlled objects
+
+ 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_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_Machine_State_Addr_NT return Address;
- procedure Set_Machine_State_Addr_NT (Addr : Address);
-
- Get_Machine_State_Addr : Get_Address_Call
- := Get_Machine_State_Addr_NT'Access;
- Set_Machine_State_Addr : Set_Address_Call
- := Set_Machine_State_Addr_NT'Access;
-
- function Get_Exc_Stack_Addr_NT return Address;
- procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address);
- -- Self_ID is a Task_ID, but in the non-tasking case there is no
- -- Task_ID type available, so make do with Address.
-
+ function Get_Exc_Stack_Addr_NT return Address;
Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access;
- Set_Exc_Stack_Addr : Set_Address_Call2 := Set_Exc_Stack_Addr_NT'Access;
- function Get_Current_Excep_NT return EOA;
+ function Get_Current_Excep_NT return EOA;
Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access;
-- Master_Id Soft-Links --
--------------------------
- -- Soft-Links are used for procedures that manipulate Master_Ids because
+ -- 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.
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 --
-------------------------------------
------------------------
-- 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.
+ -- 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) that is 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.
-
- Jmpbuf_Address : Address := 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 : Address := Null_Address;
+ -- 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
- Exc_Stack_Addr : Address := Null_Address;
- -- Address of a task-specific stack used for the propagation of
- -- exceptions in response to synchronous faults. This alternate
- -- stack is necessary when propagating Storage_Error resulting
- -- from a stack overflow, as the task's primary stack is full.
- -- This is currently only used on the SGI, and this value stays
- -- null on other platforms.
-
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.
-
- Machine_State_Addr : Address := Null_Address;
+ -- 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);
procedure Destroy_TSD (Old_TSD : in out TSD);
pragma Inline (Destroy_TSD);
- -- Called from s-tassta just before a thread is destroyed to perform
+ -- 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_Sec_Stack_Addr_Soft);
pragma Inline (Set_Sec_Stack_Addr_Soft);
- function Get_Exc_Stack_Addr_Soft return Address;
- procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address);
- pragma Inline (Get_Exc_Stack_Addr_Soft);
- pragma Inline (Set_Exc_Stack_Addr_Soft);
+ function Get_Exc_Stack_Addr_Soft return Address;
+
+ -- 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;
- function Get_Machine_State_Addr_Soft return Address;
- procedure Set_Machine_State_Addr_Soft (Addr : Address);
- pragma Inline (Get_Machine_State_Addr_Soft);
- pragma Inline (Set_Machine_State_Addr_Soft);
+ -- 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;
OSDN Git Service
