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