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