-- --
-- B o d y --
-- --
--- Copyright (C) 2004, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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, 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. --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
------------------------------------------------------------------------------
pragma Style_Checks (All_Checks);
--- Turn off subprogram alpha ordering check, since we group soft link
--- bodies and dummy soft link bodies together separately in this unit.
+-- Turn off subprogram alpha ordering check, since we group soft link bodies
+-- and dummy soft link bodies together separately in this unit.
pragma Polling (Off);
--- Turn polling off for this package. We don't need polling during any
--- of the routines in this package, and more to the point, if we try
--- to poll it can cause infinite loops.
+-- Turn polling off for this package. We don't need polling during any of the
+-- routines in this package, and more to the point, if we try to poll it can
+-- cause infinite loops.
+
+with Ada.Exceptions;
+with Ada.Exceptions.Is_Null_Occurrence;
with System.Task_Primitives.Operations;
--- Used for Self
--- Timed_Delay
+with System.Tasking;
+with System.Stack_Checking;
package body System.Soft_Links.Tasking is
package STPO renames System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
+ use Ada.Exceptions;
+
+ use type System.Tasking.Task_Id;
+ use type System.Tasking.Termination_Handler;
+
----------------
-- Local Data --
----------------
procedure Set_Sec_Stack_Addr (Addr : Address);
-- Get/Set location of current task's secondary stack
- function Get_Machine_State_Addr return Address;
- procedure Set_Machine_State_Addr (Addr : Address);
- -- Get/Set the address for storing the current task's machine state
-
- function Get_Current_Excep return SSL.EOA;
- -- Task-safe version of SSL.Get_Current_Excep
-
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
-- Task-safe version of SSL.Timed_Delay
- ----------------------
- -- Soft-Link Bodies --
- ----------------------
+ procedure Task_Termination_Handler_T (Excep : SSL.EO);
+ -- Task-safe version of the task termination procedure
- function Get_Current_Excep return SSL.EOA is
- begin
- return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
- end Get_Current_Excep;
+ function Get_Stack_Info return Stack_Checking.Stack_Access;
+ -- Get access to the current task's Stack_Info
+
+ --------------------------
+ -- Soft-Link Get Bodies --
+ --------------------------
function Get_Jmpbuf_Address return Address is
begin
return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
end Get_Jmpbuf_Address;
- function Get_Machine_State_Addr return Address is
- begin
- return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
- end Get_Machine_State_Addr;
-
function Get_Sec_Stack_Addr return Address is
begin
return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
end Get_Sec_Stack_Addr;
+ function Get_Stack_Info return Stack_Checking.Stack_Access is
+ begin
+ return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
+ end Get_Stack_Info;
+
+ --------------------------
+ -- Soft-Link Set Bodies --
+ --------------------------
+
procedure Set_Jmpbuf_Address (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
end Set_Jmpbuf_Address;
- procedure Set_Machine_State_Addr (Addr : Address) is
- begin
- STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
- end Set_Machine_State_Addr;
-
procedure Set_Sec_Stack_Addr (Addr : Address) is
begin
STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
+ -------------------
+ -- Timed_Delay_T --
+ -------------------
+
procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
+ Self_Id : constant System.Tasking.Task_Id := STPO.Self;
+
begin
- STPO.Timed_Delay (STPO.Self, Time, Mode);
+ -- In case pragma Detect_Blocking is active then Program_Error
+ -- must be raised if this potentially blocking operation
+ -- is called from a protected operation.
+
+ if System.Tasking.Detect_Blocking
+ and then Self_Id.Common.Protected_Action_Nesting > 0
+ then
+ raise Program_Error with "potentially blocking operation";
+ else
+ Abort_Defer.all;
+ STPO.Timed_Delay (Self_Id, Time, Mode);
+ Abort_Undefer.all;
+ end if;
end Timed_Delay_T;
+ --------------------------------
+ -- Task_Termination_Handler_T --
+ --------------------------------
+
+ procedure Task_Termination_Handler_T (Excep : SSL.EO) is
+ Self_Id : constant System.Tasking.Task_Id := STPO.Self;
+ Cause : System.Tasking.Cause_Of_Termination;
+ EO : Ada.Exceptions.Exception_Occurrence;
+
+ begin
+ -- We can only be here because we are terminating the environment task.
+ -- Task termination for the rest of the tasks is handled in the
+ -- Task_Wrapper.
+
+ pragma Assert (Self_Id = STPO.Environment_Task);
+
+ -- Normal task termination
+
+ if Is_Null_Occurrence (Excep) then
+ Cause := System.Tasking.Normal;
+ Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
+
+ -- Abnormal task termination
+
+ elsif Exception_Identity (Excep) = Standard'Abort_Signal'Identity then
+ Cause := System.Tasking.Abnormal;
+ Ada.Exceptions.Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
+
+ -- Termination because of an unhandled exception
+
+ else
+ Cause := System.Tasking.Unhandled_Exception;
+ Ada.Exceptions.Save_Occurrence (EO, Excep);
+ end if;
+
+ -- There is no need for explicit protection against race conditions
+ -- for this part because it can only be executed by the environment
+ -- task after all the other tasks have been finalized.
+
+ if Self_Id.Common.Specific_Handler /= null then
+ Self_Id.Common.Specific_Handler.all (Cause, Self_Id, EO);
+ elsif Self_Id.Common.Fall_Back_Handler /= null then
+ Self_Id.Common.Fall_Back_Handler.all (Cause, Self_Id, EO);
+ end if;
+ end Task_Termination_Handler_T;
+
-----------------------------
-- Init_Tasking_Soft_Links --
-----------------------------
-- The application being executed uses tasking so that the tasking
-- version of the following soft links need to be used.
- SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
- SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
- SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
- SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
- SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access;
- SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access;
- SSL.Get_Current_Excep := Get_Current_Excep'Access;
- SSL.Timed_Delay := Timed_Delay_T'Access;
+ SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access;
+ SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access;
+ SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
+ SSL.Get_Stack_Info := Get_Stack_Info'Access;
+ SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
+ SSL.Timed_Delay := Timed_Delay_T'Access;
+ SSL.Task_Termination_Handler := Task_Termination_Handler_T'Access;
-- No need to create a new Secondary Stack, since we will use the
-- default one created in s-secsta.adb
SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT);
SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
- SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
end if;
end Init_Tasking_Soft_Links;
OSDN Git Service
