1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                 A D A . T A S K _ T E R M I N A T I O N                  --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2005-2018, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT 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-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with System.Tasking;
33with System.Task_Primitives.Operations;
34with System.Parameters;
35with System.Soft_Links;
36
37with Ada.Unchecked_Conversion;
38
39package body Ada.Task_Termination is
40
41   use type Ada.Task_Identification.Task_Id;
42
43   package STPO renames System.Task_Primitives.Operations;
44   package SSL  renames System.Soft_Links;
45
46   use System.Parameters;
47
48   -----------------------
49   -- Local subprograms --
50   -----------------------
51
52   function To_TT is new Ada.Unchecked_Conversion
53     (System.Tasking.Termination_Handler, Termination_Handler);
54
55   function To_ST is new Ada.Unchecked_Conversion
56     (Termination_Handler, System.Tasking.Termination_Handler);
57
58   function To_Task_Id is new Ada.Unchecked_Conversion
59     (Ada.Task_Identification.Task_Id, System.Tasking.Task_Id);
60
61   -----------------------------------
62   -- Current_Task_Fallback_Handler --
63   -----------------------------------
64
65   function Current_Task_Fallback_Handler return Termination_Handler is
66   begin
67      --  There is no need for explicit protection against race conditions
68      --  for this function because this function can only be executed by
69      --  Self, and the Fall_Back_Handler can only be modified by Self.
70
71      return To_TT (STPO.Self.Common.Fall_Back_Handler);
72   end Current_Task_Fallback_Handler;
73
74   -------------------------------------
75   -- Set_Dependents_Fallback_Handler --
76   -------------------------------------
77
78   procedure Set_Dependents_Fallback_Handler
79     (Handler : Termination_Handler)
80   is
81      Self : constant System.Tasking.Task_Id := STPO.Self;
82
83   begin
84      SSL.Abort_Defer.all;
85
86      if Single_Lock then
87         STPO.Lock_RTS;
88      end if;
89
90      STPO.Write_Lock (Self);
91
92      Self.Common.Fall_Back_Handler := To_ST (Handler);
93
94      STPO.Unlock (Self);
95
96      if Single_Lock then
97         STPO.Unlock_RTS;
98      end if;
99
100      SSL.Abort_Undefer.all;
101   end Set_Dependents_Fallback_Handler;
102
103   --------------------------
104   -- Set_Specific_Handler --
105   --------------------------
106
107   procedure Set_Specific_Handler
108     (T       : Ada.Task_Identification.Task_Id;
109      Handler : Termination_Handler)
110   is
111   begin
112      --  Tasking_Error is raised if the task identified by T has already
113      --  terminated. Program_Error is raised if the value of T is
114      --  Null_Task_Id.
115
116      if T = Ada.Task_Identification.Null_Task_Id then
117         raise Program_Error;
118      elsif Ada.Task_Identification.Is_Terminated (T) then
119         raise Tasking_Error;
120      else
121         declare
122            Target : constant System.Tasking.Task_Id := To_Task_Id (T);
123
124         begin
125            SSL.Abort_Defer.all;
126
127            if Single_Lock then
128               STPO.Lock_RTS;
129            end if;
130
131            STPO.Write_Lock (Target);
132
133            Target.Common.Specific_Handler := To_ST (Handler);
134
135            STPO.Unlock (Target);
136
137            if Single_Lock then
138               STPO.Unlock_RTS;
139            end if;
140
141            SSL.Abort_Undefer.all;
142         end;
143      end if;
144   end Set_Specific_Handler;
145
146   ----------------------
147   -- Specific_Handler --
148   ----------------------
149
150   function Specific_Handler
151     (T : Ada.Task_Identification.Task_Id) return Termination_Handler
152   is
153   begin
154      --  Tasking_Error is raised if the task identified by T has already
155      --  terminated. Program_Error is raised if the value of T is
156      --  Null_Task_Id.
157
158      if T = Ada.Task_Identification.Null_Task_Id then
159         raise Program_Error;
160      elsif Ada.Task_Identification.Is_Terminated (T) then
161         raise Tasking_Error;
162      else
163         declare
164            Target : constant System.Tasking.Task_Id := To_Task_Id (T);
165            TH     : Termination_Handler;
166
167         begin
168            SSL.Abort_Defer.all;
169
170            if Single_Lock then
171               STPO.Lock_RTS;
172            end if;
173
174            STPO.Write_Lock (Target);
175
176            TH := To_TT (Target.Common.Specific_Handler);
177
178            STPO.Unlock (Target);
179
180            if Single_Lock then
181               STPO.Unlock_RTS;
182            end if;
183
184            SSL.Abort_Undefer.all;
185
186            return TH;
187         end;
188      end if;
189   end Specific_Handler;
190
191end Ada.Task_Termination;
192