1------------------------------------------------------------------------------
2--                                                                          --
3--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
4--                                                                          --
5--         S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S      --
6--                                                                          --
7--                                  B o d y                                 --
8--                                                                          --
9--             Copyright (C) 1991-1994, Florida State University            --
10--                     Copyright (C) 1995-2013, AdaCore                     --
11--                                                                          --
12-- GNAT is free software;  you can  redistribute it  and/or modify it under --
13-- terms of the  GNU General Public License as published  by the Free Soft- --
14-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
15-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
16-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
17-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
18--                                                                          --
19-- As a special exception under Section 7 of GPL version 3, you are granted --
20-- additional permissions described in the GCC Runtime Library Exception,   --
21-- version 3.1, as published by the Free Software Foundation.               --
22--                                                                          --
23-- You should have received a copy of the GNU General Public License and    --
24-- a copy of the GCC Runtime Library Exception along with this program;     --
25-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
26-- <http://www.gnu.org/licenses/>.                                          --
27--                                                                          --
28-- GNARL was developed by the GNARL team at Florida State University.       --
29-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
30--                                                                          --
31------------------------------------------------------------------------------
32
33with Ada.Unchecked_Conversion;
34
35with System.Task_Primitives.Operations;
36with System.Tasking.Initialization;
37
38package body System.Tasking.Task_Attributes is
39
40   use Task_Primitives.Operations;
41   use Tasking.Initialization;
42
43   function To_Access_Address is new Ada.Unchecked_Conversion
44     (Access_Node, Access_Address);
45   --  Store pointer to indirect attribute list
46
47   --------------
48   -- Finalize --
49   --------------
50
51   procedure Finalize (X : in out Instance) is
52      Q, To_Be_Freed : Access_Node;
53      Self_Id        : constant Task_Id := Self;
54
55   begin
56      --  Defer abort. Note that we use the nestable versions of Defer_Abort
57      --  and Undefer_Abort, because abort can already deferred when this is
58      --  called during finalization, which would cause an assert failure
59      --  in Defer_Abort.
60
61      Defer_Abort_Nestable (Self_Id);
62      Lock_RTS;
63
64      --  Remove this instantiation from the list of all instantiations
65
66      declare
67         P : Access_Instance;
68         Q : Access_Instance := All_Attributes;
69
70      begin
71         while Q /= null and then Q /= X'Unchecked_Access loop
72            P := Q; Q := Q.Next;
73         end loop;
74
75         pragma Assert (Q /= null);
76
77         if P = null then
78            All_Attributes := Q.Next;
79         else
80            P.Next := Q.Next;
81         end if;
82      end;
83
84      if X.Index /= 0 then
85
86         --  Free location of this attribute, for reuse
87
88         In_Use := In_Use and not (2**Natural (X.Index));
89
90         --  There is no need for finalization in this case, since controlled
91         --  types are too big to fit in the TCB.
92
93      else
94         --  Remove nodes for this attribute from the lists of all tasks,
95         --  and deallocate the nodes. Deallocation does finalization, if
96         --  necessary.
97
98         declare
99            C : System.Tasking.Task_Id := All_Tasks_List;
100            P : Access_Node;
101
102         begin
103            while C /= null loop
104               Write_Lock (C);
105
106               Q := To_Access_Node (C.Indirect_Attributes);
107               while Q /= null
108                 and then Q.Instance /= X'Unchecked_Access
109               loop
110                  P := Q;
111                  Q := Q.Next;
112               end loop;
113
114               if Q /= null then
115                  if P = null then
116                     C.Indirect_Attributes := To_Access_Address (Q.Next);
117                  else
118                     P.Next := Q.Next;
119                  end if;
120
121                  --  Can't Deallocate now since we are holding RTS_Lock
122
123                  Q.Next := To_Be_Freed;
124                  To_Be_Freed := Q;
125               end if;
126
127               Unlock (C);
128               C := C.Common.All_Tasks_Link;
129            end loop;
130         end;
131      end if;
132
133      Unlock_RTS;
134
135      while To_Be_Freed /= null loop
136         Q := To_Be_Freed;
137         To_Be_Freed := To_Be_Freed.Next;
138         X.Deallocate.all (Q);
139      end loop;
140
141      Undefer_Abort_Nestable (Self_Id);
142
143   exception
144      when others =>
145         null;
146         pragma Assert (False,
147           "Exception in task attribute instance finalization");
148   end Finalize;
149
150   -------------------------
151   -- Finalize Attributes --
152   -------------------------
153
154   --  This is to be called just before the ATCB is deallocated.
155   --  It relies on the caller holding T.L write-lock on entry.
156
157   procedure Finalize_Attributes (T : Task_Id) is
158      P : Access_Node;
159      Q : Access_Node := To_Access_Node (T.Indirect_Attributes);
160
161   begin
162      --  Deallocate all the indirect attributes of this task
163
164      while Q /= null loop
165         P := Q;
166         Q := Q.Next; P.Instance.Deallocate.all (P);
167      end loop;
168
169      T.Indirect_Attributes := null;
170
171   exception
172      when others =>
173         null;
174         pragma Assert (False,
175           "Exception in per-task attributes finalization");
176   end Finalize_Attributes;
177
178   ---------------------------
179   -- Initialize Attributes --
180   ---------------------------
181
182   --  This is to be called by System.Tasking.Stages.Create_Task
183
184   procedure Initialize_Attributes (T : Task_Id) is
185      P       : Access_Instance;
186      Self_Id : constant Task_Id := Self;
187
188   begin
189      --  Note: we call [Un]Defer_Abort_Nestable, rather than [Un]Defer_Abort,
190      --  because Abort might already be deferred in Create_Task.
191
192      Defer_Abort_Nestable (Self_Id);
193      Lock_RTS;
194
195      --  Initialize all the direct-access attributes of this task
196
197      P := All_Attributes;
198
199      while P /= null loop
200         if P.Index /= 0 then
201            T.Direct_Attributes (P.Index) :=
202              Direct_Attribute_Element
203                (System.Storage_Elements.To_Address (P.Initial_Value));
204         end if;
205
206         P := P.Next;
207      end loop;
208
209      Unlock_RTS;
210      Undefer_Abort_Nestable (Self_Id);
211
212   exception
213      when others =>
214         null;
215         pragma Assert (False);
216   end Initialize_Attributes;
217
218end System.Tasking.Task_Attributes;
219