1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT 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-2018, 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 3,  or (at your option) any later ver- --
14-- sion.  GNAT 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.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNARL was developed by the GNARL team at Florida State University.       --
28-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
29--                                                                          --
30------------------------------------------------------------------------------
31
32pragma Polling (Off);
33--  Turn off polling, we do not want ATC polling to take place during tasking
34--  operations. It causes infinite loops and other problems.
35
36pragma Partition_Elaboration_Policy (Concurrent);
37--  This package only implements the concurrent elaboration policy. This pragma
38--  will enforce it (and detect conflicts with user specified policy).
39
40with Ada.Exceptions;
41with Ada.Unchecked_Deallocation;
42
43with System.Interrupt_Management;
44with System.Tasking.Debug;
45with System.Address_Image;
46with System.Task_Primitives;
47with System.Task_Primitives.Operations;
48with System.Tasking.Utilities;
49with System.Tasking.Queuing;
50with System.Tasking.Rendezvous;
51with System.OS_Primitives;
52with System.Secondary_Stack;
53with System.Restrictions;
54with System.Standard_Library;
55with System.Stack_Usage;
56with System.Storage_Elements;
57
58with System.Soft_Links;
59--  These are procedure pointers to non-tasking routines that use task
60--  specific data. In the absence of tasking, these routines refer to global
61--  data. In the presence of tasking, they must be replaced with pointers to
62--  task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current
63--  _Excep, Finalize_Library_Objects, Task_Termination, Handler.
64
65with System.Tasking.Initialization;
66pragma Elaborate_All (System.Tasking.Initialization);
67--  This insures that tasking is initialized if any tasks are created
68
69package body System.Tasking.Stages is
70
71   package STPO renames System.Task_Primitives.Operations;
72   package SSL  renames System.Soft_Links;
73   package SSE  renames System.Storage_Elements;
74
75   use Ada.Exceptions;
76
77   use Parameters;
78   use Secondary_Stack;
79   use Task_Primitives;
80   use Task_Primitives.Operations;
81
82   -----------------------
83   -- Local Subprograms --
84   -----------------------
85
86   procedure Free is new
87     Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
88
89   procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
90   --  This procedure outputs the task specific message for exception
91   --  tracing purposes.
92
93   procedure Task_Wrapper (Self_ID : Task_Id);
94   pragma Convention (C, Task_Wrapper);
95   --  This is the procedure that is called by the GNULL from the new context
96   --  when a task is created. It waits for activation and then calls the task
97   --  body procedure. When the task body procedure completes, it terminates
98   --  the task.
99   --
100   --  The Task_Wrapper's address will be provided to the underlying threads
101   --  library as the task entry point. Convention C is what makes most sense
102   --  for that purpose (Export C would make the function globally visible,
103   --  and affect the link name on which GDB depends). This will in addition
104   --  trigger an automatic stack alignment suitable for GCC's assumptions if
105   --  need be.
106
107   --  "Vulnerable_..." in the procedure names below means they must be called
108   --  with abort deferred.
109
110   procedure Vulnerable_Complete_Task (Self_ID : Task_Id);
111   --  Complete the calling task. This procedure must be called with
112   --  abort deferred. It should only be called by Complete_Task and
113   --  Finalize_Global_Tasks (for the environment task).
114
115   procedure Vulnerable_Complete_Master (Self_ID : Task_Id);
116   --  Complete the current master of the calling task. This procedure
117   --  must be called with abort deferred. It should only be called by
118   --  Vulnerable_Complete_Task and Complete_Master.
119
120   procedure Vulnerable_Complete_Activation (Self_ID : Task_Id);
121   --  Signal to Self_ID's activator that Self_ID has completed activation.
122   --  This procedure must be called with abort deferred.
123
124   procedure Abort_Dependents (Self_ID : Task_Id);
125   --  Abort all the direct dependents of Self at its current master nesting
126   --  level, plus all of their dependents, transitively. RTS_Lock should be
127   --  locked by the caller.
128
129   procedure Vulnerable_Free_Task (T : Task_Id);
130   --  Recover all runtime system storage associated with the task T. This
131   --  should only be called after T has terminated and will no longer be
132   --  referenced.
133   --
134   --  For tasks created by an allocator that fails, due to an exception, it is
135   --  called from Expunge_Unactivated_Tasks.
136   --
137   --  Different code is used at master completion, in Terminate_Dependents,
138   --  due to a need for tighter synchronization with the master.
139
140   ----------------------
141   -- Abort_Dependents --
142   ----------------------
143
144   procedure Abort_Dependents (Self_ID : Task_Id) is
145      C : Task_Id;
146      P : Task_Id;
147
148      --  Each task C will take care of its own dependents, so there is no
149      --  need to worry about them here. In fact, it would be wrong to abort
150      --  indirect dependents here, because we can't distinguish between
151      --  duplicate master ids. For example, suppose we have three nested
152      --  task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and
153      --  both P and Q are task masters). Q will have the same master id as
154      --  Master_Of_Task of T3. Previous versions of this would abort T3 when
155      --  Q calls Complete_Master, which was completely wrong.
156
157   begin
158      C := All_Tasks_List;
159      while C /= null loop
160         P := C.Common.Parent;
161
162         if P = Self_ID then
163            if C.Master_Of_Task = Self_ID.Master_Within then
164               pragma Debug
165                 (Debug.Trace (Self_ID, "Aborting", 'X', C));
166               Utilities.Abort_One_Task (Self_ID, C);
167               C.Dependents_Aborted := True;
168            end if;
169         end if;
170
171         C := C.Common.All_Tasks_Link;
172      end loop;
173
174      Self_ID.Dependents_Aborted := True;
175   end Abort_Dependents;
176
177   -----------------
178   -- Abort_Tasks --
179   -----------------
180
181   procedure Abort_Tasks (Tasks : Task_List) is
182   begin
183      Utilities.Abort_Tasks (Tasks);
184   end Abort_Tasks;
185
186   --------------------
187   -- Activate_Tasks --
188   --------------------
189
190   --  Note that locks of activator and activated task are both locked here.
191   --  This is necessary because C.Common.State and Self.Common.Wait_Count have
192   --  to be synchronized. This is safe from deadlock because the activator is
193   --  always created before the activated task. That satisfies our
194   --  in-order-of-creation ATCB locking policy.
195
196   --  At one point, we may also lock the parent, if the parent is different
197   --  from the activator. That is also consistent with the lock ordering
198   --  policy, since the activator cannot be created before the parent.
199
200   --  Since we are holding both the activator's lock, and Task_Wrapper locks
201   --  that before it does anything more than initialize the low-level ATCB
202   --  components, it should be safe to wait to update the counts until we see
203   --  that the thread creation is successful.
204
205   --  If the thread creation fails, we do need to close the entries of the
206   --  task. The first phase, of dequeuing calls, only requires locking the
207   --  acceptor's ATCB, but the waking up of the callers requires locking the
208   --  caller's ATCB. We cannot safely do this while we are holding other
209   --  locks. Therefore, the queue-clearing operation is done in a separate
210   --  pass over the activation chain.
211
212   procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is
213      Self_ID        : constant Task_Id := STPO.Self;
214      P              : Task_Id;
215      C              : Task_Id;
216      Next_C, Last_C : Task_Id;
217      Activate_Prio  : System.Any_Priority;
218      Success        : Boolean;
219      All_Elaborated : Boolean := True;
220
221   begin
222      --  If pragma Detect_Blocking is active, then we must check whether this
223      --  potentially blocking operation is called from a protected action.
224
225      if System.Tasking.Detect_Blocking
226        and then Self_ID.Common.Protected_Action_Nesting > 0
227      then
228         raise Program_Error with "potentially blocking operation";
229      end if;
230
231      pragma Debug
232        (Debug.Trace (Self_ID, "Activate_Tasks", 'C'));
233
234      Initialization.Defer_Abort_Nestable (Self_ID);
235
236      pragma Assert (Self_ID.Common.Wait_Count = 0);
237
238      --  Lock RTS_Lock, to prevent activated tasks from racing ahead before
239      --  we finish activating the chain.
240
241      Lock_RTS;
242
243      --  Check that all task bodies have been elaborated
244
245      C := Chain_Access.T_ID;
246      Last_C := null;
247      while C /= null loop
248         if C.Common.Elaborated /= null
249           and then not C.Common.Elaborated.all
250         then
251            All_Elaborated := False;
252         end if;
253
254         --  Reverse the activation chain so that tasks are activated in the
255         --  same order they're declared.
256
257         Next_C := C.Common.Activation_Link;
258         C.Common.Activation_Link := Last_C;
259         Last_C := C;
260         C := Next_C;
261      end loop;
262
263      Chain_Access.T_ID := Last_C;
264
265      if not All_Elaborated then
266         Unlock_RTS;
267         Initialization.Undefer_Abort_Nestable (Self_ID);
268         raise Program_Error with "Some tasks have not been elaborated";
269      end if;
270
271      --  Activate all the tasks in the chain. Creation of the thread of
272      --  control was deferred until activation. So create it now.
273
274      C := Chain_Access.T_ID;
275      while C /= null loop
276         if C.Common.State /= Terminated then
277            pragma Assert (C.Common.State = Unactivated);
278
279            P := C.Common.Parent;
280            Write_Lock (P);
281            Write_Lock (C);
282
283            Activate_Prio :=
284              (if C.Common.Base_Priority < Get_Priority (Self_ID)
285               then Get_Priority (Self_ID)
286               else C.Common.Base_Priority);
287
288            System.Task_Primitives.Operations.Create_Task
289              (C, Task_Wrapper'Address,
290               Parameters.Size_Type
291                 (C.Common.Compiler_Data.Pri_Stack_Info.Size),
292               Activate_Prio, Success);
293
294            --  There would be a race between the created task and the creator
295            --  to do the following initialization, if we did not have a
296            --  Lock/Unlock_RTS pair in the task wrapper to prevent it from
297            --  racing ahead.
298
299            if Success then
300               C.Common.State := Activating;
301               C.Awake_Count := 1;
302               C.Alive_Count := 1;
303               P.Awake_Count := P.Awake_Count + 1;
304               P.Alive_Count := P.Alive_Count + 1;
305
306               if P.Common.State = Master_Completion_Sleep and then
307                 C.Master_Of_Task = P.Master_Within
308               then
309                  pragma Assert (Self_ID /= P);
310                  P.Common.Wait_Count := P.Common.Wait_Count + 1;
311               end if;
312
313               for J in System.Tasking.Debug.Known_Tasks'Range loop
314                  if System.Tasking.Debug.Known_Tasks (J) = null then
315                     System.Tasking.Debug.Known_Tasks (J) := C;
316                     C.Known_Tasks_Index := J;
317                     exit;
318                  end if;
319               end loop;
320
321               if Global_Task_Debug_Event_Set then
322                  Debug.Signal_Debug_Event
323                   (Debug.Debug_Event_Activating, C);
324               end if;
325
326               C.Common.State := Runnable;
327
328               Unlock (C);
329               Unlock (P);
330
331            else
332               --  No need to set Awake_Count, State, etc. here since the loop
333               --  below will do that for any Unactivated tasks.
334
335               Unlock (C);
336               Unlock (P);
337               Self_ID.Common.Activation_Failed := True;
338            end if;
339         end if;
340
341         C := C.Common.Activation_Link;
342      end loop;
343
344      if not Single_Lock then
345         Unlock_RTS;
346      end if;
347
348      --  Close the entries of any tasks that failed thread creation, and count
349      --  those that have not finished activation.
350
351      Write_Lock (Self_ID);
352      Self_ID.Common.State := Activator_Sleep;
353
354      C := Chain_Access.T_ID;
355      while C /= null loop
356         Write_Lock (C);
357
358         if C.Common.State = Unactivated then
359            C.Common.Activator := null;
360            C.Common.State := Terminated;
361            C.Callable := False;
362            Utilities.Cancel_Queued_Entry_Calls (C);
363
364         elsif C.Common.Activator /= null then
365            Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
366         end if;
367
368         Unlock (C);
369         P := C.Common.Activation_Link;
370         C.Common.Activation_Link := null;
371         C := P;
372      end loop;
373
374      --  Wait for the activated tasks to complete activation. It is
375      --  unsafe to abort any of these tasks until the count goes to zero.
376
377      loop
378         exit when Self_ID.Common.Wait_Count = 0;
379         Sleep (Self_ID, Activator_Sleep);
380      end loop;
381
382      Self_ID.Common.State := Runnable;
383      Unlock (Self_ID);
384
385      if Single_Lock then
386         Unlock_RTS;
387      end if;
388
389      --  Remove the tasks from the chain
390
391      Chain_Access.T_ID := null;
392      Initialization.Undefer_Abort_Nestable (Self_ID);
393
394      if Self_ID.Common.Activation_Failed then
395         Self_ID.Common.Activation_Failed := False;
396         raise Tasking_Error with "Failure during activation";
397      end if;
398   end Activate_Tasks;
399
400   -------------------------
401   -- Complete_Activation --
402   -------------------------
403
404   procedure Complete_Activation is
405      Self_ID : constant Task_Id := STPO.Self;
406
407   begin
408      Initialization.Defer_Abort_Nestable (Self_ID);
409
410      if Single_Lock then
411         Lock_RTS;
412      end if;
413
414      Vulnerable_Complete_Activation (Self_ID);
415
416      if Single_Lock then
417         Unlock_RTS;
418      end if;
419
420      Initialization.Undefer_Abort_Nestable (Self_ID);
421
422      --  ??? Why do we need to allow for nested deferral here?
423
424   end Complete_Activation;
425
426   ---------------------
427   -- Complete_Master --
428   ---------------------
429
430   procedure Complete_Master is
431      Self_ID : constant Task_Id := STPO.Self;
432   begin
433      pragma Assert
434        (Self_ID.Deferral_Level > 0
435          or else not System.Restrictions.Abort_Allowed);
436      Vulnerable_Complete_Master (Self_ID);
437   end Complete_Master;
438
439   -------------------
440   -- Complete_Task --
441   -------------------
442
443   --  See comments on Vulnerable_Complete_Task for details
444
445   procedure Complete_Task is
446      Self_ID  : constant Task_Id := STPO.Self;
447
448   begin
449      pragma Assert
450        (Self_ID.Deferral_Level > 0
451          or else not System.Restrictions.Abort_Allowed);
452
453      Vulnerable_Complete_Task (Self_ID);
454
455      --  All of our dependents have terminated, never undefer abort again
456
457   end Complete_Task;
458
459   -----------------
460   -- Create_Task --
461   -----------------
462
463   --  Compiler interface only. Do not call from within the RTS. This must be
464   --  called to create a new task.
465
466   procedure Create_Task
467     (Priority             : Integer;
468      Stack_Size           : System.Parameters.Size_Type;
469      Secondary_Stack_Size : System.Parameters.Size_Type;
470      Task_Info            : System.Task_Info.Task_Info_Type;
471      CPU                  : Integer;
472      Relative_Deadline    : Ada.Real_Time.Time_Span;
473      Domain               : Dispatching_Domain_Access;
474      Num_Entries          : Task_Entry_Index;
475      Master               : Master_Level;
476      State                : Task_Procedure_Access;
477      Discriminants        : System.Address;
478      Elaborated           : Access_Boolean;
479      Chain                : in out Activation_Chain;
480      Task_Image           : String;
481      Created_Task         : out Task_Id)
482   is
483      T, P          : Task_Id;
484      Self_ID       : constant Task_Id := STPO.Self;
485      Success       : Boolean;
486      Base_Priority : System.Any_Priority;
487      Len           : Natural;
488      Base_CPU      : System.Multiprocessors.CPU_Range;
489
490      use type System.Multiprocessors.CPU_Range;
491
492      pragma Unreferenced (Relative_Deadline);
493      --  EDF scheduling is not supported by any of the target platforms so
494      --  this parameter is not passed any further.
495
496   begin
497      --  If Master is greater than the current master, it means that Master
498      --  has already awaited its dependent tasks. This raises Program_Error,
499      --  by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads.
500
501      if Self_ID.Master_Of_Task /= Foreign_Task_Level
502        and then Master > Self_ID.Master_Within
503      then
504         raise Program_Error with
505           "create task after awaiting termination";
506      end if;
507
508      --  If pragma Detect_Blocking is active must be checked whether this
509      --  potentially blocking operation is called from a protected action.
510
511      if System.Tasking.Detect_Blocking
512        and then Self_ID.Common.Protected_Action_Nesting > 0
513      then
514         raise Program_Error with "potentially blocking operation";
515      end if;
516
517      pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C'));
518
519      Base_Priority :=
520        (if Priority = Unspecified_Priority
521         then Self_ID.Common.Base_Priority
522         else System.Any_Priority (Priority));
523
524      --  Legal values of CPU are the special Unspecified_CPU value which is
525      --  inserted by the compiler for tasks without CPU aspect, and those in
526      --  the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise
527      --  the task is defined to have failed, and it becomes a completed task
528      --  (RM D.16(14/3)).
529
530      if CPU /= Unspecified_CPU
531        and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
532                    or else
533                  CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
534      then
535         raise Tasking_Error with "CPU not in range";
536
537      --  Normal CPU affinity
538
539      else
540         --  When the application code says nothing about the task affinity
541         --  (task without CPU aspect) then the compiler inserts the value
542         --  Unspecified_CPU which indicates to the run-time library that
543         --  the task will activate and execute on the same processor as its
544         --  activating task if the activating task is assigned a processor
545         --  (RM D.16(14/3)).
546
547         Base_CPU :=
548           (if CPU = Unspecified_CPU
549            then Self_ID.Common.Base_CPU
550            else System.Multiprocessors.CPU_Range (CPU));
551      end if;
552
553      --  Find parent P of new Task, via master level number. Independent
554      --  tasks should have Parent = Environment_Task, and all tasks created
555      --  by independent tasks are also independent. See, for example,
556      --  s-interr.adb, where Interrupt_Manager does "new Server_Task". The
557      --  access type is at library level, so the parent of the Server_Task
558      --  is Environment_Task.
559
560      P := Self_ID;
561
562      if P.Master_Of_Task <= Independent_Task_Level then
563         P := Environment_Task;
564      else
565         while P /= null and then P.Master_Of_Task >= Master loop
566            P := P.Common.Parent;
567         end loop;
568      end if;
569
570      Initialization.Defer_Abort_Nestable (Self_ID);
571
572      begin
573         T := New_ATCB (Num_Entries);
574      exception
575         when others =>
576            Initialization.Undefer_Abort_Nestable (Self_ID);
577            raise Storage_Error with "Cannot allocate task";
578      end;
579
580      --  RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this
581      --  point, it is possible that we may be part of a family of tasks that
582      --  is being aborted.
583
584      Lock_RTS;
585      Write_Lock (Self_ID);
586
587      --  Now, we must check that we have not been aborted. If so, we should
588      --  give up on creating this task, and simply return.
589
590      if not Self_ID.Callable then
591         pragma Assert (Self_ID.Pending_ATC_Level = 0);
592         pragma Assert (Self_ID.Pending_Action);
593         pragma Assert
594           (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated);
595
596         Unlock (Self_ID);
597         Unlock_RTS;
598         Initialization.Undefer_Abort_Nestable (Self_ID);
599
600         --  ??? Should never get here
601
602         pragma Assert (False);
603         raise Standard'Abort_Signal;
604      end if;
605
606      Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
607        Base_Priority, Base_CPU, Domain, Task_Info, Stack_Size, T, Success);
608
609      if not Success then
610         Free (T);
611         Unlock (Self_ID);
612         Unlock_RTS;
613         Initialization.Undefer_Abort_Nestable (Self_ID);
614         raise Storage_Error with "Failed to initialize task";
615      end if;
616
617      if Master = Foreign_Task_Level + 2 then
618
619         --  This should not happen, except when a foreign task creates non
620         --  library-level Ada tasks. In this case, we pretend the master is
621         --  a regular library level task, otherwise the run-time will get
622         --  confused when waiting for these tasks to terminate.
623
624         T.Master_Of_Task := Library_Task_Level;
625
626      else
627         T.Master_Of_Task := Master;
628      end if;
629
630      T.Master_Within := T.Master_Of_Task + 1;
631
632      for L in T.Entry_Calls'Range loop
633         T.Entry_Calls (L).Self := T;
634         T.Entry_Calls (L).Level := L;
635      end loop;
636
637      if Task_Image'Length = 0 then
638         T.Common.Task_Image_Len := 0;
639      else
640         Len := 1;
641         T.Common.Task_Image (1) := Task_Image (Task_Image'First);
642
643         --  Remove unwanted blank space generated by 'Image
644
645         for J in Task_Image'First + 1 .. Task_Image'Last loop
646            if Task_Image (J) /= ' '
647              or else Task_Image (J - 1) /= '('
648            then
649               Len := Len + 1;
650               T.Common.Task_Image (Len) := Task_Image (J);
651               exit when Len = T.Common.Task_Image'Last;
652            end if;
653         end loop;
654
655         T.Common.Task_Image_Len := Len;
656      end if;
657
658      --  Note: we used to have code here to initialize T.Commmon.Domain, but
659      --  that is not needed, since this is initialized in System.Tasking.
660
661      Unlock (Self_ID);
662      Unlock_RTS;
663
664      --  The CPU associated to the task (if any) must belong to the
665      --  dispatching domain.
666
667      if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
668        and then
669          (Base_CPU not in T.Common.Domain'Range
670            or else not T.Common.Domain (Base_CPU))
671      then
672         Initialization.Undefer_Abort_Nestable (Self_ID);
673         raise Tasking_Error with "CPU not in dispatching domain";
674      end if;
675
676      --  To handle the interaction between pragma CPU and dispatching domains
677      --  we need to signal that this task is being allocated to a processor.
678      --  This is needed only for tasks belonging to the system domain (the
679      --  creation of new dispatching domains can only take processors from the
680      --  system domain) and only before the environment task calls the main
681      --  procedure (dispatching domains cannot be created after this).
682
683      if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU
684        and then T.Common.Domain = System.Tasking.System_Domain
685        and then not System.Tasking.Dispatching_Domains_Frozen
686      then
687         --  Increase the number of tasks attached to the CPU to which this
688         --  task is being moved.
689
690         Dispatching_Domain_Tasks (Base_CPU) :=
691           Dispatching_Domain_Tasks (Base_CPU) + 1;
692      end if;
693
694      --  Create the secondary stack for the task as early as possible during
695      --  in the creation of a task, since it may be used by the operation of
696      --  Ada code within the task.
697
698      begin
699         SSL.Create_TSD (T.Common.Compiler_Data, null, Secondary_Stack_Size);
700      exception
701         when others =>
702            Initialization.Undefer_Abort_Nestable (Self_ID);
703            raise Storage_Error with "Secondary stack could not be allocated";
704      end;
705
706      T.Common.Activation_Link := Chain.T_ID;
707      Chain.T_ID := T;
708      Created_Task := T;
709      Initialization.Undefer_Abort_Nestable (Self_ID);
710
711      pragma Debug
712        (Debug.Trace
713           (Self_ID, "Created task in " & T.Master_Of_Task'Img, 'C', T));
714   end Create_Task;
715
716   --------------------
717   -- Current_Master --
718   --------------------
719
720   function Current_Master return Master_Level is
721   begin
722      return STPO.Self.Master_Within;
723   end Current_Master;
724
725   ------------------
726   -- Enter_Master --
727   ------------------
728
729   procedure Enter_Master is
730      Self_ID : constant Task_Id := STPO.Self;
731   begin
732      Self_ID.Master_Within := Self_ID.Master_Within + 1;
733      pragma Debug
734        (Debug.Trace
735           (Self_ID, "Enter_Master ->" & Self_ID.Master_Within'Img, 'M'));
736   end Enter_Master;
737
738   -------------------------------
739   -- Expunge_Unactivated_Tasks --
740   -------------------------------
741
742   --  See procedure Close_Entries for the general case
743
744   procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is
745      Self_ID : constant Task_Id := STPO.Self;
746      C       : Task_Id;
747      Call    : Entry_Call_Link;
748      Temp    : Task_Id;
749
750   begin
751      pragma Debug
752        (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C'));
753
754      Initialization.Defer_Abort_Nestable (Self_ID);
755
756      --  ???
757      --  Experimentation has shown that abort is sometimes (but not always)
758      --  already deferred when this is called.
759
760      --  That may indicate an error. Find out what is going on
761
762      C := Chain.T_ID;
763      while C /= null loop
764         pragma Assert (C.Common.State = Unactivated);
765
766         Temp := C.Common.Activation_Link;
767
768         if C.Common.State = Unactivated then
769            Lock_RTS;
770            Write_Lock (C);
771
772            for J in 1 .. C.Entry_Num loop
773               Queuing.Dequeue_Head (C.Entry_Queues (J), Call);
774               pragma Assert (Call = null);
775            end loop;
776
777            Unlock (C);
778
779            Initialization.Remove_From_All_Tasks_List (C);
780            Unlock_RTS;
781
782            Vulnerable_Free_Task (C);
783            C := Temp;
784         end if;
785      end loop;
786
787      Chain.T_ID := null;
788      Initialization.Undefer_Abort_Nestable (Self_ID);
789   end Expunge_Unactivated_Tasks;
790
791   ---------------------------
792   -- Finalize_Global_Tasks --
793   ---------------------------
794
795   --  ???
796   --  We have a potential problem here if finalization of global objects does
797   --  anything with signals or the timer server, since by that time those
798   --  servers have terminated.
799
800   --  It is hard to see how that would occur
801
802   --  However, a better solution might be to do all this finalization
803   --  using the global finalization chain.
804
805   procedure Finalize_Global_Tasks is
806      Self_ID : constant Task_Id := STPO.Self;
807
808      Ignore_1 : Boolean;
809      Ignore_2 : Boolean;
810
811      function State
812        (Int : System.Interrupt_Management.Interrupt_ID) return Character;
813      pragma Import (C, State, "__gnat_get_interrupt_state");
814      --  Get interrupt state for interrupt number Int. Defined in init.c
815
816      Default : constant Character := 's';
817      --    's'   Interrupt_State pragma set state to System (use "default"
818      --           system handler)
819
820   begin
821      if Self_ID.Deferral_Level = 0 then
822         --  ???
823         --  In principle, we should be able to predict whether abort is
824         --  already deferred here (and it should not be deferred yet but in
825         --  practice it seems Finalize_Global_Tasks is being called sometimes,
826         --  from RTS code for exceptions, with abort already deferred.
827
828         Initialization.Defer_Abort_Nestable (Self_ID);
829
830         --  Never undefer again
831      end if;
832
833      --  This code is only executed by the environment task
834
835      pragma Assert (Self_ID = Environment_Task);
836
837      --  Set Environment_Task'Callable to false to notify library-level tasks
838      --  that it is waiting for them.
839
840      Self_ID.Callable := False;
841
842      --  Exit level 2 master, for normal tasks in library-level packages
843
844      Complete_Master;
845
846      --  Force termination of "independent" library-level server tasks
847
848      Lock_RTS;
849
850      Abort_Dependents (Self_ID);
851
852      if not Single_Lock then
853         Unlock_RTS;
854      end if;
855
856      --  We need to explicitly wait for the task to be terminated here
857      --  because on true concurrent system, we may end this procedure before
858      --  the tasks are really terminated.
859
860      Write_Lock (Self_ID);
861
862      --  If the Abort_Task signal is set to system, it means that we may
863      --  not have been able to abort all independent tasks (in particular,
864      --  Server_Task may be blocked, waiting for a signal), in which case, do
865      --  not wait for Independent_Task_Count to go down to 0. We arbitrarily
866      --  limit the number of loop iterations; if an independent task does not
867      --  terminate, we do not want to hang here. In that case, the thread will
868      --  be terminated when the process exits.
869
870      if State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
871      then
872         for J in 1 .. 10 loop
873            exit when Utilities.Independent_Task_Count = 0;
874
875            --  We used to yield here, but this did not take into account low
876            --  priority tasks that would cause dead lock in some cases (true
877            --  FIFO scheduling).
878
879            Timed_Sleep
880              (Self_ID, 0.01, System.OS_Primitives.Relative,
881               Self_ID.Common.State, Ignore_1, Ignore_2);
882         end loop;
883      end if;
884
885      --  ??? On multi-processor environments, it seems that the above loop
886      --  isn't sufficient, so we need to add an additional delay.
887
888      Timed_Sleep
889        (Self_ID, 0.01, System.OS_Primitives.Relative,
890         Self_ID.Common.State, Ignore_1, Ignore_2);
891
892      Unlock (Self_ID);
893
894      if Single_Lock then
895         Unlock_RTS;
896      end if;
897
898      --  Complete the environment task
899
900      Vulnerable_Complete_Task (Self_ID);
901
902      --  Handle normal task termination by the environment task, but only
903      --  for the normal task termination. In the case of Abnormal and
904      --  Unhandled_Exception they must have been handled before, and the
905      --  task termination soft link must have been changed so the task
906      --  termination routine is not executed twice.
907
908      SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
909
910      --  Finalize all library-level controlled objects
911
912      if not SSL."=" (SSL.Finalize_Library_Objects, null) then
913         SSL.Finalize_Library_Objects.all;
914      end if;
915
916      --  Reset the soft links to non-tasking
917
918      SSL.Abort_Defer        := SSL.Abort_Defer_NT'Access;
919      SSL.Abort_Undefer      := SSL.Abort_Undefer_NT'Access;
920      SSL.Lock_Task          := SSL.Task_Lock_NT'Access;
921      SSL.Unlock_Task        := SSL.Task_Unlock_NT'Access;
922      SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access;
923      SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access;
924      SSL.Get_Sec_Stack      := SSL.Get_Sec_Stack_NT'Access;
925      SSL.Set_Sec_Stack      := SSL.Set_Sec_Stack_NT'Access;
926      SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access;
927      SSL.Get_Stack_Info     := SSL.Get_Stack_Info_NT'Access;
928
929      --  Don't bother trying to finalize Initialization.Global_Task_Lock
930      --  and System.Task_Primitives.RTS_Lock.
931
932   end Finalize_Global_Tasks;
933
934   ---------------
935   -- Free_Task --
936   ---------------
937
938   procedure Free_Task (T : Task_Id) is
939      Self_Id : constant Task_Id := Self;
940
941   begin
942      if T.Common.State = Terminated then
943
944         --  It is not safe to call Abort_Defer or Write_Lock at this stage
945
946         Initialization.Task_Lock (Self_Id);
947
948         Lock_RTS;
949         Initialization.Finalize_Attributes (T);
950         Initialization.Remove_From_All_Tasks_List (T);
951         Unlock_RTS;
952
953         Initialization.Task_Unlock (Self_Id);
954
955         System.Task_Primitives.Operations.Finalize_TCB (T);
956
957      else
958         --  If the task is not terminated, then mark the task as to be freed
959         --  upon termination.
960
961         T.Free_On_Termination := True;
962      end if;
963   end Free_Task;
964
965   ---------------------------
966   -- Move_Activation_Chain --
967   ---------------------------
968
969   procedure Move_Activation_Chain
970     (From, To   : Activation_Chain_Access;
971      New_Master : Master_ID)
972   is
973      Self_ID : constant Task_Id := STPO.Self;
974      C       : Task_Id;
975
976   begin
977      pragma Debug
978        (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C'));
979
980      --  Nothing to do if From is empty, and we can check that without
981      --  deferring aborts.
982
983      C := From.all.T_ID;
984
985      if C = null then
986         return;
987      end if;
988
989      Initialization.Defer_Abort_Nestable (Self_ID);
990
991      --  Loop through the From chain, changing their Master_Of_Task fields,
992      --  and to find the end of the chain.
993
994      loop
995         C.Master_Of_Task := New_Master;
996         exit when C.Common.Activation_Link = null;
997         C := C.Common.Activation_Link;
998      end loop;
999
1000      --  Hook From in at the start of To
1001
1002      C.Common.Activation_Link := To.all.T_ID;
1003      To.all.T_ID := From.all.T_ID;
1004
1005      --  Set From to empty
1006
1007      From.all.T_ID := null;
1008
1009      Initialization.Undefer_Abort_Nestable (Self_ID);
1010   end Move_Activation_Chain;
1011
1012   ------------------
1013   -- Task_Wrapper --
1014   ------------------
1015
1016   --  The task wrapper is a procedure that is called first for each task body
1017   --  and which in turn calls the compiler-generated task body procedure.
1018   --  The wrapper's main job is to do initialization for the task. It also
1019   --  has some locally declared objects that serve as per-task local data.
1020   --  Task finalization is done by Complete_Task, which is called from an
1021   --  at-end handler that the compiler generates.
1022
1023   procedure Task_Wrapper (Self_ID : Task_Id) is
1024      use System.Standard_Library;
1025      use System.Stack_Usage;
1026
1027      Bottom_Of_Stack : aliased Integer;
1028
1029      Task_Alternate_Stack :
1030        aliased SSE.Storage_Array (1 .. Alternate_Stack_Size);
1031      --  The alternate signal stack for this task, if any
1032
1033      Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
1034      --  Whether to use above alternate signal stack for stack overflows
1035
1036      SEH_Table : aliased SSE.Storage_Array (1 .. 8);
1037      --  Structured Exception Registration table (2 words)
1038
1039      procedure Install_SEH_Handler (Addr : System.Address);
1040      pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler");
1041      --  Install the SEH (Structured Exception Handling) handler
1042
1043      Cause : Cause_Of_Termination := Normal;
1044      --  Indicates the reason why this task terminates. Normal corresponds to
1045      --  a task terminating due to completing the last statement of its body,
1046      --  or as a result of waiting on a terminate alternative. If the task
1047      --  terminates because it is being aborted then Cause will be set
1048      --  to Abnormal. If the task terminates because of an exception
1049      --  raised by the execution of its task body, then Cause is set
1050      --  to Unhandled_Exception.
1051
1052      EO : Exception_Occurrence;
1053      --  If the task terminates because of an exception raised by the
1054      --  execution of its task body, then EO will contain the associated
1055      --  exception occurrence. Otherwise, it will contain Null_Occurrence.
1056
1057      TH : Termination_Handler := null;
1058      --  Pointer to the protected procedure to be executed upon task
1059      --  termination.
1060
1061      procedure Search_Fall_Back_Handler (ID : Task_Id);
1062      --  Procedure that searches recursively a fall-back handler through the
1063      --  master relationship. If the handler is found, its pointer is stored
1064      --  in TH. It stops when the handler is found or when the ID is null.
1065
1066      ------------------------------
1067      -- Search_Fall_Back_Handler --
1068      ------------------------------
1069
1070      procedure Search_Fall_Back_Handler (ID : Task_Id) is
1071      begin
1072         --  A null Task_Id indicates that we have reached the root of the
1073         --  task hierarchy and no handler has been found.
1074
1075         if ID = null then
1076            return;
1077
1078         --  If there is a fall back handler, store its pointer for later
1079         --  execution.
1080
1081         elsif ID.Common.Fall_Back_Handler /= null then
1082            TH := ID.Common.Fall_Back_Handler;
1083
1084         --  Otherwise look for a fall back handler in the parent
1085
1086         else
1087            Search_Fall_Back_Handler (ID.Common.Parent);
1088         end if;
1089      end Search_Fall_Back_Handler;
1090
1091   --  Start of processing for Task_Wrapper
1092
1093   begin
1094      pragma Assert (Self_ID.Deferral_Level = 1);
1095
1096      Debug.Master_Hook
1097        (Self_ID, Self_ID.Common.Parent, Self_ID.Master_Of_Task);
1098
1099      if Use_Alternate_Stack then
1100         Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address;
1101      end if;
1102
1103      --  Set the guard page at the bottom of the stack. The call to unprotect
1104      --  the page is done in Terminate_Task
1105
1106      Stack_Guard (Self_ID, True);
1107
1108      --  Initialize low-level TCB components, that cannot be initialized by
1109      --  the creator. Enter_Task sets Self_ID.LL.Thread.
1110
1111      Enter_Task (Self_ID);
1112
1113      --  Initialize dynamic stack usage
1114
1115      if System.Stack_Usage.Is_Enabled then
1116         declare
1117            Guard_Page_Size : constant := 16 * 1024;
1118            --  Part of the stack used as a guard page. This is an OS dependent
1119            --  value, so we need to use the maximum. This value is only used
1120            --  when the stack address is known, that is currently Windows.
1121
1122            Small_Overflow_Guard : constant := 12 * 1024;
1123            --  Note: this used to be 4K, but was changed to 12K, since
1124            --  smaller values resulted in segmentation faults from dynamic
1125            --  stack analysis.
1126
1127            Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024;
1128            Small_Stack_Limit  : constant := 64 * 1024;
1129            --  ??? These three values are experimental, and seem to work on
1130            --  most platforms. They still need to be analyzed further. They
1131            --  also need documentation, what are they and why does the logic
1132            --  differ depending on whether the stack is large or small???
1133
1134            Pattern_Size : Natural :=
1135                             Natural (Self_ID.Common.
1136                                        Compiler_Data.Pri_Stack_Info.Size);
1137            --  Size of the pattern
1138
1139            Stack_Base : Address;
1140            --  Address of the base of the stack
1141
1142         begin
1143            Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base;
1144
1145            if Stack_Base = Null_Address then
1146
1147               --  On many platforms, we don't know the real stack base
1148               --  address. Estimate it using an address in the frame.
1149
1150               Stack_Base := Bottom_Of_Stack'Address;
1151
1152               --  Adjustments for inner frames
1153
1154               Pattern_Size := Pattern_Size -
1155                 (if Pattern_Size < Small_Stack_Limit
1156                    then Small_Overflow_Guard
1157                    else Big_Overflow_Guard);
1158            else
1159               --  Reduce by the size of the final guard page
1160
1161               Pattern_Size := Pattern_Size - Guard_Page_Size;
1162            end if;
1163
1164            STPO.Lock_RTS;
1165            Initialize_Analyzer
1166              (Self_ID.Common.Analyzer,
1167               Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len),
1168               Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size),
1169               SSE.To_Integer (Stack_Base),
1170               Pattern_Size);
1171            STPO.Unlock_RTS;
1172            Fill_Stack (Self_ID.Common.Analyzer);
1173         end;
1174      end if;
1175
1176      --  We setup the SEH (Structured Exception Handling) handler if supported
1177      --  on the target.
1178
1179      Install_SEH_Handler (SEH_Table'Address);
1180
1181      --  Initialize exception occurrence
1182
1183      Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence);
1184
1185      --  We lock RTS_Lock to wait for activator to finish activating the rest
1186      --  of the chain, so that everyone in the chain comes out in priority
1187      --  order.
1188
1189      --  This also protects the value of
1190      --    Self_ID.Common.Activator.Common.Wait_Count.
1191
1192      Lock_RTS;
1193      Unlock_RTS;
1194
1195      if not System.Restrictions.Abort_Allowed then
1196
1197         --  If Abort is not allowed, reset the deferral level since it will
1198         --  not get changed by the generated code. Keeping a default value
1199         --  of one would prevent some operations (e.g. select or delay) to
1200         --  proceed successfully.
1201
1202         Self_ID.Deferral_Level := 0;
1203      end if;
1204
1205      if Global_Task_Debug_Event_Set then
1206         Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID);
1207      end if;
1208
1209      begin
1210         --  We are separating the following portion of the code in order to
1211         --  place the exception handlers in a different block. In this way,
1212         --  we do not call Set_Jmpbuf_Address (which needs Self) before we
1213         --  set Self in Enter_Task
1214
1215         --  Call the task body procedure
1216
1217         --  The task body is called with abort still deferred. That
1218         --  eliminates a dangerous window, for which we had to patch-up in
1219         --  Terminate_Task.
1220
1221         --  During the expansion of the task body, we insert an RTS-call
1222         --  to Abort_Undefer, at the first point where abort should be
1223         --  allowed.
1224
1225         Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
1226         Initialization.Defer_Abort_Nestable (Self_ID);
1227
1228      exception
1229         --  We can't call Terminate_Task in the exception handlers below,
1230         --  since there may be (e.g. in the case of GCC exception handling)
1231         --  clean ups associated with the exception handler that need to
1232         --  access task specific data.
1233
1234         --  Defer abort so that this task can't be aborted while exiting
1235
1236         when Standard'Abort_Signal =>
1237            Initialization.Defer_Abort_Nestable (Self_ID);
1238
1239            --  Update the cause that motivated the task termination so that
1240            --  the appropriate information is passed to the task termination
1241            --  procedure. Task termination as a result of waiting on a
1242            --  terminate alternative is a normal termination, although it is
1243            --  implemented using the abort mechanisms.
1244
1245            if Self_ID.Terminate_Alternative then
1246               Cause := Normal;
1247
1248               if Global_Task_Debug_Event_Set then
1249                  Debug.Signal_Debug_Event
1250                   (Debug.Debug_Event_Terminated, Self_ID);
1251               end if;
1252            else
1253               Cause := Abnormal;
1254
1255               if Global_Task_Debug_Event_Set then
1256                  Debug.Signal_Debug_Event
1257                   (Debug.Debug_Event_Abort_Terminated, Self_ID);
1258               end if;
1259            end if;
1260
1261         when others =>
1262            --  ??? Using an E : others here causes CD2C11A to fail on Tru64
1263
1264            Initialization.Defer_Abort_Nestable (Self_ID);
1265
1266            --  Perform the task specific exception tracing duty.  We handle
1267            --  these outputs here and not in the common notification routine
1268            --  because we need access to tasking related data and we don't
1269            --  want to drag dependencies against tasking related units in the
1270            --  the common notification units. Additionally, no trace is ever
1271            --  triggered from the common routine for the Unhandled_Raise case
1272            --  in tasks, since an exception never appears unhandled in this
1273            --  context because of this handler.
1274
1275            if Exception_Trace = Unhandled_Raise then
1276               Trace_Unhandled_Exception_In_Task (Self_ID);
1277            end if;
1278
1279            --  Update the cause that motivated the task termination so that
1280            --  the appropriate information is passed to the task termination
1281            --  procedure, as well as the associated Exception_Occurrence.
1282
1283            Cause := Unhandled_Exception;
1284
1285            Save_Occurrence (EO, SSL.Get_Current_Excep.all.all);
1286
1287            if Global_Task_Debug_Event_Set then
1288               Debug.Signal_Debug_Event
1289                 (Debug.Debug_Event_Exception_Terminated, Self_ID);
1290            end if;
1291      end;
1292
1293      --  Look for a task termination handler. This code is for all tasks but
1294      --  the environment task. The task termination code for the environment
1295      --  task is executed by SSL.Task_Termination_Handler.
1296
1297      if Single_Lock then
1298         Lock_RTS;
1299      end if;
1300
1301      Write_Lock (Self_ID);
1302
1303      if Self_ID.Common.Specific_Handler /= null then
1304         TH := Self_ID.Common.Specific_Handler;
1305
1306      --  Independent tasks should not call the Fall_Back_Handler (of the
1307      --  environment task), because they are implementation artifacts that
1308      --  should be invisible to Ada programs.
1309
1310      elsif Self_ID.Master_Of_Task /= Independent_Task_Level then
1311
1312         --  Look for a fall-back handler following the master relationship
1313         --  for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back
1314         --  handler applies only to the dependent tasks of the task". Hence,
1315         --  if the terminating tasks (Self_ID) had a fall-back handler, it
1316         --  would not apply to itself, so we start the search with the parent.
1317
1318         Search_Fall_Back_Handler (Self_ID.Common.Parent);
1319      end if;
1320
1321      Unlock (Self_ID);
1322
1323      if Single_Lock then
1324         Unlock_RTS;
1325      end if;
1326
1327      --  Execute the task termination handler if we found it
1328
1329      if TH /= null then
1330         begin
1331            TH.all (Cause, Self_ID, EO);
1332
1333         exception
1334
1335            --  RM-C.7.3 requires all exceptions raised here to be ignored
1336
1337            when others =>
1338               null;
1339         end;
1340      end if;
1341
1342      if System.Stack_Usage.Is_Enabled then
1343         Compute_Result (Self_ID.Common.Analyzer);
1344         Report_Result (Self_ID.Common.Analyzer);
1345      end if;
1346
1347      Terminate_Task (Self_ID);
1348   end Task_Wrapper;
1349
1350   --------------------
1351   -- Terminate_Task --
1352   --------------------
1353
1354   --  Before we allow the thread to exit, we must clean up. This is a delicate
1355   --  job. We must wake up the task's master, who may immediately try to
1356   --  deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING.
1357
1358   --  To avoid this, the parent task must be blocked up to the latest
1359   --  statement executed. The trouble is that we have another step that we
1360   --  also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
1361   --  We have to postpone that until the end because compiler-generated code
1362   --  is likely to try to access that data at just about any point.
1363
1364   --  We can't call Destroy_TSD while we are holding any other locks, because
1365   --  it locks Global_Task_Lock, and our deadlock prevention rules require
1366   --  that to be the outermost lock. Our first "solution" was to just lock
1367   --  Global_Task_Lock in addition to the other locks, and force the parent to
1368   --  also lock this lock between its wakeup and its freeing of the ATCB. See
1369   --  Complete_Task for the parent-side of the code that has the matching
1370   --  calls to Task_Lock and Task_Unlock. That was not really a solution,
1371   --  since the operation Task_Unlock continued to access the ATCB after
1372   --  unlocking, after which the parent was observed to race ahead, deallocate
1373   --  the ATCB, and then reallocate it to another task. The call to
1374   --  Undefer_Abort in Task_Unlock by the "terminated" task was overwriting
1375   --  the data of the new task that reused the ATCB. To solve this problem, we
1376   --  introduced the new operation Final_Task_Unlock.
1377
1378   procedure Terminate_Task (Self_ID : Task_Id) is
1379      Environment_Task : constant Task_Id := STPO.Environment_Task;
1380      Master_Of_Task   : Integer;
1381      Deallocate       : Boolean;
1382
1383   begin
1384      Debug.Task_Termination_Hook;
1385
1386      --  Since GCC cannot allocate stack chunks efficiently without reordering
1387      --  some of the allocations, we have to handle this unexpected situation
1388      --  here. Normally we never have to call Vulnerable_Complete_Task here.
1389
1390      if Self_ID.Common.Activator /= null then
1391         Vulnerable_Complete_Task (Self_ID);
1392      end if;
1393
1394      Initialization.Task_Lock (Self_ID);
1395
1396      if Single_Lock then
1397         Lock_RTS;
1398      end if;
1399
1400      Master_Of_Task := Self_ID.Master_Of_Task;
1401
1402      --  Check if the current task is an independent task If so, decrement
1403      --  the Independent_Task_Count value.
1404
1405      if Master_Of_Task = Independent_Task_Level then
1406         if Single_Lock then
1407            Utilities.Independent_Task_Count :=
1408              Utilities.Independent_Task_Count - 1;
1409
1410         else
1411            Write_Lock (Environment_Task);
1412            Utilities.Independent_Task_Count :=
1413              Utilities.Independent_Task_Count - 1;
1414            Unlock (Environment_Task);
1415         end if;
1416      end if;
1417
1418      --  Unprotect the guard page if needed
1419
1420      Stack_Guard (Self_ID, False);
1421
1422      Utilities.Make_Passive (Self_ID, Task_Completed => True);
1423      Deallocate := Self_ID.Free_On_Termination;
1424
1425      if Single_Lock then
1426         Unlock_RTS;
1427      end if;
1428
1429      pragma Assert (Check_Exit (Self_ID));
1430
1431      SSL.Destroy_TSD (Self_ID.Common.Compiler_Data);
1432      Initialization.Final_Task_Unlock (Self_ID);
1433
1434      --  WARNING: past this point, this thread must assume that the ATCB has
1435      --  been deallocated, and can't access it anymore (which is why we have
1436      --  saved the Free_On_Termination flag in a temporary variable).
1437
1438      if Deallocate then
1439         Free_Task (Self_ID);
1440      end if;
1441
1442      if Master_Of_Task > 0 then
1443         STPO.Exit_Task;
1444      end if;
1445   end Terminate_Task;
1446
1447   ----------------
1448   -- Terminated --
1449   ----------------
1450
1451   function Terminated (T : Task_Id) return Boolean is
1452      Self_ID : constant Task_Id := STPO.Self;
1453      Result  : Boolean;
1454
1455   begin
1456      Initialization.Defer_Abort_Nestable (Self_ID);
1457
1458      if Single_Lock then
1459         Lock_RTS;
1460      end if;
1461
1462      Write_Lock (T);
1463      Result := T.Common.State = Terminated;
1464      Unlock (T);
1465
1466      if Single_Lock then
1467         Unlock_RTS;
1468      end if;
1469
1470      Initialization.Undefer_Abort_Nestable (Self_ID);
1471      return Result;
1472   end Terminated;
1473
1474   ----------------------------------------
1475   -- Trace_Unhandled_Exception_In_Task --
1476   ----------------------------------------
1477
1478   procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is
1479      procedure To_Stderr (S : String);
1480      pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
1481
1482      use System.Soft_Links;
1483
1484      function To_Address is new
1485        Ada.Unchecked_Conversion
1486         (Task_Id, System.Task_Primitives.Task_Address);
1487
1488      Excep : constant Exception_Occurrence_Access :=
1489                SSL.Get_Current_Excep.all;
1490
1491   begin
1492      --  This procedure is called by the task outermost handler in
1493      --  Task_Wrapper below, so only once the task stack has been fully
1494      --  unwound. The common notification routine has been called at the
1495      --  raise point already.
1496
1497      --  Lock to prevent unsynchronized output
1498
1499      Initialization.Task_Lock (Self_Id);
1500      To_Stderr ("task ");
1501
1502      if Self_Id.Common.Task_Image_Len /= 0 then
1503         To_Stderr
1504           (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
1505         To_Stderr ("_");
1506      end if;
1507
1508      To_Stderr (System.Address_Image (To_Address (Self_Id)));
1509      To_Stderr (" terminated by unhandled exception");
1510      To_Stderr ((1 => ASCII.LF));
1511      To_Stderr (Exception_Information (Excep.all));
1512      Initialization.Task_Unlock (Self_Id);
1513   end Trace_Unhandled_Exception_In_Task;
1514
1515   ------------------------------------
1516   -- Vulnerable_Complete_Activation --
1517   ------------------------------------
1518
1519   --  As in several other places, the locks of the activator and activated
1520   --  task are both locked here. This follows our deadlock prevention lock
1521   --  ordering policy, since the activated task must be created after the
1522   --  activator.
1523
1524   procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is
1525      Activator : constant Task_Id := Self_ID.Common.Activator;
1526
1527   begin
1528      pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C'));
1529
1530      Write_Lock (Activator);
1531      Write_Lock (Self_ID);
1532
1533      pragma Assert (Self_ID.Common.Activator /= null);
1534
1535      --  Remove dangling reference to Activator, since a task may outlive its
1536      --  activator.
1537
1538      Self_ID.Common.Activator := null;
1539
1540      --  Wake up the activator, if it is waiting for a chain of tasks to
1541      --  activate, and we are the last in the chain to complete activation.
1542
1543      if Activator.Common.State = Activator_Sleep then
1544         Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
1545
1546         if Activator.Common.Wait_Count = 0 then
1547            Wakeup (Activator, Activator_Sleep);
1548         end if;
1549      end if;
1550
1551      --  The activator raises a Tasking_Error if any task it is activating
1552      --  is completed before the activation is done. However, if the reason
1553      --  for the task completion is an abort, we do not raise an exception.
1554      --  See RM 9.2(5).
1555
1556      if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
1557         Activator.Common.Activation_Failed := True;
1558      end if;
1559
1560      Unlock (Self_ID);
1561      Unlock (Activator);
1562
1563      --  After the activation, active priority should be the same as base
1564      --  priority. We must unlock the Activator first, though, since it
1565      --  should not wait if we have lower priority.
1566
1567      if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then
1568         Write_Lock (Self_ID);
1569         Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1570         Unlock (Self_ID);
1571      end if;
1572   end Vulnerable_Complete_Activation;
1573
1574   --------------------------------
1575   -- Vulnerable_Complete_Master --
1576   --------------------------------
1577
1578   procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is
1579      C  : Task_Id;
1580      P  : Task_Id;
1581      CM : constant Master_Level := Self_ID.Master_Within;
1582      T  : aliased Task_Id;
1583
1584      To_Be_Freed : Task_Id;
1585      --  This is a list of ATCBs to be freed, after we have released all RTS
1586      --  locks. This is necessary because of the locking order rules, since
1587      --  the storage manager uses Global_Task_Lock.
1588
1589      pragma Warnings (Off);
1590      function Check_Unactivated_Tasks return Boolean;
1591      pragma Warnings (On);
1592      --  Temporary error-checking code below. This is part of the checks
1593      --  added in the new run time. Call it only inside a pragma Assert.
1594
1595      -----------------------------
1596      -- Check_Unactivated_Tasks --
1597      -----------------------------
1598
1599      function Check_Unactivated_Tasks return Boolean is
1600      begin
1601         if not Single_Lock then
1602            Lock_RTS;
1603         end if;
1604
1605         Write_Lock (Self_ID);
1606
1607         C := All_Tasks_List;
1608         while C /= null loop
1609            if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then
1610               return False;
1611            end if;
1612
1613            if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
1614               Write_Lock (C);
1615
1616               if C.Common.State = Unactivated then
1617                  return False;
1618               end if;
1619
1620               Unlock (C);
1621            end if;
1622
1623            C := C.Common.All_Tasks_Link;
1624         end loop;
1625
1626         Unlock (Self_ID);
1627
1628         if not Single_Lock then
1629            Unlock_RTS;
1630         end if;
1631
1632         return True;
1633      end Check_Unactivated_Tasks;
1634
1635   --  Start of processing for Vulnerable_Complete_Master
1636
1637   begin
1638      pragma Debug
1639        (Debug.Trace (Self_ID, "V_Complete_Master(" & CM'Img & ")", 'C'));
1640
1641      pragma Assert (Self_ID.Common.Wait_Count = 0);
1642      pragma Assert
1643        (Self_ID.Deferral_Level > 0
1644          or else not System.Restrictions.Abort_Allowed);
1645
1646      --  Count how many active dependent tasks this master currently has, and
1647      --  record this in Wait_Count.
1648
1649      --  This count should start at zero, since it is initialized to zero for
1650      --  new tasks, and the task should not exit the sleep-loops that use this
1651      --  count until the count reaches zero.
1652
1653      --  While we're counting, if we run across any unactivated tasks that
1654      --  belong to this master, we summarily terminate them as required by
1655      --  RM-9.2(6).
1656
1657      Lock_RTS;
1658      Write_Lock (Self_ID);
1659
1660      C := All_Tasks_List;
1661      while C /= null loop
1662
1663         --  Terminate unactivated (never-to-be activated) tasks
1664
1665         if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then
1666
1667            --  Usually, C.Common.Activator = Self_ID implies C.Master_Of_Task
1668            --  = CM. The only case where C is pending activation by this
1669            --  task, but the master of C is not CM is in Ada 2005, when C is
1670            --  part of a return object of a build-in-place function.
1671
1672            pragma Assert (C.Common.State = Unactivated);
1673
1674            Write_Lock (C);
1675            C.Common.Activator := null;
1676            C.Common.State := Terminated;
1677            C.Callable := False;
1678            Utilities.Cancel_Queued_Entry_Calls (C);
1679            Unlock (C);
1680         end if;
1681
1682         --  Count it if directly dependent on this master
1683
1684         if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
1685            Write_Lock (C);
1686
1687            if C.Awake_Count /= 0 then
1688               Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1689            end if;
1690
1691            Unlock (C);
1692         end if;
1693
1694         C := C.Common.All_Tasks_Link;
1695      end loop;
1696
1697      Self_ID.Common.State := Master_Completion_Sleep;
1698      Unlock (Self_ID);
1699
1700      if not Single_Lock then
1701         Unlock_RTS;
1702      end if;
1703
1704      --  Wait until dependent tasks are all terminated or ready to terminate.
1705      --  While waiting, the task may be awakened if the task's priority needs
1706      --  changing, or this master is aborted. In the latter case, we abort the
1707      --  dependents, and resume waiting until Wait_Count goes to zero.
1708
1709      Write_Lock (Self_ID);
1710
1711      loop
1712         exit when Self_ID.Common.Wait_Count = 0;
1713
1714         --  Here is a difference as compared to Complete_Master
1715
1716         if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1717           and then not Self_ID.Dependents_Aborted
1718         then
1719            if Single_Lock then
1720               Abort_Dependents (Self_ID);
1721            else
1722               Unlock (Self_ID);
1723               Lock_RTS;
1724               Abort_Dependents (Self_ID);
1725               Unlock_RTS;
1726               Write_Lock (Self_ID);
1727            end if;
1728         else
1729            pragma Debug
1730              (Debug.Trace (Self_ID, "master_completion_sleep", 'C'));
1731            Sleep (Self_ID, Master_Completion_Sleep);
1732         end if;
1733      end loop;
1734
1735      Self_ID.Common.State := Runnable;
1736      Unlock (Self_ID);
1737
1738      --  Dependents are all terminated or on terminate alternatives. Now,
1739      --  force those on terminate alternatives to terminate, by aborting them.
1740
1741      pragma Assert (Check_Unactivated_Tasks);
1742
1743      if Self_ID.Alive_Count > 1 then
1744         --  ???
1745         --  Consider finding a way to skip the following extra steps if there
1746         --  are no dependents with terminate alternatives. This could be done
1747         --  by adding another count to the ATCB, similar to Awake_Count, but
1748         --  keeping track of tasks that are on terminate alternatives.
1749
1750         pragma Assert (Self_ID.Common.Wait_Count = 0);
1751
1752         --  Force any remaining dependents to terminate by aborting them
1753
1754         if not Single_Lock then
1755            Lock_RTS;
1756         end if;
1757
1758         Abort_Dependents (Self_ID);
1759
1760         --  Above, when we "abort" the dependents we are simply using this
1761         --  operation for convenience. We are not required to support the full
1762         --  abort-statement semantics; in particular, we are not required to
1763         --  immediately cancel any queued or in-service entry calls. That is
1764         --  good, because if we tried to cancel a call we would need to lock
1765         --  the caller, in order to wake the caller up. Our anti-deadlock
1766         --  rules prevent us from doing that without releasing the locks on C
1767         --  and Self_ID. Releasing and retaking those locks would be wasteful
1768         --  at best, and should not be considered further without more
1769         --  detailed analysis of potential concurrent accesses to the ATCBs
1770         --  of C and Self_ID.
1771
1772         --  Count how many "alive" dependent tasks this master currently has,
1773         --  and record this in Wait_Count. This count should start at zero,
1774         --  since it is initialized to zero for new tasks, and the task should
1775         --  not exit the sleep-loops that use this count until the count
1776         --  reaches zero.
1777
1778         pragma Assert (Self_ID.Common.Wait_Count = 0);
1779
1780         Write_Lock (Self_ID);
1781
1782         C := All_Tasks_List;
1783         while C /= null loop
1784            if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then
1785               Write_Lock (C);
1786
1787               pragma Assert (C.Awake_Count = 0);
1788
1789               if C.Alive_Count > 0 then
1790                  pragma Assert (C.Terminate_Alternative);
1791                  Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1;
1792               end if;
1793
1794               Unlock (C);
1795            end if;
1796
1797            C := C.Common.All_Tasks_Link;
1798         end loop;
1799
1800         Self_ID.Common.State := Master_Phase_2_Sleep;
1801         Unlock (Self_ID);
1802
1803         if not Single_Lock then
1804            Unlock_RTS;
1805         end if;
1806
1807         --  Wait for all counted tasks to finish terminating themselves
1808
1809         Write_Lock (Self_ID);
1810
1811         loop
1812            exit when Self_ID.Common.Wait_Count = 0;
1813            Sleep (Self_ID, Master_Phase_2_Sleep);
1814         end loop;
1815
1816         Self_ID.Common.State := Runnable;
1817         Unlock (Self_ID);
1818      end if;
1819
1820      --  We don't wake up for abort here. We are already terminating just as
1821      --  fast as we can, so there is no point.
1822
1823      --  Remove terminated tasks from the list of Self_ID's dependents, but
1824      --  don't free their ATCBs yet, because of lock order restrictions, which
1825      --  don't allow us to call "free" or "malloc" while holding any other
1826      --  locks. Instead, we put those ATCBs to be freed onto a temporary list,
1827      --  called To_Be_Freed.
1828
1829      if not Single_Lock then
1830         Lock_RTS;
1831      end if;
1832
1833      C := All_Tasks_List;
1834      P := null;
1835      while C /= null loop
1836
1837         --  If Free_On_Termination is set, do nothing here, and let the
1838         --  task free itself if not already done, otherwise we risk a race
1839         --  condition where Vulnerable_Free_Task is called in the loop below,
1840         --  while the task calls Free_Task itself, in Terminate_Task.
1841
1842         if C.Common.Parent = Self_ID
1843           and then C.Master_Of_Task >= CM
1844           and then not C.Free_On_Termination
1845         then
1846            if P /= null then
1847               P.Common.All_Tasks_Link := C.Common.All_Tasks_Link;
1848            else
1849               All_Tasks_List := C.Common.All_Tasks_Link;
1850            end if;
1851
1852            T := C.Common.All_Tasks_Link;
1853            C.Common.All_Tasks_Link := To_Be_Freed;
1854            To_Be_Freed := C;
1855            C := T;
1856
1857         else
1858            P := C;
1859            C := C.Common.All_Tasks_Link;
1860         end if;
1861      end loop;
1862
1863      Unlock_RTS;
1864
1865      --  Free all the ATCBs on the list To_Be_Freed
1866
1867      --  The ATCBs in the list are no longer in All_Tasks_List, and after
1868      --  any interrupt entries are detached from them they should no longer
1869      --  be referenced.
1870
1871      --  Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to
1872      --  avoid a race between a terminating task and its parent. The parent
1873      --  might try to deallocate the ACTB out from underneath the exiting
1874      --  task. Note that Free will also lock Global_Task_Lock, but that is
1875      --  OK, since this is the *one* lock for which we have a mechanism to
1876      --  support nested locking. See Task_Wrapper and its finalizer for more
1877      --  explanation.
1878
1879      --  ???
1880      --  The check "T.Common.Parent /= null ..." below is to prevent dangling
1881      --  references to terminated library-level tasks, which could otherwise
1882      --  occur during finalization of library-level objects. A better solution
1883      --  might be to hook task objects into the finalization chain and
1884      --  deallocate the ATCB when the task object is deallocated. However,
1885      --  this change is not likely to gain anything significant, since all
1886      --  this storage should be recovered en-masse when the process exits.
1887
1888      while To_Be_Freed /= null loop
1889         T := To_Be_Freed;
1890         To_Be_Freed := T.Common.All_Tasks_Link;
1891
1892         --  ??? On SGI there is currently no Interrupt_Manager, that's why we
1893         --  need to check if the Interrupt_Manager_ID is null.
1894
1895         if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then
1896            declare
1897               Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
1898               --  Corresponds to the entry index of System.Interrupts.
1899               --  Interrupt_Manager.Detach_Interrupt_Entries. Be sure
1900               --  to update this value when changing Interrupt_Manager specs.
1901
1902               type Param_Type is access all Task_Id;
1903
1904               Param : aliased Param_Type := T'Access;
1905
1906            begin
1907               System.Tasking.Rendezvous.Call_Simple
1908                 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index,
1909                  Param'Address);
1910            end;
1911         end if;
1912
1913         if (T.Common.Parent /= null
1914              and then T.Common.Parent.Common.Parent /= null)
1915           or else T.Master_Of_Task > Library_Task_Level
1916         then
1917            Initialization.Task_Lock (Self_ID);
1918
1919            --  If Sec_Stack_Ptr is not null, it means that Destroy_TSD
1920            --  has not been called yet (case of an unactivated task).
1921
1922            if T.Common.Compiler_Data.Sec_Stack_Ptr /= null then
1923               SSL.Destroy_TSD (T.Common.Compiler_Data);
1924            end if;
1925
1926            Vulnerable_Free_Task (T);
1927            Initialization.Task_Unlock (Self_ID);
1928         end if;
1929      end loop;
1930
1931      --  It might seem nice to let the terminated task deallocate its own
1932      --  ATCB. That would not cover the case of unactivated tasks. It also
1933      --  would force us to keep the underlying thread around past termination,
1934      --  since references to the ATCB are possible past termination.
1935
1936      --  Currently, we get rid of the thread as soon as the task terminates,
1937      --  and let the parent recover the ATCB later.
1938
1939      --  Some day, if we want to recover the ATCB earlier, at task
1940      --  termination, we could consider using "fat task IDs", that include the
1941      --  serial number with the ATCB pointer, to catch references to tasks
1942      --  that no longer have ATCBs. It is not clear how much this would gain,
1943      --  since the user-level task object would still be occupying storage.
1944
1945      --  Make next master level up active. We don't need to lock the ATCB,
1946      --  since the value is only updated by each task for itself.
1947
1948      Self_ID.Master_Within := CM - 1;
1949
1950      Debug.Master_Completed_Hook (Self_ID, CM);
1951   end Vulnerable_Complete_Master;
1952
1953   ------------------------------
1954   -- Vulnerable_Complete_Task --
1955   ------------------------------
1956
1957   --  Complete the calling task
1958
1959   --  This procedure must be called with abort deferred. It should only be
1960   --  called by Complete_Task and Finalize_Global_Tasks (for the environment
1961   --  task).
1962
1963   --  The effect is similar to that of Complete_Master. Differences include
1964   --  the closing of entries here, and computation of the number of active
1965   --  dependent tasks in Complete_Master.
1966
1967   --  We don't lock Self_ID before the call to Vulnerable_Complete_Activation,
1968   --  because that does its own locking, and because we do not need the lock
1969   --  to test Self_ID.Common.Activator. That value should only be read and
1970   --  modified by Self.
1971
1972   procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is
1973   begin
1974      pragma Assert
1975        (Self_ID.Deferral_Level > 0
1976          or else not System.Restrictions.Abort_Allowed);
1977      pragma Assert (Self_ID = Self);
1978      pragma Assert
1979        (Self_ID.Master_Within in
1980           Self_ID.Master_Of_Task .. Self_ID.Master_Of_Task + 3);
1981      pragma Assert (Self_ID.Common.Wait_Count = 0);
1982      pragma Assert (Self_ID.Open_Accepts = null);
1983      pragma Assert (Self_ID.ATC_Nesting_Level = 1);
1984
1985      pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C'));
1986
1987      if Single_Lock then
1988         Lock_RTS;
1989      end if;
1990
1991      Write_Lock (Self_ID);
1992      Self_ID.Callable := False;
1993
1994      --  In theory, Self should have no pending entry calls left on its
1995      --  call-stack. Each async. select statement should clean its own call,
1996      --  and blocking entry calls should defer abort until the calls are
1997      --  cancelled, then clean up.
1998
1999      Utilities.Cancel_Queued_Entry_Calls (Self_ID);
2000      Unlock (Self_ID);
2001
2002      if Self_ID.Common.Activator /= null then
2003         Vulnerable_Complete_Activation (Self_ID);
2004      end if;
2005
2006      if Single_Lock then
2007         Unlock_RTS;
2008      end if;
2009
2010      --  If Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 we may have
2011      --  dependent tasks for which we need to wait. Otherwise we just exit.
2012
2013      if Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 then
2014         Vulnerable_Complete_Master (Self_ID);
2015      end if;
2016   end Vulnerable_Complete_Task;
2017
2018   --------------------------
2019   -- Vulnerable_Free_Task --
2020   --------------------------
2021
2022   --  Recover all runtime system storage associated with the task T. This
2023   --  should only be called after T has terminated and will no longer be
2024   --  referenced.
2025
2026   --  For tasks created by an allocator that fails, due to an exception, it
2027   --  is called from Expunge_Unactivated_Tasks.
2028
2029   --  For tasks created by elaboration of task object declarations it is
2030   --  called from the finalization code of the Task_Wrapper procedure.
2031
2032   procedure Vulnerable_Free_Task (T : Task_Id) is
2033   begin
2034      pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
2035
2036      if Single_Lock then
2037         Lock_RTS;
2038      end if;
2039
2040      Write_Lock (T);
2041      Initialization.Finalize_Attributes (T);
2042      Unlock (T);
2043
2044      if Single_Lock then
2045         Unlock_RTS;
2046      end if;
2047
2048      System.Task_Primitives.Operations.Finalize_TCB (T);
2049   end Vulnerable_Free_Task;
2050
2051--  Package elaboration code
2052
2053begin
2054   --  Establish the Adafinal softlink
2055
2056   --  This is not done inside the central RTS initialization routine
2057   --  to avoid with'ing this package from System.Tasking.Initialization.
2058
2059   SSL.Adafinal := Finalize_Global_Tasks'Access;
2060
2061   --  Establish soft links for subprograms that manipulate master_id's.
2062   --  This cannot be done when the RTS is initialized, because of various
2063   --  elaboration constraints.
2064
2065   SSL.Current_Master  := Stages.Current_Master'Access;
2066   SSL.Enter_Master    := Stages.Enter_Master'Access;
2067   SSL.Complete_Master := Stages.Complete_Master'Access;
2068end System.Tasking.Stages;
2069