|
111
|
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-2017, 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 -- 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 type Unsigned is mod 2 ** Integer'Size;
|
|
|
97 function To_Address is new
|
|
|
98 Ada.Unchecked_Conversion (Attribute, System.Address);
|
|
|
99 function To_Unsigned is new
|
|
|
100 Ada.Unchecked_Conversion (Attribute, Unsigned);
|
|
|
101
|
|
|
102 pragma Warnings (On);
|
|
|
103
|
|
|
104 function To_Address is new
|
|
|
105 Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address);
|
|
|
106
|
|
|
107 pragma Warnings (Off);
|
|
|
108 -- Kill warning about possible aliasing
|
|
|
109
|
|
|
110 function To_Handle is new
|
|
|
111 Ada.Unchecked_Conversion (System.Address, Attribute_Handle);
|
|
|
112
|
|
|
113 pragma Warnings (On);
|
|
|
114
|
|
|
115 function To_Task_Id is new
|
|
|
116 Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id);
|
|
|
117 -- To access TCB of identified task
|
|
|
118
|
|
|
119 procedure Free is new
|
|
|
120 Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access);
|
|
|
121
|
|
|
122 Fast_Path : constant Boolean :=
|
|
|
123 (Attribute'Size = Integer'Size
|
|
|
124 and then Attribute'Alignment <= Atomic_Address'Alignment
|
|
|
125 and then To_Unsigned (Initial_Value) = 0)
|
|
|
126 or else (Attribute'Size = System.Address'Size
|
|
|
127 and then Attribute'Alignment <= Atomic_Address'Alignment
|
|
|
128 and then To_Address (Initial_Value) = System.Null_Address);
|
|
|
129 -- If the attribute fits in an Atomic_Address (both size and alignment)
|
|
|
130 -- and Initial_Value is 0 (or null), then we will map the attribute
|
|
|
131 -- directly into ATCB.Attributes (Index), otherwise we will create
|
|
|
132 -- a level of indirection and instead use Attributes (Index) as a
|
|
|
133 -- Real_Attribute_Access.
|
|
|
134
|
|
|
135 Index : constant Integer :=
|
|
|
136 Next_Index (Require_Finalization => not Fast_Path);
|
|
|
137 -- Index in the task control block's Attributes array
|
|
|
138
|
|
|
139 --------------
|
|
|
140 -- Finalize --
|
|
|
141 --------------
|
|
|
142
|
|
|
143 procedure Finalize (Cleanup : in out Attribute_Cleanup) is
|
|
|
144 pragma Unreferenced (Cleanup);
|
|
|
145
|
|
|
146 begin
|
|
|
147 STPO.Lock_RTS;
|
|
|
148
|
|
|
149 declare
|
|
|
150 C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
|
|
|
151
|
|
|
152 begin
|
|
|
153 while C /= null loop
|
|
|
154 STPO.Write_Lock (C);
|
|
|
155
|
|
|
156 if C.Attributes (Index) /= 0
|
|
|
157 and then Require_Finalization (Index)
|
|
|
158 then
|
|
|
159 Deallocate (C.Attributes (Index));
|
|
|
160 C.Attributes (Index) := 0;
|
|
|
161 end if;
|
|
|
162
|
|
|
163 STPO.Unlock (C);
|
|
|
164 C := C.Common.All_Tasks_Link;
|
|
|
165 end loop;
|
|
|
166 end;
|
|
|
167
|
|
|
168 Finalize (Index);
|
|
|
169 STPO.Unlock_RTS;
|
|
|
170 end Finalize;
|
|
|
171
|
|
|
172 ----------------
|
|
|
173 -- Deallocate --
|
|
|
174 ----------------
|
|
|
175
|
|
|
176 procedure Deallocate (Ptr : Atomic_Address) is
|
|
|
177 Obj : Real_Attribute_Access := To_Real_Attribute (Ptr);
|
|
|
178 begin
|
|
|
179 Free (Obj);
|
|
|
180 end Deallocate;
|
|
|
181
|
|
|
182 -------------------
|
|
|
183 -- New_Attribute --
|
|
|
184 -------------------
|
|
|
185
|
|
|
186 function New_Attribute (Val : Attribute) return Atomic_Address is
|
|
|
187 Tmp : Real_Attribute_Access;
|
|
|
188 begin
|
|
|
189 Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access,
|
|
|
190 Value => Val);
|
|
|
191 return To_Address (Tmp);
|
|
|
192 end New_Attribute;
|
|
|
193
|
|
|
194 ---------------
|
|
|
195 -- Reference --
|
|
|
196 ---------------
|
|
|
197
|
|
|
198 function Reference
|
|
|
199 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
|
|
|
200 return Attribute_Handle
|
|
|
201 is
|
|
|
202 Self_Id : Task_Id;
|
|
|
203 TT : constant Task_Id := To_Task_Id (T);
|
|
|
204 Error_Message : constant String := "trying to get the reference of a ";
|
|
|
205 Result : Attribute_Handle;
|
|
|
206
|
|
|
207 begin
|
|
|
208 if TT = null then
|
|
|
209 raise Program_Error with Error_Message & "null task";
|
|
|
210 end if;
|
|
|
211
|
|
|
212 if TT.Common.State = Terminated then
|
|
|
213 raise Tasking_Error with Error_Message & "terminated task";
|
|
|
214 end if;
|
|
|
215
|
|
|
216 if Fast_Path then
|
|
|
217 -- Kill warning about possible alignment mismatch. If this happens,
|
|
|
218 -- Fast_Path will be False anyway
|
|
|
219 pragma Warnings (Off);
|
|
|
220 return To_Handle (TT.Attributes (Index)'Address);
|
|
|
221 pragma Warnings (On);
|
|
|
222 else
|
|
|
223 Self_Id := STPO.Self;
|
|
|
224 Task_Lock (Self_Id);
|
|
|
225
|
|
|
226 if TT.Attributes (Index) = 0 then
|
|
|
227 TT.Attributes (Index) := New_Attribute (Initial_Value);
|
|
|
228 end if;
|
|
|
229
|
|
|
230 Result := To_Handle
|
|
|
231 (To_Real_Attribute (TT.Attributes (Index)).Value'Address);
|
|
|
232 Task_Unlock (Self_Id);
|
|
|
233
|
|
|
234 return Result;
|
|
|
235 end if;
|
|
|
236 end Reference;
|
|
|
237
|
|
|
238 ------------------
|
|
|
239 -- Reinitialize --
|
|
|
240 ------------------
|
|
|
241
|
|
|
242 procedure Reinitialize
|
|
|
243 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
|
|
|
244 is
|
|
|
245 Self_Id : Task_Id;
|
|
|
246 TT : constant Task_Id := To_Task_Id (T);
|
|
|
247 Error_Message : constant String := "Trying to Reinitialize a ";
|
|
|
248
|
|
|
249 begin
|
|
|
250 if TT = null then
|
|
|
251 raise Program_Error with Error_Message & "null task";
|
|
|
252 end if;
|
|
|
253
|
|
|
254 if TT.Common.State = Terminated then
|
|
|
255 raise Tasking_Error with Error_Message & "terminated task";
|
|
|
256 end if;
|
|
|
257
|
|
|
258 if Fast_Path then
|
|
|
259
|
|
|
260 -- No finalization needed, simply reset to Initial_Value
|
|
|
261
|
|
|
262 TT.Attributes (Index) := To_Address (Initial_Value);
|
|
|
263
|
|
|
264 else
|
|
|
265 Self_Id := STPO.Self;
|
|
|
266 Task_Lock (Self_Id);
|
|
|
267
|
|
|
268 declare
|
|
|
269 Attr : Atomic_Address renames TT.Attributes (Index);
|
|
|
270 begin
|
|
|
271 if Attr /= 0 then
|
|
|
272 Deallocate (Attr);
|
|
|
273 Attr := 0;
|
|
|
274 end if;
|
|
|
275 end;
|
|
|
276
|
|
|
277 Task_Unlock (Self_Id);
|
|
|
278 end if;
|
|
|
279 end Reinitialize;
|
|
|
280
|
|
|
281 ---------------
|
|
|
282 -- Set_Value --
|
|
|
283 ---------------
|
|
|
284
|
|
|
285 procedure Set_Value
|
|
|
286 (Val : Attribute;
|
|
|
287 T : Task_Identification.Task_Id := Task_Identification.Current_Task)
|
|
|
288 is
|
|
|
289 Self_Id : Task_Id;
|
|
|
290 TT : constant Task_Id := To_Task_Id (T);
|
|
|
291 Error_Message : constant String := "trying to set the value of a ";
|
|
|
292
|
|
|
293 begin
|
|
|
294 if TT = null then
|
|
|
295 raise Program_Error with Error_Message & "null task";
|
|
|
296 end if;
|
|
|
297
|
|
|
298 if TT.Common.State = Terminated then
|
|
|
299 raise Tasking_Error with Error_Message & "terminated task";
|
|
|
300 end if;
|
|
|
301
|
|
|
302 if Fast_Path then
|
|
|
303
|
|
|
304 -- No finalization needed, simply set to Val
|
|
|
305
|
|
|
306 if Attribute'Size = Integer'Size then
|
|
|
307 TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val));
|
|
|
308 else
|
|
|
309 TT.Attributes (Index) := To_Address (Val);
|
|
|
310 end if;
|
|
|
311
|
|
|
312 else
|
|
|
313 Self_Id := STPO.Self;
|
|
|
314 Task_Lock (Self_Id);
|
|
|
315
|
|
|
316 declare
|
|
|
317 Attr : Atomic_Address renames TT.Attributes (Index);
|
|
|
318
|
|
|
319 begin
|
|
|
320 if Attr /= 0 then
|
|
|
321 Deallocate (Attr);
|
|
|
322 end if;
|
|
|
323
|
|
|
324 Attr := New_Attribute (Val);
|
|
|
325 end;
|
|
|
326
|
|
|
327 Task_Unlock (Self_Id);
|
|
|
328 end if;
|
|
|
329 end Set_Value;
|
|
|
330
|
|
|
331 -----------
|
|
|
332 -- Value --
|
|
|
333 -----------
|
|
|
334
|
|
|
335 function Value
|
|
|
336 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
|
|
|
337 return Attribute
|
|
|
338 is
|
|
|
339 Self_Id : Task_Id;
|
|
|
340 TT : constant Task_Id := To_Task_Id (T);
|
|
|
341 Error_Message : constant String := "trying to get the value of a ";
|
|
|
342
|
|
|
343 begin
|
|
|
344 if TT = null then
|
|
|
345 raise Program_Error with Error_Message & "null task";
|
|
|
346 end if;
|
|
|
347
|
|
|
348 if TT.Common.State = Terminated then
|
|
|
349 raise Tasking_Error with Error_Message & "terminated task";
|
|
|
350 end if;
|
|
|
351
|
|
|
352 if Fast_Path then
|
|
|
353 return To_Attribute (TT.Attributes (Index));
|
|
|
354
|
|
|
355 else
|
|
|
356 Self_Id := STPO.Self;
|
|
|
357 Task_Lock (Self_Id);
|
|
|
358
|
|
|
359 declare
|
|
|
360 Attr : Atomic_Address renames TT.Attributes (Index);
|
|
|
361
|
|
|
362 begin
|
|
|
363 if Attr = 0 then
|
|
|
364 Task_Unlock (Self_Id);
|
|
|
365 return Initial_Value;
|
|
|
366
|
|
|
367 else
|
|
|
368 declare
|
|
|
369 Result : constant Attribute :=
|
|
|
370 To_Real_Attribute (Attr).Value;
|
|
|
371 begin
|
|
|
372 Task_Unlock (Self_Id);
|
|
|
373 return Result;
|
|
|
374 end;
|
|
|
375 end if;
|
|
|
376 end;
|
|
|
377 end if;
|
|
|
378 end Value;
|
|
|
379
|
|
|
380 end Ada.Task_Attributes;
|
