-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- 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 GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, 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/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- This is a DEC Unix 4.0d version of this package
+-- This is a Tru64 version of this package
--- This package contains all the GNULL primitives that interface directly
--- with the underlying OS.
+-- This package contains all the GNULL primitives that interface directly with
+-- the underlying OS.
pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+-- Turn off polling, we do not want ATC polling to take place during tasking
+-- operations. It causes infinite loops and other problems.
-with System.Tasking.Debug;
--- used for Known_Tasks
+with Interfaces;
+with Interfaces.C;
+with System.Tasking.Debug;
with System.Interrupt_Management;
--- used for Keep_Unmasked
--- Abort_Task_Interrupt
--- Interrupt_ID
-
+with System.OS_Constants;
with System.OS_Primitives;
--- used for Delay_Modes
-
with System.Task_Info;
--- used for Task_Info_Type
-
-with Interfaces;
--- used for Shift_Left
-
-with Interfaces.C;
--- used for int
--- size_t
with System.Soft_Links;
--- used for Abort_Defer/Undefer
-
-- We use System.Soft_Links instead of System.Tasking.Initialization
-- because the later is a higher level package that we shouldn't depend on.
-- For example when using the restricted run time, it is replaced by
-- System.Tasking.Restricted.Stages.
-with Ada.Unchecked_Deallocation;
-
package body System.Task_Primitives.Operations is
+ package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
use System.Tasking.Debug;
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_Id associated with a thread
-
Environment_Task_Id : Task_Id;
-- A variable to hold Task_Id for the environment task
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads)
+ Abort_Handler_Installed : Boolean := False;
+ -- True if a handler for the abort signal is installed
+
--------------------
-- Local Packages --
--------------------
package body Specific is separate;
-- The body of this package is target specific
+ ----------------------------------
+ -- ATCB allocation/deallocation --
+ ----------------------------------
+
+ package body ATCB_Allocation is separate;
+ -- The body of this package is shared across several targets
+
---------------------------------
-- Support for foreign threads --
---------------------------------
pragma Unreferenced (Sig);
T : constant Task_Id := Self;
- Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+ pragma Warnings (Off, Result);
+
begin
- -- It is not safe to raise an exception when using ZCX and the GCC
- -- exception handling mechanism.
+ -- It's not safe to raise an exception when using GCC ZCX mechanism.
+ -- Note that we still need to install a signal handler, since in some
+ -- cases (e.g. shutdown of the Server_Task in System.Interrupts) we
+ -- need to send the Abort signal to a task.
- if ZCX_By_Default and then GCC_ZCX_Support then
+ if ZCX_By_Default then
return;
end if;
Result :=
pthread_sigmask
(SIG_UNBLOCK,
- Unblocked_Signal_Mask'Unchecked_Access,
- Old_Set'Unchecked_Access);
+ Unblocked_Signal_Mask'Access,
+ Old_Set'Access);
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
-- Note: mutexes and cond_variables needed per-task basis are initialized
-- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
-- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
- -- status change of RTS. Therefore rasing Storage_Error in the following
+ -- status change of RTS. Therefore raising Storage_Error in the following
-- routines should be able to be handled safely.
procedure Initialize_Lock
Result : Interfaces.C.int;
begin
- if Single_Lock then
- Result :=
- pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
- else
- Result :=
- pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
- end if;
+ Result :=
+ pthread_cond_wait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access));
-- EINTR is not considered a failure
Timedout := True;
Yielded := False;
- if Mode = Relative then
- Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
- else
- Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
- end if;
+ Abs_Time :=
+ (if Mode = Relative
+ then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
if Abs_Time > Check_Time then
Request := To_Timespec (Abs_Time);
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- if Single_Lock then
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Request'Access);
-
- else
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Request'Access);
- end if;
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
Write_Lock (Self_ID);
- if Mode = Relative then
- Abs_Time := Time + Check_Time;
- else
- Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
- end if;
+ Abs_Time :=
+ (if Mode = Relative
+ then Time + Check_Time
+ else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
if Abs_Time > Check_Time then
Request := To_Timespec (Abs_Time);
loop
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- if Single_Lock then
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access,
- Request'Access);
- else
- Result :=
- pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access,
- Self_ID.Common.LL.L'Access,
- Request'Access);
- end if;
+ Result :=
+ pthread_cond_timedwait
+ (cond => Self_ID.Common.LL.CV'Access,
+ mutex => (if Single_Lock
+ then Single_RTS_Lock'Access
+ else Self_ID.Common.LL.L'Access),
+ abstime => Request'Access);
Check_Time := Monotonic_Clock;
exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
TS : aliased timespec;
Result : Interfaces.C.int;
begin
- Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
procedure Enter_Task (Self_ID : Task_Id) is
begin
- Hide_Yellow_Zone;
+ Hide_Unhide_Yellow_Zone (Hide => True);
Self_ID.Common.LL.Thread := pthread_self;
- Specific.Set (Self_ID);
-
- Lock_RTS;
-
- for J in Known_Tasks'Range loop
- if Known_Tasks (J) = null then
- Known_Tasks (J) := Self_ID;
- Self_ID.Known_Tasks_Index := J;
- exit;
- end if;
- end loop;
- Unlock_RTS;
+ Specific.Set (Self_ID);
end Enter_Task;
- --------------
- -- New_ATCB --
- --------------
-
- function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
- begin
- return new Ada_Task_Control_Block (Entry_Num);
- end New_ATCB;
-
-------------------
-- Is_Valid_Task --
-------------------
use System.Task_Info;
begin
- -- Account for the Yellow Zone (2 pages) and the guard page
- -- right above. See Hide_Yellow_Zone for the rationale.
+ -- Account for the Yellow Zone (2 pages) and the guard page right above.
+ -- See Hide_Unhide_Yellow_Zone for the rationale.
Adjusted_Stack_Size :=
Interfaces.C.size_t (Stack_Size) + 3 * Get_Page_Size;
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
+ -- Note: the use of Unrestricted_Access in the following call is needed
+ -- because otherwise we have an error of getting a access-to-volatile
+ -- value which points to a non-volatile object. But in this case it is
+ -- safe to do this, since we know we have no problems with aliasing and
+ -- Unrestricted_Access bypasses this check.
+
Result :=
pthread_create
- (T.Common.LL.Thread'Access,
+ (T.Common.LL.Thread'Unrestricted_Access,
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
Result := pthread_attr_destroy (Attributes'Access);
pragma Assert (Result = 0);
- if T.Common.Task_Info /= null then
+ if Succeeded and then T.Common.Task_Info /= null then
-- ??? We're using a process-wide function to implement a task
-- specific characteristic.
------------------
procedure Finalize_TCB (T : Task_Id) is
- Result : Interfaces.C.int;
- Tmp : Task_Id := T;
- Is_Self : constant Boolean := T = Self;
-
- procedure Free is new
- Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ Result : Interfaces.C.int;
begin
if not Single_Lock then
Known_Tasks (T.Known_Tasks_Index) := null;
end if;
- Free (Tmp);
-
- if Is_Self then
- Specific.Set (null);
- end if;
+ ATCB_Allocation.Free_ATCB (T);
end Finalize_TCB;
---------------
procedure Exit_Task is
begin
Specific.Set (null);
+ Hide_Unhide_Yellow_Zone (Hide => False);
end Exit_Task;
----------------
procedure Abort_Task (T : Task_Id) is
Result : Interfaces.C.int;
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
- pragma Assert (Result = 0);
+ if Abort_Handler_Installed then
+ Result := pthread_kill (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end if;
end Abort_Task;
----------------
S.State := False;
else
S.Waiting := True;
- Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+
+ loop
+ -- Loop in case pthread_cond_wait returns earlier than expected
+ -- (e.g. in case of EINTR caused by a signal).
+
+ Result := pthread_cond_wait (S.CV'Access, S.L'Access);
+ pragma Assert (Result = 0 or else Result = EINTR);
+
+ exit when not S.Waiting;
+ end loop;
end if;
Result := pthread_mutex_unlock (S.L'Access);
Specific.Initialize (Environment_Task);
- Enter_Task (Environment_Task);
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
+
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
- -- Install the abort-signal handler
+ Enter_Task (Environment_Task);
if State
(System.Interrupt_Management.Abort_Task_Interrupt) /= Default
act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
+ Abort_Handler_Installed := True;
end if;
end Initialize;
+ -----------------------
+ -- Set_Task_Affinity --
+ -----------------------
+
+ procedure Set_Task_Affinity (T : ST.Task_Id) is
+ pragma Unreferenced (T);
+
+ begin
+ -- Setting task affinity is not supported by the underlying system
+
+ null;
+ end Set_Task_Affinity;
end System.Task_Primitives.Operations;
OSDN Git Service
