blob: 539325f703ac31add95f1050415f076e9cd8a3f1 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2022, 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 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. --
-- --
-- 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 Ada.Unchecked_Conversion;
with Ada.Task_Identification;
with System.Task_Primitives.Operations;
with System.Tasking.Utilities;
with System.Tasking.Initialization;
with System.Tasking.Debug;
with System.OS_Primitives;
with System.Interrupt_Management.Operations;
package body System.Tasking.Async_Delays is
package STPO renames System.Task_Primitives.Operations;
package ST renames System.Tasking;
package STU renames System.Tasking.Utilities;
package STI renames System.Tasking.Initialization;
package OSP renames System.OS_Primitives;
function To_System is new Ada.Unchecked_Conversion
(Ada.Task_Identification.Task_Id, Task_Id);
Timer_Attention : Boolean := False;
pragma Atomic (Timer_Attention);
task Timer_Server is
pragma Interrupt_Priority (System.Any_Priority'Last);
end Timer_Server;
Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity);
-- The timer queue is a circular doubly linked list, ordered by absolute
-- wakeup time. The first item in the queue is Timer_Queue.Succ.
-- It is given a Resume_Time that is larger than any legitimate wakeup
-- time, so that the ordered insertion will always stop searching when it
-- gets back to the queue header block.
Timer_Queue : aliased Delay_Block;
package Init_Timer_Queue is end Init_Timer_Queue;
pragma Unreferenced (Init_Timer_Queue);
-- Initialize the Timer_Queue. This is a package to work around the
-- fact that statements are syntactically illegal here. We want this
-- initialization to happen before the Timer_Server is activated. A
-- build-in-place function would also work, but that's not supported
-- on all platforms (e.g. cil).
package body Init_Timer_Queue is
begin
Timer_Queue.Succ := Timer_Queue'Unchecked_Access;
Timer_Queue.Pred := Timer_Queue'Unchecked_Access;
Timer_Queue.Resume_Time := Duration'Last;
end Init_Timer_Queue;
------------------------
-- Cancel_Async_Delay --
------------------------
-- This should (only) be called from the compiler-generated cleanup routine
-- for an async. select statement with delay statement as trigger. The
-- effect should be to remove the delay from the timer queue, and exit one
-- ATC nesting level.
-- The usage and logic are similar to Cancel_Protected_Entry_Call, but
-- simplified because this is not a true entry call.
procedure Cancel_Async_Delay (D : Delay_Block_Access) is
Dpred : Delay_Block_Access;
Dsucc : Delay_Block_Access;
begin
-- A delay block level of Level_No_Pending_Abort indicates the delay
-- has been canceled. If the delay has already been canceled, there is
-- nothing more to be done.
if D.Level = Level_No_Pending_Abort then
return;
end if;
D.Level := Level_No_Pending_Abort;
-- Remove self from timer queue
STI.Defer_Abort_Nestable (D.Self_Id);
STPO.Write_Lock (Timer_Server_ID);
Dpred := D.Pred;
Dsucc := D.Succ;
Dpred.Succ := Dsucc;
Dsucc.Pred := Dpred;
D.Succ := D;
D.Pred := D;
STPO.Unlock (Timer_Server_ID);
-- Note that the above deletion code is required to be
-- idempotent, since the block may have been dequeued
-- previously by the Timer_Server.
-- leave the asynchronous select
STPO.Write_Lock (D.Self_Id);
STU.Exit_One_ATC_Level (D.Self_Id);
STPO.Unlock (D.Self_Id);
STI.Undefer_Abort_Nestable (D.Self_Id);
end Cancel_Async_Delay;
----------------------
-- Enqueue_Duration --
----------------------
function Enqueue_Duration
(T : Duration;
D : Delay_Block_Access) return Boolean
is
begin
if T <= 0.0 then
D.Timed_Out := True;
STPO.Yield;
return False;
else
-- The corresponding call to Undefer_Abort is performed by the
-- expanded code (see exp_ch9).
STI.Defer_Abort (STPO.Self);
Time_Enqueue
(STPO.Monotonic_Clock
+ Duration'Min (T, OSP.Max_Sensible_Delay), D);
return True;
end if;
end Enqueue_Duration;
------------------
-- Time_Enqueue --
------------------
-- Allocate a queue element for the wakeup time T and put it in the
-- queue in wakeup time order. Assume we are on an asynchronous
-- select statement with delay trigger. Put the calling task to
-- sleep until either the delay expires or is canceled.
-- We use one entry call record for this delay, since we have
-- to increment the ATC nesting level, but since it is not a
-- real entry call we do not need to use any of the fields of
-- the call record. The following code implements a subset of
-- the actions for the asynchronous case of Protected_Entry_Call,
-- much simplified since we know this never blocks, and does not
-- have the full semantics of a protected entry call.
procedure Time_Enqueue
(T : Duration;
D : Delay_Block_Access)
is
Self_Id : constant Task_Id := STPO.Self;
Q : Delay_Block_Access;
begin
pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
pragma Assert (Self_Id.Deferral_Level = 1,
"async delay from within abort-deferred region");
if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
raise Storage_Error with "not enough ATC nesting levels";
end if;
Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
pragma Debug
(Debug.Trace (Self_Id, "ASD: entered ATC level: " &
ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
D.Level := Self_Id.ATC_Nesting_Level;
D.Self_Id := Self_Id;
D.Resume_Time := T;
STPO.Write_Lock (Timer_Server_ID);
-- Previously, there was code here to dynamically create
-- the Timer_Server task, if one did not already exist.
-- That code had a timing window that could allow multiple
-- timer servers to be created. Luckily, the need for
-- postponing creation of the timer server should now be
-- gone, since this package will only be linked in if
-- there are calls to enqueue calls on the timer server.
-- Insert D in the timer queue, at the position determined
-- by the wakeup time T.
Q := Timer_Queue.Succ;
while Q.Resume_Time < T loop
Q := Q.Succ;
end loop;
-- Q is the block that has Resume_Time equal to or greater than
-- T. After the insertion we want Q to be the successor of D.
D.Succ := Q;
D.Pred := Q.Pred;
D.Pred.Succ := D;
Q.Pred := D;
-- If the new element became the head of the queue,
-- signal the Timer_Server to wake up.
if Timer_Queue.Succ = D then
Timer_Attention := True;
STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);
end if;
STPO.Unlock (Timer_Server_ID);
end Time_Enqueue;
---------------
-- Timed_Out --
---------------
function Timed_Out (D : Delay_Block_Access) return Boolean is
begin
return D.Timed_Out;
end Timed_Out;
------------------
-- Timer_Server --
------------------
task body Timer_Server is
Ignore : constant Boolean := STU.Make_Independent;
-- Local Declarations
Next_Wakeup_Time : Duration := Duration'Last;
Timedout : Boolean;
Yielded : Boolean;
Now : Duration;
Dequeued : Delay_Block_Access;
Dequeued_Task : Task_Id;
begin
pragma Assert (Timer_Server_ID = STPO.Self);
-- Since this package may be elaborated before System.Interrupt,
-- we need to call Setup_Interrupt_Mask explicitly to ensure that
-- this task has the proper signal mask.
Interrupt_Management.Operations.Setup_Interrupt_Mask;
-- Initialize the timer queue to empty, and make the wakeup time of the
-- header node be larger than any real wakeup time we will ever use.
loop
STI.Defer_Abort (Timer_Server_ID);
STPO.Write_Lock (Timer_Server_ID);
-- The timer server needs to catch pending aborts after finalization
-- of library packages. If it doesn't poll for it, the server will
-- sometimes hang.
if not Timer_Attention then
Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
if Next_Wakeup_Time = Duration'Last then
Timer_Server_ID.User_State := 1;
Next_Wakeup_Time :=
STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
else
Timer_Server_ID.User_State := 2;
end if;
STPO.Timed_Sleep
(Timer_Server_ID, Next_Wakeup_Time,
OSP.Absolute_RT, ST.Timer_Server_Sleep,
Timedout, Yielded);
Timer_Server_ID.Common.State := ST.Runnable;
end if;
-- Service all of the wakeup requests on the queue whose times have
-- been reached, and update Next_Wakeup_Time to next wakeup time
-- after that (the wakeup time of the head of the queue if any, else
-- a time far in the future).
Timer_Server_ID.User_State := 3;
Timer_Attention := False;
Now := STPO.Monotonic_Clock;
while Timer_Queue.Succ.Resume_Time <= Now loop
-- Dequeue the waiting task from the front of the queue
pragma Debug (System.Tasking.Debug.Trace
(Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
Dequeued := Timer_Queue.Succ;
Timer_Queue.Succ := Dequeued.Succ;
Dequeued.Succ.Pred := Dequeued.Pred;
Dequeued.Succ := Dequeued;
Dequeued.Pred := Dequeued;
-- We want to abort the queued task to the level of the async.
-- select statement with the delay. To do that, we need to lock
-- the ATCB of that task, but to avoid deadlock we need to release
-- the lock of the Timer_Server. This leaves a window in which
-- another task might perform an enqueue or dequeue operation on
-- the timer queue, but that is OK because we always restart the
-- next iteration at the head of the queue.
STPO.Unlock (Timer_Server_ID);
STPO.Write_Lock (Dequeued.Self_Id);
Dequeued_Task := Dequeued.Self_Id;
Dequeued.Timed_Out := True;
STI.Locked_Abort_To_Level
(Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
STPO.Unlock (Dequeued_Task);
STPO.Write_Lock (Timer_Server_ID);
end loop;
Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
-- Service returns the Next_Wakeup_Time.
-- The Next_Wakeup_Time is either an infinity (no delay request)
-- or the wakeup time of the queue head. This value is used for
-- an actual delay in this server.
STPO.Unlock (Timer_Server_ID);
STI.Undefer_Abort (Timer_Server_ID);
end loop;
end Timer_Server;
end System.Tasking.Async_Delays;