1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . T A S K _ A T T R I B U T E S --
11 -- Copyright (C) 1991-2000 Florida State University --
13 -- GNARL is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNARL; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNARL was developed by the GNARL team at Florida State University. It is --
32 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
33 -- State University (http://www.gnat.com). --
35 ------------------------------------------------------------------------------
37 -- The following notes are provided in case someone decides the
38 -- implementation of this package is too complicated, or too slow.
39 -- Please read this before making any "simplifications".
41 -- Correct implementation of this package is more difficult than one
42 -- might expect. After considering (and coding) several alternatives,
43 -- we settled on the present compromise. Things we do not like about
44 -- this implementation include:
46 -- - It is vulnerable to bad Task_ID values, to the extent of
47 -- possibly trashing memory and crashing the runtime system.
49 -- - It requires dynamic storage allocation for each new attribute value,
50 -- except for types that happen to be the same size as System.Address,
53 -- - Instantiations at other than the library level rely on being able to
54 -- do down-level calls to a procedure declared in the generic package body.
55 -- This makes it potentially vulnerable to compiler changes.
57 -- The main implementation issue here is that the connection from
58 -- task to attribute is a potential source of dangling references.
60 -- When a task goes away, we want to be able to recover all the storage
61 -- associated with its attributes. The Ada mechanism for this is
62 -- finalization, via controlled attribute types. For this reason,
63 -- the ARM requires finalization of attribute values when the
64 -- associated task terminates.
66 -- This finalization must be triggered by the tasking runtime system,
67 -- during termination of the task. Given the active set of instantiations
68 -- of Ada.Task_Attributes is dynamic, the number and types of attributes
69 -- belonging to a task will not be known until the task actually terminates.
70 -- Some of these types may be controlled and some may not. The RTS must find
71 -- some way to determine which of these attributes need finalization, and
72 -- invoke the appropriate finalization on them.
74 -- One way this might be done is to create a special finalization chain
75 -- for each task, similar to the finalization chain that is used for
76 -- controlled objects within the task. This would differ from the usual
77 -- finalization chain in that it would not have a LIFO structure, since
78 -- attributes may be added to a task at any time during its lifetime.
79 -- This might be the right way to go for the longer term, but at present
80 -- this approach is not open, since GNAT does not provide such special
81 -- finalization support.
83 -- Lacking special compiler support, the RTS is limited to the
84 -- normal ways an application invokes finalization, i.e.
86 -- a) Explicit call to the procedure Finalize, if we know the type
87 -- has this operation defined on it. This is not sufficient, since
88 -- we have no way of determining whether a given generic formal
89 -- Attribute type is controlled, and no visibility of the associated
90 -- Finalize procedure, in the generic body.
92 -- b) Leaving the scope of a local object of a controlled type.
93 -- This does not help, since the lifetime of an instantiation of
94 -- Ada.Task_Attributes does not correspond to the lifetimes of the
95 -- various tasks which may have that attribute.
97 -- c) Assignment of another value to the object. This would not help,
98 -- since we then have to finalize the new value of the object.
100 -- d) Unchecked deallocation of an object of a controlled type.
101 -- This seems to be the only mechanism available to the runtime
102 -- system for finalization of task attributes.
104 -- We considered two ways of using unchecked deallocation, both based
105 -- on a linked list of that would hang from the task control block.
107 -- In the first approach the objects on the attribute list are all derived
108 -- from one controlled type, say T, and are linked using an access type to
109 -- T'Class. The runtime system has an Unchecked_Deallocation for T'Class
110 -- with access type T'Class, and uses this to deallocate and finalize all
111 -- the items in the list. The limitation of this approach is that each
112 -- instantiation of the package Ada.Task_Attributes derives a new record
113 -- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation
114 -- is only allowed at the library level.
116 -- In the second approach the objects on the attribute list are of
117 -- unrelated but structurally similar types. Unchecked conversion is
118 -- used to circument Ada type checking. Each attribute-storage node
119 -- contains not only the attribute value and a link for chaining, but
120 -- also a pointer to a descriptor for the corresponding instantiation
121 -- of Task_Attributes. The instantiation-descriptor contains a
122 -- pointer to a procedure that can do the correct deallocation and
123 -- finalization for that type of attribute. On task termination, the
124 -- runtime system uses the pointer to call the appropriate deallocator.
126 -- While this gets around the limitation that instantiations be at
127 -- the library level, it relies on an implementation feature that
128 -- may not always be safe, i.e. that it is safe to call the
129 -- Deallocate procedure for an instantiation of Ada.Task_Attributes
130 -- that no longer exists. In general, it seems this might result in
131 -- dangling references.
133 -- Another problem with instantiations deeper than the library level
134 -- is that there is risk of storage leakage, or dangling references
135 -- to reused storage. That is, if an instantiation of Ada.Task_Attributes
136 -- is made within a procedure, what happens to the storage allocated for
137 -- attributes, when the procedure call returns? Apparently (RM 7.6.1 (4))
138 -- any such objects must be finalized, since they will no longer be
139 -- accessible, and in general one would expect that the storage they occupy
140 -- would be recovered for later reuse. (If not, we would have a case of
141 -- storage leakage.) Assuming the storage is recovered and later reused,
142 -- we have potentially dangerous dangling references. When the procedure
143 -- containing the instantiation of Ada.Task_Attributes returns, there
144 -- may still be unterminated tasks with associated attribute values for
145 -- that instantiation. When such tasks eventually terminate, the RTS
146 -- will attempt to call the Deallocate procedure on them. If the
147 -- corresponding storage has already been deallocated, when the master
148 -- of the access type was left, we have a potential disaster. This
149 -- disaster is compounded since the pointer to Deallocate is probably
150 -- through a "trampoline" which will also have been destroyed.
152 -- For this reason, we arrange to remove all dangling references
153 -- before leaving the scope of an instantiation. This is ugly, since
154 -- it requires traversing the list of all tasks, but it is no more ugly
155 -- than a similar traversal that we must do at the point of instantiation
156 -- in order to initialize the attributes of all tasks. At least we only
157 -- need to do these traversals if the type is controlled.
159 -- We chose to defer allocation of storage for attributes until the
160 -- Reference function is called or the attribute is first set to a value
161 -- different from the default initial one. This allows a potential
162 -- savings in allocation, for attributes that are not used by all tasks.
164 -- For efficiency, we reserve space in the TCB for a fixed number of
165 -- direct-access attributes. These are required to be of a size that
166 -- fits in the space of an object of type System.Address. Because
167 -- we must use unchecked bitwise copy operations on these values, they
168 -- cannot be of a controlled type, but that is covered automatically
169 -- since controlled objects are too large to fit in the spaces.
171 -- We originally deferred the initialization of these direct-access
172 -- attributes, just as we do for the indirect-access attributes, and
173 -- used a per-task bit vector to keep track of which attributes were
174 -- currently defined for that task. We found that the overhead of
175 -- maintaining this bit-vector seriously slowed down access to the
176 -- attributes, and made the fetch operation non-atomic, so that even
177 -- to read an attribute value required locking the TCB. Therefore,
178 -- we now initialize such attributes for all existing tasks at the time
179 -- of the attribute instantiation, and initialize existing attributes
180 -- for each new task at the time it is created.
182 -- The latter initialization requires a list of all the instantiation
183 -- descriptors. Updates to this list, as well as the bit-vector that
184 -- is used to reserve slots for attributes in the TCB, require mutual
185 -- exclusion. That is provided by the lock
186 -- System.Tasking.Task_Attributes.All_Attrs_L.
188 -- One special problem that added complexity to the design is that
189 -- the per-task list of indirect attributes contains objects of
190 -- different types. We use unchecked pointer conversion to link
191 -- these nodes together and access them, but the records may not have
192 -- identical internal structure. Initially, we thought it would be
193 -- enough to allocate all the common components of the records at the
194 -- front of each record, so that their positions would correspond.
195 -- Unfortunately, GNAT adds "dope" information at the front of a record,
196 -- if the record contains any controlled-type components.
198 -- This means that the offset of the fields we use to link the nodes is
199 -- at different positions on nodes of different types. To get around this,
200 -- each attribute storage record consists of a core node and wrapper.
201 -- The core nodes are all of the same type, and it is these that are
202 -- linked together and generally "seen" by the RTS. Each core node
203 -- contains a pointer to its own wrapper, which is a record that contains
204 -- the core node along with an attribute value, approximately
208 -- type Node_Access is access all Node;
210 -- type Access_Wrapper is access all Wrapper;
211 -- type Node is record
212 -- Next : Node_Access;
214 -- Wrapper : Access_Wrapper;
216 -- type Wrapper is record
217 -- Noed : aliased Node;
218 -- Value : aliased Attribute; -- the generic formal type
221 -- Another interesting problem is with the initialization of
222 -- the instantiation descriptors. Originally, we did this all via
223 -- the Initialize procedure of the descriptor type and code in the
224 -- package body. It turned out that the Initialize procedure needed
225 -- quite a bit of information, including the size of the attribute
226 -- type, the initial value of the attribute (if it fits in the TCB),
227 -- and a pointer to the deallocator procedure. These needed to be
228 -- "passed" in via access discriminants. GNAT was having trouble
229 -- with access discriminants, so all this work was moved to the
232 with Ada.Task_Identification;
237 with System.Error_Reporting;
238 -- used for Shutdown;
240 with System.Storage_Elements;
241 -- used for Integer_Address
243 with System.Task_Primitives.Operations;
244 -- used for Write_Lock
246 -- Lock/Unlock_All_Tasks_List
249 -- used for Access_Address
251 -- Direct_Index_Vector
254 with System.Tasking.Initialization;
255 -- used for Defer_Abortion
257 -- Initialize_Attributes_Link
258 -- Finalize_Attributes_Link
260 with System.Tasking.Task_Attributes;
261 -- used for Access_Node
262 -- Access_Dummy_Wrapper
269 -- used for Raise_Exception
271 with Unchecked_Conversion;
272 with Unchecked_Deallocation;
274 pragma Elaborate_All (System.Tasking.Task_Attributes);
275 -- to ensure the initialization of object Local (below) will work
277 package body Ada.Task_Attributes is
279 use System.Error_Reporting,
280 System.Tasking.Initialization,
282 System.Tasking.Task_Attributes,
285 use type System.Tasking.Access_Address;
287 package POP renames System.Task_Primitives.Operations;
289 ---------------------------
290 -- Unchecked Conversions --
291 ---------------------------
293 pragma Warnings (Off);
294 -- These unchecked conversions can give warnings when alignments
295 -- are incorrect, but they will not be used in such cases anyway,
296 -- so the warnings can be safely ignored.
298 -- The following type corresponds to Dummy_Wrapper,
299 -- declared in System.Tasking.Task_Attributes.
302 type Access_Wrapper is access all Wrapper;
304 function To_Attribute_Handle is new Unchecked_Conversion
305 (Access_Address, Attribute_Handle);
306 -- For reference to directly addressed task attributes
308 type Access_Integer_Address is access all
309 System.Storage_Elements.Integer_Address;
311 function To_Attribute_Handle is new Unchecked_Conversion
312 (Access_Integer_Address, Attribute_Handle);
313 -- For reference to directly addressed task attributes
315 function To_Access_Address is new Unchecked_Conversion
316 (Access_Node, Access_Address);
317 -- To store pointer to list of indirect attributes
319 function To_Access_Node is new Unchecked_Conversion
320 (Access_Address, Access_Node);
321 -- To fetch pointer to list of indirect attributes
323 function To_Access_Wrapper is new Unchecked_Conversion
324 (Access_Dummy_Wrapper, Access_Wrapper);
325 -- To fetch pointer to actual wrapper of attribute node
327 function To_Access_Dummy_Wrapper is new Unchecked_Conversion
328 (Access_Wrapper, Access_Dummy_Wrapper);
329 -- To store pointer to actual wrapper of attribute node
331 function To_Task_ID is new Unchecked_Conversion
332 (Task_Identification.Task_Id, Task_ID);
333 -- To access TCB of identified task
335 Null_ID : constant Task_ID := To_Task_ID (Task_Identification.Null_Task_Id);
336 -- ??? need comments on use and purpose
338 type Local_Deallocator is
339 access procedure (P : in out Access_Node);
341 function To_Lib_Level_Deallocator is new Unchecked_Conversion
342 (Local_Deallocator, Deallocator);
343 -- To defeat accessibility check
345 pragma Warnings (On);
347 ------------------------
348 -- Storage Management --
349 ------------------------
351 procedure Deallocate (P : in out Access_Node);
352 -- Passed to the RTS via unchecked conversion of a pointer to
353 -- permit finalization and deallocation of attribute storage nodes
355 --------------------------
356 -- Instantiation Record --
357 --------------------------
359 Local : aliased Instance;
360 -- Initialized in package body
362 type Wrapper is record
365 Value : aliased Attribute := Initial_Value;
366 -- The generic formal type, may be controlled
370 new Unchecked_Deallocation (Wrapper, Access_Wrapper);
372 procedure Deallocate (P : in out Access_Node) is
373 T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
380 pragma Assert (Shutdown ("Exception in Deallocate")); null;
388 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
389 return Attribute_Handle
391 TT : Task_ID := To_Task_ID (T);
392 Error_Message : constant String := "Trying to get the reference of a";
396 Raise_Exception (Program_Error'Identity,
397 Error_Message & "null task");
400 if TT.Common.State = Terminated then
401 Raise_Exception (Tasking_Error'Identity,
402 Error_Message & "terminated task");
407 POP.Write_Lock (All_Attrs_L'Access);
409 if Local.Index /= 0 then
410 POP.Unlock (All_Attrs_L'Access);
413 To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access);
417 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
422 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
423 POP.Unlock (All_Attrs_L'Access);
425 return To_Access_Wrapper (P.Wrapper).Value'Access;
431 -- Unlock All_Attrs_L here to follow the lock ordering rule
432 -- that prevent us from using new (i.e the Global_Lock) while
433 -- holding any other lock.
435 POP.Unlock (All_Attrs_L'Access);
437 ((null, Local'Unchecked_Access, null), Initial_Value);
438 POP.Write_Lock (All_Attrs_L'Access);
440 P := W.Noed'Unchecked_Access;
441 P.Wrapper := To_Access_Dummy_Wrapper (W);
442 P.Next := To_Access_Node (TT.Indirect_Attributes);
443 TT.Indirect_Attributes := To_Access_Address (P);
444 POP.Unlock (All_Attrs_L'Access);
446 return W.Value'Access;
450 pragma Assert (Shutdown ("Should never get here in Reference"));
455 POP.Unlock (All_Attrs_L'Access);
461 when Tasking_Error | Program_Error =>
472 procedure Reinitialize
473 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
475 TT : Task_ID := To_Task_ID (T);
476 Error_Message : constant String := "Trying to Reinitialize a";
480 Raise_Exception (Program_Error'Identity,
481 Error_Message & "null task");
484 if TT.Common.State = Terminated then
485 Raise_Exception (Tasking_Error'Identity,
486 Error_Message & "terminated task");
489 if Local.Index = 0 then
496 POP.Write_Lock (All_Attrs_L'Access);
498 Q := To_Access_Node (TT.Indirect_Attributes);
500 if Q.Instance = Access_Instance'(Local'Unchecked_Access) then
502 TT.Indirect_Attributes := To_Access_Address (Q.Next);
507 W := To_Access_Wrapper (Q.Wrapper);
509 POP.Unlock (All_Attrs_L'Access);
518 POP.Unlock (All_Attrs_L'Access);
523 POP.Unlock (All_Attrs_L'Access);
528 Set_Value (Initial_Value, T);
532 when Tasking_Error | Program_Error =>
545 T : Task_Identification.Task_Id := Task_Identification.Current_Task)
547 TT : Task_ID := To_Task_ID (T);
548 Error_Message : constant String := "Trying to Set the Value of a";
552 Raise_Exception (Program_Error'Identity,
553 Error_Message & "null task");
556 if TT.Common.State = Terminated then
557 Raise_Exception (Tasking_Error'Identity,
558 Error_Message & "terminated task");
563 POP.Write_Lock (All_Attrs_L'Access);
565 if Local.Index /= 0 then
567 (TT.Direct_Attributes (Local.Index)'Access).all := Val;
568 POP.Unlock (All_Attrs_L'Access);
574 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
580 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
581 To_Access_Wrapper (P.Wrapper).Value := Val;
582 POP.Unlock (All_Attrs_L'Access);
590 -- Unlock TT here to follow the lock ordering rule that
591 -- prevent us from using new (i.e the Global_Lock) while
592 -- holding any other lock.
594 POP.Unlock (All_Attrs_L'Access);
596 ((null, Local'Unchecked_Access, null), Val);
597 POP.Write_Lock (All_Attrs_L'Access);
599 P := W.Noed'Unchecked_Access;
600 P.Wrapper := To_Access_Dummy_Wrapper (W);
601 P.Next := To_Access_Node (TT.Indirect_Attributes);
602 TT.Indirect_Attributes := To_Access_Address (P);
606 POP.Unlock (All_Attrs_L'Access);
611 POP.Unlock (All_Attrs_L'Access);
619 when Tasking_Error | Program_Error =>
632 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
636 TT : Task_ID := To_Task_ID (T);
637 Error_Message : constant String := "Trying to get the Value of a";
642 (Program_Error'Identity, Error_Message & "null task");
645 if TT.Common.State = Terminated then
647 (Program_Error'Identity, Error_Message & "terminated task");
651 if Local.Index /= 0 then
654 (TT.Direct_Attributes (Local.Index)'Access).all;
662 POP.Write_Lock (All_Attrs_L'Access);
664 P := To_Access_Node (TT.Indirect_Attributes);
666 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
667 POP.Unlock (All_Attrs_L'Access);
669 return To_Access_Wrapper (P.Wrapper).Value;
675 Result := Initial_Value;
676 POP.Unlock (All_Attrs_L'Access);
681 POP.Unlock (All_Attrs_L'Access);
691 when Tasking_Error | Program_Error =>
698 -- Start of elaboration code for package Ada.Task_Attributes
701 -- This unchecked conversion can give warnings when alignments
702 -- are incorrect, but they will not be used in such cases anyway,
703 -- so the warnings can be safely ignored.
705 pragma Warnings (Off);
706 Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
707 pragma Warnings (On);
710 Two_To_J : Direct_Index_Vector;
714 POP.Write_Lock (All_Attrs_L'Access);
716 -- Add this instantiation to the list of all instantiations.
718 Local.Next := System.Tasking.Task_Attributes.All_Attributes;
719 System.Tasking.Task_Attributes.All_Attributes :=
720 Local'Unchecked_Access;
722 -- Try to find space for the attribute in the TCB.
725 Two_To_J := 2 ** Direct_Index'First;
727 if Attribute'Size <= System.Address'Size then
728 for J in Direct_Index loop
729 if (Two_To_J and In_Use) /= 0 then
731 -- Reserve location J for this attribute
733 In_Use := In_Use or Two_To_J;
736 -- This unchecked conversions can give a warning when the
737 -- the alignment is incorrect, but it will not be used in
738 -- such a case anyway, so the warning can be safely ignored.
740 pragma Warnings (Off);
741 To_Attribute_Handle (Local.Initial_Value'Access).all :=
743 pragma Warnings (On);
748 Two_To_J := Two_To_J * 2;
752 -- Need protection of All_Tasks_L for updating links to
753 -- per-task initialization and finalization routines,
754 -- in case some task is being created or terminated concurrently.
756 POP.Lock_All_Tasks_List;
758 -- Attribute goes directly in the TCB
760 if Local.Index /= 0 then
762 -- Replace stub for initialization routine
763 -- that is called at task creation.
765 Initialization.Initialize_Attributes_Link :=
766 System.Tasking.Task_Attributes.Initialize_Attributes'Access;
768 -- Initialize the attribute, for all tasks.
771 C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List;
776 C.Direct_Attributes (Local.Index) :=
777 System.Storage_Elements.To_Address (Local.Initial_Value);
779 C := C.Common.All_Tasks_Link;
783 -- Attribute goes into a node onto a linked list
786 -- Replace stub for finalization routine
787 -- that is called at task termination.
789 Initialization.Finalize_Attributes_Link :=
790 System.Tasking.Task_Attributes.Finalize_Attributes'Access;
794 POP.Unlock_All_Tasks_List;
795 POP.Unlock (All_Attrs_L'Access);
800 pragma Assert (Shutdown ("Exception in task attribute initializer"));
802 -- If we later decide to allow exceptions to propagate, we need to
803 -- not only release locks and undefer abortion, we also need to undo
804 -- any initializations that succeeded up to this point, or we will
805 -- risk a dangling reference when the task terminates.
808 end Ada.Task_Attributes;