gcc/ada/s-tasuti.adb

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