1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . T A S K _ A T T R I B U T E S --
10 -- Copyright (C) 1991-2002 Florida State University --
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. --
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. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- The following notes are provided in case someone decides the
36 -- implementation of this package is too complicated, or too slow.
37 -- Please read this before making any "simplifications".
39 -- Correct implementation of this package is more difficult than one
40 -- might expect. After considering (and coding) several alternatives,
41 -- we settled on the present compromise. Things we do not like about
42 -- this implementation include:
44 -- - It is vulnerable to bad Task_ID values, to the extent of
45 -- possibly 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,
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
56 -- task to 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
60 -- finalization, via controlled attribute types. For this reason,
61 -- the ARM requires finalization of attribute values when the
62 -- associated task terminates.
64 -- This finalization must be triggered by the tasking runtime system,
65 -- during termination of the task. Given the active set of instantiations
66 -- of Ada.Task_Attributes is dynamic, the number and types of attributes
67 -- belonging to a task will not be known until the task actually terminates.
68 -- Some of these types may be controlled and some may not. The RTS must find
69 -- some way to determine which of these attributes need finalization, and
70 -- invoke the appropriate finalization on them.
72 -- One way this might be done is to create a special finalization chain
73 -- for each task, similar to the finalization chain that is used for
74 -- controlled objects within the task. This would differ from the usual
75 -- finalization chain in that it would not have a LIFO structure, since
76 -- attributes may be added to a task at any time during its lifetime.
77 -- This might be the right way to go for the longer term, but at present
78 -- this approach is not open, since GNAT does not provide such special
79 -- finalization support.
81 -- Lacking special compiler support, the RTS is limited to the
82 -- normal ways an application invokes finalization, i.e.
84 -- a) Explicit call to the procedure Finalize, if we know the type
85 -- has this operation defined on it. This is not sufficient, since
86 -- we have no way of determining whether a given generic formal
87 -- Attribute type is controlled, and no visibility of the associated
88 -- Finalize procedure, in the generic body.
90 -- b) Leaving the scope of a local object of a controlled type.
91 -- This does not help, since the lifetime of an instantiation of
92 -- Ada.Task_Attributes does not correspond to the lifetimes of the
93 -- various tasks which may have that attribute.
95 -- c) Assignment of another value to the object. This would not help,
96 -- since we then have to finalize the new value of the object.
98 -- d) Unchecked deallocation of an object of a controlled type.
99 -- This seems to be the only mechanism available to the runtime
100 -- system for finalization of task attributes.
102 -- We considered two ways of using unchecked deallocation, both based
103 -- on a linked list of that would hang from the task control block.
105 -- In the first approach the objects on the attribute list are all derived
106 -- from one controlled type, say T, and are linked using an access type to
107 -- T'Class. The runtime system has an Unchecked_Deallocation for T'Class
108 -- with access type T'Class, and uses this to deallocate and finalize all
109 -- the items in the list. The limitation of this approach is that each
110 -- instantiation of the package Ada.Task_Attributes derives a new record
111 -- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation
112 -- is only allowed at the library level.
114 -- In the second approach the objects on the attribute list are of
115 -- unrelated but structurally similar types. Unchecked conversion is
116 -- used to circument Ada type checking. Each attribute-storage node
117 -- contains not only the attribute value and a link for chaining, but
118 -- also a pointer to a descriptor for the corresponding instantiation
119 -- of Task_Attributes. The instantiation-descriptor contains a
120 -- pointer to a procedure that can do the correct deallocation and
121 -- finalization for that type of attribute. On task termination, the
122 -- runtime system uses the pointer to call the appropriate deallocator.
124 -- While this gets around the limitation that instantiations be at
125 -- the library level, it relies on an implementation feature that
126 -- may not always be safe, i.e. that it is safe to call the
127 -- Deallocate procedure for an instantiation of Ada.Task_Attributes
128 -- that no longer exists. In general, it seems this might result in
129 -- dangling references.
131 -- Another problem with instantiations deeper than the library level
132 -- is that there is risk of storage leakage, or dangling references
133 -- to reused storage. That is, if an instantiation of Ada.Task_Attributes
134 -- is made within a procedure, what happens to the storage allocated for
135 -- attributes, when the procedure call returns? Apparently (RM 7.6.1 (4))
136 -- any such objects must be finalized, since they will no longer be
137 -- accessible, and in general one would expect that the storage they occupy
138 -- would be recovered for later reuse. (If not, we would have a case of
139 -- storage leakage.) Assuming the storage is recovered and later reused,
140 -- we have potentially dangerous dangling references. When the procedure
141 -- containing the instantiation of Ada.Task_Attributes returns, there
142 -- may still be unterminated tasks with associated attribute values for
143 -- that instantiation. When such tasks eventually terminate, the RTS
144 -- will attempt to call the Deallocate procedure on them. If the
145 -- corresponding storage has already been deallocated, when the master
146 -- of the access type was left, we have a potential disaster. This
147 -- disaster is compounded since the pointer to Deallocate is probably
148 -- through a "trampoline" which will also have been destroyed.
150 -- For this reason, we arrange to remove all dangling references
151 -- before leaving the scope of an instantiation. This is ugly, since
152 -- it requires traversing the list of all tasks, but it is no more ugly
153 -- than a similar traversal that we must do at the point of instantiation
154 -- in order to initialize the attributes of all tasks. At least we only
155 -- need to do these traversals if the type is controlled.
157 -- We chose to defer allocation of storage for attributes until the
158 -- Reference function is called or the attribute is first set to a value
159 -- different from the default initial one. This allows a potential
160 -- savings in allocation, for attributes that are not used by all tasks.
162 -- For efficiency, we reserve space in the TCB for a fixed number of
163 -- direct-access attributes. These are required to be of a size that
164 -- fits in the space of an object of type System.Address. Because
165 -- we must use unchecked bitwise copy operations on these values, they
166 -- cannot be of a controlled type, but that is covered automatically
167 -- since controlled objects are too large to fit in the spaces.
169 -- We originally deferred the initialization of these direct-access
170 -- attributes, just as we do for the indirect-access attributes, and
171 -- used a per-task bit vector to keep track of which attributes were
172 -- currently defined for that task. We found that the overhead of
173 -- maintaining this bit-vector seriously slowed down access to the
174 -- attributes, and made the fetch operation non-atomic, so that even
175 -- to read an attribute value required locking the TCB. Therefore,
176 -- we now initialize such attributes for all existing tasks at the time
177 -- of the attribute instantiation, and initialize existing attributes
178 -- for each new task at the time it is created.
180 -- The latter initialization requires a list of all the instantiation
181 -- descriptors. Updates to this list, as well as the bit-vector that
182 -- is used to reserve slots for attributes in the TCB, require mutual
183 -- exclusion. That is provided by the Lock/Unlock_RTS.
185 -- One special problem that added complexity to the design is that
186 -- the per-task list of indirect attributes contains objects of
187 -- different types. We use unchecked pointer conversion to link
188 -- these nodes together and access them, but the records may not have
189 -- identical internal structure. Initially, we thought it would be
190 -- enough to allocate all the common components of the records at the
191 -- front of each record, so that their positions would correspond.
192 -- Unfortunately, GNAT adds "dope" information at the front of a record,
193 -- if the record contains any controlled-type components.
195 -- This means that the offset of the fields we use to link the nodes is
196 -- at different positions on nodes of different types. To get around this,
197 -- each attribute storage record consists of a core node and wrapper.
198 -- The core nodes are all of the same type, and it is these that are
199 -- linked together and generally "seen" by the RTS. Each core node
200 -- contains a pointer to its own wrapper, which is a record that contains
201 -- the core node along with an attribute value, approximately
205 -- type Node_Access is access all Node;
207 -- type Access_Wrapper is access all Wrapper;
208 -- type Node is record
209 -- Next : Node_Access;
211 -- Wrapper : Access_Wrapper;
213 -- type Wrapper is record
214 -- Noed : aliased Node;
215 -- Value : aliased Attribute; -- the generic formal type
218 -- Another interesting problem is with the initialization of
219 -- the instantiation descriptors. Originally, we did this all via
220 -- the Initialize procedure of the descriptor type and code in the
221 -- package body. It turned out that the Initialize procedure needed
222 -- quite a bit of information, including the size of the attribute
223 -- type, the initial value of the attribute (if it fits in the TCB),
224 -- and a pointer to the deallocator procedure. These needed to be
225 -- "passed" in via access discriminants. GNAT was having trouble
226 -- with access discriminants, so all this work was moved to the
229 with Ada
.Task_Identification
;
234 with System
.Error_Reporting
;
235 -- used for Shutdown;
237 with System
.Storage_Elements
;
238 -- used for Integer_Address
240 with System
.Task_Primitives
.Operations
;
241 -- used for Write_Lock
246 -- used for Access_Address
248 -- Direct_Index_Vector
251 with System
.Tasking
.Initialization
;
252 -- used for Defer_Abortion
254 -- Initialize_Attributes_Link
255 -- Finalize_Attributes_Link
257 with System
.Tasking
.Task_Attributes
;
258 -- used for Access_Node
259 -- Access_Dummy_Wrapper
266 -- used for Raise_Exception
268 with Unchecked_Conversion
;
269 with Unchecked_Deallocation
;
271 pragma Elaborate_All
(System
.Tasking
.Task_Attributes
);
272 -- to ensure the initialization of object Local (below) will work
274 package body Ada
.Task_Attributes
is
276 use System
.Error_Reporting
,
277 System
.Tasking
.Initialization
,
279 System
.Tasking
.Task_Attributes
,
282 use type System
.Tasking
.Access_Address
;
284 package POP
renames System
.Task_Primitives
.Operations
;
286 ---------------------------
287 -- Unchecked Conversions --
288 ---------------------------
290 pragma Warnings
(Off
);
291 -- These unchecked conversions can give warnings when alignments
292 -- are incorrect, but they will not be used in such cases anyway,
293 -- so the warnings can be safely ignored.
295 -- The following type corresponds to Dummy_Wrapper,
296 -- declared in System.Tasking.Task_Attributes.
299 type Access_Wrapper
is access all Wrapper
;
301 pragma Warnings
(Off
);
302 -- We turn warnings off for the following declarations of the
303 -- To_Attribute_Handle conversions, since these are used only
304 -- for small attributes where we know that there are no problems
305 -- with alignment, but the compiler will generate warnings for
306 -- the occurrences in the large attribute case, even though
307 -- they will not actually be used.
309 function To_Attribute_Handle
is new Unchecked_Conversion
310 (Access_Address
, Attribute_Handle
);
311 -- For reference to directly addressed task attributes
313 type Access_Integer_Address
is access all
314 System
.Storage_Elements
.Integer_Address
;
316 function To_Attribute_Handle
is new Unchecked_Conversion
317 (Access_Integer_Address
, Attribute_Handle
);
318 -- For reference to directly addressed task attributes
320 pragma Warnings
(On
);
321 -- End of warnings off region for directly addressed
322 -- attribute conversion functions.
324 function To_Access_Address
is new Unchecked_Conversion
325 (Access_Node
, Access_Address
);
326 -- To store pointer to list of indirect attributes
328 function To_Access_Node
is new Unchecked_Conversion
329 (Access_Address
, Access_Node
);
330 -- To fetch pointer to list of indirect attributes
332 pragma Warnings
(Off
);
333 function To_Access_Wrapper
is new Unchecked_Conversion
334 (Access_Dummy_Wrapper
, Access_Wrapper
);
335 pragma Warnings
(On
);
336 -- To fetch pointer to actual wrapper of attribute node. We turn off
337 -- warnings since this may generate an alignment warning. The warning
338 -- can be ignored since Dummy_Wrapper is only a non-generic standin
339 -- for the real wrapper type (we never actually allocate objects of
340 -- type Dummy_Wrapper).
342 function To_Access_Dummy_Wrapper
is new Unchecked_Conversion
343 (Access_Wrapper
, Access_Dummy_Wrapper
);
344 -- To store pointer to actual wrapper of attribute node
346 function To_Task_ID
is new Unchecked_Conversion
347 (Task_Identification
.Task_Id
, Task_ID
);
348 -- To access TCB of identified task
350 Null_ID
: constant Task_ID
:= To_Task_ID
(Task_Identification
.Null_Task_Id
);
351 -- ??? need comments on use and purpose
353 type Local_Deallocator
is
354 access procedure (P
: in out Access_Node
);
356 function To_Lib_Level_Deallocator
is new Unchecked_Conversion
357 (Local_Deallocator
, Deallocator
);
358 -- To defeat accessibility check
360 pragma Warnings
(On
);
362 ------------------------
363 -- Storage Management --
364 ------------------------
366 procedure Deallocate
(P
: in out Access_Node
);
367 -- Passed to the RTS via unchecked conversion of a pointer to
368 -- permit finalization and deallocation of attribute storage nodes
370 --------------------------
371 -- Instantiation Record --
372 --------------------------
374 Local
: aliased Instance
;
375 -- Initialized in package body
377 type Wrapper
is record
380 Value
: aliased Attribute
:= Initial_Value
;
381 -- The generic formal type, may be controlled
385 new Unchecked_Deallocation
(Wrapper
, Access_Wrapper
);
387 procedure Deallocate
(P
: in out Access_Node
) is
388 T
: Access_Wrapper
:= To_Access_Wrapper
(P
.Wrapper
);
395 pragma Assert
(Shutdown
("Exception in Deallocate")); null;
403 (T
: Task_Identification
.Task_Id
:= Task_Identification
.Current_Task
)
404 return Attribute_Handle
406 TT
: Task_ID
:= To_Task_ID
(T
);
407 Error_Message
: constant String := "Trying to get the reference of a";
411 Raise_Exception
(Program_Error
'Identity,
412 Error_Message
& "null task");
415 if TT
.Common
.State
= Terminated
then
416 Raise_Exception
(Tasking_Error
'Identity,
417 Error_Message
& "terminated task");
424 -- Directly addressed case
426 if Local
.Index
/= 0 then
430 -- Return the attribute handle. Warnings off because this return
431 -- statement generates alignment warnings for large attributes
432 -- (but will never be executed in this case anyway).
434 pragma Warnings
(Off
);
436 To_Attribute_Handle
(TT
.Direct_Attributes
(Local
.Index
)'Access);
437 pragma Warnings
(On
);
439 -- Not directly addressed
443 P
: Access_Node
:= To_Access_Node
(TT
.Indirect_Attributes
);
448 if P
.Instance
= Access_Instance
'(Local'Unchecked_Access) then
451 return To_Access_Wrapper (P.Wrapper).Value'Access;
457 -- Unlock the RTS here to follow the lock ordering rule
458 -- that prevent us from using new (i.e the Global_Lock) while
459 -- holding any other lock.
463 ((null, Local
'Unchecked_Access, null), Initial_Value
);
466 P
:= W
.Noed
'Unchecked_Access;
467 P
.Wrapper
:= To_Access_Dummy_Wrapper
(W
);
468 P
.Next
:= To_Access_Node
(TT
.Indirect_Attributes
);
469 TT
.Indirect_Attributes
:= To_Access_Address
(P
);
472 return W
.Value
'Access;
476 pragma Assert
(Shutdown
("Should never get here in Reference"));
487 when Tasking_Error | Program_Error
=>
498 procedure Reinitialize
499 (T
: Task_Identification
.Task_Id
:= Task_Identification
.Current_Task
)
501 TT
: Task_ID
:= To_Task_ID
(T
);
502 Error_Message
: constant String := "Trying to Reinitialize a";
506 Raise_Exception
(Program_Error
'Identity,
507 Error_Message
& "null task");
510 if TT
.Common
.State
= Terminated
then
511 Raise_Exception
(Tasking_Error
'Identity,
512 Error_Message
& "terminated task");
515 if Local
.Index
= 0 then
523 Q
:= To_Access_Node
(TT
.Indirect_Attributes
);
526 if Q
.Instance
= Access_Instance
'(Local'Unchecked_Access) then
528 TT.Indirect_Attributes := To_Access_Address (Q.Next);
533 W := To_Access_Wrapper (Q.Wrapper);
554 Set_Value (Initial_Value, T);
558 when Tasking_Error | Program_Error =>
571 T : Task_Identification.Task_Id := Task_Identification.Current_Task)
573 TT : Task_ID := To_Task_ID (T);
574 Error_Message : constant String := "Trying to Set the Value of a";
578 Raise_Exception (Program_Error'Identity,
579 Error_Message & "null task");
582 if TT.Common.State = Terminated then
583 Raise_Exception (Tasking_Error'Identity,
584 Error_Message & "terminated task");
591 -- Directly addressed case
593 if Local.Index /= 0 then
595 -- Set attribute handle, warnings off, because this code can
596 -- generate alignment warnings with large attributes (but of
597 -- course wil not be executed in this case, since we never
598 -- have direct addressing in such cases).
600 pragma Warnings (Off);
602 (TT.Direct_Attributes (Local.Index)'Access).all := Val;
603 pragma Warnings (On);
608 -- Not directly addressed
612 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
618 if P.Instance = Access_Instance'(Local
'Unchecked_Access) then
619 To_Access_Wrapper
(P
.Wrapper
).Value
:= Val
;
628 -- Unlock RTS here to follow the lock ordering rule that
629 -- prevent us from using new (i.e the Global_Lock) while
630 -- holding any other lock.
634 ((null, Local'Unchecked_Access, null), Val);
636 P := W.Noed'Unchecked_Access;
637 P.Wrapper := To_Access_Dummy_Wrapper (W);
638 P.Next := To_Access_Node (TT.Indirect_Attributes);
639 TT.Indirect_Attributes := To_Access_Address (P);
656 when Tasking_Error | Program_Error =>
669 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
673 TT : Task_ID := To_Task_ID (T);
674 Error_Message : constant String := "Trying to get the Value of a";
679 (Program_Error'Identity, Error_Message & "null task");
682 if TT.Common.State = Terminated then
684 (Program_Error'Identity, Error_Message & "terminated task");
688 -- Directly addressed case
690 if Local.Index /= 0 then
692 -- Get value of attribute. Warnings off, because for large
693 -- attributes, this code can generate alignment warnings.
694 -- But of course large attributes are never directly addressed
695 -- so in fact we will never execute the code in this case.
697 pragma Warnings (Off);
700 (TT.Direct_Attributes (Local.Index)'Access).all;
701 pragma Warnings (On);
703 -- Not directly addressed
712 P := To_Access_Node (TT.Indirect_Attributes);
715 if P.Instance = Access_Instance'(Local
'Unchecked_Access) then
718 return To_Access_Wrapper
(P
.Wrapper
).Value
;
724 Result
:= Initial_Value
;
740 when Tasking_Error | Program_Error
=>
747 -- Start of elaboration code for package Ada.Task_Attributes
750 -- This unchecked conversion can give warnings when alignments
751 -- are incorrect, but they will not be used in such cases anyway,
752 -- so the warnings can be safely ignored.
754 pragma Warnings
(Off
);
755 Local
.Deallocate
:= To_Lib_Level_Deallocator
(Deallocate
'Access);
756 pragma Warnings
(On
);
759 Two_To_J
: Direct_Index_Vector
;
763 -- Need protection for updating links to per-task initialization and
764 -- finalization routines, in case some task is being created or
765 -- terminated concurrently.
769 -- Add this instantiation to the list of all instantiations.
771 Local
.Next
:= System
.Tasking
.Task_Attributes
.All_Attributes
;
772 System
.Tasking
.Task_Attributes
.All_Attributes
:=
773 Local
'Unchecked_Access;
775 -- Try to find space for the attribute in the TCB.
778 Two_To_J
:= 2 ** Direct_Index
'First;
780 if Attribute
'Size <= System
.Address
'Size then
781 for J
in Direct_Index
loop
782 if (Two_To_J
and In_Use
) /= 0 then
784 -- Reserve location J for this attribute
786 In_Use
:= In_Use
or Two_To_J
;
789 -- This unchecked conversions can give a warning when the
790 -- the alignment is incorrect, but it will not be used in
791 -- such a case anyway, so the warning can be safely ignored.
793 pragma Warnings
(Off
);
794 To_Attribute_Handle
(Local
.Initial_Value
'Access).all :=
796 pragma Warnings
(On
);
801 Two_To_J
:= Two_To_J
* 2;
805 -- Attribute goes directly in the TCB
807 if Local
.Index
/= 0 then
809 -- Replace stub for initialization routine
810 -- that is called at task creation.
812 Initialization
.Initialize_Attributes_Link
:=
813 System
.Tasking
.Task_Attributes
.Initialize_Attributes
'Access;
815 -- Initialize the attribute, for all tasks.
818 C
: System
.Tasking
.Task_ID
:= System
.Tasking
.All_Tasks_List
;
823 C
.Direct_Attributes
(Local
.Index
) :=
824 System
.Storage_Elements
.To_Address
(Local
.Initial_Value
);
826 C
:= C
.Common
.All_Tasks_Link
;
830 -- Attribute goes into a node onto a linked list
833 -- Replace stub for finalization routine
834 -- that is called at task termination.
836 Initialization
.Finalize_Attributes_Link
:=
837 System
.Tasking
.Task_Attributes
.Finalize_Attributes
'Access;
846 pragma Assert
(Shutdown
("Exception in task attribute initializer"));
848 -- If we later decide to allow exceptions to propagate, we need to
849 -- not only release locks and undefer abortion, we also need to undo
850 -- any initializations that succeeded up to this point, or we will
851 -- risk a dangling reference when the task terminates.
853 end Ada
.Task_Attributes
;