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-2019, 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
32with System.Tasking;
33with System.Tasking.Initialization;
34with System.Tasking.Task_Attributes;
35pragma Elaborate_All (System.Tasking.Task_Attributes);
36
37with System.Task_Primitives.Operations;
38
39with Ada.Finalization; use Ada.Finalization;
40with Ada.Unchecked_Conversion;
41with Ada.Unchecked_Deallocation;
42
43package 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
380end Ada.Task_Attributes;
381