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