gcc/ada/s-tassta.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 . S T A G E S                --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2002, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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. It is --
  30 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 pragma Polling (Off);
  35 --  Turn off polling, we do not want ATC polling to take place during
  36 --  tasking operations. It causes infinite loops and other problems.
  37
  38 with Ada.Exceptions;
  39 --  used for Raise_Exception
  40
  41 with System.Tasking.Debug;
  42 pragma Warnings (Off, System.Tasking.Debug);
  43 --  used for enabling tasking facilities with gdb
  44
  45 with System.Address_Image;
  46 --  used for the function itself.
  47
  48 with System.Parameters;
  49 --  used for Size_Type
  50 --           Single_Lock
  51 --           Runtime_Traces
  52
  53 with System.Task_Info;
  54 --  used for Task_Info_Type
  55 --           Task_Image_Type
  56
  57 with System.Task_Primitives.Operations;
  58 --  used for Finalize_Lock
  59 --           Enter_Task
  60 --           Write_Lock
  61 --           Unlock
  62 --           Sleep
  63 --           Wakeup
  64 --           Get_Priority
  65 --           Lock/Unlock_RTS
  66 --           New_ATCB
  67
  68 with System.Soft_Links;
  69 --  These are procedure pointers to non-tasking routines that use
  70 --  task specific data. In the absence of tasking, these routines
  71 --  refer to global data. In the presense of tasking, they must be
  72 --  replaced with pointers to task-specific versions.
  73 --  Also used for Create_TSD, Destroy_TSD, Get_Current_Excep
  74
  75 with System.Tasking.Initialization;
  76 --  Used for Remove_From_All_Tasks_List
  77 --           Defer_Abort
  78 --           Undefer_Abort
  79 --           Initialization.Poll_Base_Priority_Change
  80 --           Finalize_Attributes_Link
  81 --           Initialize_Attributes_Link
  82
  83 pragma Elaborate_All (System.Tasking.Initialization);
  84 --  This insures that tasking is initialized if any tasks are created.
  85
  86 with System.Tasking.Utilities;
  87 --  Used for Make_Passive
  88 --           Abort_One_Task
  89
  90 with System.Tasking.Queuing;
  91 --  Used for Dequeue_Head
  92
  93 with System.Tasking.Rendezvous;
  94 --  Used for Call_Simple
  95
  96 with System.OS_Primitives;
  97 --  Used for Delay_Modes
  98
  99 with System.Finalization_Implementation;
 100 --  Used for System.Finalization_Implementation.Finalize_Global_List
 101
 102 with Interfaces.C;
 103 --  Used for type Unsigned.
 104
 105 with System.Secondary_Stack;
 106 --  used for SS_Init;
 107
 108 with System.Storage_Elements;
 109 --  used for Storage_Array;
 110
 111 with System.Standard_Library;
 112 --  used for Exception_Trace
 113
 114 with System.Traces.Tasking;
 115 --  used for Send_Trace_Info
 116
 117 package body System.Tasking.Stages is
 118
 119    package STPO renames System.Task_Primitives.Operations;
 120    package SSL  renames System.Soft_Links;
 121    package SSE  renames System.Storage_Elements;
 122    package SST  renames System.Secondary_Stack;
 123
 124    use Ada.Exceptions;
 125
 126    use Parameters;
 127    use Task_Primitives;
 128    use Task_Primitives.Operations;
 129    use Task_Info;
 130
 131    use System.Traces;
 132    use System.Traces.Tasking;
 133
 134    -----------------------
 135    -- Local Subprograms --
 136    -----------------------
 137
 138    procedure Notify_Exception
 139      (Self_Id : Task_ID;
 140       Excep   : Exception_Occurrence);
 141    --  This procedure will output the task ID and the exception information,
 142    --  including traceback if available.
 143
 144    procedure Task_Wrapper (Self_ID : Task_ID);
 145    --  This is the procedure that is called by the GNULL from the
 146    --  new context when a task is created. It waits for activation
 147    --  and then calls the task body procedure. When the task body
 148    --  procedure completes, it terminates the task.
 149
 150    procedure Vulnerable_Complete_Task (Self_ID : Task_ID);
 151    --  Complete the calling task.
 152    --  This procedure must be called with abort deferred.
 153    --  It should only be called by Complete_Task and
 154    --  Finalizate_Global_Tasks (for the environment task).
 155
 156    procedure Vulnerable_Complete_Master (Self_ID : Task_ID);
 157    --  Complete the current master of the calling task.
 158    --  This procedure must be called with abort deferred.
 159    --  It should only be called by Vulnerable_Complete_Task and
 160    --  Complete_Master.
 161
 162    procedure Vulnerable_Complete_Activation (Self_ID : Task_ID);
 163    --  Signal to Self_ID's activator that Self_ID has
 164    --  completed activation.
 165    --
 166    --  Call this procedure with abort deferred.
 167
 168    procedure Abort_Dependents (Self_ID : Task_ID);
 169    --  Abort all the direct dependents of Self at its current master
 170    --  nesting level, plus all of their dependents, transitively.
 171    --  RTS_Lock should be locked by the caller.
 172
 173    procedure Vulnerable_Free_Task (T : Task_ID);
 174    --  Recover all runtime system storage associated with the task T.
 175    --  This should only be called after T has terminated and will no
 176    --  longer be referenced.
 177    --
 178    --  For tasks created by an allocator that fails, due to an exception,
 179    --  it is called from Expunge_Unactivated_Tasks.
 180    --
 181    --  It is also called from Unchecked_Deallocation, for objects that
 182    --  are or contain tasks.
 183    --
 184    --  Different code is used at master completion, in Terminate_Dependents,
 185    --  due to a need for tighter synchronization with the master.
 186
 187    procedure Terminate_Task (Self_ID : Task_ID);
 188    --  Terminate the calling task.
 189    --  This should only be called by the Task_Wrapper procedure.
 190
 191    ----------------------
 192    -- Abort_Dependents --
 193    ----------------------
 194
 195    procedure Abort_Dependents (Self_ID : Task_ID) is
 196       C : Task_ID;
 197       P : Task_ID;
 198
 199    begin
 200       C := All_Tasks_List;
 201
 202       while C /= null loop
 203          P := C.Common.Parent;
 204
 205          while P /= null loop
 206             if P = Self_ID then
 207                --  ??? C is supposed to take care of its own dependents, so
 208                --  there should be no need to worry about them. Need to double
 209                --  check this.
 210
 211                if C.Master_of_Task = Self_ID.Master_Within then
 212                   Utilities.Abort_One_Task (Self_ID, C);
 213                   C.Dependents_Aborted := True;
 214                end if;
 215
 216                exit;
 217             end if;
 218
 219             P := P.Common.Parent;
 220          end loop;
 221
 222          C := C.Common.All_Tasks_Link;
 223       end loop;
 224
 225       Self_ID.Dependents_Aborted := True;
 226    end Abort_Dependents;
 227
 228    -----------------
 229    -- Abort_Tasks --
 230    -----------------
 231
 232    procedure Abort_Tasks (Tasks : Task_List) is
 233    begin
 234       Utilities.Abort_Tasks (Tasks);
 235    end Abort_Tasks;
 236
 237    --------------------
 238    -- Activate_Tasks --
 239    --------------------
 240
 241    --  Note that locks of activator and activated task are both locked
 242    --  here. This is necessary because C.Common.State and
 243    --  Self.Common.Wait_Count have to be synchronized. This is safe from
 244    --  deadlock because the activator is always created before the activated
 245    --  task. That satisfies our in-order-of-creation ATCB locking policy.
 246
 247    --  At one point, we may also lock the parent, if the parent is
 248    --  different from the activator. That is also consistent with the
 249    --  lock ordering policy, since the activator cannot be created
 250    --  before the parent.
 251
 252    --  Since we are holding both the activator's lock, and Task_Wrapper
 253    --  locks that before it does anything more than initialize the
 254    --  low-level ATCB components, it should be safe to wait to update
 255    --  the counts until we see that the thread creation is successful.
 256
 257    --  If the thread creation fails, we do need to close the entries
 258    --  of the task. The first phase, of dequeuing calls, only requires
 259    --  locking the acceptor's ATCB, but the waking up of the callers
 260    --  requires locking the caller's ATCB. We cannot safely do this
 261    --  while we are holding other locks. Therefore, the queue-clearing
 262    --  operation is done in a separate pass over the activation chain.
 263
 264    procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
 265       Self_ID        : constant Task_ID := STPO.Self;
 266       P              : Task_ID;
 267       C              : Task_ID;
 268       Next_C, Last_C : Task_ID;
 269       Activate_Prio  : System.Any_Priority;
 270       Success        : Boolean;
 271       All_Elaborated : Boolean := True;
 272
 273    begin
 274       pragma Debug
 275         (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
 276
 277       Initialization.Defer_Abort_Nestable (Self_ID);
 278
 279       pragma Assert (Self_ID.Common.Wait_Count = 0);
 280
 281       --  Lock RTS_Lock, to prevent activated tasks
 282       --  from racing ahead before we finish activating the chain.
 283
 284       Lock_RTS;
 285
 286       --  Check that all task bodies have been elaborated.
 287
 288       C := Chain_Access.T_ID;
 289       Last_C := null;
 290
 291       while C /= null loop
 292          if C.Common.Elaborated /= null
 293            and then not C.Common.Elaborated.all
 294          then
 295             All_Elaborated := False;
 296          end if;
 297
 298          --  Reverse the activation chain so that tasks are
 299          --  activated in the same order they're declared.
 300
 301          Next_C := C.Common.Activation_Link;
 302          C.Common.Activation_Link := Last_C;
 303          Last_C := C;
 304          C := Next_C;
 305       end loop;
 306
 307       Chain_Access.T_ID := Last_C;
 308
 309       if not All_Elaborated then
 310          Unlock_RTS;
 311          Initialization.Undefer_Abort_Nestable (Self_ID);
 312          Raise_Exception
 313            (Program_Error'Identity, "Some tasks have not been elaborated");
 314       end if;
 315
 316       --  Activate all the tasks in the chain.
 317       --  Creation of the thread of control was deferred until
 318       --  activation. So create it now.
 319
 320       C := Chain_Access.T_ID;
 321
 322       while C /= null loop
 323          if C.Common.State /= Terminated then
 324             pragma Assert (C.Common.State = Unactivated);
 325
 326             P := C.Common.Parent;
 327             Write_Lock (P);
 328             Write_Lock (C);
 329
 330             if C.Common.Base_Priority < Get_Priority (Self_ID) then
 331                Activate_Prio := Get_Priority (Self_ID);
 332             else
 333                Activate_Prio := C.Common.Base_Priority;
 334             end if;
 335
 336             System.Task_Primitives.Operations.Create_Task
 337               (C, Task_Wrapper'Address,
 338                Parameters.Size_Type
 339                  (C.Common.Compiler_Data.Pri_Stack_Info.Size),
 340                Activate_Prio, Success);
 341
 342             --  There would be a race between the created task and
 343             --  the creator to do the following initialization,
 344             --  if we did not have a Lock/Unlock_RTS pair
 345             --  in the task wrapper, to prevent it from racing ahead.
 346
 347             if Success then
 348                C.Common.State := Runnable;
 349                C.Awake_Count := 1;
 350                C.Alive_Count := 1;
 351                P.Awake_Count := P.Awake_Count + 1;
 352                P.Alive_Count := P.Alive_Count + 1;
 353
 354                if P.Common.State = Master_Completion_Sleep and then
 355                  C.Master_of_Task = P.Master_Within
 356                then
 357                   pragma Assert (Self_ID /= P);
 358                   P.Common.Wait_Count := P.Common.Wait_Count + 1;
 359                end if;
 360
 361                Unlock (C);
 362                Unlock (P);
 363
 364             else
 365                --  No need to set Awake_Count, State, etc. here since the loop
 366                --  below will do that for any Unactivated tasks.
 367
 368                Unlock (C);
 369                Unlock (P);
 370                Self_ID.Common.Activation_Failed := True;
 371             end if;
 372          end if;
 373
 374          C := C.Common.Activation_Link;
 375       end loop;
 376
 377       if not Single_Lock then
 378          Unlock_RTS;
 379       end if;
 380
 381       --  Close the entries of any tasks that failed thread creation,
 382       --  and count those that have not finished activation.
 383
 384       Write_Lock (Self_ID);
 385       Self_ID.Common.State := Activator_Sleep;
 386
 387       C :=  Chain_Access.T_ID;
 388       while C /= null loop
 389          Write_Lock (C);
 390
 391          if C.Common.State = Unactivated then
 392             C.Common.Activator := null;
 393             C.Common.State := Terminated;
 394             C.Callable := False;
 395             Utilities.Cancel_Queued_Entry_Calls (C);
 396
 397          elsif C.Common.Activator /= null then
 398             Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
 399          end if;
 400
 401          Unlock (C);
 402          P := C.Common.Activation_Link;
 403          C.Common.Activation_Link := null;
 404          C := P;
 405       end loop;
 406
 407       --  Wait for the activated tasks to complete activation.
 408       --  It is unsafe to abort any of these tasks until the count goes to
 409       --  zero.
 410
 411       loop
 412          Initialization.Poll_Base_Priority_Change (Self_ID);
 413          exit when Self_ID.Common.Wait_Count = 0;
 414          Sleep (Self_ID, Activator_Sleep);
 415       end loop;
 416
 417       Self_ID.Common.State := Runnable;
 418       Unlock (Self_ID);
 419
 420       if Single_Lock then
 421          Unlock_RTS;
 422       end if;
 423
 424       --  Remove the tasks from the chain.
 425
 426       Chain_Access.T_ID := null;
 427       Initialization.Undefer_Abort_Nestable (Self_ID);
 428
 429       if Self_ID.Common.Activation_Failed then
 430          Self_ID.Common.Activation_Failed := False;
 431          Raise_Exception (Tasking_Error'Identity,
 432            "Failure during activation");
 433       end if;
 434    end Activate_Tasks;
 435
 436    -------------------------
 437    -- Complete_Activation --
 438    -------------------------
 439
 440    procedure Complete_Activation is
 441       Self_ID : constant Task_ID := STPO.Self;
 442    begin
 443       Initialization.Defer_Abort_Nestable (Self_ID);
 444
 445       if Single_Lock then
 446          Lock_RTS;
 447       end if;
 448
 449       Vulnerable_Complete_Activation (Self_ID);
 450
 451       if Single_Lock then
 452          Unlock_RTS;
 453       end if;
 454
 455       Initialization.Undefer_Abort_Nestable (Self_ID);
 456
 457       --  ???
 458       --  Why do we need to allow for nested deferral here?
 459
 460       if Runtime_Traces then
 461          Send_Trace_Info (T_Activate);
 462       end if;
 463    end Complete_Activation;
 464
 465    ---------------------
 466    -- Complete_Master --
 467    ---------------------
 468
 469    procedure Complete_Master is
 470       Self_ID : Task_ID := STPO.Self;
 471
 472    begin
 473       pragma Assert (Self_ID.Deferral_Level > 0);
 474
 475       Vulnerable_Complete_Master (Self_ID);
 476    end Complete_Master;
 477
 478    -------------------
 479    -- Complete_Task --
 480    -------------------
 481
 482    --  See comments on Vulnerable_Complete_Task for details.
 483
 484    procedure Complete_Task is
 485       Self_ID  : constant Task_ID := STPO.Self;
 486    begin
 487       pragma Assert (Self_ID.Deferral_Level > 0);
 488
 489       Vulnerable_Complete_Task (Self_ID);
 490
 491       --  All of our dependents have terminated.
 492       --  Never undefer abort again!
 493    end Complete_Task;
 494
 495    -----------------
 496    -- Create_Task --
 497    -----------------
 498
 499    --  Compiler interface only. Do not call from within the RTS.
 500    --  This must be called to create a new task.
 501
 502    procedure Create_Task
 503      (Priority      : Integer;
 504       Size          : System.Parameters.Size_Type;
 505       Task_Info     : System.Task_Info.Task_Info_Type;
 506       Num_Entries   : Task_Entry_Index;
 507       Master        : Master_Level;
 508       State         : Task_Procedure_Access;
 509       Discriminants : System.Address;
 510       Elaborated    : Access_Boolean;
 511       Chain         : in out Activation_Chain;
 512       Task_Image    : System.Task_Info.Task_Image_Type;
 513       Created_Task  : out Task_ID)
 514    is
 515       T, P          : Task_ID;
 516       Self_ID       : constant Task_ID := STPO.Self;
 517       Success       : Boolean;
 518       Base_Priority : System.Any_Priority;
 519
 520    begin
 521       pragma Debug
 522         (Debug.Trace (Self_ID, "Create_Task", 'C'));
 523
 524       if Priority = Unspecified_Priority then
 525          Base_Priority := Self_ID.Common.Base_Priority;
 526       else
 527          Base_Priority := System.Any_Priority (Priority);
 528       end if;
 529
 530       --  Find parent P of new Task, via master level number.
 531
 532       P := Self_ID;
 533
 534       if P /= null then
 535          while P.Master_of_Task >= Master loop
 536             P := P.Common.Parent;
 537             exit when P = null;
 538          end loop;
 539       end if;
 540
 541       Initialization.Defer_Abort_Nestable (Self_ID);
 542
 543       begin
 544          T := New_ATCB (Num_Entries);
 545
 546       exception
 547          when others =>
 548             Initialization.Undefer_Abort_Nestable (Self_ID);
 549             Raise_Exception (Storage_Error'Identity, "Cannot allocate task");
 550       end;
 551
 552       --  RTS_Lock is used by Abort_Dependents and Abort_Tasks.
 553       --  Up to this point, it is possible that we may be part of
 554       --  a family of tasks that is being aborted.
 555
 556       Lock_RTS;
 557       Write_Lock (Self_ID);
 558
 559       --  Now, we must check that we have not been aborted.
 560       --  If so, we should give up on creating this task,
 561       --  and simply return.
 562
 563       if not Self_ID.Callable then
 564          pragma Assert (Self_ID.Pending_ATC_Level = 0);
 565          pragma Assert (Self_ID.Pending_Action);
 566          pragma Assert (Chain.T_ID = null
 567              or else Chain.T_ID.Common.State = Unactivated);
 568
 569          Unlock (Self_ID);
 570          Unlock_RTS;
 571          Initialization.Undefer_Abort_Nestable (Self_ID);
 572
 573          --  ??? Should never get here
 574
 575          pragma Assert (False);
 576          raise Standard'Abort_Signal;
 577       end if;
 578
 579       Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
 580         Base_Priority, Task_Info, Size, T, Success);
 581
 582       if not Success then
 583          Unlock (Self_ID);
 584          Unlock_RTS;
 585          Initialization.Undefer_Abort_Nestable (Self_ID);
 586          Raise_Exception
 587            (Storage_Error'Identity, "Failed to initialize task");
 588       end if;
 589
 590       T.Master_of_Task := Master;
 591       T.Master_Within := T.Master_of_Task + 1;
 592
 593       for L in T.Entry_Calls'Range loop
 594          T.Entry_Calls (L).Self := T;
 595          T.Entry_Calls (L).Level := L;
 596       end loop;
 597
 598       T.Common.Task_Image := Task_Image;
 599       Unlock (Self_ID);
 600       Unlock_RTS;
 601
 602       --  Create TSD as early as possible in the creation of a task, since it
 603       --  may be used by the operation of Ada code within the task.
 604
 605       SSL.Create_TSD (T.Common.Compiler_Data);
 606       T.Common.Activation_Link := Chain.T_ID;
 607       Chain.T_ID := T;
 608       Initialization.Initialize_Attributes_Link.all (T);
 609       Created_Task := T;
 610       Initialization.Undefer_Abort_Nestable (Self_ID);
 611
 612       if Runtime_Traces then
 613          Send_Trace_Info (T_Create, T);
 614       end if;
 615    end Create_Task;
 616
 617    --------------------
 618    -- Current_Master --
 619    --------------------
 620
 621    function Current_Master return Master_Level is
 622    begin
 623       return STPO.Self.Master_Within;
 624    end Current_Master;
 625
 626    ------------------
 627    -- Enter_Master --
 628    ------------------
 629
 630    procedure Enter_Master is
 631       Self_ID : constant Task_ID := STPO.Self;
 632
 633    begin
 634       Self_ID.Master_Within := Self_ID.Master_Within + 1;
 635    end Enter_Master;
 636
 637    -------------------------------
 638    -- Expunge_Unactivated_Tasks --
 639    -------------------------------
 640
 641    --  See procedure Close_Entries for the general case.
 642
 643    procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
 644       Self_ID : constant Task_ID := STPO.Self;
 645       C       : Task_ID;
 646       Call    : Entry_Call_Link;
 647       Temp    : Task_ID;
 648
 649    begin
 650       pragma Debug
 651         (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
 652
 653       Initialization.Defer_Abort_Nestable (Self_ID);
 654
 655       --  ???
 656       --  Experimentation has shown that abort is sometimes (but not
 657       --  always) already deferred when this is called.
 658       --  That may indicate an error. Find out what is going on.
 659
 660       C := Chain.T_ID;
 661
 662       while C /= null loop
 663          pragma Assert (C.Common.State = Unactivated);
 664
 665          Temp := C.Common.Activation_Link;
 666
 667          if C.Common.State = Unactivated then
 668             Lock_RTS;
 669             Write_Lock (C);
 670
 671             for J in 1 .. C.Entry_Num loop
 672                Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
 673                pragma Assert (Call = null);
 674             end loop;
 675
 676             Unlock (C);
 677
 678             Initialization.Remove_From_All_Tasks_List (C);
 679             Unlock_RTS;
 680
 681             Vulnerable_Free_Task (C);
 682             C := Temp;
 683          end if;
 684       end loop;
 685
 686       Chain.T_ID := null;
 687       Initialization.Undefer_Abort_Nestable (Self_ID);
 688    end Expunge_Unactivated_Tasks;
 689
 690    ---------------------------
 691    -- Finalize_Global_Tasks --
 692    ---------------------------
 693
 694    --  ???
 695    --  We have a potential problem here if finalization of global
 696    --  objects does anything with signals or the timer server, since
 697    --  by that time those servers have terminated.
 698
 699    --  It is hard to see how that would occur.
 700
 701    --  However, a better solution might be to do all this finalization
 702    --  using the global finalization chain.
 703
 704    procedure Finalize_Global_Tasks is
 705       Self_ID : constant Task_ID := STPO.Self;
 706       Ignore  : Boolean;
 707
 708    begin
 709       if Self_ID.Deferral_Level = 0 then
 710          --  ???
 711          --  In principle, we should be able to predict whether
 712          --  abort is already deferred here (and it should not be deferred
 713          --  yet but in practice it seems Finalize_Global_Tasks is being
 714          --  called sometimes, from RTS code for exceptions, with abort already
 715          --  deferred.
 716
 717          Initialization.Defer_Abort_Nestable (Self_ID);
 718
 719          --  Never undefer again!!!
 720       end if;
 721
 722       --  This code is only executed by the environment task
 723
 724       pragma Assert (Self_ID = Environment_Task);
 725
 726       --  Set Environment_Task'Callable to false to notify library-level tasks
 727       --  that it is waiting for them (cf 5619-003).
 728
 729       Self_ID.Callable := False;
 730
 731       --  Exit level 2 master, for normal tasks in library-level packages.
 732
 733       Complete_Master;
 734
 735       --  Force termination of "independent" library-level server tasks.
 736
 737       Lock_RTS;
 738
 739       Abort_Dependents (Self_ID);
 740
 741       if not Single_Lock then
 742          Unlock_RTS;
 743       end if;
 744
 745       --  We need to explicitly wait for the task to be
 746       --  terminated here because on true concurrent system, we
 747       --  may end this procedure before the tasks are really
 748       --  terminated.
 749
 750       Write_Lock (Self_ID);
 751
 752       loop
 753          exit when Utilities.Independent_Task_Count = 0;
 754
 755          --  We used to yield here, but this did not take into account
 756          --  low priority tasks that would cause dead lock in some cases.
 757          --  See 8126-020.
 758
 759          Timed_Sleep
 760            (Self_ID, 0.01, System.OS_Primitives.Relative,
 761             Self_ID.Common.State, Ignore, Ignore);
 762       end loop;
 763
 764       --  ??? On multi-processor environments, it seems that the above loop
 765       --  isn't sufficient, so we need to add an additional delay.
 766
 767       Timed_Sleep
 768         (Self_ID, 0.01, System.OS_Primitives.Relative,
 769          Self_ID.Common.State, Ignore, Ignore);
 770
 771       Unlock (Self_ID);
 772
 773       if Single_Lock then
 774          Unlock_RTS;
 775       end if;
 776
 777       --  Complete the environment task.
 778
 779       Vulnerable_Complete_Task (Self_ID);
 780
 781       System.Finalization_Implementation.Finalize_Global_List;
 782
 783       SSL.Abort_Defer        := SSL.Abort_Defer_NT'Access;
 784       SSL.Abort_Undefer      := SSL.Abort_Undefer_NT'Access;
 785       SSL.Lock_Task          := SSL.Task_Lock_NT'Access;
 786       SSL.Unlock_Task        := SSL.Task_Unlock_NT'Access;
 787       SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
 788       SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
 789       SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access;
 790       SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access;
 791       SSL.Get_Exc_Stack_Addr := SSL.Get_Exc_Stack_Addr_NT'Access;
 792       SSL.Set_Exc_Stack_Addr := SSL.Set_Exc_Stack_Addr_NT'Access;
 793       SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
 794       SSL.Get_Stack_Info     := SSL.Get_Stack_Info_NT'Access;
 795
 796       --  Don't bother trying to finalize Initialization.Global_Task_Lock
 797       --  and System.Task_Primitives.RTS_Lock.
 798
 799    end Finalize_Global_Tasks;
 800
 801    ---------------
 802    -- Free_Task --
 803    ---------------
 804
 805    procedure Free_Task (T : Task_ID) is
 806       Self_Id : constant Task_ID := Self;
 807
 808    begin
 809       if T.Common.State = Terminated then
 810          --  It is not safe to call Abort_Defer or Write_Lock at this stage
 811
 812          Initialization.Task_Lock (Self_Id);
 813
 814          if T.Common.Task_Image /= null then
 815             Free_Task_Image (T.Common.Task_Image);
 816          end if;
 817
 818          Lock_RTS;
 819          Initialization.Remove_From_All_Tasks_List (T);
 820          Unlock_RTS;
 821
 822          Initialization.Task_Unlock (Self_Id);
 823
 824          System.Task_Primitives.Operations.Finalize_TCB (T);
 825
 826       --  If the task is not terminated, then we simply ignore the call. This
 827       --  happens when a user program attempts an unchecked deallocation on
 828       --  a non-terminated task.
 829
 830       else
 831          null;
 832       end if;
 833    end Free_Task;
 834
 835    ----------------------
 836    -- Notify_Exception --
 837    ----------------------
 838
 839    procedure Notify_Exception
 840      (Self_Id : Task_ID;
 841       Excep   : Exception_Occurrence)
 842    is
 843       procedure To_Stderr (S : String);
 844       pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
 845
 846       use System.Task_Info;
 847       use System.Soft_Links;
 848
 849       function To_Address is new
 850         Unchecked_Conversion (Task_ID, System.Address);
 851
 852       function Tailored_Exception_Information
 853         (E : Exception_Occurrence) return String;
 854       pragma Import
 855         (Ada, Tailored_Exception_Information,
 856          "__gnat_tailored_exception_information");
 857
 858    begin
 859       To_Stderr ("task ");
 860
 861       if Self_Id.Common.Task_Image /= null then
 862          To_Stderr (Self_Id.Common.Task_Image.all);
 863          To_Stderr ("_");
 864       end if;
 865
 866       To_Stderr (System.Address_Image (To_Address (Self_Id)));
 867       To_Stderr (" terminated by unhandled exception");
 868       To_Stderr ((1 => ASCII.LF));
 869       To_Stderr (Tailored_Exception_Information (Excep));
 870    end Notify_Exception;
 871
 872    ------------------
 873    -- Task_Wrapper --
 874    ------------------
 875
 876    --  The task wrapper is a procedure that is called first for each task
 877    --  task body, and which in turn calls the compiler-generated task body
 878    --  procedure. The wrapper's main job is to do initialization for the task.
 879    --  It also has some locally declared objects that server as per-task local
 880    --  data. Task finalization is done by Complete_Task, which is called from
 881    --  an at-end handler that the compiler generates.
 882
 883    --  The variable ID in the task wrapper is used to implement the Self
 884    --  function on targets where there is a fast way to find the stack base
 885    --  of the current thread, since it should be at a fixed offset from the
 886    --  stack base.
 887
 888    --  The variable Magic_Number is also used in such implementations
 889    --  of Self, to check whether the current task is an Ada task, as
 890    --  compared to other-language threads.
 891
 892    --  Both act as constants, once initialized, but need to be marked as
 893    --  volatile or aliased to prevent the compiler from optimizing away the
 894    --  storage. See System.Task_Primitives.Operations.Self for more info.
 895
 896    procedure Task_Wrapper (Self_ID : Task_ID) is
 897       ID : Task_ID := Self_ID;
 898       pragma Volatile (ID);
 899       --  Do not delete this variable.
 900       --  In some targets, we need this variable to implement a fast Self.
 901
 902       Magic_Number : Interfaces.C.unsigned := 16#ADAADAAD#;
 903       pragma Volatile (Magic_Number);
 904       --  We use this to verify that we are looking at an Ada task,
 905       --  inside of System.Task_Primitives.Operations.Self.
 906
 907       use type System.Parameters.Size_Type;
 908       use type SSE.Storage_Offset;
 909       use System.Standard_Library;
 910
 911       Secondary_Stack : aliased SSE.Storage_Array
 912         (1 .. ID.Common.Compiler_Data.Pri_Stack_Info.Size *
 913            SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
 914       Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
 915
 916    begin
 917       pragma Assert (Self_ID.Deferral_Level = 1);
 918
 919       if not Parameters.Sec_Stack_Dynamic then
 920          ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address;
 921          SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
 922       end if;
 923
 924       --  Set the guard page at the bottom of the stack.
 925       --  The call to unprotect the page is done in Terminate_Task
 926
 927       Stack_Guard (Self_ID, True);
 928
 929       --  Initialize low-level TCB components, that
 930       --  cannot be initialized by the creator.
 931       --  Enter_Task sets Self_ID.Known_Tasks_Index
 932       --  and Self_ID.LL.Thread
 933
 934       Enter_Task (Self_ID);
 935
 936       --  We lock RTS_Lock to wait for activator to finish activating
 937       --  the rest of the chain, so that everyone in the chain comes out
 938       --  in priority order.
 939       --  This also protects the value of
 940       --   Self_ID.Common.Activator.Common.Wait_Count.
 941
 942       Lock_RTS;
 943       Unlock_RTS;
 944
 945       begin
 946          --  We are separating the following portion of the code in order to
 947          --  place the exception handlers in a different block.
 948          --  In this way we do not call Set_Jmpbuf_Address (which needs
 949          --  Self) before we set Self in Enter_Task
 950
 951          --  Call the task body procedure.
 952
 953          --  The task body is called with abort still deferred. That
 954          --  eliminates a dangerous window, for which we had to patch-up in
 955          --  Terminate_Task.
 956          --  During the expansion of the task body, we insert an RTS-call
 957          --  to Abort_Undefer, at the first point where abort should be
 958          --  allowed.
 959
 960          Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
 961          Terminate_Task (Self_ID);
 962
 963       exception
 964          when Standard'Abort_Signal =>
 965             Terminate_Task (Self_ID);
 966
 967          when others =>
 968             --  ??? Using an E : others here causes CD2C11A  to fail on
 969             --      DEC Unix, see 7925-005.
 970
 971             if Exception_Trace = Unhandled_Raise then
 972                Notify_Exception (Self_ID, SSL.Get_Current_Excep.all.all);
 973             end if;
 974
 975             Terminate_Task (Self_ID);
 976       end;
 977    end Task_Wrapper;
 978
 979    --------------------
 980    -- Terminate_Task --
 981    --------------------
 982
 983    --  Before we allow the thread to exit, we must clean up. This is a
 984    --  a delicate job. We must wake up the task's master, who may immediately
 985    --  try to deallocate the ATCB out from under the current task WHILE IT IS
 986    --  STILL EXECUTING.
 987
 988    --  To avoid this, the parent task must be blocked up to the last thing
 989    --  done before the call to Exit_Task. The trouble is that we have another
 990    --  step that we also want to postpone to the very end, i.e., calling
 991    --  SSL.Destroy_TSD. We have to postpone that until the end because
 992    --  compiler-generated code is likely to try to access that data at just
 993    --  about any point.
 994
 995    --  We can't call Destroy_TSD while we are holding any other locks, because
 996    --  it locks Global_Task_Lock, and our deadlock prevention rules require
 997    --  that to be the outermost lock. Our first "solution" was to just lock
 998    --  Global_Task_Lock in addition to the other locks, and force the parent
 999    --  to also lock this lock between its wakeup and its freeing of the ATCB.
1000    --  See Complete_Task for the parent-side of the code that has the matching
1001    --  calls to Task_Lock and Task_Unlock. That was not really a solution,
1002    --  since the operation Task_Unlock continued to access the ATCB after
1003    --  unlocking, after which the parent was observed to race ahead,
1004    --  deallocate the ATCB, and then reallocate it to another task. The
1005    --  call to Undefer_Abortion in Task_Unlock by the "terminated" task was
1006    --  overwriting the data of the new task that reused the ATCB! To solve
1007    --  this problem, we introduced the new operation Final_Task_Unlock.
1008
1009    procedure Terminate_Task (Self_ID : Task_ID) is
1010       Environment_Task : constant Task_ID := STPO.Environment_Task;
1011
1012    begin
1013       if Runtime_Traces then
1014          Send_Trace_Info (T_Terminate);
1015       end if;
1016
1017       --  Since GCC cannot allocate stack chunks efficiently without reordering
1018       --  some of the allocations, we have to handle this unexpected situation
1019       --  here. We should normally never have to call Vulnerable_Complete_Task
1020       --  here. See 6602-003 for more details.
1021
1022       if Self_ID.Common.Activator /= null then
1023          Vulnerable_Complete_Task (Self_ID);
1024       end if;
1025
1026       Initialization.Task_Lock (Self_ID);
1027
1028       if Single_Lock then
1029          Lock_RTS;
1030       end if;
1031
1032       --  Check if the current task is an independent task
1033       --  If so, decrement the Independent_Task_Count value.
1034
1035       if Self_ID.Master_of_Task = 2 then
1036          if Single_Lock then
1037             Utilities.Independent_Task_Count :=
1038               Utilities.Independent_Task_Count - 1;
1039
1040          else
1041             Write_Lock (Environment_Task);
1042             Utilities.Independent_Task_Count :=
1043               Utilities.Independent_Task_Count - 1;
1044             Unlock (Environment_Task);
1045          end if;
1046       end if;
1047
1048       --  Unprotect the guard page if needed.
1049
1050       Stack_Guard (Self_ID, False);
1051
1052       Utilities.Make_Passive (Self_ID, Task_Completed => True);
1053
1054       if Single_Lock then
1055          Unlock_RTS;
1056       end if;
1057
1058       pragma Assert (Check_Exit (Self_ID));
1059
1060       SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
1061       Initialization.Final_Task_Unlock (Self_ID);
1062
1063       --  WARNING
1064       --  past this point, this thread must assume that the ATCB
1065       --  has been deallocated. It should not be accessed again.
1066
1067       STPO.Exit_Task;
1068    end Terminate_Task;
1069
1070    ----------------
1071    -- Terminated --
1072    ----------------
1073
1074    function Terminated (T : Task_ID) return Boolean is
1075       Result  : Boolean;
1076       Self_ID : Task_ID := STPO.Self;
1077
1078    begin
1079       Initialization.Defer_Abort_Nestable (Self_ID);
1080
1081       if Single_Lock then
1082          Lock_RTS;
1083       end if;
1084
1085       Write_Lock (T);
1086       Result := T.Common.State = Terminated;
1087       Unlock (T);
1088
1089       if Single_Lock then
1090          Unlock_RTS;
1091       end if;
1092
1093       Initialization.Undefer_Abort_Nestable (Self_ID);
1094       return Result;
1095    end Terminated;
1096
1097    ------------------------------------
1098    -- Vulnerable_Complete_Activation --
1099    ------------------------------------
1100
1101    --  As in several other places, the locks of the activator and activated
1102    --  task are both locked here. This follows our deadlock prevention lock
1103    --  ordering policy, since the activated task must be created after the
1104    --  activator.
1105
1106    procedure Vulnerable_Complete_Activation (Self_ID : Task_ID) is
1107       Activator : constant Task_ID := Self_ID.Common.Activator;
1108
1109    begin
1110       pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
1111
1112       Write_Lock (Activator);
1113       Write_Lock (Self_ID);
1114
1115       pragma Assert (Self_ID.Common.Activator /= null);
1116
1117       --  Remove dangling reference to Activator,
1118       --  since a task may outlive its activator.
1119
1120       Self_ID.Common.Activator := null;
1121
1122       --  Wake up the activator, if it is waiting for a chain
1123       --  of tasks to activate, and we are the last in the chain
1124       --  to complete activation
1125
1126       if Activator.Common.State = Activator_Sleep then
1127          Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
1128
1129          if Activator.Common.Wait_Count = 0 then
1130             Wakeup (Activator, Activator_Sleep);
1131          end if;
1132       end if;
1133
1134       --  The activator raises a Tasking_Error if any task
1135       --  it is activating is completed before the activation is
1136       --  done. However, if the reason for the task completion is
1137       --  an abortion, we do not raise an exception. ARM 9.2(5).
1138
1139       if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
1140          Activator.Common.Activation_Failed := True;
1141       end if;
1142
1143       Unlock (Self_ID);
1144       Unlock (Activator);
1145
1146       --  After the activation, active priority should be the same
1147       --  as base priority. We must unlock the Activator first,
1148       --  though, since it should not wait if we have lower priority.
1149
1150       if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
1151          Write_Lock (Self_ID);
1152          Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1153          Unlock (Self_ID);
1154       end if;
1155    end Vulnerable_Complete_Activation;
1156
1157    --------------------------------
1158    -- Vulnerable_Complete_Master --
1159    --------------------------------
1160
1161    procedure Vulnerable_Complete_Master (Self_ID : Task_ID) is
1162       C      : Task_ID;
1163       P      : Task_ID;
1164       CM     : Master_Level := Self_ID.Master_Within;
1165       T      : aliased Task_ID;
1166
1167       To_Be_Freed : Task_ID;
1168       --  This is a list of ATCBs to be freed, after we have released
1169       --  all RTS locks. This is necessary because of the locking order
1170       --  rules, since the storage manager uses Global_Task_Lock.
1171
1172       pragma Warnings (Off);
1173       function Check_Unactivated_Tasks return Boolean;
1174       pragma Warnings (On);
1175       --  Temporary error-checking code below. This is part of the checks
1176       --  added in the new run time. Call it only inside a pragma Assert.
1177
1178       -----------------------------
1179       -- Check_Unactivated_Tasks --
1180       -----------------------------
1181
1182       function Check_Unactivated_Tasks return Boolean is
1183       begin
1184          if not Single_Lock then
1185             Lock_RTS;
1186          end if;
1187
1188          Write_Lock (Self_ID);
1189          C := All_Tasks_List;
1190
1191          while C /= null loop
1192             if C.Common.Activator = Self_ID then
1193                return False;
1194             end if;
1195
1196             if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1197                Write_Lock (C);
1198
1199                if C.Common.State = Unactivated then
1200                   return False;
1201                end if;
1202
1203                Unlock (C);
1204             end if;
1205
1206             C := C.Common.All_Tasks_Link;
1207          end loop;
1208
1209          Unlock (Self_ID);
1210
1211          if not Single_Lock then
1212             Unlock_RTS;
1213          end if;
1214
1215          return True;
1216       end Check_Unactivated_Tasks;
1217
1218    --  Start of processing for Vulnerable_Complete_Master
1219
1220    begin
1221       pragma Debug
1222         (Debug.Trace (Self_ID, "V_Complete_Master", 'C'));
1223
1224       pragma Assert (Self_ID.Common.Wait_Count = 0);
1225       pragma Assert (Self_ID.Deferral_Level > 0);
1226
1227       --  Count how many active dependent tasks this master currently
1228       --  has, and record this in Wait_Count.
1229
1230       --  This count should start at zero, since it is initialized to
1231       --  zero for new tasks, and the task should not exit the
1232       --  sleep-loops that use this count until the count reaches zero.
1233
1234       Lock_RTS;
1235       Write_Lock (Self_ID);
1236       C := All_Tasks_List;
1237
1238       while C /= null loop
1239          if C.Common.Activator = Self_ID then
1240             pragma Assert (C.Common.State = Unactivated);
1241
1242             Write_Lock (C);
1243             C.Common.Activator := null;
1244             C.Common.State := Terminated;
1245             C.Callable := False;
1246             Utilities.Cancel_Queued_Entry_Calls (C);
1247             Unlock (C);
1248          end if;
1249
1250          if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1251             Write_Lock (C);
1252
1253             if C.Awake_Count /= 0 then
1254                Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1255             end if;
1256
1257             Unlock (C);
1258          end if;
1259
1260          C := C.Common.All_Tasks_Link;
1261       end loop;
1262
1263       Self_ID.Common.State := Master_Completion_Sleep;
1264       Unlock (Self_ID);
1265
1266       if not Single_Lock then
1267          Unlock_RTS;
1268       end if;
1269
1270       --  Wait until dependent tasks are all terminated or ready to terminate.
1271       --  While waiting, the task may be awakened if the task's priority needs
1272       --  changing, or this master is aborted. In the latter case, we want
1273       --  to abort the dependents, and resume waiting until Wait_Count goes
1274       --  to zero.
1275
1276       Write_Lock (Self_ID);
1277
1278       loop
1279          Initialization.Poll_Base_Priority_Change (Self_ID);
1280          exit when Self_ID.Common.Wait_Count = 0;
1281
1282          --  Here is a difference as compared to Complete_Master
1283
1284          if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1285            and then not Self_ID.Dependents_Aborted
1286          then
1287             if Single_Lock then
1288                Abort_Dependents (Self_ID);
1289             else
1290                Unlock (Self_ID);
1291                Lock_RTS;
1292                Abort_Dependents (Self_ID);
1293                Unlock_RTS;
1294                Write_Lock (Self_ID);
1295             end if;
1296          else
1297             Sleep (Self_ID, Master_Completion_Sleep);
1298          end if;
1299       end loop;
1300
1301       Self_ID.Common.State := Runnable;
1302       Unlock (Self_ID);
1303
1304       --  Dependents are all terminated or on terminate alternatives.
1305       --  Now, force those on terminate alternatives to terminate, by
1306       --  aborting them.
1307
1308       pragma Assert (Check_Unactivated_Tasks);
1309
1310       if Self_ID.Alive_Count > 1 then
1311          --  ???
1312          --  Consider finding a way to skip the following extra steps if there
1313          --  are no dependents with terminate alternatives. This could be done
1314          --  by adding another count to the ATCB, similar to Awake_Count, but
1315          --  keeping track of tasks that are on terminate alternatives.
1316
1317          pragma Assert (Self_ID.Common.Wait_Count = 0);
1318
1319          --  Force any remaining dependents to terminate, by aborting them.
1320
1321          if not Single_Lock then
1322             Lock_RTS;
1323          end if;
1324
1325          Abort_Dependents (Self_ID);
1326
1327          --  Above, when we "abort" the dependents we are simply using this
1328          --  operation for convenience. We are not required to support the full
1329          --  abort-statement semantics; in particular, we are not required to
1330          --  immediately cancel any queued or in-service entry calls. That is
1331          --  good, because if we tried to cancel a call we would need to lock
1332          --  the caller, in order to wake the caller up. Our anti-deadlock
1333          --  rules prevent us from doing that without releasing the locks on C
1334          --  and Self_ID. Releasing and retaking those locks would be wasteful
1335          --  at best, and should not be considered further without more
1336          --  detailed analysis of potential concurrent accesses to the
1337          --  ATCBs of C and Self_ID.
1338
1339          --  Count how many "alive" dependent tasks this master currently
1340          --  has, and record this in Wait_Count. This count should start at
1341          --  zero, since it is initialized to zero for new tasks, and the
1342          --  task should not exit the sleep-loops that use this count until
1343          --  the count reaches zero.
1344
1345          pragma Assert (Self_ID.Common.Wait_Count = 0);
1346
1347          Write_Lock (Self_ID);
1348          C := All_Tasks_List;
1349
1350          while C /= null loop
1351             if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then
1352                Write_Lock (C);
1353
1354                pragma Assert (C.Awake_Count = 0);
1355
1356                if C.Alive_Count > 0 then
1357                   pragma Assert (C.Terminate_Alternative);
1358                   Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1359                end if;
1360
1361                Unlock (C);
1362             end if;
1363
1364             C := C.Common.All_Tasks_Link;
1365          end loop;
1366
1367          Self_ID.Common.State := Master_Phase_2_Sleep;
1368          Unlock (Self_ID);
1369
1370          if not Single_Lock then
1371             Unlock_RTS;
1372          end if;
1373
1374          --  Wait for all counted tasks to finish terminating themselves.
1375
1376          Write_Lock (Self_ID);
1377
1378          loop
1379             Initialization.Poll_Base_Priority_Change (Self_ID);
1380             exit when Self_ID.Common.Wait_Count = 0;
1381             Sleep (Self_ID, Master_Phase_2_Sleep);
1382          end loop;
1383
1384          Self_ID.Common.State := Runnable;
1385          Unlock (Self_ID);
1386       end if;
1387
1388       --  We don't wake up for abortion here. We are already terminating
1389       --  just as fast as we can, so there is no point.
1390
1391       --  Remove terminated tasks from the list of Self_ID's dependents, but
1392       --  don't free their ATCBs yet, because of lock order restrictions,
1393       --  which don't allow us to call "free" or "malloc" while holding any
1394       --  other locks. Instead, we put those ATCBs to be freed onto a
1395       --  temporary list, called To_Be_Freed.
1396
1397       if not Single_Lock then
1398          Lock_RTS;
1399       end if;
1400
1401       C := All_Tasks_List;
1402       P := null;
1403
1404       while C /= null loop
1405          if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then
1406             if P /= null then
1407                P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
1408             else
1409                All_Tasks_List := C.Common.All_Tasks_Link;
1410             end if;
1411
1412             T := C.Common.All_Tasks_Link;
1413             C.Common.All_Tasks_Link := To_Be_Freed;
1414             To_Be_Freed := C;
1415             C := T;
1416
1417          else
1418             P := C;
1419             C := C.Common.All_Tasks_Link;
1420          end if;
1421       end loop;
1422
1423       Unlock_RTS;
1424
1425       --  Free all the ATCBs on the list To_Be_Freed.
1426
1427       --  The ATCBs in the list are no longer in All_Tasks_List, and after
1428       --  any interrupt entries are detached from them they should no longer
1429       --  be referenced.
1430
1431       --  Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1432       --  avoid a race between a terminating task and its parent. The parent
1433       --  might try to deallocate the ACTB out from underneath the exiting
1434       --  task. Note that Free will also lock Global_Task_Lock, but that is
1435       --  OK, since this is the *one* lock for which we have a mechanism to
1436       --  support nested locking. See Task_Wrapper and its finalizer for more
1437       --  explanation.
1438
1439       --  ???
1440       --  The check "T.Common.Parent /= null ..." below is to prevent dangling
1441       --  references to terminated library-level tasks, which could
1442       --  otherwise occur during finalization of library-level objects.
1443       --  A better solution might be to hook task objects into the
1444       --  finalization chain and deallocate the ATCB when the task
1445       --  object is deallocated. However, this change is not likely
1446       --  to gain anything significant, since all this storage should
1447       --  be recovered en-masse when the process exits.
1448
1449       while To_Be_Freed /= null loop
1450          T := To_Be_Freed;
1451          To_Be_Freed := T.Common.All_Tasks_Link;
1452
1453          --  ??? On SGI there is currently no Interrupt_Manager, that's
1454          --  why we need to check if the Interrupt_Manager_ID is null
1455
1456          if T.Interrupt_Entry and Interrupt_Manager_ID /= null then
1457             declare
1458                Detach_Interrupt_Entries_Index : Task_Entry_Index := 1;
1459                --  Corresponds to the entry index of System.Interrupts.
1460                --  Interrupt_Manager.Detach_Interrupt_Entries.
1461                --  Be sure to update this value when changing
1462                --  Interrupt_Manager specs.
1463
1464                type Param_Type is access all Task_ID;
1465
1466                Param : aliased Param_Type := T'Access;
1467
1468             begin
1469                System.Tasking.Rendezvous.Call_Simple
1470                  (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
1471                   Param'Address);
1472             end;
1473          end if;
1474
1475          if (T.Common.Parent /= null
1476               and then T.Common.Parent.Common.Parent /= null)
1477            or else T.Master_of_Task > 3
1478          then
1479             Initialization.Task_Lock (Self_ID);
1480
1481             --  If Sec_Stack_Addr is not null, it means that Destroy_TSD
1482             --  has not been called yet (case of an unactivated task).
1483
1484             if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then
1485                SSL.Destroy_TSD (T.Common.Compiler_Data);
1486             end if;
1487
1488             Vulnerable_Free_Task (T);
1489             Initialization.Task_Unlock (Self_ID);
1490          end if;
1491       end loop;
1492
1493       --  It might seem nice to let the terminated task deallocate its own
1494       --  ATCB. That would not cover the case of unactivated tasks. It also
1495       --  would force us to keep the underlying thread around past termination,
1496       --  since references to the ATCB are possible past termination.
1497       --  Currently, we get rid of the thread as soon as the task terminates,
1498       --  and let the parent recover the ATCB later.
1499
1500       --  Some day, if we want to recover the ATCB earlier, at task
1501       --  termination, we could consider using "fat task IDs", that include the
1502       --  serial number with the ATCB pointer, to catch references to tasks
1503       --  that no longer have ATCBs. It is not clear how much this would gain,
1504       --  since the user-level task object would still be occupying storage.
1505
1506       --  Make next master level up active.
1507       --  We don't need to lock the ATCB, since the value is only updated by
1508       --  each task for itself.
1509
1510       Self_ID.Master_Within := CM - 1;
1511    end Vulnerable_Complete_Master;
1512
1513    ------------------------------
1514    -- Vulnerable_Complete_Task --
1515    ------------------------------
1516
1517    --  Complete the calling task
1518
1519    --  This procedure must be called with abort deferred. (That's why the
1520    --  name has "Vulnerable" in it.) It should only be called by Complete_Task
1521    --  and Finalize_Global_Tasks (for the environment task).
1522
1523    --  The effect is similar to that of Complete_Master. Differences include
1524    --  the closing of entries here, and computation of the number of active
1525    --  dependent tasks in Complete_Master.
1526
1527    --  We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1528    --  because that does its own locking, and because we do not need the lock
1529    --  to test Self_ID.Common.Activator. That value should only be read and
1530    --  modified by Self.
1531
1532    procedure Vulnerable_Complete_Task (Self_ID : Task_ID) is
1533    begin
1534       pragma Assert (Self_ID.Deferral_Level > 0);
1535       pragma Assert (Self_ID = Self);
1536       pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1
1537                        or else
1538                      Self_ID.Master_Within = Self_ID.Master_of_Task + 2);
1539       pragma Assert (Self_ID.Common.Wait_Count = 0);
1540       pragma Assert (Self_ID.Open_Accepts = null);
1541       pragma Assert (Self_ID.ATC_Nesting_Level = 1);
1542
1543       pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
1544
1545       if Single_Lock then
1546          Lock_RTS;
1547       end if;
1548
1549       Write_Lock (Self_ID);
1550       Self_ID.Callable := False;
1551
1552       --  In theory, Self should have no pending entry calls left on its
1553       --  call-stack. Each async. select statement should clean its own call,
1554       --  and blocking entry calls should defer abort until the calls are
1555       --  cancelled, then clean up.
1556
1557       Utilities.Cancel_Queued_Entry_Calls (Self_ID);
1558       Unlock (Self_ID);
1559
1560       if Self_ID.Common.Activator /= null then
1561          Vulnerable_Complete_Activation (Self_ID);
1562       end if;
1563
1564       if Single_Lock then
1565          Unlock_RTS;
1566       end if;
1567
1568       --  If Self_ID.Master_Within = Self_ID.Master_of_Task + 2
1569       --  we may have dependent tasks for which we need to wait.
1570       --  Otherwise, we can just exit.
1571
1572       if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then
1573          Vulnerable_Complete_Master (Self_ID);
1574       end if;
1575    end Vulnerable_Complete_Task;
1576
1577    --------------------------
1578    -- Vulnerable_Free_Task --
1579    --------------------------
1580
1581    --  Recover all runtime system storage associated with the task T.
1582    --  This should only be called after T has terminated and will no
1583    --  longer be referenced.
1584
1585    --  For tasks created by an allocator that fails, due to an exception,
1586    --  it is called from Expunge_Unactivated_Tasks.
1587
1588    --  For tasks created by elaboration of task object declarations it
1589    --  is called from the finalization code of the Task_Wrapper procedure.
1590    --  It is also called from Unchecked_Deallocation, for objects that
1591    --  are or contain tasks.
1592
1593    procedure Vulnerable_Free_Task (T : Task_ID) is
1594    begin
1595       pragma Debug
1596         (Debug.Trace ("Vulnerable_Free_Task", T, 'C'));
1597
1598       if Single_Lock then
1599          Lock_RTS;
1600       end if;
1601
1602       Write_Lock (T);
1603       Initialization.Finalize_Attributes_Link.all (T);
1604       Unlock (T);
1605
1606       if Single_Lock then
1607          Unlock_RTS;
1608       end if;
1609
1610       if T.Common.Task_Image /= null then
1611          Free_Task_Image (T.Common.Task_Image);
1612       end if;
1613
1614       System.Task_Primitives.Operations.Finalize_TCB (T);
1615    end Vulnerable_Free_Task;
1616
1617 begin
1618    --  Establish the Adafinal softlink.
1619    --  This is not done inside the central RTS initialization routine
1620    --  to avoid with-ing this package from System.Tasking.Initialization.
1621
1622    SSL.Adafinal := Finalize_Global_Tasks'Access;
1623
1624    --  Establish soft links for subprograms that manipulate master_id's.
1625    --  This cannot be done when the RTS is initialized, because of various
1626    --  elaboration constraints.
1627
1628    SSL.Current_Master  := Stages.Current_Master'Access;
1629    SSL.Enter_Master    := Stages.Enter_Master'Access;
1630    SSL.Complete_Master := Stages.Complete_Master'Access;
1631 end System.Tasking.Stages;