1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
5--           S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S          --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--         Copyright (C) 1998-2020, Free Software Foundation, Inc.          --
10--                                                                          --
11-- GNARL is free software; you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNARL was developed by the GNARL team at Florida State University.       --
28-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with Ada.Unchecked_Conversion;
33with Ada.Task_Identification;
34
35with System.Task_Primitives.Operations;
36with System.Tasking.Utilities;
37with System.Tasking.Initialization;
38with System.Tasking.Debug;
39with System.OS_Primitives;
40with System.Interrupt_Management.Operations;
41
42package body System.Tasking.Async_Delays is
43
44   package STPO renames System.Task_Primitives.Operations;
45   package ST renames System.Tasking;
46   package STU renames System.Tasking.Utilities;
47   package STI renames System.Tasking.Initialization;
48   package OSP renames System.OS_Primitives;
49
50   function To_System is new Ada.Unchecked_Conversion
51     (Ada.Task_Identification.Task_Id, Task_Id);
52
53   Timer_Attention : Boolean := False;
54   pragma Atomic (Timer_Attention);
55
56   task Timer_Server is
57      pragma Interrupt_Priority (System.Any_Priority'Last);
58   end Timer_Server;
59
60   Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity);
61
62   --  The timer queue is a circular doubly linked list, ordered by absolute
63   --  wakeup time. The first item in the queue is Timer_Queue.Succ.
64   --  It is given a Resume_Time that is larger than any legitimate wakeup
65   --  time, so that the ordered insertion will always stop searching when it
66   --  gets back to the queue header block.
67
68   Timer_Queue : aliased Delay_Block;
69
70   package Init_Timer_Queue is end Init_Timer_Queue;
71   pragma Unreferenced (Init_Timer_Queue);
72   --  Initialize the Timer_Queue. This is a package to work around the
73   --  fact that statements are syntactically illegal here. We want this
74   --  initialization to happen before the Timer_Server is activated. A
75   --  build-in-place function would also work, but that's not supported
76   --  on all platforms (e.g. cil).
77
78   package body Init_Timer_Queue is
79   begin
80      Timer_Queue.Succ := Timer_Queue'Unchecked_Access;
81      Timer_Queue.Pred := Timer_Queue'Unchecked_Access;
82      Timer_Queue.Resume_Time := Duration'Last;
83   end Init_Timer_Queue;
84
85   ------------------------
86   -- Cancel_Async_Delay --
87   ------------------------
88
89   --  This should (only) be called from the compiler-generated cleanup routine
90   --  for an async. select statement with delay statement as trigger. The
91   --  effect should be to remove the delay from the timer queue, and exit one
92   --  ATC nesting level.
93
94   --  The usage and logic are similar to Cancel_Protected_Entry_Call, but
95   --  simplified because this is not a true entry call.
96
97   procedure Cancel_Async_Delay (D : Delay_Block_Access) is
98      Dpred : Delay_Block_Access;
99      Dsucc : Delay_Block_Access;
100
101   begin
102      --  A delay block level of Level_No_Pending_Abort indicates the delay
103      --  has been canceled. If the delay has already been canceled, there is
104      --  nothing more to be done.
105
106      if D.Level = Level_No_Pending_Abort then
107         return;
108      end if;
109
110      D.Level := Level_No_Pending_Abort;
111
112      --  Remove self from timer queue
113
114      STI.Defer_Abort_Nestable (D.Self_Id);
115      STPO.Write_Lock (Timer_Server_ID);
116      Dpred := D.Pred;
117      Dsucc := D.Succ;
118      Dpred.Succ := Dsucc;
119      Dsucc.Pred := Dpred;
120      D.Succ := D;
121      D.Pred := D;
122      STPO.Unlock (Timer_Server_ID);
123
124      --  Note that the above deletion code is required to be
125      --  idempotent, since the block may have been dequeued
126      --  previously by the Timer_Server.
127
128      --  leave the asynchronous select
129
130      STPO.Write_Lock (D.Self_Id);
131      STU.Exit_One_ATC_Level (D.Self_Id);
132      STPO.Unlock (D.Self_Id);
133      STI.Undefer_Abort_Nestable (D.Self_Id);
134   end Cancel_Async_Delay;
135
136   ----------------------
137   -- Enqueue_Duration --
138   ----------------------
139
140   function Enqueue_Duration
141     (T : Duration;
142      D : Delay_Block_Access) return Boolean
143   is
144   begin
145      if T <= 0.0 then
146         D.Timed_Out := True;
147         STPO.Yield;
148         return False;
149
150      else
151         --  The corresponding call to Undefer_Abort is performed by the
152         --  expanded code (see exp_ch9).
153
154         STI.Defer_Abort (STPO.Self);
155         Time_Enqueue
156           (STPO.Monotonic_Clock
157            + Duration'Min (T, OSP.Max_Sensible_Delay), D);
158         return True;
159      end if;
160   end Enqueue_Duration;
161
162   ------------------
163   -- Time_Enqueue --
164   ------------------
165
166   --  Allocate a queue element for the wakeup time T and put it in the
167   --  queue in wakeup time order.  Assume we are on an asynchronous
168   --  select statement with delay trigger. Put the calling task to
169   --  sleep until either the delay expires or is canceled.
170
171   --  We use one entry call record for this delay, since we have
172   --  to increment the ATC nesting level, but since it is not a
173   --  real entry call we do not need to use any of the fields of
174   --  the call record.  The following code implements a subset of
175   --  the actions for the asynchronous case of Protected_Entry_Call,
176   --  much simplified since we know this never blocks, and does not
177   --  have the full semantics of a protected entry call.
178
179   procedure Time_Enqueue
180     (T : Duration;
181      D : Delay_Block_Access)
182   is
183      Self_Id : constant Task_Id  := STPO.Self;
184      Q       : Delay_Block_Access;
185
186   begin
187      pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
188      pragma Assert (Self_Id.Deferral_Level = 1,
189        "async delay from within abort-deferred region");
190
191      if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
192         raise Storage_Error with "not enough ATC nesting levels";
193      end if;
194
195      Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
196
197      pragma Debug
198        (Debug.Trace (Self_Id, "ASD: entered ATC level: " &
199         ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
200
201      D.Level := Self_Id.ATC_Nesting_Level;
202      D.Self_Id := Self_Id;
203      D.Resume_Time := T;
204      STPO.Write_Lock (Timer_Server_ID);
205
206      --  Previously, there was code here to dynamically create
207      --  the Timer_Server task, if one did not already exist.
208      --  That code had a timing window that could allow multiple
209      --  timer servers to be created. Luckily, the need for
210      --  postponing creation of the timer server should now be
211      --  gone, since this package will only be linked in if
212      --  there are calls to enqueue calls on the timer server.
213
214      --  Insert D in the timer queue, at the position determined
215      --  by the wakeup time T.
216
217      Q := Timer_Queue.Succ;
218
219      while Q.Resume_Time < T loop
220         Q := Q.Succ;
221      end loop;
222
223      --  Q is the block that has Resume_Time equal to or greater than
224      --  T. After the insertion we want Q to be the successor of D.
225
226      D.Succ := Q;
227      D.Pred := Q.Pred;
228      D.Pred.Succ := D;
229      Q.Pred := D;
230
231      --  If the new element became the head of the queue,
232      --  signal the Timer_Server to wake up.
233
234      if Timer_Queue.Succ = D then
235         Timer_Attention := True;
236         STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);
237      end if;
238
239      STPO.Unlock (Timer_Server_ID);
240   end Time_Enqueue;
241
242   ---------------
243   -- Timed_Out --
244   ---------------
245
246   function Timed_Out (D : Delay_Block_Access) return Boolean is
247   begin
248      return D.Timed_Out;
249   end Timed_Out;
250
251   ------------------
252   -- Timer_Server --
253   ------------------
254
255   task body Timer_Server is
256      Ignore : constant Boolean := STU.Make_Independent;
257
258      --  Local Declarations
259
260      Next_Wakeup_Time : Duration := Duration'Last;
261      Timedout         : Boolean;
262      Yielded          : Boolean;
263      Now              : Duration;
264      Dequeued         : Delay_Block_Access;
265      Dequeued_Task    : Task_Id;
266
267      pragma Unreferenced (Timedout, Yielded);
268
269   begin
270      pragma Assert (Timer_Server_ID = STPO.Self);
271
272      --  Since this package may be elaborated before System.Interrupt,
273      --  we need to call Setup_Interrupt_Mask explicitly to ensure that
274      --  this task has the proper signal mask.
275
276      Interrupt_Management.Operations.Setup_Interrupt_Mask;
277
278      --  Initialize the timer queue to empty, and make the wakeup time of the
279      --  header node be larger than any real wakeup time we will ever use.
280
281      loop
282         STI.Defer_Abort (Timer_Server_ID);
283         STPO.Write_Lock (Timer_Server_ID);
284
285         --  The timer server needs to catch pending aborts after finalization
286         --  of library packages. If it doesn't poll for it, the server will
287         --  sometimes hang.
288
289         if not Timer_Attention then
290            Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
291
292            if Next_Wakeup_Time = Duration'Last then
293               Timer_Server_ID.User_State := 1;
294               Next_Wakeup_Time :=
295                 STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
296
297            else
298               Timer_Server_ID.User_State := 2;
299            end if;
300
301            STPO.Timed_Sleep
302              (Timer_Server_ID, Next_Wakeup_Time,
303               OSP.Absolute_RT, ST.Timer_Server_Sleep,
304               Timedout, Yielded);
305            Timer_Server_ID.Common.State := ST.Runnable;
306         end if;
307
308         --  Service all of the wakeup requests on the queue whose times have
309         --  been reached, and update Next_Wakeup_Time to next wakeup time
310         --  after that (the wakeup time of the head of the queue if any, else
311         --  a time far in the future).
312
313         Timer_Server_ID.User_State := 3;
314         Timer_Attention := False;
315
316         Now := STPO.Monotonic_Clock;
317         while Timer_Queue.Succ.Resume_Time <= Now loop
318
319            --  Dequeue the waiting task from the front of the queue
320
321            pragma Debug (System.Tasking.Debug.Trace
322              (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
323
324            Dequeued := Timer_Queue.Succ;
325            Timer_Queue.Succ := Dequeued.Succ;
326            Dequeued.Succ.Pred := Dequeued.Pred;
327            Dequeued.Succ := Dequeued;
328            Dequeued.Pred := Dequeued;
329
330            --  We want to abort the queued task to the level of the async.
331            --  select statement with the delay. To do that, we need to lock
332            --  the ATCB of that task, but to avoid deadlock we need to release
333            --  the lock of the Timer_Server. This leaves a window in which
334            --  another task might perform an enqueue or dequeue operation on
335            --  the timer queue, but that is OK because we always restart the
336            --  next iteration at the head of the queue.
337
338            STPO.Unlock (Timer_Server_ID);
339            STPO.Write_Lock (Dequeued.Self_Id);
340            Dequeued_Task := Dequeued.Self_Id;
341            Dequeued.Timed_Out := True;
342            STI.Locked_Abort_To_Level
343              (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
344            STPO.Unlock (Dequeued_Task);
345            STPO.Write_Lock (Timer_Server_ID);
346         end loop;
347
348         Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
349
350         --  Service returns the Next_Wakeup_Time.
351         --  The Next_Wakeup_Time is either an infinity (no delay request)
352         --  or the wakeup time of the queue head. This value is used for
353         --  an actual delay in this server.
354
355         STPO.Unlock (Timer_Server_ID);
356         STI.Undefer_Abort (Timer_Server_ID);
357      end loop;
358   end Timer_Server;
359
360end System.Tasking.Async_Delays;
361