gcc/ada/s-tasuti.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 . U T I L I T I E S             --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2002, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 --  This package provides RTS Internal Declarations.
  35 --  These declarations are not part of the GNARLI
  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 System.Tasking.Debug;
  42 --  used for Known_Tasks
  43
  44 with System.Task_Primitives.Operations;
  45 --  used for Write_Lock
  46 --           Set_Priority
  47 --           Wakeup
  48 --           Unlock
  49 --           Sleep
  50 --           Abort_Task
  51 --           Lock/Unlock_RTS
  52
  53 with System.Tasking.Initialization;
  54 --  Used for Defer_Abort
  55 --           Undefer_Abort
  56 --           Locked_Abort_To_Level
  57
  58 with System.Tasking.Queuing;
  59 --  used for Dequeue_Call
  60 --           Dequeue_Head
  61
  62 with System.Tasking.Debug;
  63 --  used for Trace
  64
  65 with System.Parameters;
  66 --  used for Single_Lock
  67 --           Runtime_Traces
  68
  69 with System.Traces.Tasking;
  70 --  used for Send_Trace_Info
  71
  72 with Unchecked_Conversion;
  73
  74 package body System.Tasking.Utilities is
  75
  76    package STPO renames System.Task_Primitives.Operations;
  77
  78    use Parameters;
  79    use Tasking.Debug;
  80    use Task_Primitives;
  81    use Task_Primitives.Operations;
  82
  83    use System.Traces;
  84    use System.Traces.Tasking;
  85
  86    --------------------
  87    -- Abort_One_Task --
  88    --------------------
  89
  90    --  Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:
  91    --    (1) caller should be holding no locks except RTS_Lock when Single_Lock
  92    --    (2) may be called for tasks that have not yet been activated
  93    --    (3) always aborts whole task
  94
  95    procedure Abort_One_Task (Self_ID : Task_ID; T : Task_ID) is
  96    begin
  97       if Parameters.Runtime_Traces then
  98          Send_Trace_Info (T_Abort, Self_ID, T);
  99       end if;
 100
 101       Write_Lock (T);
 102
 103       if T.Common.State = Unactivated then
 104          T.Common.Activator := null;
 105          T.Common.State := Terminated;
 106          T.Callable := False;
 107          Cancel_Queued_Entry_Calls (T);
 108
 109       elsif T.Common.State /= Terminated then
 110          Initialization.Locked_Abort_To_Level (Self_ID, T, 0);
 111       end if;
 112
 113       Unlock (T);
 114    end Abort_One_Task;
 115
 116    -----------------
 117    -- Abort_Tasks --
 118    -----------------
 119
 120    --  Compiler interface only: Do not call from within the RTS,
 121
 122    --  except in the implementation of Ada.Task_Identification.
 123    --  This must be called to implement the abort statement.
 124    --  Much of the actual work of the abort is done by the abortee,
 125    --  via the Abort_Handler signal handler, and propagation of the
 126    --  Abort_Signal special exception.
 127
 128    procedure Abort_Tasks (Tasks : Task_List) is
 129       Self_Id : constant Task_ID := STPO.Self;
 130       C       : Task_ID;
 131       P       : Task_ID;
 132
 133    begin
 134       Initialization.Defer_Abort_Nestable (Self_Id);
 135
 136       --  ?????
 137       --  Really should not be nested deferral here.
 138       --  Patch for code generation error that defers abort before
 139       --  evaluating parameters of an entry call (at least, timed entry
 140       --  calls), and so may propagate an exception that causes abort
 141       --  to remain undeferred indefinitely. See C97404B. When all
 142       --  such bugs are fixed, this patch can be removed.
 143
 144       Lock_RTS;
 145
 146       for J in Tasks'Range loop
 147          C := Tasks (J);
 148          Abort_One_Task (Self_Id, C);
 149       end loop;
 150
 151       C := All_Tasks_List;
 152
 153       while C /= null loop
 154          if C.Pending_ATC_Level > 0 then
 155             P := C.Common.Parent;
 156
 157             while P /= null loop
 158                if P.Pending_ATC_Level = 0 then
 159                   Abort_One_Task (Self_Id, C);
 160                   exit;
 161                end if;
 162
 163                P := P.Common.Parent;
 164             end loop;
 165          end if;
 166
 167          C := C.Common.All_Tasks_Link;
 168       end loop;
 169
 170       Unlock_RTS;
 171       Initialization.Undefer_Abort_Nestable (Self_Id);
 172    end Abort_Tasks;
 173
 174    -------------------------------
 175    -- Cancel_Queued_Entry_Calls --
 176    -------------------------------
 177
 178    --  This should only be called by T, unless T is a terminated previously
 179    --  unactivated task.
 180
 181    procedure Cancel_Queued_Entry_Calls (T : Task_ID) is
 182       Next_Entry_Call : Entry_Call_Link;
 183       Entry_Call      : Entry_Call_Link;
 184       Self_Id         : constant Task_ID := STPO.Self;
 185
 186       Caller : Task_ID;
 187       pragma Unreferenced (Caller);
 188       --  Should this be removed ???
 189
 190       Level : Integer;
 191       pragma Unreferenced (Level);
 192       --  Should this be removed ???
 193
 194    begin
 195       pragma Assert (T = Self or else T.Common.State = Terminated);
 196
 197       for J in 1 .. T.Entry_Num loop
 198          Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call);
 199
 200          while Entry_Call /= null loop
 201
 202             --  Leave Entry_Call.Done = False, since this is cancelled
 203
 204             Caller := Entry_Call.Self;
 205             Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
 206             Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call);
 207             Level := Entry_Call.Level - 1;
 208             Unlock (T);
 209             Write_Lock (Entry_Call.Self);
 210             Initialization.Wakeup_Entry_Caller
 211               (Self_Id, Entry_Call, Cancelled);
 212             Unlock (Entry_Call.Self);
 213             Write_Lock (T);
 214             Entry_Call.State := Done;
 215             Entry_Call := Next_Entry_Call;
 216          end loop;
 217       end loop;
 218    end Cancel_Queued_Entry_Calls;
 219
 220    ------------------------
 221    -- Exit_One_ATC_Level --
 222    ------------------------
 223
 224    --  Call only with abort deferred and holding lock of Self_Id.
 225    --  This is a bit of common code for all entry calls.
 226    --  The effect is to exit one level of ATC nesting.
 227
 228    --  If we have reached the desired ATC nesting level, reset the
 229    --  requested level to effective infinity, to allow further calls.
 230    --  In any case, reset Self_Id.Aborting, to allow re-raising of
 231    --  Abort_Signal.
 232
 233    procedure Exit_One_ATC_Level (Self_ID : Task_ID) is
 234    begin
 235       Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
 236
 237       pragma Debug
 238         (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " &
 239          ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
 240
 241       pragma Assert (Self_ID.ATC_Nesting_Level >= 1);
 242
 243       if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then
 244          if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then
 245             Self_ID.Pending_ATC_Level := ATC_Level_Infinity;
 246             Self_ID.Aborting := False;
 247          else
 248             --  Force the next Undefer_Abort to re-raise Abort_Signal
 249
 250             pragma Assert
 251              (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level);
 252
 253             if Self_ID.Aborting then
 254                Self_ID.ATC_Hack := True;
 255                Self_ID.Pending_Action := True;
 256             end if;
 257          end if;
 258       end if;
 259    end Exit_One_ATC_Level;
 260
 261    ----------------------
 262    -- Make_Independent --
 263    ----------------------
 264
 265    procedure Make_Independent is
 266       Self_Id               : constant Task_ID := STPO.Self;
 267       Environment_Task      : constant Task_ID := STPO.Environment_Task;
 268       Parent                : constant Task_ID := Self_Id.Common.Parent;
 269       Parent_Needs_Updating : Boolean := False;
 270       Master_of_Task        : Integer;
 271
 272    begin
 273       if Self_Id.Known_Tasks_Index /= -1 then
 274          Known_Tasks (Self_Id.Known_Tasks_Index) := null;
 275       end if;
 276
 277       Initialization.Defer_Abort (Self_Id);
 278
 279       if Single_Lock then
 280          Lock_RTS;
 281       end if;
 282
 283       Write_Lock (Environment_Task);
 284       Write_Lock (Self_Id);
 285
 286       pragma Assert (Parent = Environment_Task
 287         or else Self_Id.Master_of_Task = Library_Task_Level);
 288
 289       Master_of_Task := Self_Id.Master_of_Task;
 290       Self_Id.Master_of_Task := Independent_Task_Level;
 291
 292       --  The run time assumes that the parent of an independent task is the
 293       --  environment task.
 294
 295       if Parent /= Environment_Task then
 296
 297          --  We can not lock three tasks at the same time, so defer the
 298          --  operations on the parent.
 299
 300          Parent_Needs_Updating := True;
 301          Self_Id.Common.Parent := Environment_Task;
 302       end if;
 303
 304       --  Update Independent_Task_Count that is needed for the GLADE
 305       --  termination rule. See also pending update in
 306       --  System.Tasking.Stages.Check_Independent
 307
 308       Independent_Task_Count := Independent_Task_Count + 1;
 309
 310       Unlock (Self_Id);
 311
 312       --  Changing the parent after creation is not trivial. Do not forget
 313       --  to update the old parent counts, and the new parent (i.e. the
 314       --  Environment_Task) counts.
 315
 316       if Parent_Needs_Updating then
 317          Write_Lock (Parent);
 318          Parent.Awake_Count := Parent.Awake_Count - 1;
 319          Parent.Alive_Count := Parent.Alive_Count - 1;
 320          Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1;
 321          Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1;
 322          Unlock (Parent);
 323       end if;
 324
 325       --  In case the environment task is already waiting for children to
 326       --  complete.
 327       --  ??? There may be a race condition if the environment task was not in
 328       --  master completion sleep when this task was created, but now is
 329
 330       if Environment_Task.Common.State = Master_Completion_Sleep and then
 331         Master_of_Task = Environment_Task.Master_Within
 332       then
 333          Environment_Task.Common.Wait_Count :=
 334            Environment_Task.Common.Wait_Count - 1;
 335       end if;
 336
 337       Unlock (Environment_Task);
 338
 339       if Single_Lock then
 340          Unlock_RTS;
 341       end if;
 342
 343       Initialization.Undefer_Abort (Self_Id);
 344    end Make_Independent;
 345
 346    ------------------
 347    -- Make_Passive --
 348    ------------------
 349
 350    procedure Make_Passive (Self_ID : Task_ID; Task_Completed : Boolean) is
 351       C : Task_ID := Self_ID;
 352       P : Task_ID := C.Common.Parent;
 353
 354       Master_Completion_Phase : Integer;
 355
 356    begin
 357       if P /= null then
 358          Write_Lock (P);
 359       end if;
 360
 361       Write_Lock (C);
 362
 363       if Task_Completed then
 364          Self_ID.Common.State := Terminated;
 365
 366          if Self_ID.Awake_Count = 0 then
 367
 368             --  We are completing via a terminate alternative.
 369             --  Our parent should wait in Phase 2 of Complete_Master.
 370
 371             Master_Completion_Phase := 2;
 372
 373             pragma Assert (Task_Completed);
 374             pragma Assert (Self_ID.Terminate_Alternative);
 375             pragma Assert (Self_ID.Alive_Count = 1);
 376
 377          else
 378             --  We are NOT on a terminate alternative.
 379             --  Our parent should wait in Phase 1 of Complete_Master.
 380
 381             Master_Completion_Phase := 1;
 382             pragma Assert (Self_ID.Awake_Count = 1);
 383          end if;
 384
 385       --  We are accepting with a terminate alternative.
 386
 387       else
 388          if Self_ID.Open_Accepts = null then
 389
 390             --  Somebody started a rendezvous while we had our lock open.
 391             --  Skip the terminate alternative.
 392
 393             Unlock (C);
 394
 395             if P /= null then
 396                Unlock (P);
 397             end if;
 398
 399             return;
 400          end if;
 401
 402          Self_ID.Terminate_Alternative := True;
 403          Master_Completion_Phase := 0;
 404
 405          pragma Assert (Self_ID.Terminate_Alternative);
 406          pragma Assert (Self_ID.Awake_Count >= 1);
 407       end if;
 408
 409       if Master_Completion_Phase = 2 then
 410
 411          --  Since our Awake_Count is zero but our Alive_Count
 412          --  is nonzero, we have been accepting with a terminate
 413          --  alternative, and we now have been told to terminate
 414          --  by a completed master (in some ancestor task) that
 415          --  is waiting (with zero Awake_Count) in Phase 2 of
 416          --  Complete_Master.
 417
 418          pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M'));
 419
 420          pragma Assert (P /= null);
 421
 422          C.Alive_Count := C.Alive_Count - 1;
 423
 424          if C.Alive_Count > 0 then
 425             Unlock (C);
 426             Unlock (P);
 427             return;
 428          end if;
 429
 430          --  C's count just went to zero, indicating that
 431          --  all of C's dependents are terminated.
 432          --  C has a parent, P.
 433
 434          loop
 435             --  C's count just went to zero, indicating that all of C's
 436             --  dependents are terminated. C has a parent, P. Notify P that
 437             --  C and its dependents have all terminated.
 438
 439             P.Alive_Count := P.Alive_Count - 1;
 440             exit when P.Alive_Count > 0;
 441             Unlock (C);
 442             Unlock (P);
 443             C := P;
 444             P := C.Common.Parent;
 445
 446             --  Environment task cannot have terminated yet
 447
 448             pragma Assert (P /= null);
 449
 450             Write_Lock (P);
 451             Write_Lock (C);
 452          end loop;
 453
 454          pragma Assert (P.Awake_Count /= 0);
 455
 456          if P.Common.State = Master_Phase_2_Sleep
 457            and then C.Master_of_Task = P.Master_Within
 458          then
 459             pragma Assert (P.Common.Wait_Count > 0);
 460             P.Common.Wait_Count := P.Common.Wait_Count - 1;
 461
 462             if P.Common.Wait_Count = 0 then
 463                Wakeup (P, Master_Phase_2_Sleep);
 464             end if;
 465          end if;
 466
 467          Unlock (C);
 468          Unlock (P);
 469          return;
 470       end if;
 471
 472       --  We are terminating in Phase 1 or Complete_Master,
 473       --  or are accepting on a terminate alternative.
 474
 475       C.Awake_Count := C.Awake_Count - 1;
 476
 477       if Task_Completed then
 478          pragma Assert (Self_ID.Awake_Count = 0);
 479          C.Alive_Count := C.Alive_Count - 1;
 480       end if;
 481
 482       if C.Awake_Count > 0 or else P = null then
 483          Unlock (C);
 484
 485          if P /= null then
 486             Unlock (P);
 487          end if;
 488
 489          return;
 490       end if;
 491
 492       --  C's count just went to zero, indicating that all of C's
 493       --  dependents are terminated or accepting with terminate alt.
 494       --  C has a parent, P.
 495
 496       loop
 497          --  Notify P that C has gone passive.
 498
 499          P.Awake_Count := P.Awake_Count - 1;
 500
 501          if Task_Completed and then C.Alive_Count = 0 then
 502             P.Alive_Count := P.Alive_Count - 1;
 503          end if;
 504
 505          exit when P.Awake_Count > 0;
 506          Unlock (C);
 507          Unlock (P);
 508          C := P;
 509          P := C.Common.Parent;
 510
 511          if P = null then
 512             return;
 513          end if;
 514
 515          Write_Lock (P);
 516          Write_Lock (C);
 517       end loop;
 518
 519       --  P has non-passive dependents.
 520
 521       if P.Common.State = Master_Completion_Sleep
 522         and then C.Master_of_Task = P.Master_Within
 523       then
 524          pragma Debug
 525            (Debug.Trace
 526             (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M'));
 527
 528          --  If parent is in Master_Completion_Sleep, it
 529          --  cannot be on a terminate alternative, hence
 530          --  it cannot have Awake_Count of zero.
 531
 532          pragma Assert (P.Common.Wait_Count > 0);
 533          P.Common.Wait_Count := P.Common.Wait_Count - 1;
 534
 535          if P.Common.Wait_Count = 0 then
 536             Wakeup (P, Master_Completion_Sleep);
 537          end if;
 538
 539       else
 540          pragma Debug
 541            (Debug.Trace
 542              (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
 543          null;
 544       end if;
 545
 546       Unlock (C);
 547       Unlock (P);
 548    end Make_Passive;
 549
 550 end System.Tasking.Utilities;