1------------------------------------------------------------------------------
2--                                                                          --
3--                GNU ADA 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-2003, Ada Core Technologies               --
11--                                                                          --
12-- GNARL 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 2,  or (at your option) any later ver- --
15-- sion. GNARL 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.  See the GNU General Public License --
18-- for  more details.  You should have  received  a copy of the GNU General --
19-- Public License  distributed with GNARL; see file COPYING.  If not, write --
20-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
21-- MA 02111-1307, USA.                                                      --
22--                                                                          --
23-- As a special exception,  if other files  instantiate  generics from this --
24-- unit, or you link  this unit with other files  to produce an executable, --
25-- this  unit  does not  by itself cause  the resulting  executable  to  be --
26-- covered  by the  GNU  General  Public  License.  This exception does not --
27-- however invalidate  any other reasons why  the executable file  might be --
28-- covered by the  GNU Public License.                                      --
29--                                                                          --
30-- GNARL was developed by the GNARL team at Florida State University.       --
31-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
32--                                                                          --
33------------------------------------------------------------------------------
34
35with System.Storage_Elements;
36--  used for To_Address
37
38with System.Task_Primitives.Operations;
39--  used for Write_Lock
40--           Unlock
41--           Lock/Unlock_RTS
42
43with System.Tasking.Initialization;
44--  used for Defer_Abort
45--           Undefer_Abort
46
47with Unchecked_Conversion;
48
49package body System.Tasking.Task_Attributes is
50
51   use Task_Primitives.Operations;
52   use Tasking.Initialization;
53
54   function To_Access_Node is new Unchecked_Conversion
55     (Access_Address, Access_Node);
56   --  Tetch pointer to indirect attribute list
57
58   function To_Access_Address is new Unchecked_Conversion
59     (Access_Node, Access_Address);
60   --  Store pointer to indirect attribute list
61
62   --------------
63   -- Finalize --
64   --------------
65
66   procedure Finalize (X : in out Instance) is
67      Q, To_Be_Freed : Access_Node;
68
69   begin
70      Defer_Abortion;
71      Lock_RTS;
72
73      --  Remove this instantiation from the list of all instantiations.
74
75      declare
76         P : Access_Instance;
77         Q : Access_Instance := All_Attributes;
78
79      begin
80         while Q /= null and then Q /= X'Unchecked_Access loop
81            P := Q; Q := Q.Next;
82         end loop;
83
84         pragma Assert (Q /= null);
85
86         if P = null then
87            All_Attributes := Q.Next;
88         else
89            P.Next := Q.Next;
90         end if;
91      end;
92
93      if X.Index /= 0 then
94         --  Free location of this attribute, for reuse.
95
96         In_Use := In_Use and not (2**Natural (X.Index));
97
98         --  There is no need for finalization in this case,
99         --  since controlled types are too big to fit in the TCB.
100
101      else
102         --  Remove nodes for this attribute from the lists of
103         --  all tasks, and deallocate the nodes.
104         --  Deallocation does finalization, if necessary.
105
106         declare
107            C : System.Tasking.Task_ID := All_Tasks_List;
108            P : Access_Node;
109
110         begin
111            while C /= null loop
112               Write_Lock (C);
113
114               Q := To_Access_Node (C.Indirect_Attributes);
115               while Q /= null
116                 and then Q.Instance /= X'Unchecked_Access
117               loop
118                  P := Q;
119                  Q := Q.Next;
120               end loop;
121
122               if Q /= null then
123                  if P = null then
124                     C.Indirect_Attributes := To_Access_Address (Q.Next);
125                  else
126                     P.Next := Q.Next;
127                  end if;
128
129                  --  Can't Deallocate now since we are holding RTS_Lock.
130
131                  Q.Next := To_Be_Freed;
132                  To_Be_Freed := Q;
133               end if;
134
135               Unlock (C);
136               C := C.Common.All_Tasks_Link;
137            end loop;
138         end;
139      end if;
140
141      Unlock_RTS;
142
143      while To_Be_Freed /= null loop
144         Q := To_Be_Freed;
145         To_Be_Freed := To_Be_Freed.Next;
146         X.Deallocate.all (Q);
147      end loop;
148
149      Undefer_Abortion;
150
151   exception
152      when others =>
153         null;
154         pragma Assert (False,
155           "Exception in task attribute instance finalization");
156   end Finalize;
157
158   -------------------------
159   -- Finalize Attributes --
160   -------------------------
161
162   --  This is to be called just before the ATCB is deallocated.
163   --  It relies on the caller holding T.L write-lock on entry.
164
165   procedure Finalize_Attributes (T : Task_ID) is
166      P : Access_Node;
167      Q : Access_Node := To_Access_Node (T.Indirect_Attributes);
168
169   begin
170      --  Deallocate all the indirect attributes of this task.
171
172      while Q /= null loop
173         P := Q;
174         Q := Q.Next; P.Instance.Deallocate.all (P);
175      end loop;
176
177      T.Indirect_Attributes := null;
178
179   exception
180      when others =>
181         null;
182         pragma Assert (False,
183           "Exception in per-task attributes finalization");
184   end Finalize_Attributes;
185
186   ---------------------------
187   -- Initialize Attributes --
188   ---------------------------
189
190   --  This is to be called by System.Tasking.Stages.Create_Task.
191
192   procedure Initialize_Attributes (T : Task_ID) is
193      P : Access_Instance;
194   begin
195      Defer_Abortion;
196      Lock_RTS;
197
198      --  Initialize all the direct-access attributes of this task.
199
200      P := All_Attributes;
201
202      while P /= null loop
203         if P.Index /= 0 then
204            T.Direct_Attributes (P.Index) :=
205              Direct_Attribute_Element
206                (System.Storage_Elements.To_Address (P.Initial_Value));
207         end if;
208
209         P := P.Next;
210      end loop;
211
212      Unlock_RTS;
213      Undefer_Abortion;
214
215   exception
216      when others =>
217         null;
218         pragma Assert (False);
219   end Initialize_Attributes;
220
221end System.Tasking.Task_Attributes;
222