-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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. --
with System.Tasking.Debug;
with System.Interrupt_Management;
with System.OS_Primitives;
-with System.Storage_Elements;
with System.Stack_Checking.Operations;
with System.Soft_Links;
use System.OS_Interface;
use System.Parameters;
use System.OS_Primitives;
- use System.Storage_Elements;
use System.Task_Info;
----------------
Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads)
+ Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
+ -- Whether to use an alternate signal stack for stack overflows
+
+ Abort_Handler_Installed : Boolean := False;
+ -- True if a handler for the abort signal is installed
+
--------------------
-- Local Packages --
--------------------
function To_pthread_t is new Ada.Unchecked_Conversion
(unsigned_long, System.OS_Interface.pthread_t);
- procedure Get_Stack_Attributes
- (T : Task_Id;
- ISP : out System.Address;
- Size : out Storage_Offset);
- -- Fill ISP and Size with the Initial Stack Pointer value and the
- -- thread stack size for task T.
-
-------------------
-- Abort_Handler --
-------------------
Old_Set : aliased sigset_t;
begin
+ -- 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
return;
end if;
-- 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
begin
pragma Assert (Self_ID = Self);
- 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;
---------------------
function Monotonic_Clock return Duration is
- TV : aliased struct_timeval;
- Result : Interfaces.C.int;
+ use Interfaces;
+
+ type timeval is array (1 .. 2) of C.long;
+
+ procedure timeval_to_duration
+ (T : not null access timeval;
+ sec : not null access C.long;
+ usec : not null access C.long);
+ pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
+
+ Micro : constant := 10**6;
+ sec : aliased C.long;
+ usec : aliased C.long;
+ TV : aliased timeval;
+ Result : int;
+
+ function gettimeofday
+ (Tv : access timeval;
+ Tz : System.Address := System.Null_Address) return int;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
begin
Result := gettimeofday (TV'Access, System.Null_Address);
pragma Assert (Result = 0);
- return To_Duration (TV);
+ timeval_to_duration (TV'Access, sec'Access, usec'Access);
+ return Duration (sec) + Duration (usec) / Micro;
end Monotonic_Clock;
-------------------
return T.Common.Current_Priority;
end Get_Priority;
- --------------------------
- -- Get_Stack_Attributes --
- --------------------------
-
- procedure Get_Stack_Attributes
- (T : Task_Id;
- ISP : out System.Address;
- Size : out Storage_Offset)
- is
- function pthread_getattr_np
- (thread : pthread_t;
- attr : System.Address) return Interfaces.C.int;
- pragma Import (C, pthread_getattr_np, "pthread_getattr_np");
-
- function pthread_attr_getstack
- (attr : System.Address;
- base : System.Address;
- size : System.Address) return Interfaces.C.int;
- pragma Import (C, pthread_attr_getstack, "pthread_attr_getstack");
-
- Result : Interfaces.C.int;
-
- Attributes : aliased pthread_attr_t;
- Stack_Base : aliased System.Address;
- Stack_Size : aliased Storage_Offset;
-
- begin
- Result :=
- pthread_getattr_np
- (T.Common.LL.Thread, Attributes'Address);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_attr_getstack
- (Attributes'Address, Stack_Base'Address, Stack_Size'Address);
- pragma Assert (Result = 0);
-
- Result := pthread_attr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
-
- ISP := Stack_Base + Stack_Size;
- Size := Stack_Size;
- end Get_Stack_Attributes;
-
----------------
-- Enter_Task --
----------------
procedure Enter_Task (Self_ID : Task_Id) is
begin
if Self_ID.Common.Task_Info /= null
- and then
- Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
+ and then Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
then
raise Invalid_CPU_Number;
end if;
Self_ID.Common.LL.Thread := pthread_self;
+ Self_ID.Common.LL.LWP := lwp_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;
-
- -- Determine where the task stack starts, how large it is, and let the
- -- stack checking engine know about it.
-
- declare
- Initial_SP : System.Address;
- Stack_Size : Storage_Offset;
- begin
- Get_Stack_Attributes (Self_ID, Initial_SP, Stack_Size);
- System.Stack_Checking.Operations.Notify_Stack_Attributes
- (Initial_SP, Stack_Size);
- end;
+ if Use_Alternate_Stack then
+ declare
+ Stack : aliased stack_t;
+ Result : Interfaces.C.int;
+ begin
+ Stack.ss_sp := Self_ID.Common.Task_Alternate_Stack;
+ Stack.ss_size := Alternate_Stack_Size;
+ Stack.ss_flags := 0;
+ Result := sigaltstack (Stack'Access, null);
+ pragma Assert (Result = 0);
+ end;
+ end if;
end Enter_Task;
--------------
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
- Attributes : aliased pthread_attr_t;
- Result : Interfaces.C.int;
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
begin
+ Adjusted_Stack_Size :=
+ Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
+
Result := pthread_attr_init (Attributes'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
Result :=
pthread_attr_setstacksize
- (Attributes'Access, Interfaces.C.size_t (Stack_Size));
+ (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
Result :=
Attributes'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
- pragma Assert (Result = 0 or else Result = EAGAIN);
+ pragma Assert
+ (Result = 0 or else Result = EAGAIN or else Result = ENOMEM);
if Result /= 0 then
Succeeded := False;
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;
----------------
SSL.Abort_Undefer.all;
raise Program_Error;
+
else
-- Suspend the task if the state is False. Otherwise, the task
-- continues its execution, and the state of the suspension object
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). This should not
+ -- happen with the current Linux implementation of pthread, but
+ -- POSIX does not guarantee it so this may change in future.
+
+ 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);
pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
- end
- if;
+ end if;
end Suspend_Until_True;
----------------
old_act : aliased struct_sigaction;
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
+ -- Whether to use an alternate signal stack for stack overflows
function State
(Int : System.Interrupt_Management.Interrupt_ID) return Character;
Specific.Initialize (Environment_Task);
- Enter_Task (Environment_Task);
+ if Use_Alternate_Stack then
+ Environment_Task.Common.Task_Alternate_Stack :=
+ Alternate_Stack'Address;
+ end if;
+
+ -- Make environment task known here because it doesn't go through
+ -- Activate_Tasks, which does it for all other tasks.
- -- Install the abort-signal handler
+ Known_Tasks (Known_Tasks'First) := Environment_Task;
+ Environment_Task.Known_Tasks_Index := Known_Tasks'First;
+
+ 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;
OSDN Git Service
