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-2010, AdaCore --
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. --
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. --
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/>. --
28 -- GNARL was developed by the GNARL team at Florida State University. --
29 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
31 ------------------------------------------------------------------------------
33 -- The following notes are provided in case someone decides the implementation
34 -- of this package is too complicated, or too slow. Please read this before
35 -- making any "simplifications".
37 -- Correct implementation of this package is more difficult than one might
38 -- expect. After considering (and coding) several alternatives, we settled on
39 -- the present compromise. Things we do not like about this implementation
42 -- - It is vulnerable to bad Task_Id values, to the extent of possibly
43 -- trashing memory and crashing the runtime system.
45 -- - It requires dynamic storage allocation for each new attribute value,
46 -- except for types that happen to be the same size as System.Address, or
49 -- - Instantiations at other than the library level rely on being able to
50 -- do down-level calls to a procedure declared in the generic package body.
51 -- This makes it potentially vulnerable to compiler changes.
53 -- The main implementation issue here is that the connection from task to
54 -- attribute is a potential source of dangling references.
56 -- When a task goes away, we want to be able to recover all the storage
57 -- associated with its attributes. The Ada mechanism for this is finalization,
58 -- via controlled attribute types. For this reason, the ARM requires
59 -- finalization of attribute values when the associated task terminates.
61 -- This finalization must be triggered by the tasking runtime system, during
62 -- termination of the task. Given the active set of instantiations of
63 -- Ada.Task_Attributes is dynamic, the number and types of attributes
64 -- belonging to a task will not be known until the task actually terminates.
65 -- Some of these types may be controlled and some may not. The RTS must find
66 -- some way to determine which of these attributes need finalization, and
67 -- invoke the appropriate finalization on them.
69 -- One way this might be done is to create a special finalization chain for
70 -- each task, similar to the finalization chain that is used for controlled
71 -- objects within the task. This would differ from the usual finalization
72 -- chain in that it would not have a LIFO structure, since attributes may be
73 -- added to a task at any time during its lifetime. This might be the right
74 -- way to go for the longer term, but at present this approach is not open,
75 -- since GNAT does not provide such special finalization support.
77 -- Lacking special compiler support, the RTS is limited to the normal ways an
78 -- application invokes finalization, i.e.
80 -- a) Explicit call to the procedure Finalize, if we know the type has this
81 -- operation defined on it. This is not sufficient, since we have no way
82 -- of determining whether a given generic formal Attribute type is
83 -- controlled, and no visibility of the associated Finalize procedure, in
86 -- b) Leaving the scope of a local object of a controlled type. This does not
87 -- help, since the lifetime of an instantiation of Ada.Task_Attributes
88 -- does not correspond to the lifetimes of the various tasks which may
89 -- have that attribute.
91 -- c) Assignment of another value to the object. This would not help, since
92 -- we then have to finalize the new value of the object.
94 -- d) Unchecked deallocation of an object of a controlled type. This seems to
95 -- be the only mechanism available to the runtime system for finalization
96 -- of task attributes.
98 -- We considered two ways of using unchecked deallocation, both based on a
99 -- linked list of that would hang from the task control block.
101 -- In the first approach the objects on the attribute list are all derived
102 -- from one controlled type, say T, and are linked using an access type to
103 -- T'Class. The runtime system has an Ada.Unchecked_Deallocation for T'Class
104 -- with access type T'Class, and uses this to deallocate and finalize all the
105 -- items in the list. The limitation of this approach is that each
106 -- instantiation of the package Ada.Task_Attributes derives a new record
107 -- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is
108 -- only allowed at the library level.
110 -- In the second approach the objects on the attribute list are of unrelated
111 -- but structurally similar types. Unchecked conversion is used to circument
112 -- Ada type checking. Each attribute-storage node contains not only the
113 -- attribute value and a link for chaining, but also a pointer to descriptor
114 -- for the corresponding instantiation of Task_Attributes. The instantiation
115 -- descriptor contains pointer to a procedure that can do the correct
116 -- deallocation and finalization for that type of attribute. On task
117 -- termination, the runtime system uses the pointer to call the appropriate
120 -- While this gets around the limitation that instantations be at the library
121 -- level, it relies on an implementation feature that may not always be safe,
122 -- i.e. that it is safe to call the Deallocate procedure for an instantiation
123 -- of Ada.Task_Attributes that no longer exists. In general, it seems this
124 -- might result in dangling references.
126 -- Another problem with instantiations deeper than the library level is that
127 -- there is risk of storage leakage, or dangling references to reused storage.
128 -- That is, if an instantiation of Ada.Task_Attributes is made within a
129 -- procedure, what happens to the storage allocated for attributes, when the
130 -- procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be
131 -- finalized, since they will no longer be accessible, and in general one
132 -- would expect that the storage they occupy would be recovered for later
133 -- reuse. (If not, we would have a case of storage leakage.) Assuming the
134 -- storage is recovered and later reused, we have potentially dangerous
135 -- dangling references. When the procedure containing the instantiation of
136 -- Ada.Task_Attributes returns, there may still be unterminated tasks with
137 -- associated attribute values for that instantiation. When such tasks
138 -- eventually terminate, the RTS will attempt to call the Deallocate procedure
139 -- on them. If the corresponding storage has already been deallocated, when
140 -- the master of the access type was left, we have a potential disaster. This
141 -- disaster is compounded since the pointer to Deallocate is probably through
142 -- a "trampoline" which will also have been destroyed.
144 -- For this reason, we arrange to remove all dangling references before
145 -- leaving the scope of an instantiation. This is ugly, since it requires
146 -- traversing the list of all tasks, but it is no more ugly than a similar
147 -- traversal that we must do at the point of instantiation in order to
148 -- initialize the attributes of all tasks. At least we only need to do these
149 -- traversals if the type is controlled.
151 -- We chose to defer allocation of storage for attributes until the Reference
152 -- function is called or the attribute is first set to a value different from
153 -- the default initial one. This allows a potential savings in allocation,
154 -- for attributes that are not used by all tasks.
156 -- For efficiency, we reserve space in the TCB for a fixed number of direct-
157 -- access attributes. These are required to be of a size that fits in the
158 -- space of an object of type System.Address. Because we must use unchecked
159 -- bitwise copy operations on these values, they cannot be of a controlled
160 -- type, but that is covered automatically since controlled objects are too
161 -- large to fit in the spaces.
163 -- We originally deferred initialization of these direct-access attributes,
164 -- just as we do for the indirect-access attributes, and used a per-task bit
165 -- vector to keep track of which attributes were currently defined for that
166 -- task. We found that the overhead of maintaining this bit-vector seriously
167 -- slowed down access to the attributes, and made the fetch operation non-
168 -- atomic, so that even to read an attribute value required locking the TCB.
169 -- Therefore, we now initialize such attributes for all existing tasks at the
170 -- time of the attribute instantiation, and initialize existing attributes for
171 -- each new task at the time it is created.
173 -- The latter initialization requires a list of all the instantiation
174 -- descriptors. Updates to this list, as well as the bit-vector that is used
175 -- to reserve slots for attributes in the TCB, require mutual exclusion. That
176 -- is provided by the Lock/Unlock_RTS.
178 -- One special problem that added complexity to the design is that the per-
179 -- task list of indirect attributes contains objects of different types. We
180 -- use unchecked pointer conversion to link these nodes together and access
181 -- them, but the records may not have identical internal structure. Initially,
182 -- we thought it would be enough to allocate all the common components of
183 -- the records at the front of each record, so that their positions would
184 -- correspond. Unfortunately, GNAT adds "dope" information at the front
185 -- of a record, if the record contains any controlled-type components.
187 -- This means that the offset of the fields we use to link the nodes is at
188 -- different positions on nodes of different types. To get around this, each
189 -- attribute storage record consists of a core node and wrapper. The core
190 -- nodes are all of the same type, and it is these that are linked together
191 -- and generally "seen" by the RTS. Each core node contains a pointer to its
192 -- own wrapper, which is a record that contains the core node along with an
193 -- attribute value, approximately as follows:
196 -- type Node_Access is access all Node;
198 -- type Access_Wrapper is access all Wrapper;
199 -- type Node is record
200 -- Next : Node_Access;
202 -- Wrapper : Access_Wrapper;
204 -- type Wrapper is record
205 -- Dummy_Node : aliased Node;
206 -- Value : aliased Attribute; -- the generic formal type
209 -- Another interesting problem is with the initialization of the instantiation
210 -- descriptors. Originally, we did this all via the Initialize procedure of
211 -- the descriptor type and code in the package body. It turned out that the
212 -- Initialize procedure needed quite a bit of information, including the size
213 -- of the attribute type, the initial value of the attribute (if it fits in
214 -- the TCB), and a pointer to the deallocator procedure. These needed to be
215 -- "passed" in via access discriminants. GNAT was having trouble with access
216 -- discriminants, so all this work was moved to the package body.
218 -- Note that references to objects declared in this package body must in
219 -- general use 'Unchecked_Access instead of 'Access as the package can be
220 -- instantiated from within a local context.
222 with System
.Storage_Elements
;
223 with System
.Task_Primitives
.Operations
;
225 with System
.Tasking
.Initialization
;
226 with System
.Tasking
.Task_Attributes
;
229 with Ada
.Unchecked_Conversion
;
230 with Ada
.Unchecked_Deallocation
;
232 pragma Elaborate_All
(System
.Tasking
.Task_Attributes
);
233 -- To ensure the initialization of object Local (below) will work
235 package body Ada
.Task_Attributes
is
237 use System
.Tasking
.Initialization
,
239 System
.Tasking
.Task_Attributes
,
242 package POP
renames System
.Task_Primitives
.Operations
;
244 ---------------------------
245 -- Unchecked Conversions --
246 ---------------------------
248 -- The following type corresponds to Dummy_Wrapper, declared in
249 -- System.Tasking.Task_Attributes.
252 type Access_Wrapper
is access all Wrapper
;
254 pragma Warnings
(Off
);
255 -- We turn warnings off for the following To_Attribute_Handle conversions,
256 -- since these are used only for small attributes where we know that there
257 -- are no problems with alignment, but the compiler will generate warnings
258 -- for the occurrences in the large attribute case, even though they will
259 -- not actually be used.
261 function To_Attribute_Handle
is new Ada
.Unchecked_Conversion
262 (System
.Address
, Attribute_Handle
);
263 function To_Direct_Attribute_Element
is new Ada
.Unchecked_Conversion
264 (System
.Address
, Direct_Attribute_Element
);
265 -- For reference to directly addressed task attributes
267 type Access_Integer_Address
is access all
268 System
.Storage_Elements
.Integer_Address
;
270 function To_Attribute_Handle
is new Ada
.Unchecked_Conversion
271 (Access_Integer_Address
, Attribute_Handle
);
272 -- For reference to directly addressed task attributes
274 pragma Warnings
(On
);
275 -- End warnings off region for directly addressed attribute conversions
277 function To_Access_Address
is new Ada
.Unchecked_Conversion
278 (Access_Node
, Access_Address
);
279 -- To store pointer to list of indirect attributes
281 pragma Warnings
(Off
);
282 function To_Access_Wrapper
is new Ada
.Unchecked_Conversion
283 (Access_Dummy_Wrapper
, Access_Wrapper
);
284 pragma Warnings
(On
);
285 -- To fetch pointer to actual wrapper of attribute node. We turn off
286 -- warnings since this may generate an alignment warning. The warning can
287 -- be ignored since Dummy_Wrapper is only a non-generic standin for the
288 -- real wrapper type (we never actually allocate objects of type
291 function To_Access_Dummy_Wrapper
is new Ada
.Unchecked_Conversion
292 (Access_Wrapper
, Access_Dummy_Wrapper
);
293 -- To store pointer to actual wrapper of attribute node
295 function To_Task_Id
is new Ada
.Unchecked_Conversion
296 (Task_Identification
.Task_Id
, Task_Id
);
297 -- To access TCB of identified task
299 type Local_Deallocator
is access procedure (P
: in out Access_Node
);
301 function To_Lib_Level_Deallocator
is new Ada
.Unchecked_Conversion
302 (Local_Deallocator
, Deallocator
);
303 -- To defeat accessibility check
305 ------------------------
306 -- Storage Management --
307 ------------------------
309 procedure Deallocate
(P
: in out Access_Node
);
310 -- Passed to the RTS via unchecked conversion of a pointer to permit
311 -- finalization and deallocation of attribute storage nodes.
313 --------------------------
314 -- Instantiation Record --
315 --------------------------
317 Local
: aliased Instance
;
318 -- Initialized in package body
320 type Wrapper
is record
321 Dummy_Node
: aliased Node
;
323 Value
: aliased Attribute
:= Initial_Value
;
324 -- The generic formal type, may be controlled
327 -- A number of unchecked conversions involving Wrapper_Access sources are
328 -- performed in this unit. We have to ensure that the designated object is
329 -- always strictly enough aligned.
331 for Wrapper
'Alignment use Standard
'Maximum_Alignment;
334 new Ada
.Unchecked_Deallocation
(Wrapper
, Access_Wrapper
);
336 procedure Deallocate
(P
: in out Access_Node
) is
337 T
: Access_Wrapper
:= To_Access_Wrapper
(P
.Wrapper
);
347 (T
: Task_Identification
.Task_Id
:= Task_Identification
.Current_Task
)
348 return Attribute_Handle
350 TT
: constant Task_Id
:= To_Task_Id
(T
);
351 Error_Message
: constant String := "Trying to get the reference of a ";
355 Raise_Exception
(Program_Error
'Identity, Error_Message
& "null task");
358 if TT
.Common
.State
= Terminated
then
359 Raise_Exception
(Tasking_Error
'Identity,
360 Error_Message
& "terminated task");
363 -- Directly addressed case
365 if Local
.Index
/= 0 then
367 -- Return the attribute handle. Warnings off because this return
368 -- statement generates alignment warnings for large attributes
369 -- (but will never be executed in this case anyway).
371 pragma Warnings
(Off
);
373 To_Attribute_Handle
(TT
.Direct_Attributes
(Local
.Index
)'Address);
374 pragma Warnings
(On
);
376 -- Not directly addressed
380 P
: Access_Node
:= To_Access_Node
(TT
.Indirect_Attributes
);
382 Self_Id
: constant Task_Id
:= POP
.Self
;
385 Defer_Abort
(Self_Id
);
389 if P
.Instance
= Access_Instance
'(Local'Unchecked_Access) then
391 Undefer_Abort (Self_Id);
392 return To_Access_Wrapper (P.Wrapper).Value'Access;
398 -- Unlock the RTS here to follow the lock ordering rule that
399 -- prevent us from using new (i.e the Global_Lock) while holding
404 ((null, Local
'Unchecked_Access, null), Initial_Value
);
407 P
:= W
.Dummy_Node
'Unchecked_Access;
408 P
.Wrapper
:= To_Access_Dummy_Wrapper
(W
);
409 P
.Next
:= To_Access_Node
(TT
.Indirect_Attributes
);
410 TT
.Indirect_Attributes
:= To_Access_Address
(P
);
412 Undefer_Abort
(Self_Id
);
413 return W
.Value
'Access;
418 Undefer_Abort
(Self_Id
);
424 when Tasking_Error | Program_Error
=>
435 procedure Reinitialize
436 (T
: Task_Identification
.Task_Id
:= Task_Identification
.Current_Task
)
438 TT
: constant Task_Id
:= To_Task_Id
(T
);
439 Error_Message
: constant String := "Trying to Reinitialize a ";
443 Raise_Exception
(Program_Error
'Identity, Error_Message
& "null task");
446 if TT
.Common
.State
= Terminated
then
447 Raise_Exception
(Tasking_Error
'Identity,
448 Error_Message
& "terminated task");
451 if Local
.Index
/= 0 then
452 Set_Value
(Initial_Value
, T
);
457 Self_Id
: constant Task_Id
:= POP
.Self
;
460 Defer_Abort
(Self_Id
);
462 Q
:= To_Access_Node
(TT
.Indirect_Attributes
);
465 if Q
.Instance
= Access_Instance
'(Local'Unchecked_Access) then
467 TT.Indirect_Attributes := To_Access_Address (Q.Next);
472 W := To_Access_Wrapper (Q.Wrapper);
475 Undefer_Abort (Self_Id);
484 Undefer_Abort (Self_Id);
489 Undefer_Abort (Self_Id);
495 when Tasking_Error | Program_Error =>
508 T : Task_Identification.Task_Id := Task_Identification.Current_Task)
510 TT : constant Task_Id := To_Task_Id (T);
511 Error_Message : constant String := "Trying to Set the Value of a ";
515 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
518 if TT.Common.State = Terminated then
519 Raise_Exception (Tasking_Error'Identity,
520 Error_Message & "terminated task");
523 -- Directly addressed case
525 if Local.Index /= 0 then
527 -- Set attribute handle, warnings off, because this code can generate
528 -- alignment warnings with large attributes (but of course will not
529 -- be executed in this case, since we never have direct addressing in
532 pragma Warnings (Off);
534 (TT.Direct_Attributes (Local.Index)'Address).all := Val;
535 pragma Warnings (On);
539 -- Not directly addressed
542 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
544 Self_Id : constant Task_Id := POP.Self;
547 Defer_Abort (Self_Id);
552 if P.Instance = Access_Instance'(Local
'Unchecked_Access) then
553 To_Access_Wrapper
(P
.Wrapper
).Value
:= Val
;
555 Undefer_Abort
(Self_Id
);
562 -- Unlock RTS here to follow the lock ordering rule that prevent us
563 -- from using new (i.e the Global_Lock) while holding any other lock.
566 W
:= new Wrapper
'((null, Local'Unchecked_Access, null), Val);
568 P := W.Dummy_Node'Unchecked_Access;
569 P.Wrapper := To_Access_Dummy_Wrapper (W);
570 P.Next := To_Access_Node (TT.Indirect_Attributes);
571 TT.Indirect_Attributes := To_Access_Address (P);
574 Undefer_Abort (Self_Id);
579 Undefer_Abort (Self_Id);
584 when Tasking_Error | Program_Error =>
596 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
599 TT : constant Task_Id := To_Task_Id (T);
600 Error_Message : constant String := "Trying to get the Value of a ";
604 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
607 if TT.Common.State = Terminated then
609 (Program_Error'Identity, Error_Message & "terminated task");
612 -- Directly addressed case
614 if Local.Index /= 0 then
616 -- Get value of attribute. We turn Warnings off, because for large
617 -- attributes, this code can generate alignment warnings. But of
618 -- course large attributes are never directly addressed so in fact
619 -- we will never execute the code in this case.
621 pragma Warnings (Off);
622 return To_Attribute_Handle
623 (TT.Direct_Attributes (Local.Index)'Address).all;
624 pragma Warnings (On);
627 -- Not directly addressed
632 Self_Id : constant Task_Id := POP.Self;
635 Defer_Abort (Self_Id);
637 P := To_Access_Node (TT.Indirect_Attributes);
640 if P.Instance = Access_Instance'(Local
'Unchecked_Access) then
641 Result
:= To_Access_Wrapper
(P
.Wrapper
).Value
;
643 Undefer_Abort
(Self_Id
);
651 Undefer_Abort
(Self_Id
);
652 return Initial_Value
;
657 Undefer_Abort
(Self_Id
);
662 when Tasking_Error | Program_Error
=>
669 -- Start of elaboration code for package Ada.Task_Attributes
672 -- This unchecked conversion can give warnings when alignments are
673 -- incorrect, but they will not be used in such cases anyway, so the
674 -- warnings can be safely ignored.
676 pragma Warnings
(Off
);
677 Local
.Deallocate
:= To_Lib_Level_Deallocator
(Deallocate
'Access);
678 pragma Warnings
(On
);
681 Two_To_J
: Direct_Index_Vector
;
682 Self_Id
: constant Task_Id
:= POP
.Self
;
684 Defer_Abort
(Self_Id
);
686 -- Need protection for updating links to per-task initialization and
687 -- finalization routines, in case some task is being created or
688 -- terminated concurrently.
692 -- Add this instantiation to the list of all instantiations
694 Local
.Next
:= System
.Tasking
.Task_Attributes
.All_Attributes
;
695 System
.Tasking
.Task_Attributes
.All_Attributes
:=
696 Local
'Unchecked_Access;
698 -- Try to find space for the attribute in the TCB
703 if Attribute
'Size <= System
.Address
'Size then
704 for J
in Direct_Index_Range
loop
705 if (Two_To_J
and In_Use
) = 0 then
707 -- Reserve location J for this attribute
709 In_Use
:= In_Use
or Two_To_J
;
712 -- This unchecked conversion can give a warning when the
713 -- alignment is incorrect, but it will not be used in such
714 -- a case anyway, so the warning can be safely ignored.
716 pragma Warnings
(Off
);
717 To_Attribute_Handle
(Local
.Initial_Value
'Access).all :=
719 pragma Warnings
(On
);
724 Two_To_J
:= Two_To_J
* 2;
728 -- Attribute goes directly in the TCB
730 if Local
.Index
/= 0 then
731 -- Replace stub for initialization routine that is called at task
734 Initialization
.Initialize_Attributes_Link
:=
735 System
.Tasking
.Task_Attributes
.Initialize_Attributes
'Access;
737 -- Initialize the attribute, for all tasks
740 C
: System
.Tasking
.Task_Id
:= System
.Tasking
.All_Tasks_List
;
743 C
.Direct_Attributes
(Local
.Index
) :=
744 To_Direct_Attribute_Element
745 (System
.Storage_Elements
.To_Address
(Local
.Initial_Value
));
746 C
:= C
.Common
.All_Tasks_Link
;
750 -- Attribute goes into a node onto a linked list
753 -- Replace stub for finalization routine called at task termination
755 Initialization
.Finalize_Attributes_Link
:=
756 System
.Tasking
.Task_Attributes
.Finalize_Attributes
'Access;
760 Undefer_Abort
(Self_Id
);
762 end Ada
.Task_Attributes
;