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