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