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