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