aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/a-tasatt.adb
blob: fca7bd2bcceff799aa5910bf21cabe7af6d94ffa (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
------------------------------------------------------------------------------
--                                                                          --
--                        GNAT RUN-TIME COMPONENTS                          --
--                                                                          --
--                  A D A . T A S K _ A T T R I B U T E S                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--             Copyright (C) 1991-1994, Florida State University            --
--                     Copyright (C) 1995-2006, AdaCore                     --
--                                                                          --
-- GNARL is free software; you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNARL; see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNARL was developed by the GNARL team at Florida State University.       --
-- Extensive contributions were provided by Ada Core Technologies, Inc.     --
--                                                                          --
------------------------------------------------------------------------------

--  The following notes are provided in case someone decides the implementation
--  of this package is too complicated, or too slow. Please read this before
--  making any "simplifications".

--  Correct implementation of this package is more difficult than one might
--  expect. After considering (and coding) several alternatives, we settled on
--  the present compromise. Things we do not like about this implementation
--  include:

--  - It is vulnerable to bad Task_Id values, to the extent of possibly
--     trashing memory and crashing the runtime system.

--  - It requires dynamic storage allocation for each new attribute value,
--     except for types that happen to be the same size as System.Address, or
--     shorter.

--  -  Instantiations at other than the library level rely on being able to
--     do down-level calls to a procedure declared in the generic package body.
--     This makes it potentially vulnerable to compiler changes.

--  The main implementation issue here is that the connection from task to
--  attribute is a potential source of dangling references.

--  When a task goes away, we want to be able to recover all the storage
--  associated with its attributes. The Ada mechanism for this is finalization,
--  via controlled attribute types. For this reason, the ARM requires
--  finalization of attribute values when the associated task terminates.

--  This finalization must be triggered by the tasking runtime system, during
--  termination of the task. Given the active set of instantiations of
--  Ada.Task_Attributes is dynamic, the number and types of attributes
--  belonging to a task will not be known until the task actually terminates.
--  Some of these types may be controlled and some may not. The RTS must find
--  some way to determine which of these attributes need finalization, and
--  invoke the appropriate finalization on them.

--  One way this might be done is to create a special finalization chain for
--  each task, similar to the finalization chain that is used for controlled
--  objects within the task. This would differ from the usual finalization
--  chain in that it would not have a LIFO structure, since attributes may be
--  added to a task at any time during its lifetime. This might be the right
--  way to go for the longer term, but at present this approach is not open,
--  since GNAT does not provide such special finalization support.

--  Lacking special compiler support, the RTS is limited to the normal ways an
--  application invokes finalization, i.e.

--  a) Explicit call to the procedure Finalize, if we know the type has this
--     operation defined on it. This is not sufficient, since we have no way
--     of determining whether a given generic formal Attribute type is
--     controlled, and no visibility of the associated Finalize procedure, in
--     the generic body.

--  b) Leaving the scope of a local object of a controlled type. This does not
--     help, since the lifetime of an instantiation of Ada.Task_Attributes
--     does not correspond to the lifetimes of the various tasks which may
--     have that attribute.

--  c) Assignment of another value to the object. This would not help, since
--     we then have to finalize the new value of the object.

--  d) Unchecked deallocation of an object of a controlled type. This seems to
--     be the only mechanism available to the runtime system for finalization
--     of task attributes.

--  We considered two ways of using unchecked deallocation, both based on a
--  linked list of that would hang from the task control block.

--  In the first approach the objects on the attribute list are all derived
--  from one controlled type, say T, and are linked using an access type to
--  T'Class. The runtime system has an Unchecked_Deallocation for T'Class with
--  access type T'Class, and uses this to deallocate and finalize all the
--  items in the list. The limitation of this approach is that each
--  instantiation of the package Ada.Task_Attributes derives a new record
--  extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is
--  only allowed at the library level.

--  In the second approach the objects on the attribute list are of unrelated
--  but structurally similar types. Unchecked conversion is used to circument
--  Ada type checking. Each attribute-storage node contains not only the
--  attribute value and a link for chaining, but also a pointer to descriptor
--  for the corresponding instantiation of Task_Attributes. The instantiation
--  descriptor contains pointer to a procedure that can do the correct
--  deallocation and finalization for that type of attribute. On task
--  termination, the runtime system uses the pointer to call the appropriate
--  deallocator.

--  While this gets around the limitation that instantations be at the library
--  level, it relies on an implementation feature that may not always be safe,
--  i.e. that it is safe to call the Deallocate procedure for an instantiation
--  of Ada.Task_Attributes that no longer exists. In general, it seems this
--  might result in dangling references.

--  Another problem with instantiations deeper than the library level is that
--  there is risk of storage leakage, or dangling references to reused
--  storage. That is, if an instantiation of Ada.Task_Attributes is made
--  within a procedure, what happens to the storage allocated for attributes,
--  when the procedure call returns? Apparently (RM 7.6.1 (4)) any such
--  objects must be finalized, since they will no longer be accessible, and in
--  general one would expect that the storage they occupy would be recovered
--  for later reuse. (If not, we would have a case of storage leakage.)
--  Assuming the storage is recovered and later reused, we have potentially
--  dangerous dangling references. When the procedure containing the
--  instantiation of Ada.Task_Attributes returns, there may still be
--  unterminated tasks with associated attribute values for that instantiation.
--  When such tasks eventually terminate, the RTS will attempt to call the
--  Deallocate procedure on them. If the corresponding storage has already
--  been deallocated, when the master of the access type was left, we have a
--  potential disaster. This disaster is compounded since the pointer to
--  Deallocate is probably through a "trampoline" which will also have been
--  destroyed.

--  For this reason, we arrange to remove all dangling references before
--  leaving the scope of an instantiation. This is ugly, since it requires
--  traversing the list of all tasks, but it is no more ugly than a similar
--  traversal that we must do at the point of instantiation in order to
--  initialize the attributes of all tasks. At least we only need to do these
--  traversals if the type is controlled.

--  We chose to defer allocation of storage for attributes until the Reference
--  function is called or the attribute is first set to a value different from
--  the default initial one. This allows a potential savings in allocation,
--  for attributes that are not used by all tasks.

--  For efficiency, we reserve space in the TCB for a fixed number of
--  direct-access attributes. These are required to be of a size that fits in
--  the space of an object of type System.Address. Because we must use
--  unchecked bitwise copy operations on these values, they cannot be of a
--  controlled type, but that is covered automatically since controlled
--  objects are too large to fit in the spaces.

--  We originally deferred the initialization of these direct-access
--  attributes, just as we do for the indirect-access attributes, and used a
--  per-task bit vector to keep track of which attributes were currently
--  defined for that task. We found that the overhead of maintaining this
--  bit-vector seriously slowed down access to the attributes, and made the
--  fetch operation non-atomic, so that even to read an attribute value
--  required locking the TCB. Therefore, we now initialize such attributes for
--  all existing tasks at the time of the attribute instantiation, and
--  initialize existing attributes for each new task at the time it is
--  created.

--  The latter initialization requires a list of all the instantiation
--  descriptors. Updates to this list, as well as the bit-vector that is used
--  to reserve slots for attributes in the TCB, require mutual exclusion. That
--  is provided by the Lock/Unlock_RTS.

--  One special problem that added complexity to the design is that the
--  per-task list of indirect attributes contains objects of different types.
--  We use unchecked pointer conversion to link these nodes together and
--  access them, but the records may not have identical internal structure.
--  Initially, we thought it would be enough to allocate all the common
--  components of the records at the front of each record, so that their
--  positions would correspond. Unfortunately, GNAT adds "dope" information at
--  the front of a record, if the record contains any controlled-type
--  components.
--
--  This means that the offset of the fields we use to link the nodes is at
--  different positions on nodes of different types. To get around this, each
--  attribute storage record consists of a core node and wrapper. The core
--  nodes are all of the same type, and it is these that are linked together
--  and generally "seen" by the RTS. Each core node contains a pointer to its
--  own wrapper, which is a record that contains the core node along with an
--  attribute value, approximately as follows:

--    type Node;
--    type Node_Access is access all Node;
--    type Node_Access;
--    type Access_Wrapper is access all Wrapper;
--    type Node is record
--       Next    : Node_Access;
--       ...
--       Wrapper : Access_Wrapper;
--    end record;
--    type Wrapper is record
--       Dummy_Node : aliased Node;
--       Value      : aliased Attribute;  --  the generic formal type
--    end record;

--  Another interesting problem is with the initialization of the
--  instantiation descriptors. Originally, we did this all via the Initialize
--  procedure of the descriptor type and code in the package body. It turned
--  out that the Initialize procedure needed quite a bit of information,
--  including the size of the attribute type, the initial value of the
--  attribute (if it fits in the TCB), and a pointer to the deallocator
--  procedure. These needed to be "passed" in via access discriminants. GNAT
--  was having trouble with access discriminants, so all this work was moved
--  to the package body.

with System.Error_Reporting;
--  Used for Shutdown;

with System.Storage_Elements;
--  Used for Integer_Address

with System.Task_Primitives.Operations;
--  Used for Write_Lock
--           Unlock
--           Lock/Unlock_RTS

with System.Tasking;
--  Used for Access_Address
--           Task_Id
--           Direct_Index_Vector
--           Direct_Index

with System.Tasking.Initialization;
--  Used for Defer_Abortion
--           Undefer_Abortion
--           Initialize_Attributes_Link
--           Finalize_Attributes_Link

with System.Tasking.Task_Attributes;
--  Used for Access_Node
--           Access_Dummy_Wrapper
--           Deallocator
--           Instance
--           Node
--           Access_Instance

with Ada.Exceptions;
--  Used for Raise_Exception

with Unchecked_Conversion;
with Unchecked_Deallocation;

pragma Elaborate_All (System.Tasking.Task_Attributes);
--  To ensure the initialization of object Local (below) will work

package body Ada.Task_Attributes is

   use System.Error_Reporting,
       System.Tasking.Initialization,
       System.Tasking,
       System.Tasking.Task_Attributes,
       Ada.Exceptions;

   use type System.Tasking.Access_Address;

   package POP renames System.Task_Primitives.Operations;

   ---------------------------
   -- Unchecked Conversions --
   ---------------------------

   --  The following type corresponds to Dummy_Wrapper,
   --  declared in System.Tasking.Task_Attributes.

   type Wrapper;
   type Access_Wrapper is access all Wrapper;

   pragma Warnings (Off);
   --  We turn warnings off for the following declarations of the
   --  To_Attribute_Handle conversions, since these are used only for small
   --  attributes where we know that there are no problems with alignment, but
   --  the compiler will generate warnings for the occurrences in the large
   --  attribute case, even though they will not actually be used.

   function To_Attribute_Handle is new Unchecked_Conversion
     (System.Address, Attribute_Handle);
   function To_Direct_Attribute_Element is new Unchecked_Conversion
     (System.Address, Direct_Attribute_Element);
   --  For reference to directly addressed task attributes

   type Access_Integer_Address is access all
     System.Storage_Elements.Integer_Address;

   function To_Attribute_Handle is new Unchecked_Conversion
     (Access_Integer_Address, Attribute_Handle);
   --  For reference to directly addressed task attributes

   pragma Warnings (On);
   --  End of warnings off region for directly addressed
   --  attribute conversion functions.

   function To_Access_Address is new Unchecked_Conversion
     (Access_Node, Access_Address);
   --  To store pointer to list of indirect attributes

   pragma Warnings (Off);
   function To_Access_Wrapper is new Unchecked_Conversion
     (Access_Dummy_Wrapper, Access_Wrapper);
   pragma Warnings (On);
   --  To fetch pointer to actual wrapper of attribute node. We turn off
   --  warnings since this may generate an alignment warning. The warning can
   --  be ignored since Dummy_Wrapper is only a non-generic standin for the
   --  real wrapper type (we never actually allocate objects of type
   --  Dummy_Wrapper).

   function To_Access_Dummy_Wrapper is new Unchecked_Conversion
     (Access_Wrapper, Access_Dummy_Wrapper);
   --  To store pointer to actual wrapper of attribute node

   function To_Task_Id is new Unchecked_Conversion
     (Task_Identification.Task_Id, Task_Id);
   --  To access TCB of identified task

   type Local_Deallocator is access procedure (P : in out Access_Node);

   function To_Lib_Level_Deallocator is new Unchecked_Conversion
     (Local_Deallocator, Deallocator);
   --  To defeat accessibility check

   pragma Warnings (On);

   ------------------------
   -- Storage Management --
   ------------------------

   procedure Deallocate (P : in out Access_Node);
   --  Passed to the RTS via unchecked conversion of a pointer to
   --  permit finalization and deallocation of attribute storage nodes

   --------------------------
   -- Instantiation Record --
   --------------------------

   Local : aliased Instance;
   --  Initialized in package body

   type Wrapper is record
      Dummy_Node : aliased Node;

      Value : aliased Attribute := Initial_Value;
      --  The generic formal type, may be controlled
   end record;

   --  A number of unchecked conversions involving Wrapper_Access sources
   --  are performed in this unit. We have to ensure that the designated
   --  object is always strictly enough aligned.

   for Wrapper'Alignment use Standard'Maximum_Alignment;

   procedure Free is
      new Unchecked_Deallocation (Wrapper, Access_Wrapper);

   procedure Deallocate (P : in out Access_Node) is
      T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
   begin
      Free (T);
   end Deallocate;

   ---------------
   -- Reference --
   ---------------

   function Reference
     (T    : Task_Identification.Task_Id := Task_Identification.Current_Task)
      return Attribute_Handle
   is
      TT            : constant Task_Id := To_Task_Id (T);
      Error_Message : constant String  := "Trying to get the reference of a ";

   begin
      if TT = null then
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
      end if;

      if TT.Common.State = Terminated then
         Raise_Exception (Tasking_Error'Identity,
           Error_Message & "terminated task");
      end if;

      --  Directly addressed case

      if Local.Index /= 0 then

         --  Return the attribute handle. Warnings off because this return
         --  statement generates alignment warnings for large attributes
         --  (but will never be executed in this case anyway).

         pragma Warnings (Off);
         return
           To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address);
         pragma Warnings (On);

      --  Not directly addressed

      else
         declare
            P       : Access_Node := To_Access_Node (TT.Indirect_Attributes);
            W       : Access_Wrapper;
            Self_Id : constant Task_Id := POP.Self;

         begin
            Defer_Abort (Self_Id);
            POP.Lock_RTS;

            while P /= null loop
               if P.Instance = Access_Instance'(Local'Unchecked_Access) then
                  POP.Unlock_RTS;
                  Undefer_Abort (Self_Id);
                  return To_Access_Wrapper (P.Wrapper).Value'Access;
               end if;

               P := P.Next;
            end loop;

            --  Unlock the RTS here to follow the lock ordering rule
            --  that prevent us from using new (i.e the Global_Lock) while
            --  holding any other lock.

            POP.Unlock_RTS;
            W := new Wrapper'
                  ((null, Local'Unchecked_Access, null), Initial_Value);
            POP.Lock_RTS;

            P := W.Dummy_Node'Unchecked_Access;
            P.Wrapper := To_Access_Dummy_Wrapper (W);
            P.Next := To_Access_Node (TT.Indirect_Attributes);
            TT.Indirect_Attributes := To_Access_Address (P);
            POP.Unlock_RTS;
            Undefer_Abort (Self_Id);
            return W.Value'Access;

         exception
            when others =>
               POP.Unlock_RTS;
               Undefer_Abort (Self_Id);
               raise;
         end;
      end if;

      pragma Assert (Shutdown ("Should never get here in Reference"));
      return null;

   exception
      when Tasking_Error | Program_Error =>
         raise;

      when others =>
         raise Program_Error;
   end Reference;

   ------------------
   -- Reinitialize --
   ------------------

   procedure Reinitialize
     (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
   is
      TT            : constant Task_Id := To_Task_Id (T);
      Error_Message : constant String  := "Trying to Reinitialize a ";

   begin
      if TT = null then
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
      end if;

      if TT.Common.State = Terminated then
         Raise_Exception (Tasking_Error'Identity,
           Error_Message & "terminated task");
      end if;

      if Local.Index /= 0 then
         Set_Value (Initial_Value, T);
      else
         declare
            P, Q    : Access_Node;
            W       : Access_Wrapper;
            Self_Id : constant Task_Id := POP.Self;

         begin
            Defer_Abort (Self_Id);
            POP.Lock_RTS;
            Q := To_Access_Node (TT.Indirect_Attributes);

            while Q /= null loop
               if Q.Instance = Access_Instance'(Local'Unchecked_Access) then
                  if P = null then
                     TT.Indirect_Attributes := To_Access_Address (Q.Next);
                  else
                     P.Next := Q.Next;
                  end if;

                  W := To_Access_Wrapper (Q.Wrapper);
                  Free (W);
                  POP.Unlock_RTS;
                  Undefer_Abort (Self_Id);
                  return;
               end if;

               P := Q;
               Q := Q.Next;
            end loop;

            POP.Unlock_RTS;
            Undefer_Abort (Self_Id);

         exception
            when others =>
               POP.Unlock_RTS;
               Undefer_Abort (Self_Id);
               raise;
         end;
      end if;

   exception
      when Tasking_Error | Program_Error =>
         raise;

      when others =>
         raise Program_Error;
   end Reinitialize;

   ---------------
   -- Set_Value --
   ---------------

   procedure Set_Value
     (Val : Attribute;
      T   : Task_Identification.Task_Id := Task_Identification.Current_Task)
   is
      TT            : constant Task_Id := To_Task_Id (T);
      Error_Message : constant String  := "Trying to Set the Value of a ";

   begin
      if TT = null then
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
      end if;

      if TT.Common.State = Terminated then
         Raise_Exception (Tasking_Error'Identity,
           Error_Message & "terminated task");
      end if;

      --  Directly addressed case

      if Local.Index /= 0 then

         --  Set attribute handle, warnings off, because this code can generate
         --  alignment warnings with large attributes (but of course will not
         --  be executed in this case, since we never have direct addressing in
         --  such cases).

         pragma Warnings (Off);
         To_Attribute_Handle
            (TT.Direct_Attributes (Local.Index)'Address).all := Val;
         pragma Warnings (On);
         return;
      end if;

      --  Not directly addressed

      declare
         P       : Access_Node := To_Access_Node (TT.Indirect_Attributes);
         W       : Access_Wrapper;
         Self_Id : constant Task_Id := POP.Self;

      begin
         Defer_Abort (Self_Id);
         POP.Lock_RTS;

         while P /= null loop

            if P.Instance = Access_Instance'(Local'Unchecked_Access) then
               To_Access_Wrapper (P.Wrapper).Value := Val;
               POP.Unlock_RTS;
               Undefer_Abort (Self_Id);
               return;
            end if;

            P := P.Next;
         end loop;

         --  Unlock RTS here to follow the lock ordering rule that prevent us
         --  from using new (i.e the Global_Lock) while holding any other
         --  lock.

         POP.Unlock_RTS;
         W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
         POP.Lock_RTS;
         P := W.Dummy_Node'Unchecked_Access;
         P.Wrapper := To_Access_Dummy_Wrapper (W);
         P.Next := To_Access_Node (TT.Indirect_Attributes);
         TT.Indirect_Attributes := To_Access_Address (P);

         POP.Unlock_RTS;
         Undefer_Abort (Self_Id);

      exception
         when others =>
            POP.Unlock_RTS;
            Undefer_Abort (Self_Id);
            raise;
      end;

   exception
      when Tasking_Error | Program_Error =>
         raise;

      when others =>
         raise Program_Error;
   end Set_Value;

   -----------
   -- Value --
   -----------

   function Value
     (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
      return Attribute
   is
      TT            : constant Task_Id := To_Task_Id (T);
      Error_Message : constant String  := "Trying to get the Value of a ";

   begin
      if TT = null then
         Raise_Exception (Program_Error'Identity, Error_Message & "null task");
      end if;

      if TT.Common.State = Terminated then
         Raise_Exception
           (Program_Error'Identity, Error_Message & "terminated task");
      end if;

      --  Directly addressed case

      if Local.Index /= 0 then

         --  Get value of attribute. Warnings off, because for large
         --  attributes, this code can generate alignment warnings. But of
         --  course large attributes are never directly addressed so in fact
         --  we will never execute the code in this case.

         pragma Warnings (Off);
         return To_Attribute_Handle
           (TT.Direct_Attributes (Local.Index)'Address).all;
         pragma Warnings (On);
      end if;

      --  Not directly addressed

      declare
         P       : Access_Node;
         Result  : Attribute;
         Self_Id : constant Task_Id := POP.Self;

      begin
         Defer_Abort (Self_Id);
         POP.Lock_RTS;
         P := To_Access_Node (TT.Indirect_Attributes);

         while P /= null loop
            if P.Instance = Access_Instance'(Local'Unchecked_Access) then
               Result := To_Access_Wrapper (P.Wrapper).Value;
               POP.Unlock_RTS;
               Undefer_Abort (Self_Id);
               return Result;
            end if;

            P := P.Next;
         end loop;

         POP.Unlock_RTS;
         Undefer_Abort (Self_Id);
         return Initial_Value;

      exception
         when others =>
            POP.Unlock_RTS;
            Undefer_Abort (Self_Id);
            raise;
      end;

   exception
      when Tasking_Error | Program_Error =>
         raise;

      when others =>
         raise Program_Error;
   end Value;

--  Start of elaboration code for package Ada.Task_Attributes

begin
   --  This unchecked conversion can give warnings when alignments
   --  are incorrect, but they will not be used in such cases anyway,
   --  so the warnings can be safely ignored.

   pragma Warnings (Off);
   Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
   pragma Warnings (On);

   declare
      Two_To_J : Direct_Index_Vector;
      Self_Id  : constant Task_Id := POP.Self;
   begin
      Defer_Abort (Self_Id);

      --  Need protection for updating links to per-task initialization and
      --  finalization routines, in case some task is being created or
      --  terminated concurrently.

      POP.Lock_RTS;

      --  Add this instantiation to the list of all instantiations

      Local.Next := System.Tasking.Task_Attributes.All_Attributes;
      System.Tasking.Task_Attributes.All_Attributes :=
        Local'Unchecked_Access;

      --  Try to find space for the attribute in the TCB

      Local.Index := 0;
      Two_To_J := 1;

      if Attribute'Size <= System.Address'Size then
         for J in Direct_Index_Range loop
            if (Two_To_J and In_Use) = 0 then

               --  Reserve location J for this attribute

               In_Use := In_Use or Two_To_J;
               Local.Index := J;

               --  This unchecked conversions can give a warning when the the
               --  alignment is incorrect, but it will not be used in such a
               --  case anyway, so the warning can be safely ignored.

               pragma Warnings (Off);
               To_Attribute_Handle (Local.Initial_Value'Access).all :=
                 Initial_Value;
               pragma Warnings (On);

               exit;
            end if;

            Two_To_J := Two_To_J * 2;
         end loop;
      end if;

      --  Attribute goes directly in the TCB

      if Local.Index /= 0 then
         --  Replace stub for initialization routine that is called at task
         --  creation.

         Initialization.Initialize_Attributes_Link :=
           System.Tasking.Task_Attributes.Initialize_Attributes'Access;

         --  Initialize the attribute, for all tasks

         declare
            C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
         begin
            while C /= null loop
               C.Direct_Attributes (Local.Index) :=
                 To_Direct_Attribute_Element
                   (System.Storage_Elements.To_Address (Local.Initial_Value));
               C := C.Common.All_Tasks_Link;
            end loop;
         end;

      --  Attribute goes into a node onto a linked list

      else
         --  Replace stub for finalization routine that is called at task
         --  termination.

         Initialization.Finalize_Attributes_Link :=
           System.Tasking.Task_Attributes.Finalize_Attributes'Access;
      end if;

      POP.Unlock_RTS;
      Undefer_Abort (Self_Id);
   end;
end Ada.Task_Attributes;