1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . T A S K _ A T T R I B U T E S --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2007, AdaCore --
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, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
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. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
33 ------------------------------------------------------------------------------
35 -- The following notes are provided in case someone decides the implementation
36 -- of this package is too complicated, or too slow. Please read this before
37 -- making any "simplifications".
39 -- Correct implementation of this package is more difficult than one might
40 -- expect. After considering (and coding) several alternatives, we settled on
41 -- the present compromise. Things we do not like about this implementation
44 -- - It is vulnerable to bad Task_Id values, to the extent of possibly
45 -- trashing memory and crashing the runtime system.
47 -- - It requires dynamic storage allocation for each new attribute value,
48 -- except for types that happen to be the same size as System.Address, or
51 -- - Instantiations at other than the library level rely on being able to
52 -- do down-level calls to a procedure declared in the generic package body.
53 -- This makes it potentially vulnerable to compiler changes.
55 -- The main implementation issue here is that the connection from task to
56 -- attribute is a potential source of dangling references.
58 -- When a task goes away, we want to be able to recover all the storage
59 -- associated with its attributes. The Ada mechanism for this is finalization,
60 -- via controlled attribute types. For this reason, the ARM requires
61 -- finalization of attribute values when the associated task terminates.
63 -- This finalization must be triggered by the tasking runtime system, during
64 -- termination of the task. Given the active set of instantiations of
65 -- Ada.Task_Attributes is dynamic, the number and types of attributes
66 -- belonging to a task will not be known until the task actually terminates.
67 -- Some of these types may be controlled and some may not. The RTS must find
68 -- some way to determine which of these attributes need finalization, and
69 -- invoke the appropriate finalization on them.
71 -- One way this might be done is to create a special finalization chain for
72 -- each task, similar to the finalization chain that is used for controlled
73 -- objects within the task. This would differ from the usual finalization
74 -- chain in that it would not have a LIFO structure, since attributes may be
75 -- added to a task at any time during its lifetime. This might be the right
76 -- way to go for the longer term, but at present this approach is not open,
77 -- since GNAT does not provide such special finalization support.
79 -- Lacking special compiler support, the RTS is limited to the normal ways an
80 -- application invokes finalization, i.e.
82 -- a) Explicit call to the procedure Finalize, if we know the type has this
83 -- operation defined on it. This is not sufficient, since we have no way
84 -- of determining whether a given generic formal Attribute type is
85 -- controlled, and no visibility of the associated Finalize procedure, in
88 -- b) Leaving the scope of a local object of a controlled type. This does not
89 -- help, since the lifetime of an instantiation of Ada.Task_Attributes
90 -- does not correspond to the lifetimes of the various tasks which may
91 -- have that attribute.
93 -- c) Assignment of another value to the object. This would not help, since
94 -- we then have to finalize the new value of the object.
96 -- d) Unchecked deallocation of an object of a controlled type. This seems to
97 -- be the only mechanism available to the runtime system for finalization
98 -- of task attributes.
100 -- We considered two ways of using unchecked deallocation, both based on a
101 -- linked list of that would hang from the task control block.
103 -- In the first approach the objects on the attribute list are all derived
104 -- from one controlled type, say T, and are linked using an access type to
105 -- T'Class. The runtime system has an Ada.Unchecked_Deallocation for T'Class
106 -- with access type T'Class, and uses this to deallocate and finalize all the
107 -- items in the list. The limitation of this approach is that each
108 -- instantiation of the package Ada.Task_Attributes derives a new record
109 -- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is
110 -- only allowed at the library level.
112 -- In the second approach the objects on the attribute list are of unrelated
113 -- but structurally similar types. Unchecked conversion is used to circument
114 -- Ada type checking. Each attribute-storage node contains not only the
115 -- attribute value and a link for chaining, but also a pointer to descriptor
116 -- for the corresponding instantiation of Task_Attributes. The instantiation
117 -- descriptor contains pointer to a procedure that can do the correct
118 -- deallocation and finalization for that type of attribute. On task
119 -- termination, the runtime system uses the pointer to call the appropriate
122 -- While this gets around the limitation that instantations be at the library
123 -- level, it relies on an implementation feature that may not always be safe,
124 -- i.e. that it is safe to call the Deallocate procedure for an instantiation
125 -- of Ada.Task_Attributes that no longer exists. In general, it seems this
126 -- might result in dangling references.
128 -- Another problem with instantiations deeper than the library level is that
129 -- there is risk of storage leakage, or dangling references to reused storage.
130 -- That is, if an instantiation of Ada.Task_Attributes is made within a
131 -- procedure, what happens to the storage allocated for attributes, when the
132 -- procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be
133 -- finalized, since they will no longer be accessible, and in general one
134 -- would expect that the storage they occupy would be recovered for later
135 -- reuse. (If not, we would have a case of storage leakage.) Assuming the
136 -- storage is recovered and later reused, we have potentially dangerous
137 -- dangling references. When the procedure containing the instantiation of
138 -- Ada.Task_Attributes returns, there may still be unterminated tasks with
139 -- associated attribute values for that instantiation. When such tasks
140 -- eventually terminate, the RTS will attempt to call the Deallocate procedure
141 -- on them. If the corresponding storage has already been deallocated, when
142 -- the master of the access type was left, we have a potential disaster. This
143 -- disaster is compounded since the pointer to Deallocate is probably through
144 -- a "trampoline" which will also have been destroyed.
146 -- For this reason, we arrange to remove all dangling references before
147 -- leaving the scope of an instantiation. This is ugly, since it requires
148 -- traversing the list of all tasks, but it is no more ugly than a similar
149 -- traversal that we must do at the point of instantiation in order to
150 -- initialize the attributes of all tasks. At least we only need to do these
151 -- traversals if the type is controlled.
153 -- We chose to defer allocation of storage for attributes until the Reference
154 -- function is called or the attribute is first set to a value different from
155 -- the default initial one. This allows a potential savings in allocation,
156 -- for attributes that are not used by all tasks.
158 -- For efficiency, we reserve space in the TCB for a fixed number of direct-
159 -- access attributes. These are required to be of a size that fits in the
160 -- space of an object of type System.Address. Because we must use unchecked
161 -- bitwise copy operations on these values, they cannot be of a controlled
162 -- type, but that is covered automatically since controlled objects are too
163 -- large to fit in the spaces.
165 -- We originally deferred initialization of these direct-access attributes,
166 -- just as we do for the indirect-access attributes, and used a per-task bit
167 -- vector to keep track of which attributes were currently defined for that
168 -- task. We found that the overhead of maintaining this bit-vector seriously
169 -- slowed down access to the attributes, and made the fetch operation non-
170 -- atomic, so that even to read an attribute value required locking the TCB.
171 -- Therefore, we now initialize such attributes for all existing tasks at the
172 -- time of the attribute instantiation, and initialize existing attributes for
173 -- each new task at the time it is created.
175 -- The latter initialization requires a list of all the instantiation
176 -- descriptors. Updates to this list, as well as the bit-vector that is used
177 -- to reserve slots for attributes in the TCB, require mutual exclusion. That
178 -- is provided by the Lock/Unlock_RTS.
180 -- One special problem that added complexity to the design is that the per-
181 -- task list of indirect attributes contains objects of different types. We
182 -- use unchecked pointer conversion to link these nodes together and access
183 -- them, but the records may not have identical internal structure. Initially,
184 -- we thought it would be enough to allocate all the common components of
185 -- the records at the front of each record, so that their positions would
186 -- correspond. Unfortunately, GNAT adds "dope" information at the front
187 -- of a record, if the record contains any controlled-type components.
189 -- This means that the offset of the fields we use to link the nodes is at
190 -- different positions on nodes of different types. To get around this, each
191 -- attribute storage record consists of a core node and wrapper. The core
192 -- nodes are all of the same type, and it is these that are linked together
193 -- and generally "seen" by the RTS. Each core node contains a pointer to its
194 -- own wrapper, which is a record that contains the core node along with an
195 -- attribute value, approximately as follows:
198 -- type Node_Access is access all Node;
200 -- type Access_Wrapper is access all Wrapper;
201 -- type Node is record
202 -- Next : Node_Access;
204 -- Wrapper : Access_Wrapper;
206 -- type Wrapper is record
207 -- Dummy_Node : aliased Node;
208 -- Value : aliased Attribute; -- the generic formal type
211 -- Another interesting problem is with the initialization of the instantiation
212 -- descriptors. Originally, we did this all via the Initialize procedure of
213 -- the descriptor type and code in the package body. It turned out that the
214 -- Initialize procedure needed quite a bit of information, including the size
215 -- of the attribute type, the initial value of the attribute (if it fits in
216 -- the TCB), and a pointer to the deallocator procedure. These needed to be
217 -- "passed" in via access discriminants. GNAT was having trouble with access
218 -- discriminants, so all this work was moved to the package body.
220 with System.Error_Reporting;
221 -- Used for Shutdown;
223 with System.Storage_Elements;
224 -- Used for Integer_Address
226 with System.Task_Primitives.Operations;
227 -- Used for Write_Lock
232 -- Used for Access_Address
234 -- Direct_Index_Vector
237 with System.Tasking.Initialization;
238 -- Used for Defer_Abort
240 -- Initialize_Attributes_Link
241 -- Finalize_Attributes_Link
243 with System.Tasking.Task_Attributes;
244 -- Used for Access_Node
245 -- Access_Dummy_Wrapper
252 -- Used for Raise_Exception
254 with Ada.Unchecked_Conversion;
255 with Ada.Unchecked_Deallocation;
257 pragma Elaborate_All (System.Tasking.Task_Attributes);
258 -- To ensure the initialization of object Local (below) will work
260 package body Ada.Task_Attributes is
262 use System.Error_Reporting,
263 System.Tasking.Initialization,
265 System.Tasking.Task_Attributes,
268 package POP renames System.Task_Primitives.Operations;
270 ---------------------------
271 -- Unchecked Conversions --
272 ---------------------------
274 -- The following type corresponds to Dummy_Wrapper,
275 -- declared in System.Tasking.Task_Attributes.
278 type Access_Wrapper is access all Wrapper;
280 pragma Warnings (Off);
281 -- We turn warnings off for the following To_Attribute_Handle conversions,
282 -- since these are used only for small attributes where we know that there
283 -- are no problems with alignment, but the compiler will generate warnings
284 -- for the occurrences in the large attribute case, even though they will
285 -- not actually be used.
287 function To_Attribute_Handle is new Ada.Unchecked_Conversion
288 (System.Address, Attribute_Handle);
289 function To_Direct_Attribute_Element is new Ada.Unchecked_Conversion
290 (System.Address, Direct_Attribute_Element);
291 -- For reference to directly addressed task attributes
293 type Access_Integer_Address is access all
294 System.Storage_Elements.Integer_Address;
296 function To_Attribute_Handle is new Ada.Unchecked_Conversion
297 (Access_Integer_Address, Attribute_Handle);
298 -- For reference to directly addressed task attributes
300 pragma Warnings (On);
301 -- End of warnings off region for directly addressed
302 -- attribute conversion functions.
304 function To_Access_Address is new Ada.Unchecked_Conversion
305 (Access_Node, Access_Address);
306 -- To store pointer to list of indirect attributes
308 pragma Warnings (Off);
309 function To_Access_Wrapper is new Ada.Unchecked_Conversion
310 (Access_Dummy_Wrapper, Access_Wrapper);
311 pragma Warnings (On);
312 -- To fetch pointer to actual wrapper of attribute node. We turn off
313 -- warnings since this may generate an alignment warning. The warning can
314 -- be ignored since Dummy_Wrapper is only a non-generic standin for the
315 -- real wrapper type (we never actually allocate objects of type
318 function To_Access_Dummy_Wrapper is new Ada.Unchecked_Conversion
319 (Access_Wrapper, Access_Dummy_Wrapper);
320 -- To store pointer to actual wrapper of attribute node
322 function To_Task_Id is new Ada.Unchecked_Conversion
323 (Task_Identification.Task_Id, Task_Id);
324 -- To access TCB of identified task
326 type Local_Deallocator is access procedure (P : in out Access_Node);
328 function To_Lib_Level_Deallocator is new Ada.Unchecked_Conversion
329 (Local_Deallocator, Deallocator);
330 -- To defeat accessibility check
332 pragma Warnings (On);
334 ------------------------
335 -- Storage Management --
336 ------------------------
338 procedure Deallocate (P : in out Access_Node);
339 -- Passed to the RTS via unchecked conversion of a pointer to permit
340 -- finalization and deallocation of attribute storage nodes.
342 --------------------------
343 -- Instantiation Record --
344 --------------------------
346 Local : aliased Instance;
347 -- Initialized in package body
349 type Wrapper is record
350 Dummy_Node : aliased Node;
352 Value : aliased Attribute := Initial_Value;
353 -- The generic formal type, may be controlled
356 -- A number of unchecked conversions involving Wrapper_Access sources are
357 -- performed in this unit. We have to ensure that the designated object is
358 -- always strictly enough aligned.
360 for Wrapper'Alignment use Standard'Maximum_Alignment;
363 new Ada.Unchecked_Deallocation (Wrapper, Access_Wrapper);
365 procedure Deallocate (P : in out Access_Node) is
366 T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
376 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
377 return Attribute_Handle
379 TT : constant Task_Id := To_Task_Id (T);
380 Error_Message : constant String := "Trying to get the reference of a ";
384 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
387 if TT.Common.State = Terminated then
388 Raise_Exception (Tasking_Error'Identity,
389 Error_Message & "terminated task");
392 -- Directly addressed case
394 if Local.Index /= 0 then
396 -- Return the attribute handle. Warnings off because this return
397 -- statement generates alignment warnings for large attributes
398 -- (but will never be executed in this case anyway).
400 pragma Warnings (Off);
402 To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address);
403 pragma Warnings (On);
405 -- Not directly addressed
409 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
411 Self_Id : constant Task_Id := POP.Self;
414 Defer_Abort (Self_Id);
418 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
420 Undefer_Abort (Self_Id);
421 return To_Access_Wrapper (P.Wrapper).Value'Access;
427 -- Unlock the RTS here to follow the lock ordering rule
428 -- that prevent us from using new (i.e the Global_Lock) while
429 -- holding any other lock.
433 ((null, Local'Unchecked_Access, null), Initial_Value);
436 P := W.Dummy_Node'Unchecked_Access;
437 P.Wrapper := To_Access_Dummy_Wrapper (W);
438 P.Next := To_Access_Node (TT.Indirect_Attributes);
439 TT.Indirect_Attributes := To_Access_Address (P);
441 Undefer_Abort (Self_Id);
442 return W.Value'Access;
447 Undefer_Abort (Self_Id);
452 pragma Assert (Shutdown ("Should never get here in Reference"));
456 when Tasking_Error | Program_Error =>
467 procedure Reinitialize
468 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
470 TT : constant Task_Id := To_Task_Id (T);
471 Error_Message : constant String := "Trying to Reinitialize a ";
475 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
478 if TT.Common.State = Terminated then
479 Raise_Exception (Tasking_Error'Identity,
480 Error_Message & "terminated task");
483 if Local.Index /= 0 then
484 Set_Value (Initial_Value, T);
489 Self_Id : constant Task_Id := POP.Self;
492 Defer_Abort (Self_Id);
494 Q := To_Access_Node (TT.Indirect_Attributes);
497 if Q.Instance = Access_Instance'(Local'Unchecked_Access) then
499 TT.Indirect_Attributes := To_Access_Address (Q.Next);
504 W := To_Access_Wrapper (Q.Wrapper);
507 Undefer_Abort (Self_Id);
516 Undefer_Abort (Self_Id);
521 Undefer_Abort (Self_Id);
527 when Tasking_Error | Program_Error =>
540 T : Task_Identification.Task_Id := Task_Identification.Current_Task)
542 TT : constant Task_Id := To_Task_Id (T);
543 Error_Message : constant String := "Trying to Set the Value of a ";
547 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
550 if TT.Common.State = Terminated then
551 Raise_Exception (Tasking_Error'Identity,
552 Error_Message & "terminated task");
555 -- Directly addressed case
557 if Local.Index /= 0 then
559 -- Set attribute handle, warnings off, because this code can generate
560 -- alignment warnings with large attributes (but of course will not
561 -- be executed in this case, since we never have direct addressing in
564 pragma Warnings (Off);
566 (TT.Direct_Attributes (Local.Index)'Address).all := Val;
567 pragma Warnings (On);
571 -- Not directly addressed
574 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
576 Self_Id : constant Task_Id := POP.Self;
579 Defer_Abort (Self_Id);
584 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
585 To_Access_Wrapper (P.Wrapper).Value := Val;
587 Undefer_Abort (Self_Id);
594 -- Unlock RTS here to follow the lock ordering rule that prevent us
595 -- from using new (i.e the Global_Lock) while holding any other lock.
598 W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
600 P := W.Dummy_Node'Unchecked_Access;
601 P.Wrapper := To_Access_Dummy_Wrapper (W);
602 P.Next := To_Access_Node (TT.Indirect_Attributes);
603 TT.Indirect_Attributes := To_Access_Address (P);
606 Undefer_Abort (Self_Id);
611 Undefer_Abort (Self_Id);
616 when Tasking_Error | Program_Error =>
628 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
631 TT : constant Task_Id := To_Task_Id (T);
632 Error_Message : constant String := "Trying to get the Value of a ";
636 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
639 if TT.Common.State = Terminated then
641 (Program_Error'Identity, Error_Message & "terminated task");
644 -- Directly addressed case
646 if Local.Index /= 0 then
648 -- Get value of attribute. We turn Warnings off, because for large
649 -- attributes, this code can generate alignment warnings. But of
650 -- course large attributes are never directly addressed so in fact
651 -- we will never execute the code in this case.
653 pragma Warnings (Off);
654 return To_Attribute_Handle
655 (TT.Direct_Attributes (Local.Index)'Address).all;
656 pragma Warnings (On);
659 -- Not directly addressed
664 Self_Id : constant Task_Id := POP.Self;
667 Defer_Abort (Self_Id);
669 P := To_Access_Node (TT.Indirect_Attributes);
672 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
673 Result := To_Access_Wrapper (P.Wrapper).Value;
675 Undefer_Abort (Self_Id);
683 Undefer_Abort (Self_Id);
684 return Initial_Value;
689 Undefer_Abort (Self_Id);
694 when Tasking_Error | Program_Error =>
701 -- Start of elaboration code for package Ada.Task_Attributes
704 -- This unchecked conversion can give warnings when alignments are
705 -- incorrect, but they will not be used in such cases anyway, so the
706 -- warnings can be safely ignored.
708 pragma Warnings (Off);
709 Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
710 pragma Warnings (On);
713 Two_To_J : Direct_Index_Vector;
714 Self_Id : constant Task_Id := POP.Self;
716 Defer_Abort (Self_Id);
718 -- Need protection for updating links to per-task initialization and
719 -- finalization routines, in case some task is being created or
720 -- terminated concurrently.
724 -- Add this instantiation to the list of all instantiations
726 Local.Next := System.Tasking.Task_Attributes.All_Attributes;
727 System.Tasking.Task_Attributes.All_Attributes :=
728 Local'Unchecked_Access;
730 -- Try to find space for the attribute in the TCB
735 if Attribute'Size <= System.Address'Size then
736 for J in Direct_Index_Range loop
737 if (Two_To_J and In_Use) = 0 then
739 -- Reserve location J for this attribute
741 In_Use := In_Use or Two_To_J;
744 -- This unchecked conversions can give a warning when the the
745 -- alignment is incorrect, but it will not be used in such a
746 -- case anyway, so the warning can be safely ignored.
748 pragma Warnings (Off);
749 To_Attribute_Handle (Local.Initial_Value'Access).all :=
751 pragma Warnings (On);
756 Two_To_J := Two_To_J * 2;
760 -- Attribute goes directly in the TCB
762 if Local.Index /= 0 then
763 -- Replace stub for initialization routine that is called at task
766 Initialization.Initialize_Attributes_Link :=
767 System.Tasking.Task_Attributes.Initialize_Attributes'Access;
769 -- Initialize the attribute, for all tasks
772 C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
775 C.Direct_Attributes (Local.Index) :=
776 To_Direct_Attribute_Element
777 (System.Storage_Elements.To_Address (Local.Initial_Value));
778 C := C.Common.All_Tasks_Link;
782 -- Attribute goes into a node onto a linked list
785 -- Replace stub for finalization routine called at task termination
787 Initialization.Finalize_Attributes_Link :=
788 System.Tasking.Task_Attributes.Finalize_Attributes'Access;
792 Undefer_Abort (Self_Id);
794 end Ada.Task_Attributes;