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