use System.OS_Primitives;
use System.Task_Info;
- Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
- -- Whether to use an alternate signal stack for stack overflows
-
----------------
-- Local Data --
----------------
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 --
--------------------
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;
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;
-------------------
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);
Alternate_Stack'Address;
end if;
- Enter_Task (Environment_Task);
+ -- 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
