gcc/ada/s-tasuti.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 . U T I L I T I E S             --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2011, 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 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This package provides RTS Internal Declarations
  33
  34 --  These declarations are not part of the GNARLI
  35
  36 pragma Polling (Off);
  37 --  Turn off polling, we do not want ATC polling to take place during tasking
  38 --  operations. It causes infinite loops and other problems.
  39
  40 with System.Tasking.Debug;
  41 with System.Task_Primitives.Operations;
  42 with System.Tasking.Initialization;
  43 with System.Tasking.Queuing;
  44 with System.Parameters;
  45 with System.Traces.Tasking;
  46
  47 package body System.Tasking.Utilities is
  48
  49    package STPO renames System.Task_Primitives.Operations;
  50
  51    use Parameters;
  52    use Tasking.Debug;
  53    use Task_Primitives;
  54    use Task_Primitives.Operations;
  55
  56    use System.Traces;
  57    use System.Traces.Tasking;
  58
  59    --------------------
  60    -- Abort_One_Task --
  61    --------------------
  62
  63    --  Similar to Locked_Abort_To_Level (Self_ID, T, 0), but:
  64    --    (1) caller should be holding no locks except RTS_Lock when Single_Lock
  65    --    (2) may be called for tasks that have not yet been activated
  66    --    (3) always aborts whole task
  67
  68    procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is
  69    begin
  70       if Parameters.Runtime_Traces then
  71          Send_Trace_Info (T_Abort, Self_ID, T);
  72       end if;
  73
  74       Write_Lock (T);
  75
  76       if T.Common.State = Unactivated then
  77          T.Common.Activator := null;
  78          T.Common.State := Terminated;
  79          T.Callable := False;
  80          Cancel_Queued_Entry_Calls (T);
  81
  82       elsif T.Common.State /= Terminated then
  83          Initialization.Locked_Abort_To_Level (Self_ID, T, 0);
  84       end if;
  85
  86       Unlock (T);
  87    end Abort_One_Task;
  88
  89    -----------------
  90    -- Abort_Tasks --
  91    -----------------
  92
  93    --  This must be called to implement the abort statement.
  94    --  Much of the actual work of the abort is done by the abortee,
  95    --  via the Abort_Handler signal handler, and propagation of the
  96    --  Abort_Signal special exception.
  97
  98    procedure Abort_Tasks (Tasks : Task_List) is
  99       Self_Id : constant Task_Id := STPO.Self;
 100       C       : Task_Id;
 101       P       : Task_Id;
 102
 103    begin
 104       --  If pragma Detect_Blocking is active then Program_Error must be
 105       --  raised if this potentially blocking operation is called from a
 106       --  protected action.
 107
 108       if System.Tasking.Detect_Blocking
 109         and then Self_Id.Common.Protected_Action_Nesting > 0
 110       then
 111          raise Program_Error with "potentially blocking operation";
 112       end if;
 113
 114       Initialization.Defer_Abort_Nestable (Self_Id);
 115
 116       --  ?????
 117       --  Really should not be nested deferral here.
 118       --  Patch for code generation error that defers abort before
 119       --  evaluating parameters of an entry call (at least, timed entry
 120       --  calls), and so may propagate an exception that causes abort
 121       --  to remain undeferred indefinitely. See C97404B. When all
 122       --  such bugs are fixed, this patch can be removed.
 123
 124       Lock_RTS;
 125
 126       for J in Tasks'Range loop
 127          C := Tasks (J);
 128          Abort_One_Task (Self_Id, C);
 129       end loop;
 130
 131       C := All_Tasks_List;
 132
 133       while C /= null loop
 134          if C.Pending_ATC_Level > 0 then
 135             P := C.Common.Parent;
 136
 137             while P /= null loop
 138                if P.Pending_ATC_Level = 0 then
 139                   Abort_One_Task (Self_Id, C);
 140                   exit;
 141                end if;
 142
 143                P := P.Common.Parent;
 144             end loop;
 145          end if;
 146
 147          C := C.Common.All_Tasks_Link;
 148       end loop;
 149
 150       Unlock_RTS;
 151       Initialization.Undefer_Abort_Nestable (Self_Id);
 152    end Abort_Tasks;
 153
 154    -------------------------------
 155    -- Cancel_Queued_Entry_Calls --
 156    -------------------------------
 157
 158    --  This should only be called by T, unless T is a terminated previously
 159    --  unactivated task.
 160
 161    procedure Cancel_Queued_Entry_Calls (T : Task_Id) is
 162       Next_Entry_Call : Entry_Call_Link;
 163       Entry_Call      : Entry_Call_Link;
 164       Self_Id         : constant Task_Id := STPO.Self;
 165
 166       Caller : Task_Id;
 167       pragma Unreferenced (Caller);
 168       --  Should this be removed ???
 169
 170       Level : Integer;
 171       pragma Unreferenced (Level);
 172       --  Should this be removed ???
 173
 174    begin
 175       pragma Assert (T = Self or else T.Common.State = Terminated);
 176
 177       for J in 1 .. T.Entry_Num loop
 178          Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call);
 179
 180          while Entry_Call /= null loop
 181
 182             --  Leave Entry_Call.Done = False, since this is cancelled
 183
 184             Caller := Entry_Call.Self;
 185             Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
 186             Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call);
 187             Level := Entry_Call.Level - 1;
 188             Unlock (T);
 189             Write_Lock (Entry_Call.Self);
 190             Initialization.Wakeup_Entry_Caller
 191               (Self_Id, Entry_Call, Cancelled);
 192             Unlock (Entry_Call.Self);
 193             Write_Lock (T);
 194             Entry_Call.State := Done;
 195             Entry_Call := Next_Entry_Call;
 196          end loop;
 197       end loop;
 198    end Cancel_Queued_Entry_Calls;
 199
 200    ------------------------
 201    -- Exit_One_ATC_Level --
 202    ------------------------
 203
 204    --  Call only with abort deferred and holding lock of Self_Id.
 205    --  This is a bit of common code for all entry calls.
 206    --  The effect is to exit one level of ATC nesting.
 207
 208    --  If we have reached the desired ATC nesting level, reset the
 209    --  requested level to effective infinity, to allow further calls.
 210    --  In any case, reset Self_Id.Aborting, to allow re-raising of
 211    --  Abort_Signal.
 212
 213    procedure Exit_One_ATC_Level (Self_ID : Task_Id) is
 214    begin
 215       Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1;
 216
 217       pragma Debug
 218         (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " &
 219          ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
 220
 221       pragma Assert (Self_ID.ATC_Nesting_Level >= 1);
 222
 223       if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then
 224          if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then
 225             Self_ID.Pending_ATC_Level := ATC_Level_Infinity;
 226             Self_ID.Aborting := False;
 227          else
 228             --  Force the next Undefer_Abort to re-raise Abort_Signal
 229
 230             pragma Assert
 231              (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level);
 232
 233             if Self_ID.Aborting then
 234                Self_ID.ATC_Hack := True;
 235                Self_ID.Pending_Action := True;
 236             end if;
 237          end if;
 238       end if;
 239    end Exit_One_ATC_Level;
 240
 241    ----------------------
 242    -- Make_Independent --
 243    ----------------------
 244
 245    procedure Make_Independent is
 246       Self_Id               : constant Task_Id := STPO.Self;
 247       Environment_Task      : constant Task_Id := STPO.Environment_Task;
 248       Parent                : constant Task_Id := Self_Id.Common.Parent;
 249       Parent_Needs_Updating : Boolean := False;
 250       Master_of_Task        : Integer;
 251
 252    begin
 253       if Self_Id.Known_Tasks_Index /= -1 then
 254          Known_Tasks (Self_Id.Known_Tasks_Index) := null;
 255       end if;
 256
 257       Initialization.Defer_Abort (Self_Id);
 258
 259       if Single_Lock then
 260          Lock_RTS;
 261       end if;
 262
 263       Write_Lock (Environment_Task);
 264       Write_Lock (Self_Id);
 265
 266       pragma Assert (Parent = Environment_Task
 267         or else Self_Id.Master_of_Task = Library_Task_Level);
 268
 269       Master_of_Task := Self_Id.Master_of_Task;
 270       Self_Id.Master_of_Task := Independent_Task_Level;
 271
 272       --  The run time assumes that the parent of an independent task is the
 273       --  environment task.
 274
 275       if Parent /= Environment_Task then
 276
 277          --  We cannot lock three tasks at the same time, so defer the
 278          --  operations on the parent.
 279
 280          Parent_Needs_Updating := True;
 281          Self_Id.Common.Parent := Environment_Task;
 282       end if;
 283
 284       --  Update Independent_Task_Count that is needed for the GLADE
 285       --  termination rule. See also pending update in
 286       --  System.Tasking.Stages.Check_Independent
 287
 288       Independent_Task_Count := Independent_Task_Count + 1;
 289
 290       Unlock (Self_Id);
 291
 292       --  Changing the parent after creation is not trivial. Do not forget
 293       --  to update the old parent counts, and the new parent (i.e. the
 294       --  Environment_Task) counts.
 295
 296       if Parent_Needs_Updating then
 297          Write_Lock (Parent);
 298          Parent.Awake_Count := Parent.Awake_Count - 1;
 299          Parent.Alive_Count := Parent.Alive_Count - 1;
 300          Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1;
 301          Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1;
 302          Unlock (Parent);
 303       end if;
 304
 305       --  In case the environment task is already waiting for children to
 306       --  complete.
 307       --  ??? There may be a race condition if the environment task was not in
 308       --  master completion sleep when this task was created, but now is
 309
 310       if Environment_Task.Common.State = Master_Completion_Sleep and then
 311         Master_of_Task = Environment_Task.Master_Within
 312       then
 313          Environment_Task.Common.Wait_Count :=
 314            Environment_Task.Common.Wait_Count - 1;
 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          if P.Common.State = Master_Phase_2_Sleep
 435            and then C.Master_of_Task = P.Master_Within
 436          then
 437             pragma Assert (P.Common.Wait_Count > 0);
 438             P.Common.Wait_Count := P.Common.Wait_Count - 1;
 439
 440             if P.Common.Wait_Count = 0 then
 441                Wakeup (P, Master_Phase_2_Sleep);
 442             end if;
 443          end if;
 444
 445          Unlock (C);
 446          Unlock (P);
 447          return;
 448       end if;
 449
 450       --  We are terminating in Phase 1 or Complete_Master,
 451       --  or are accepting on a terminate alternative.
 452
 453       C.Awake_Count := C.Awake_Count - 1;
 454
 455       if Task_Completed then
 456          C.Alive_Count := C.Alive_Count - 1;
 457       end if;
 458
 459       if C.Awake_Count > 0 or else P = null then
 460          Unlock (C);
 461
 462          if P /= null then
 463             Unlock (P);
 464          end if;
 465
 466          return;
 467       end if;
 468
 469       --  C's count just went to zero, indicating that all of C's
 470       --  dependents are terminated or accepting with terminate alt.
 471       --  C has a parent, P.
 472
 473       loop
 474          --  Notify P that C has gone passive
 475
 476          if P.Awake_Count > 0 then
 477             P.Awake_Count := P.Awake_Count - 1;
 478          end if;
 479
 480          if Task_Completed and then C.Alive_Count = 0 then
 481             P.Alive_Count := P.Alive_Count - 1;
 482          end if;
 483
 484          exit when P.Awake_Count > 0;
 485          Unlock (C);
 486          Unlock (P);
 487          C := P;
 488          P := C.Common.Parent;
 489
 490          if P = null then
 491             return;
 492          end if;
 493
 494          Write_Lock (P);
 495          Write_Lock (C);
 496       end loop;
 497
 498       --  P has non-passive dependents
 499
 500       if P.Common.State = Master_Completion_Sleep
 501         and then C.Master_of_Task = P.Master_Within
 502       then
 503          pragma Debug
 504            (Debug.Trace
 505             (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M'));
 506
 507          --  If parent is in Master_Completion_Sleep, it cannot be on a
 508          --  terminate alternative, hence it cannot have Wait_Count of
 509          --  zero. ???Except that the race condition in Make_Independent can
 510          --  cause Wait_Count to be zero, so we need to check for that.
 511
 512          if P.Common.Wait_Count > 0 then
 513             P.Common.Wait_Count := P.Common.Wait_Count - 1;
 514          end if;
 515
 516          if P.Common.Wait_Count = 0 then
 517             Wakeup (P, Master_Completion_Sleep);
 518          end if;
 519
 520       else
 521          pragma Debug
 522            (Debug.Trace
 523              (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
 524          null;
 525       end if;
 526
 527       Unlock (C);
 528       Unlock (P);
 529    end Make_Passive;
 530
 531 end System.Tasking.Utilities;