gcc/ada/s-taasde.adb

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