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