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-2014, 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    function Make_Independent return Boolean 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
 250    begin
 251       if Self_Id.Known_Tasks_Index /= -1 then
 252          Known_Tasks (Self_Id.Known_Tasks_Index) := null;
 253       end if;
 254
 255       Initialization.Defer_Abort (Self_Id);
 256
 257       if Single_Lock then
 258          Lock_RTS;
 259       end if;
 260
 261       Write_Lock (Environment_Task);
 262       Write_Lock (Self_Id);
 263
 264       --  The run time assumes that the parent of an independent task is the
 265       --  environment task.
 266
 267       pragma Assert (Parent = Environment_Task);
 268
 269       Self_Id.Master_of_Task := Independent_Task_Level;
 270
 271       --  Update Independent_Task_Count that is needed for the GLADE
 272       --  termination rule. See also pending update in
 273       --  System.Tasking.Stages.Check_Independent
 274
 275       Independent_Task_Count := Independent_Task_Count + 1;
 276
 277       --  This should be called before the task reaches its "begin" (see spec),
 278       --  which ensures that the environment task cannot race ahead and be
 279       --  already waiting for children to complete.
 280
 281       Unlock (Self_Id);
 282       pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep);
 283
 284       Unlock (Environment_Task);
 285
 286       if Single_Lock then
 287          Unlock_RTS;
 288       end if;
 289
 290       Initialization.Undefer_Abort (Self_Id);
 291
 292       --  Return True. Actually the return value is junk, since we expect it
 293       --  always to be ignored (see spec), but we have to return something!
 294
 295       return True;
 296    end Make_Independent;
 297
 298    ------------------
 299    -- Make_Passive --
 300    ------------------
 301
 302    procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is
 303       C : Task_Id := Self_ID;
 304       P : Task_Id := C.Common.Parent;
 305
 306       Master_Completion_Phase : Integer;
 307
 308    begin
 309       if P /= null then
 310          Write_Lock (P);
 311       end if;
 312
 313       Write_Lock (C);
 314
 315       if Task_Completed then
 316          Self_ID.Common.State := Terminated;
 317
 318          if Self_ID.Awake_Count = 0 then
 319
 320             --  We are completing via a terminate alternative.
 321             --  Our parent should wait in Phase 2 of Complete_Master.
 322
 323             Master_Completion_Phase := 2;
 324
 325             pragma Assert (Task_Completed);
 326             pragma Assert (Self_ID.Terminate_Alternative);
 327             pragma Assert (Self_ID.Alive_Count = 1);
 328
 329          else
 330             --  We are NOT on a terminate alternative.
 331             --  Our parent should wait in Phase 1 of Complete_Master.
 332
 333             Master_Completion_Phase := 1;
 334             pragma Assert (Self_ID.Awake_Count >= 1);
 335          end if;
 336
 337       --  We are accepting with a terminate alternative
 338
 339       else
 340          if Self_ID.Open_Accepts = null then
 341
 342             --  Somebody started a rendezvous while we had our lock open.
 343             --  Skip the terminate alternative.
 344
 345             Unlock (C);
 346
 347             if P /= null then
 348                Unlock (P);
 349             end if;
 350
 351             return;
 352          end if;
 353
 354          Self_ID.Terminate_Alternative := True;
 355          Master_Completion_Phase := 0;
 356
 357          pragma Assert (Self_ID.Terminate_Alternative);
 358          pragma Assert (Self_ID.Awake_Count >= 1);
 359       end if;
 360
 361       if Master_Completion_Phase = 2 then
 362
 363          --  Since our Awake_Count is zero but our Alive_Count
 364          --  is nonzero, we have been accepting with a terminate
 365          --  alternative, and we now have been told to terminate
 366          --  by a completed master (in some ancestor task) that
 367          --  is waiting (with zero Awake_Count) in Phase 2 of
 368          --  Complete_Master.
 369
 370          pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M'));
 371
 372          pragma Assert (P /= null);
 373
 374          C.Alive_Count := C.Alive_Count - 1;
 375
 376          if C.Alive_Count > 0 then
 377             Unlock (C);
 378             Unlock (P);
 379             return;
 380          end if;
 381
 382          --  C's count just went to zero, indicating that
 383          --  all of C's dependents are terminated.
 384          --  C has a parent, P.
 385
 386          loop
 387             --  C's count just went to zero, indicating that all of C's
 388             --  dependents are terminated. C has a parent, P. Notify P that
 389             --  C and its dependents have all terminated.
 390
 391             P.Alive_Count := P.Alive_Count - 1;
 392             exit when P.Alive_Count > 0;
 393             Unlock (C);
 394             Unlock (P);
 395             C := P;
 396             P := C.Common.Parent;
 397
 398             --  Environment task cannot have terminated yet
 399
 400             pragma Assert (P /= null);
 401
 402             Write_Lock (P);
 403             Write_Lock (C);
 404          end loop;
 405
 406          if P.Common.State = Master_Phase_2_Sleep
 407            and then C.Master_of_Task = P.Master_Within
 408          then
 409             pragma Assert (P.Common.Wait_Count > 0);
 410             P.Common.Wait_Count := P.Common.Wait_Count - 1;
 411
 412             if P.Common.Wait_Count = 0 then
 413                Wakeup (P, Master_Phase_2_Sleep);
 414             end if;
 415          end if;
 416
 417          Unlock (C);
 418          Unlock (P);
 419          return;
 420       end if;
 421
 422       --  We are terminating in Phase 1 or Complete_Master,
 423       --  or are accepting on a terminate alternative.
 424
 425       C.Awake_Count := C.Awake_Count - 1;
 426
 427       if Task_Completed then
 428          C.Alive_Count := C.Alive_Count - 1;
 429       end if;
 430
 431       if C.Awake_Count > 0 or else P = null then
 432          Unlock (C);
 433
 434          if P /= null then
 435             Unlock (P);
 436          end if;
 437
 438          return;
 439       end if;
 440
 441       --  C's count just went to zero, indicating that all of C's
 442       --  dependents are terminated or accepting with terminate alt.
 443       --  C has a parent, P.
 444
 445       loop
 446          --  Notify P that C has gone passive
 447
 448          if P.Awake_Count > 0 then
 449             P.Awake_Count := P.Awake_Count - 1;
 450          end if;
 451
 452          if Task_Completed and then C.Alive_Count = 0 then
 453             P.Alive_Count := P.Alive_Count - 1;
 454          end if;
 455
 456          exit when P.Awake_Count > 0;
 457          Unlock (C);
 458          Unlock (P);
 459          C := P;
 460          P := C.Common.Parent;
 461
 462          if P = null then
 463             return;
 464          end if;
 465
 466          Write_Lock (P);
 467          Write_Lock (C);
 468       end loop;
 469
 470       --  P has non-passive dependents
 471
 472       if P.Common.State = Master_Completion_Sleep
 473         and then C.Master_of_Task = P.Master_Within
 474       then
 475          pragma Debug
 476            (Debug.Trace
 477             (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M'));
 478
 479          --  If parent is in Master_Completion_Sleep, it cannot be on a
 480          --  terminate alternative, hence it cannot have Wait_Count of zero.
 481
 482          pragma Assert (P.Common.Wait_Count > 0);
 483          P.Common.Wait_Count := P.Common.Wait_Count - 1;
 484
 485          if P.Common.Wait_Count = 0 then
 486             Wakeup (P, Master_Completion_Sleep);
 487          end if;
 488
 489       else
 490          pragma Debug
 491            (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
 492          null;
 493       end if;
 494
 495       Unlock (C);
 496       Unlock (P);
 497    end Make_Passive;
 498
 499 end System.Tasking.Utilities;