gcc/ada/s-taasde.adb

   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-2014, 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
  32 pragma Polling (Off);
  33 --  Turn off polling, we do not want ATC polling to take place during
  34 --  tasking operations. It causes infinite loops and other problems.
  35
  36 with Ada.Unchecked_Conversion;
  37 with Ada.Task_Identification;
  38
  39 with System.Task_Primitives.Operations;
  40 with System.Tasking.Utilities;
  41 with System.Tasking.Initialization;
  42 with System.Tasking.Debug;
  43 with System.OS_Primitives;
  44 with System.Interrupt_Management.Operations;
  45 with System.Parameters;
  46 with System.Traces.Tasking;
  47
  48 package body System.Tasking.Async_Delays is
  49
  50    package STPO renames System.Task_Primitives.Operations;
  51    package ST renames System.Tasking;
  52    package STU renames System.Tasking.Utilities;
  53    package STI renames System.Tasking.Initialization;
  54    package OSP renames System.OS_Primitives;
  55
  56    use Parameters;
  57    use System.Traces;
  58    use System.Traces.Tasking;
  59
  60    function To_System is new Ada.Unchecked_Conversion
  61      (Ada.Task_Identification.Task_Id, Task_Id);
  62
  63    Timer_Attention : Boolean := False;
  64    pragma Atomic (Timer_Attention);
  65
  66    task Timer_Server is
  67       pragma Interrupt_Priority (System.Any_Priority'Last);
  68    end Timer_Server;
  69
  70    Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity);
  71
  72    --  The timer queue is a circular doubly linked list, ordered by absolute
  73    --  wakeup time. The first item in the queue is Timer_Queue.Succ.
  74    --  It is given a Resume_Time that is larger than any legitimate wakeup
  75    --  time, so that the ordered insertion will always stop searching when it
  76    --  gets back to the queue header block.
  77
  78    Timer_Queue : aliased Delay_Block;
  79
  80    package Init_Timer_Queue is end Init_Timer_Queue;
  81    pragma Unreferenced (Init_Timer_Queue);
  82    --  Initialize the Timer_Queue. This is a package to work around the
  83    --  fact that statements are syntactically illegal here. We want this
  84    --  initialization to happen before the Timer_Server is activated. A
  85    --  build-in-place function would also work, but that's not supported
  86    --  on all platforms (e.g. cil).
  87
  88    package body Init_Timer_Queue is
  89    begin
  90       Timer_Queue.Succ := Timer_Queue'Unchecked_Access;
  91       Timer_Queue.Pred := Timer_Queue'Unchecked_Access;
  92       Timer_Queue.Resume_Time := Duration'Last;
  93    end Init_Timer_Queue;
  94
  95    ------------------------
  96    -- Cancel_Async_Delay --
  97    ------------------------
  98
  99    --  This should (only) be called from the compiler-generated cleanup routine
 100    --  for an async. select statement with delay statement as trigger. The
 101    --  effect should be to remove the delay from the timer queue, and exit one
 102    --  ATC nesting level.
 103    --  The usage and logic are similar to Cancel_Protected_Entry_Call, but
 104    --  simplified because this is not a true entry call.
 105
 106    procedure Cancel_Async_Delay (D : Delay_Block_Access) is
 107       Dpred : Delay_Block_Access;
 108       Dsucc : Delay_Block_Access;
 109
 110    begin
 111       --  Note that we mark the delay as being cancelled
 112       --  using a level value that is reserved.
 113
 114       --  make this operation idempotent
 115
 116       if D.Level = ATC_Level_Infinity then
 117          return;
 118       end if;
 119
 120       D.Level := ATC_Level_Infinity;
 121
 122       --  remove self from timer queue
 123
 124       STI.Defer_Abort_Nestable (D.Self_Id);
 125
 126       if Single_Lock then
 127          STPO.Lock_RTS;
 128       end if;
 129
 130       STPO.Write_Lock (Timer_Server_ID);
 131       Dpred := D.Pred;
 132       Dsucc := D.Succ;
 133       Dpred.Succ := Dsucc;
 134       Dsucc.Pred := Dpred;
 135       D.Succ := D;
 136       D.Pred := D;
 137       STPO.Unlock (Timer_Server_ID);
 138
 139       --  Note that the above deletion code is required to be
 140       --  idempotent, since the block may have been dequeued
 141       --  previously by the Timer_Server.
 142
 143       --  leave the asynchronous select
 144
 145       STPO.Write_Lock (D.Self_Id);
 146       STU.Exit_One_ATC_Level (D.Self_Id);
 147       STPO.Unlock (D.Self_Id);
 148
 149       if Single_Lock then
 150          STPO.Unlock_RTS;
 151       end if;
 152
 153       STI.Undefer_Abort_Nestable (D.Self_Id);
 154    end Cancel_Async_Delay;
 155
 156    ----------------------
 157    -- Enqueue_Duration --
 158    ----------------------
 159
 160    function Enqueue_Duration
 161      (T : Duration;
 162       D : Delay_Block_Access) return Boolean
 163    is
 164    begin
 165       if T <= 0.0 then
 166          D.Timed_Out := True;
 167          STPO.Yield;
 168          return False;
 169
 170       else
 171          --  The corresponding call to Undefer_Abort is performed by the
 172          --  expanded code (see exp_ch9).
 173
 174          STI.Defer_Abort (STPO.Self);
 175          Time_Enqueue
 176            (STPO.Monotonic_Clock
 177             + Duration'Min (T, OSP.Max_Sensible_Delay), D);
 178          return True;
 179       end if;
 180    end Enqueue_Duration;
 181
 182    ------------------
 183    -- Time_Enqueue --
 184    ------------------
 185
 186    --  Allocate a queue element for the wakeup time T and put it in the
 187    --  queue in wakeup time order.  Assume we are on an asynchronous
 188    --  select statement with delay trigger.  Put the calling task to
 189    --  sleep until either the delay expires or is cancelled.
 190
 191    --  We use one entry call record for this delay, since we have
 192    --  to increment the ATC nesting level, but since it is not a
 193    --  real entry call we do not need to use any of the fields of
 194    --  the call record.  The following code implements a subset of
 195    --  the actions for the asynchronous case of Protected_Entry_Call,
 196    --  much simplified since we know this never blocks, and does not
 197    --  have the full semantics of a protected entry call.
 198
 199    procedure Time_Enqueue
 200      (T : Duration;
 201       D : Delay_Block_Access)
 202    is
 203       Self_Id : constant Task_Id  := STPO.Self;
 204       Q       : Delay_Block_Access;
 205
 206       use type ST.Task_Id;
 207       --  for visibility of operator "="
 208
 209    begin
 210       pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
 211       pragma Assert (Self_Id.Deferral_Level = 1,
 212         "async delay from within abort-deferred region");
 213
 214       if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
 215          raise Storage_Error with "not enough ATC nesting levels";
 216       end if;
 217
 218       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
 219
 220       pragma Debug
 221         (Debug.Trace (Self_Id, "ASD: entered ATC level: " &
 222          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
 223
 224       D.Level := Self_Id.ATC_Nesting_Level;
 225       D.Self_Id := Self_Id;
 226       D.Resume_Time := T;
 227
 228       if Single_Lock then
 229          STPO.Lock_RTS;
 230       end if;
 231
 232       STPO.Write_Lock (Timer_Server_ID);
 233
 234       --  Previously, there was code here to dynamically create
 235       --  the Timer_Server task, if one did not already exist.
 236       --  That code had a timing window that could allow multiple
 237       --  timer servers to be created. Luckily, the need for
 238       --  postponing creation of the timer server should now be
 239       --  gone, since this package will only be linked in if
 240       --  there are calls to enqueue calls on the timer server.
 241
 242       --  Insert D in the timer queue, at the position determined
 243       --  by the wakeup time T.
 244
 245       Q := Timer_Queue.Succ;
 246
 247       while Q.Resume_Time < T loop
 248          Q := Q.Succ;
 249       end loop;
 250
 251       --  Q is the block that has Resume_Time equal to or greater than
 252       --  T. After the insertion we want Q to be the successor of D.
 253
 254       D.Succ := Q;
 255       D.Pred := Q.Pred;
 256       D.Pred.Succ := D;
 257       Q.Pred := D;
 258
 259       --  If the new element became the head of the queue,
 260       --  signal the Timer_Server to wake up.
 261
 262       if Timer_Queue.Succ = D then
 263          Timer_Attention := True;
 264          STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);
 265       end if;
 266
 267       STPO.Unlock (Timer_Server_ID);
 268
 269       if Single_Lock then
 270          STPO.Unlock_RTS;
 271       end if;
 272    end Time_Enqueue;
 273
 274    ---------------
 275    -- Timed_Out --
 276    ---------------
 277
 278    function Timed_Out (D : Delay_Block_Access) return Boolean is
 279    begin
 280       return D.Timed_Out;
 281    end Timed_Out;
 282
 283    ------------------
 284    -- Timer_Server --
 285    ------------------
 286
 287    task body Timer_Server is
 288       Ignore : constant Boolean := STU.Make_Independent;
 289
 290       --  Local Declarations
 291
 292       Next_Wakeup_Time : Duration := Duration'Last;
 293       Timedout         : Boolean;
 294       Yielded          : Boolean;
 295       Now              : Duration;
 296       Dequeued         : Delay_Block_Access;
 297       Dequeued_Task    : Task_Id;
 298
 299       pragma Unreferenced (Timedout, Yielded);
 300
 301    begin
 302       pragma Assert (Timer_Server_ID = STPO.Self);
 303
 304       --  Since this package may be elaborated before System.Interrupt,
 305       --  we need to call Setup_Interrupt_Mask explicitly to ensure that
 306       --  this task has the proper signal mask.
 307
 308       Interrupt_Management.Operations.Setup_Interrupt_Mask;
 309
 310       --  Initialize the timer queue to empty, and make the wakeup time of the
 311       --  header node be larger than any real wakeup time we will ever use.
 312
 313       loop
 314          STI.Defer_Abort (Timer_Server_ID);
 315
 316          if Single_Lock then
 317             STPO.Lock_RTS;
 318          end if;
 319
 320          STPO.Write_Lock (Timer_Server_ID);
 321
 322          --  The timer server needs to catch pending aborts after finalization
 323          --  of library packages. If it doesn't poll for it, the server will
 324          --  sometimes hang.
 325
 326          if not Timer_Attention then
 327             Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
 328
 329             if Next_Wakeup_Time = Duration'Last then
 330                Timer_Server_ID.User_State := 1;
 331                Next_Wakeup_Time :=
 332                  STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
 333
 334             else
 335                Timer_Server_ID.User_State := 2;
 336             end if;
 337
 338             STPO.Timed_Sleep
 339               (Timer_Server_ID, Next_Wakeup_Time,
 340                OSP.Absolute_RT, ST.Timer_Server_Sleep,
 341                Timedout, Yielded);
 342             Timer_Server_ID.Common.State := ST.Runnable;
 343          end if;
 344
 345          --  Service all of the wakeup requests on the queue whose times have
 346          --  been reached, and update Next_Wakeup_Time to next wakeup time
 347          --  after that (the wakeup time of the head of the queue if any, else
 348          --  a time far in the future).
 349
 350          Timer_Server_ID.User_State := 3;
 351          Timer_Attention := False;
 352
 353          Now := STPO.Monotonic_Clock;
 354          while Timer_Queue.Succ.Resume_Time <= Now loop
 355
 356             --  Dequeue the waiting task from the front of the queue
 357
 358             pragma Debug (System.Tasking.Debug.Trace
 359               (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
 360
 361             Dequeued := Timer_Queue.Succ;
 362             Timer_Queue.Succ := Dequeued.Succ;
 363             Dequeued.Succ.Pred := Dequeued.Pred;
 364             Dequeued.Succ := Dequeued;
 365             Dequeued.Pred := Dequeued;
 366
 367             --  We want to abort the queued task to the level of the async.
 368             --  select statement with the delay. To do that, we need to lock
 369             --  the ATCB of that task, but to avoid deadlock we need to release
 370             --  the lock of the Timer_Server. This leaves a window in which
 371             --  another task might perform an enqueue or dequeue operation on
 372             --  the timer queue, but that is OK because we always restart the
 373             --  next iteration at the head of the queue.
 374
 375             if Parameters.Runtime_Traces then
 376                Send_Trace_Info (E_Kill, Dequeued.Self_Id);
 377             end if;
 378
 379             STPO.Unlock (Timer_Server_ID);
 380             STPO.Write_Lock (Dequeued.Self_Id);
 381             Dequeued_Task := Dequeued.Self_Id;
 382             Dequeued.Timed_Out := True;
 383             STI.Locked_Abort_To_Level
 384               (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
 385             STPO.Unlock (Dequeued_Task);
 386             STPO.Write_Lock (Timer_Server_ID);
 387          end loop;
 388
 389          Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
 390
 391          --  Service returns the Next_Wakeup_Time.
 392          --  The Next_Wakeup_Time is either an infinity (no delay request)
 393          --  or the wakeup time of the queue head. This value is used for
 394          --  an actual delay in this server.
 395
 396          STPO.Unlock (Timer_Server_ID);
 397
 398          if Single_Lock then
 399             STPO.Unlock_RTS;
 400          end if;
 401
 402          STI.Undefer_Abort (Timer_Server_ID);
 403       end loop;
 404    end Timer_Server;
 405
 406 end System.Tasking.Async_Delays;