Dead
[official-gcc.git] / gomp-20050608-branch / gcc / ada / a-tasatt.adb
blobfca7bd2bcceff799aa5910bf21cabe7af6d94ffa
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . T A S K _ A T T R I B U T E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1991-1994, Florida State University --
10 -- Copyright (C) 1995-2006, AdaCore --
11 -- --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
22 -- --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
29 -- --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 -- --
33 ------------------------------------------------------------------------------
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
42 -- include:
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
49 -- shorter.
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
86 -- the generic body.
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 Unchecked_Deallocation for T'Class with
106 -- 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
120 -- deallocator.
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
130 -- storage. That is, if an instantiation of Ada.Task_Attributes is made
131 -- within a procedure, what happens to the storage allocated for attributes,
132 -- when the procedure call returns? Apparently (RM 7.6.1 (4)) any such
133 -- objects must be finalized, since they will no longer be accessible, and in
134 -- general one would expect that the storage they occupy would be recovered
135 -- for later reuse. (If not, we would have a case of storage leakage.)
136 -- Assuming the storage is recovered and later reused, we have potentially
137 -- dangerous dangling references. When the procedure containing the
138 -- instantiation of Ada.Task_Attributes returns, there may still be
139 -- unterminated tasks with associated attribute values for that instantiation.
140 -- When such tasks eventually terminate, the RTS will attempt to call the
141 -- Deallocate procedure on them. If the corresponding storage has already
142 -- been deallocated, when the master of the access type was left, we have a
143 -- potential disaster. This disaster is compounded since the pointer to
144 -- Deallocate is probably through a "trampoline" which will also have been
145 -- destroyed.
147 -- For this reason, we arrange to remove all dangling references before
148 -- leaving the scope of an instantiation. This is ugly, since it requires
149 -- traversing the list of all tasks, but it is no more ugly than a similar
150 -- traversal that we must do at the point of instantiation in order to
151 -- initialize the attributes of all tasks. At least we only need to do these
152 -- traversals if the type is controlled.
154 -- We chose to defer allocation of storage for attributes until the Reference
155 -- function is called or the attribute is first set to a value different from
156 -- the default initial one. This allows a potential savings in allocation,
157 -- for attributes that are not used by all tasks.
159 -- For efficiency, we reserve space in the TCB for a fixed number of
160 -- direct-access attributes. These are required to be of a size that fits in
161 -- the space of an object of type System.Address. Because we must use
162 -- unchecked bitwise copy operations on these values, they cannot be of a
163 -- controlled type, but that is covered automatically since controlled
164 -- objects are too large to fit in the spaces.
166 -- We originally deferred the initialization of these direct-access
167 -- attributes, just as we do for the indirect-access attributes, and used a
168 -- per-task bit vector to keep track of which attributes were currently
169 -- defined for that task. We found that the overhead of maintaining this
170 -- bit-vector seriously slowed down access to the attributes, and made the
171 -- fetch operation non-atomic, so that even to read an attribute value
172 -- required locking the TCB. Therefore, we now initialize such attributes for
173 -- all existing tasks at the time of the attribute instantiation, and
174 -- initialize existing attributes for each new task at the time it is
175 -- created.
177 -- The latter initialization requires a list of all the instantiation
178 -- descriptors. Updates to this list, as well as the bit-vector that is used
179 -- to reserve slots for attributes in the TCB, require mutual exclusion. That
180 -- is provided by the Lock/Unlock_RTS.
182 -- One special problem that added complexity to the design is that the
183 -- per-task list of indirect attributes contains objects of different types.
184 -- We use unchecked pointer conversion to link these nodes together and
185 -- access them, but the records may not have identical internal structure.
186 -- Initially, we thought it would be enough to allocate all the common
187 -- components of the records at the front of each record, so that their
188 -- positions would correspond. Unfortunately, GNAT adds "dope" information at
189 -- the front of a record, if the record contains any controlled-type
190 -- components.
192 -- This means that the offset of the fields we use to link the nodes is at
193 -- different positions on nodes of different types. To get around this, each
194 -- attribute storage record consists of a core node and wrapper. The core
195 -- nodes are all of the same type, and it is these that are linked together
196 -- and generally "seen" by the RTS. Each core node contains a pointer to its
197 -- own wrapper, which is a record that contains the core node along with an
198 -- attribute value, approximately as follows:
200 -- type Node;
201 -- type Node_Access is access all Node;
202 -- type Node_Access;
203 -- type Access_Wrapper is access all Wrapper;
204 -- type Node is record
205 -- Next : Node_Access;
206 -- ...
207 -- Wrapper : Access_Wrapper;
208 -- end record;
209 -- type Wrapper is record
210 -- Dummy_Node : aliased Node;
211 -- Value : aliased Attribute; -- the generic formal type
212 -- end record;
214 -- Another interesting problem is with the initialization of the
215 -- instantiation descriptors. Originally, we did this all via the Initialize
216 -- procedure of the descriptor type and code in the package body. It turned
217 -- out that the Initialize procedure needed quite a bit of information,
218 -- including the size of the attribute type, the initial value of the
219 -- attribute (if it fits in the TCB), and a pointer to the deallocator
220 -- procedure. These needed to be "passed" in via access discriminants. GNAT
221 -- was having trouble with access discriminants, so all this work was moved
222 -- to the package body.
224 with System.Error_Reporting;
225 -- Used for Shutdown;
227 with System.Storage_Elements;
228 -- Used for Integer_Address
230 with System.Task_Primitives.Operations;
231 -- Used for Write_Lock
232 -- Unlock
233 -- Lock/Unlock_RTS
235 with System.Tasking;
236 -- Used for Access_Address
237 -- Task_Id
238 -- Direct_Index_Vector
239 -- Direct_Index
241 with System.Tasking.Initialization;
242 -- Used for Defer_Abortion
243 -- Undefer_Abortion
244 -- Initialize_Attributes_Link
245 -- Finalize_Attributes_Link
247 with System.Tasking.Task_Attributes;
248 -- Used for Access_Node
249 -- Access_Dummy_Wrapper
250 -- Deallocator
251 -- Instance
252 -- Node
253 -- Access_Instance
255 with Ada.Exceptions;
256 -- Used for Raise_Exception
258 with Unchecked_Conversion;
259 with Unchecked_Deallocation;
261 pragma Elaborate_All (System.Tasking.Task_Attributes);
262 -- To ensure the initialization of object Local (below) will work
264 package body Ada.Task_Attributes is
266 use System.Error_Reporting,
267 System.Tasking.Initialization,
268 System.Tasking,
269 System.Tasking.Task_Attributes,
270 Ada.Exceptions;
272 use type System.Tasking.Access_Address;
274 package POP renames System.Task_Primitives.Operations;
276 ---------------------------
277 -- Unchecked Conversions --
278 ---------------------------
280 -- The following type corresponds to Dummy_Wrapper,
281 -- declared in System.Tasking.Task_Attributes.
283 type Wrapper;
284 type Access_Wrapper is access all Wrapper;
286 pragma Warnings (Off);
287 -- We turn warnings off for the following declarations of the
288 -- To_Attribute_Handle conversions, since these are used only for small
289 -- attributes where we know that there are no problems with alignment, but
290 -- the compiler will generate warnings for the occurrences in the large
291 -- attribute case, even though they will not actually be used.
293 function To_Attribute_Handle is new Unchecked_Conversion
294 (System.Address, Attribute_Handle);
295 function To_Direct_Attribute_Element is new Unchecked_Conversion
296 (System.Address, Direct_Attribute_Element);
297 -- For reference to directly addressed task attributes
299 type Access_Integer_Address is access all
300 System.Storage_Elements.Integer_Address;
302 function To_Attribute_Handle is new Unchecked_Conversion
303 (Access_Integer_Address, Attribute_Handle);
304 -- For reference to directly addressed task attributes
306 pragma Warnings (On);
307 -- End of warnings off region for directly addressed
308 -- attribute conversion functions.
310 function To_Access_Address is new Unchecked_Conversion
311 (Access_Node, Access_Address);
312 -- To store pointer to list of indirect attributes
314 pragma Warnings (Off);
315 function To_Access_Wrapper is new Unchecked_Conversion
316 (Access_Dummy_Wrapper, Access_Wrapper);
317 pragma Warnings (On);
318 -- To fetch pointer to actual wrapper of attribute node. We turn off
319 -- warnings since this may generate an alignment warning. The warning can
320 -- be ignored since Dummy_Wrapper is only a non-generic standin for the
321 -- real wrapper type (we never actually allocate objects of type
322 -- Dummy_Wrapper).
324 function To_Access_Dummy_Wrapper is new Unchecked_Conversion
325 (Access_Wrapper, Access_Dummy_Wrapper);
326 -- To store pointer to actual wrapper of attribute node
328 function To_Task_Id is new Unchecked_Conversion
329 (Task_Identification.Task_Id, Task_Id);
330 -- To access TCB of identified task
332 type Local_Deallocator is access procedure (P : in out Access_Node);
334 function To_Lib_Level_Deallocator is new Unchecked_Conversion
335 (Local_Deallocator, Deallocator);
336 -- To defeat accessibility check
338 pragma Warnings (On);
340 ------------------------
341 -- Storage Management --
342 ------------------------
344 procedure Deallocate (P : in out Access_Node);
345 -- Passed to the RTS via unchecked conversion of a pointer to
346 -- permit finalization and deallocation of attribute storage nodes
348 --------------------------
349 -- Instantiation Record --
350 --------------------------
352 Local : aliased Instance;
353 -- Initialized in package body
355 type Wrapper is record
356 Dummy_Node : aliased Node;
358 Value : aliased Attribute := Initial_Value;
359 -- The generic formal type, may be controlled
360 end record;
362 -- A number of unchecked conversions involving Wrapper_Access sources
363 -- are performed in this unit. We have to ensure that the designated
364 -- object is always strictly enough aligned.
366 for Wrapper'Alignment use Standard'Maximum_Alignment;
368 procedure Free is
369 new Unchecked_Deallocation (Wrapper, Access_Wrapper);
371 procedure Deallocate (P : in out Access_Node) is
372 T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
373 begin
374 Free (T);
375 end Deallocate;
377 ---------------
378 -- Reference --
379 ---------------
381 function Reference
382 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
383 return Attribute_Handle
385 TT : constant Task_Id := To_Task_Id (T);
386 Error_Message : constant String := "Trying to get the reference of a ";
388 begin
389 if TT = null then
390 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
391 end if;
393 if TT.Common.State = Terminated then
394 Raise_Exception (Tasking_Error'Identity,
395 Error_Message & "terminated task");
396 end if;
398 -- Directly addressed case
400 if Local.Index /= 0 then
402 -- Return the attribute handle. Warnings off because this return
403 -- statement generates alignment warnings for large attributes
404 -- (but will never be executed in this case anyway).
406 pragma Warnings (Off);
407 return
408 To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address);
409 pragma Warnings (On);
411 -- Not directly addressed
413 else
414 declare
415 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
416 W : Access_Wrapper;
417 Self_Id : constant Task_Id := POP.Self;
419 begin
420 Defer_Abort (Self_Id);
421 POP.Lock_RTS;
423 while P /= null loop
424 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
425 POP.Unlock_RTS;
426 Undefer_Abort (Self_Id);
427 return To_Access_Wrapper (P.Wrapper).Value'Access;
428 end if;
430 P := P.Next;
431 end loop;
433 -- Unlock the RTS here to follow the lock ordering rule
434 -- that prevent us from using new (i.e the Global_Lock) while
435 -- holding any other lock.
437 POP.Unlock_RTS;
438 W := new Wrapper'
439 ((null, Local'Unchecked_Access, null), Initial_Value);
440 POP.Lock_RTS;
442 P := W.Dummy_Node'Unchecked_Access;
443 P.Wrapper := To_Access_Dummy_Wrapper (W);
444 P.Next := To_Access_Node (TT.Indirect_Attributes);
445 TT.Indirect_Attributes := To_Access_Address (P);
446 POP.Unlock_RTS;
447 Undefer_Abort (Self_Id);
448 return W.Value'Access;
450 exception
451 when others =>
452 POP.Unlock_RTS;
453 Undefer_Abort (Self_Id);
454 raise;
455 end;
456 end if;
458 pragma Assert (Shutdown ("Should never get here in Reference"));
459 return null;
461 exception
462 when Tasking_Error | Program_Error =>
463 raise;
465 when others =>
466 raise Program_Error;
467 end Reference;
469 ------------------
470 -- Reinitialize --
471 ------------------
473 procedure Reinitialize
474 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
476 TT : constant Task_Id := To_Task_Id (T);
477 Error_Message : constant String := "Trying to Reinitialize a ";
479 begin
480 if TT = null then
481 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
482 end if;
484 if TT.Common.State = Terminated then
485 Raise_Exception (Tasking_Error'Identity,
486 Error_Message & "terminated task");
487 end if;
489 if Local.Index /= 0 then
490 Set_Value (Initial_Value, T);
491 else
492 declare
493 P, Q : Access_Node;
494 W : Access_Wrapper;
495 Self_Id : constant Task_Id := POP.Self;
497 begin
498 Defer_Abort (Self_Id);
499 POP.Lock_RTS;
500 Q := To_Access_Node (TT.Indirect_Attributes);
502 while Q /= null loop
503 if Q.Instance = Access_Instance'(Local'Unchecked_Access) then
504 if P = null then
505 TT.Indirect_Attributes := To_Access_Address (Q.Next);
506 else
507 P.Next := Q.Next;
508 end if;
510 W := To_Access_Wrapper (Q.Wrapper);
511 Free (W);
512 POP.Unlock_RTS;
513 Undefer_Abort (Self_Id);
514 return;
515 end if;
517 P := Q;
518 Q := Q.Next;
519 end loop;
521 POP.Unlock_RTS;
522 Undefer_Abort (Self_Id);
524 exception
525 when others =>
526 POP.Unlock_RTS;
527 Undefer_Abort (Self_Id);
528 raise;
529 end;
530 end if;
532 exception
533 when Tasking_Error | Program_Error =>
534 raise;
536 when others =>
537 raise Program_Error;
538 end Reinitialize;
540 ---------------
541 -- Set_Value --
542 ---------------
544 procedure Set_Value
545 (Val : Attribute;
546 T : Task_Identification.Task_Id := Task_Identification.Current_Task)
548 TT : constant Task_Id := To_Task_Id (T);
549 Error_Message : constant String := "Trying to Set the Value of a ";
551 begin
552 if TT = null then
553 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
554 end if;
556 if TT.Common.State = Terminated then
557 Raise_Exception (Tasking_Error'Identity,
558 Error_Message & "terminated task");
559 end if;
561 -- Directly addressed case
563 if Local.Index /= 0 then
565 -- Set attribute handle, warnings off, because this code can generate
566 -- alignment warnings with large attributes (but of course will not
567 -- be executed in this case, since we never have direct addressing in
568 -- such cases).
570 pragma Warnings (Off);
571 To_Attribute_Handle
572 (TT.Direct_Attributes (Local.Index)'Address).all := Val;
573 pragma Warnings (On);
574 return;
575 end if;
577 -- Not directly addressed
579 declare
580 P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
581 W : Access_Wrapper;
582 Self_Id : constant Task_Id := POP.Self;
584 begin
585 Defer_Abort (Self_Id);
586 POP.Lock_RTS;
588 while P /= null loop
590 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
591 To_Access_Wrapper (P.Wrapper).Value := Val;
592 POP.Unlock_RTS;
593 Undefer_Abort (Self_Id);
594 return;
595 end if;
597 P := P.Next;
598 end loop;
600 -- Unlock RTS here to follow the lock ordering rule that prevent us
601 -- from using new (i.e the Global_Lock) while holding any other
602 -- lock.
604 POP.Unlock_RTS;
605 W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
606 POP.Lock_RTS;
607 P := W.Dummy_Node'Unchecked_Access;
608 P.Wrapper := To_Access_Dummy_Wrapper (W);
609 P.Next := To_Access_Node (TT.Indirect_Attributes);
610 TT.Indirect_Attributes := To_Access_Address (P);
612 POP.Unlock_RTS;
613 Undefer_Abort (Self_Id);
615 exception
616 when others =>
617 POP.Unlock_RTS;
618 Undefer_Abort (Self_Id);
619 raise;
620 end;
622 exception
623 when Tasking_Error | Program_Error =>
624 raise;
626 when others =>
627 raise Program_Error;
628 end Set_Value;
630 -----------
631 -- Value --
632 -----------
634 function Value
635 (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
636 return Attribute
638 TT : constant Task_Id := To_Task_Id (T);
639 Error_Message : constant String := "Trying to get the Value of a ";
641 begin
642 if TT = null then
643 Raise_Exception (Program_Error'Identity, Error_Message & "null task");
644 end if;
646 if TT.Common.State = Terminated then
647 Raise_Exception
648 (Program_Error'Identity, Error_Message & "terminated task");
649 end if;
651 -- Directly addressed case
653 if Local.Index /= 0 then
655 -- Get value of attribute. Warnings off, because for large
656 -- attributes, this code can generate alignment warnings. But of
657 -- course large attributes are never directly addressed so in fact
658 -- we will never execute the code in this case.
660 pragma Warnings (Off);
661 return To_Attribute_Handle
662 (TT.Direct_Attributes (Local.Index)'Address).all;
663 pragma Warnings (On);
664 end if;
666 -- Not directly addressed
668 declare
669 P : Access_Node;
670 Result : Attribute;
671 Self_Id : constant Task_Id := POP.Self;
673 begin
674 Defer_Abort (Self_Id);
675 POP.Lock_RTS;
676 P := To_Access_Node (TT.Indirect_Attributes);
678 while P /= null loop
679 if P.Instance = Access_Instance'(Local'Unchecked_Access) then
680 Result := To_Access_Wrapper (P.Wrapper).Value;
681 POP.Unlock_RTS;
682 Undefer_Abort (Self_Id);
683 return Result;
684 end if;
686 P := P.Next;
687 end loop;
689 POP.Unlock_RTS;
690 Undefer_Abort (Self_Id);
691 return Initial_Value;
693 exception
694 when others =>
695 POP.Unlock_RTS;
696 Undefer_Abort (Self_Id);
697 raise;
698 end;
700 exception
701 when Tasking_Error | Program_Error =>
702 raise;
704 when others =>
705 raise Program_Error;
706 end Value;
708 -- Start of elaboration code for package Ada.Task_Attributes
710 begin
711 -- This unchecked conversion can give warnings when alignments
712 -- are incorrect, but they will not be used in such cases anyway,
713 -- so the warnings can be safely ignored.
715 pragma Warnings (Off);
716 Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
717 pragma Warnings (On);
719 declare
720 Two_To_J : Direct_Index_Vector;
721 Self_Id : constant Task_Id := POP.Self;
722 begin
723 Defer_Abort (Self_Id);
725 -- Need protection for updating links to per-task initialization and
726 -- finalization routines, in case some task is being created or
727 -- terminated concurrently.
729 POP.Lock_RTS;
731 -- Add this instantiation to the list of all instantiations
733 Local.Next := System.Tasking.Task_Attributes.All_Attributes;
734 System.Tasking.Task_Attributes.All_Attributes :=
735 Local'Unchecked_Access;
737 -- Try to find space for the attribute in the TCB
739 Local.Index := 0;
740 Two_To_J := 1;
742 if Attribute'Size <= System.Address'Size then
743 for J in Direct_Index_Range loop
744 if (Two_To_J and In_Use) = 0 then
746 -- Reserve location J for this attribute
748 In_Use := In_Use or Two_To_J;
749 Local.Index := J;
751 -- This unchecked conversions can give a warning when the the
752 -- alignment is incorrect, but it will not be used in such a
753 -- case anyway, so the warning can be safely ignored.
755 pragma Warnings (Off);
756 To_Attribute_Handle (Local.Initial_Value'Access).all :=
757 Initial_Value;
758 pragma Warnings (On);
760 exit;
761 end if;
763 Two_To_J := Two_To_J * 2;
764 end loop;
765 end if;
767 -- Attribute goes directly in the TCB
769 if Local.Index /= 0 then
770 -- Replace stub for initialization routine that is called at task
771 -- creation.
773 Initialization.Initialize_Attributes_Link :=
774 System.Tasking.Task_Attributes.Initialize_Attributes'Access;
776 -- Initialize the attribute, for all tasks
778 declare
779 C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
780 begin
781 while C /= null loop
782 C.Direct_Attributes (Local.Index) :=
783 To_Direct_Attribute_Element
784 (System.Storage_Elements.To_Address (Local.Initial_Value));
785 C := C.Common.All_Tasks_Link;
786 end loop;
787 end;
789 -- Attribute goes into a node onto a linked list
791 else
792 -- Replace stub for finalization routine that is called at task
793 -- termination.
795 Initialization.Finalize_Attributes_Link :=
796 System.Tasking.Task_Attributes.Finalize_Attributes'Access;
797 end if;
799 POP.Unlock_RTS;
800 Undefer_Abort (Self_Id);
801 end;
802 end Ada.Task_Attributes;