File : a-tasatt.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . T A S K _ A T T R I B U T E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2014-2016, 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 -- --
19 -- --
20 -- --
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
32 with System.Tasking;
33 with System.Tasking.Initialization;
34 with System.Tasking.Task_Attributes;
35 pragma Elaborate_All (System.Tasking.Task_Attributes);
36
37 with System.Task_Primitives.Operations;
38
39 with Ada.Finalization; use Ada.Finalization;
40 with Ada.Unchecked_Conversion;
41 with Ada.Unchecked_Deallocation;
42
43 package body Ada.Task_Attributes is
44
45 use System,
46 System.Tasking.Initialization,
47 System.Tasking,
48 System.Tasking.Task_Attributes;
49
50 package STPO renames System.Task_Primitives.Operations;
51
52 type Attribute_Cleanup is new Limited_Controlled with null record;
53 procedure Finalize (Cleanup : in out Attribute_Cleanup);
54 -- Finalize all tasks' attributes for this package
55
56 Cleanup : Attribute_Cleanup;
57 pragma Unreferenced (Cleanup);
58 -- Will call Finalize when this instantiation gets out of scope
59
60 ---------------------------
61 -- Unchecked Conversions --
62 ---------------------------
63
64 type Real_Attribute is record
65 Free : Deallocator;
66 Value : Attribute;
67 end record;
68 type Real_Attribute_Access is access all Real_Attribute;
69 pragma No_Strict_Aliasing (Real_Attribute_Access);
70 -- Each value in the task control block's Attributes array is either
71 -- mapped to the attribute value directly if Fast_Path is True, or
72 -- is in effect a Real_Attribute_Access.
73 --
74 -- Note: the Deallocator field must be first, for compatibility with
75 -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked
76 -- conversions between Attribute_Access and Real_Attribute_Access.
77
78 function New_Attribute (Val : Attribute) return Atomic_Address;
79 -- Create a new Real_Attribute using Val, and return its address. The
80 -- returned value can be converted via To_Real_Attribute.
81
82 procedure Deallocate (Ptr : Atomic_Address);
83 -- Free memory associated with Ptr, a Real_Attribute_Access in reality
84
85 function To_Real_Attribute is new
86 Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access);
87
88 pragma Warnings (Off);
89 -- Kill warning about possible size mismatch
90
91 function To_Address is new
92 Ada.Unchecked_Conversion (Attribute, Atomic_Address);
93 function To_Attribute is new
94 Ada.Unchecked_Conversion (Atomic_Address, Attribute);
95
96 function To_Address is new
97 Ada.Unchecked_Conversion (Attribute, System.Address);
98 function To_Int is new
99 Ada.Unchecked_Conversion (Attribute, Integer);
100
101 pragma Warnings (On);
102
103 function To_Address is new
104 Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address);
105
106 pragma Warnings (Off);
107 -- Kill warning about possible aliasing
108
109 function To_Handle is new
110 Ada.Unchecked_Conversion (System.Address, Attribute_Handle);
111
112 pragma Warnings (On);
113
114 function To_Task_Id is new
115 Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id);
116 -- To access TCB of identified task
117
118 procedure Free is new
119 Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access);
120
121 Fast_Path : constant Boolean :=
122 (Attribute'Size = Integer'Size
123 and then Attribute'Alignment <= Atomic_Address'Alignment
124 and then To_Int (Initial_Value) = 0)
125 or else (Attribute'Size = System.Address'Size
126 and then Attribute'Alignment <= Atomic_Address'Alignment
127 and then To_Address (Initial_Value) = System.Null_Address);
128 -- If the attribute fits in an Atomic_Address (both size and alignment)
129 -- and Initial_Value is 0 (or null), then we will map the attribute
130 -- directly into ATCB.Attributes (Index), otherwise we will create
131 -- a level of indirection and instead use Attributes (Index) as a
132 -- Real_Attribute_Access.
133
134 Index : constant Integer :=
135 Next_Index (Require_Finalization => not Fast_Path);
136 -- Index in the task control block's Attributes array
137
138 --------------
139 -- Finalize --
140 --------------
141
142 procedure Finalize (Cleanup : in out Attribute_Cleanup) is
143 pragma Unreferenced (Cleanup);
144
145 begin
146 STPO.Lock_RTS;
147
148 declare
149 C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
150
151 begin
152 while C /= null loop
153 STPO.Write_Lock (C);
154
155 if C.Attributes (Index) /= 0
156 and then Require_Finalization (Index)
157 then
158 Deallocate (C.Attributes (Index));
159 C.Attributes (Index) := 0;
160 end if;
161
162 STPO.Unlock (C);
163 C := C.Common.All_Tasks_Link;
164 end loop;
165 end;
166
167 Finalize (Index);
168 STPO.Unlock_RTS;
169 end Finalize;
170
171 ----------------
172 -- Deallocate --
173 ----------------
174
175 procedure Deallocate (Ptr : Atomic_Address) is
176 Obj : Real_Attribute_Access := To_Real_Attribute (Ptr);
177 begin
178 Free (Obj);
179 end Deallocate;
180
181 -------------------
182 -- New_Attribute --
183 -------------------
184
185 function New_Attribute (Val : Attribute) return Atomic_Address is
186 Tmp : Real_Attribute_Access;
187 begin
188 Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access,
189 Value => Val);
190 return To_Address (Tmp);
191 end New_Attribute;
192
193 ---------------
194 -- Reference --
195 ---------------
196
197 function Reference
198 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
199 return Attribute_Handle
200 is
201 Self_Id : Task_Id;
202 TT : constant Task_Id := To_Task_Id (T);
203 Error_Message : constant String := "trying to get the reference of a ";
204 Result : Attribute_Handle;
205
206 begin
207 if TT = null then
208 raise Program_Error with Error_Message & "null task";
209 end if;
210
211 if TT.Common.State = Terminated then
212 raise Tasking_Error with Error_Message & "terminated task";
213 end if;
214
215 if Fast_Path then
216 -- Kill warning about possible alignment mismatch. If this happens,
217 -- Fast_Path will be False anyway
218 pragma Warnings (Off);
219 return To_Handle (TT.Attributes (Index)'Address);
220 pragma Warnings (On);
221 else
222 Self_Id := STPO.Self;
223 Task_Lock (Self_Id);
224
225 if TT.Attributes (Index) = 0 then
226 TT.Attributes (Index) := New_Attribute (Initial_Value);
227 end if;
228
229 Result := To_Handle
230 (To_Real_Attribute (TT.Attributes (Index)).Value'Address);
231 Task_Unlock (Self_Id);
232
233 return Result;
234 end if;
235 end Reference;
236
237 ------------------
238 -- Reinitialize --
239 ------------------
240
241 procedure Reinitialize
242 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
243 is
244 Self_Id : Task_Id;
245 TT : constant Task_Id := To_Task_Id (T);
246 Error_Message : constant String := "Trying to Reinitialize a ";
247
248 begin
249 if TT = null then
250 raise Program_Error with Error_Message & "null task";
251 end if;
252
253 if TT.Common.State = Terminated then
254 raise Tasking_Error with Error_Message & "terminated task";
255 end if;
256
257 if Fast_Path then
258
259 -- No finalization needed, simply reset to Initial_Value
260
261 TT.Attributes (Index) := To_Address (Initial_Value);
262
263 else
264 Self_Id := STPO.Self;
265 Task_Lock (Self_Id);
266
267 declare
268 Attr : Atomic_Address renames TT.Attributes (Index);
269 begin
270 if Attr /= 0 then
271 Deallocate (Attr);
272 Attr := 0;
273 end if;
274 end;
275
276 Task_Unlock (Self_Id);
277 end if;
278 end Reinitialize;
279
280 ---------------
281 -- Set_Value --
282 ---------------
283
284 procedure Set_Value
285 (Val : Attribute;
286 T : Task_Identification.Task_Id := Task_Identification.Current_Task)
287 is
288 Self_Id : Task_Id;
289 TT : constant Task_Id := To_Task_Id (T);
290 Error_Message : constant String := "trying to set the value of a ";
291
292 begin
293 if TT = null then
294 raise Program_Error with Error_Message & "null task";
295 end if;
296
297 if TT.Common.State = Terminated then
298 raise Tasking_Error with Error_Message & "terminated task";
299 end if;
300
301 if Fast_Path then
302
303 -- No finalization needed, simply set to Val
304
305 TT.Attributes (Index) := To_Address (Val);
306
307 else
308 Self_Id := STPO.Self;
309 Task_Lock (Self_Id);
310
311 declare
312 Attr : Atomic_Address renames TT.Attributes (Index);
313
314 begin
315 if Attr /= 0 then
316 Deallocate (Attr);
317 end if;
318
319 Attr := New_Attribute (Val);
320 end;
321
322 Task_Unlock (Self_Id);
323 end if;
324 end Set_Value;
325
326 -----------
327 -- Value --
328 -----------
329
330 function Value
331 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
332 return Attribute
333 is
334 Self_Id : Task_Id;
335 TT : constant Task_Id := To_Task_Id (T);
336 Error_Message : constant String := "trying to get the value of a ";
337
338 begin
339 if TT = null then
340 raise Program_Error with Error_Message & "null task";
341 end if;
342
343 if TT.Common.State = Terminated then
344 raise Tasking_Error with Error_Message & "terminated task";
345 end if;
346
347 if Fast_Path then
348 return To_Attribute (TT.Attributes (Index));
349
350 else
351 Self_Id := STPO.Self;
352 Task_Lock (Self_Id);
353
354 declare
355 Attr : Atomic_Address renames TT.Attributes (Index);
356
357 begin
358 if Attr = 0 then
359 Task_Unlock (Self_Id);
360 return Initial_Value;
361
362 else
363 declare
364 Result : constant Attribute :=
365 To_Real_Attribute (Attr).Value;
366 begin
367 Task_Unlock (Self_Id);
368 return Result;
369 end;
370 end if;
371 end;
372 end if;
373 end Value;
374
375 end Ada.Task_Attributes;