gcc/ada/a-tasatt.adb

   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 --                            $Revision$
  10 --                                                                          --
  11 --             Copyright (C) 1991-2002 Florida State University             --
  12 --                                                                          --
  13 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNARL was developed by the GNARL team at Florida State University. It is --
  32 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  The following notes are provided in case someone decides the
  37 --  implementation of this package is too complicated, or too slow.
  38 --  Please read this before making any "simplifications".
  39
  40 --  Correct implementation of this package is more difficult than one
  41 --  might expect. After considering (and coding) several alternatives,
  42 --  we settled on the present compromise. Things we do not like about
  43 --  this implementation include:
  44
  45 --  -  It is vulnerable to bad Task_ID values, to the extent of
  46 --     possibly trashing memory and crashing the runtime system.
  47
  48 --  -  It requires dynamic storage allocation for each new attribute value,
  49 --     except for types that happen to be the same size as System.Address,
  50 --     or shorter.
  51
  52 --  -  Instantiations at other than the library level rely on being able to
  53 --     do down-level calls to a procedure declared in the generic package body.
  54 --     This makes it potentially vulnerable to compiler changes.
  55
  56 --  The main implementation issue here is that the connection from
  57 --  task to attribute is a potential source of dangling references.
  58
  59 --  When a task goes away, we want to be able to recover all the storage
  60 --  associated with its attributes. The Ada mechanism for this is
  61 --  finalization, via controlled attribute types. For this reason,
  62 --  the ARM requires finalization of attribute values when the
  63 --  associated task terminates.
  64
  65 --  This finalization must be triggered by the tasking runtime system,
  66 --  during termination of the task. Given the active set of instantiations
  67 --  of Ada.Task_Attributes is dynamic, the number and types of attributes
  68 --  belonging to a task will not be known until the task actually terminates.
  69 --  Some of these types may be controlled and some may not. The RTS must find
  70 --  some way to determine which of these attributes need finalization, and
  71 --  invoke the appropriate finalization on them.
  72
  73 --  One way this might be done is to create a special finalization chain
  74 --  for each task, similar to the finalization chain that is used for
  75 --  controlled objects within the task. This would differ from the usual
  76 --  finalization chain in that it would not have a LIFO structure, since
  77 --  attributes may be added to a task at any time during its lifetime.
  78 --  This might be the right way to go for the longer term, but at present
  79 --  this approach is not open, since GNAT does not provide such special
  80 --  finalization support.
  81
  82 --  Lacking special compiler support, the RTS is limited to the
  83 --  normal ways an application invokes finalization, i.e.
  84
  85 --  a) Explicit call to the procedure Finalize, if we know the type
  86 --     has this operation defined on it. This is not sufficient, since
  87 --     we have no way of determining whether a given generic formal
  88 --     Attribute type is controlled, and no visibility of the associated
  89 --     Finalize procedure, in the generic body.
  90
  91 --  b) Leaving the scope of a local object of a controlled type.
  92 --     This does not help, since the lifetime of an instantiation of
  93 --     Ada.Task_Attributes does not correspond to the lifetimes of the
  94 --     various tasks which may have that attribute.
  95
  96 --  c) Assignment of another value to the object. This would not help,
  97 --     since we then have to finalize the new value of the object.
  98
  99 --  d) Unchecked deallocation of an object of a controlled type.
 100 --     This seems to be the only mechanism available to the runtime
 101 --     system for finalization of task attributes.
 102
 103 --  We considered two ways of using unchecked deallocation, both based
 104 --  on a linked list of that would hang from the task control block.
 105
 106 --  In the first approach the objects on the attribute list are all derived
 107 --  from one controlled type, say T, and are linked using an access type to
 108 --  T'Class. The runtime system has an Unchecked_Deallocation for T'Class
 109 --  with access type T'Class, and uses this to deallocate and finalize all
 110 --  the items in the list. The limitation of this approach is that each
 111 --  instantiation of the package Ada.Task_Attributes derives a new record
 112 --  extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation
 113 --  is only allowed at the library level.
 114
 115 --  In the second approach the objects on the attribute list are of
 116 --  unrelated but structurally similar types. Unchecked conversion is
 117 --  used to circument Ada type checking. Each attribute-storage node
 118 --  contains not only the attribute value and a link for chaining, but
 119 --  also a pointer to a descriptor for the corresponding instantiation
 120 --  of Task_Attributes. The instantiation-descriptor contains a
 121 --  pointer to a procedure that can do the correct deallocation and
 122 --  finalization for that type of attribute. On task termination, the
 123 --  runtime system uses the pointer to call the appropriate deallocator.
 124
 125 --  While this gets around the limitation that instantiations be at
 126 --  the library level, it relies on an implementation feature that
 127 --  may not always be safe, i.e. that it is safe to call the
 128 --  Deallocate procedure for an instantiation of Ada.Task_Attributes
 129 --  that no longer exists. In general, it seems this might result in
 130 --  dangling references.
 131
 132 --  Another problem with instantiations deeper than the library level
 133 --  is that there is risk of storage leakage, or dangling references
 134 --  to reused storage. That is, if an instantiation of Ada.Task_Attributes
 135 --  is made within a procedure, what happens to the storage allocated for
 136 --  attributes, when the procedure call returns?  Apparently (RM 7.6.1 (4))
 137 --  any such objects must be finalized, since they will no longer be
 138 --  accessible, and in general one would expect that the storage they occupy
 139 --  would be recovered for later reuse. (If not, we would have a case of
 140 --  storage leakage.)  Assuming the storage is recovered and later reused,
 141 --  we have potentially dangerous dangling references. When the procedure
 142 --  containing the instantiation of Ada.Task_Attributes returns, there
 143 --  may still be unterminated tasks with associated attribute values for
 144 --  that instantiation. When such tasks eventually terminate, the RTS
 145 --  will attempt to call the Deallocate procedure on them. If the
 146 --  corresponding storage has already been deallocated, when the master
 147 --  of the access type was left, we have a potential disaster. This
 148 --  disaster is compounded since the pointer to Deallocate is probably
 149 --  through a "trampoline" which will also have been destroyed.
 150
 151 --  For this reason, we arrange to remove all dangling references
 152 --  before leaving the scope of an instantiation. This is ugly, since
 153 --  it requires traversing the list of all tasks, but it is no more ugly
 154 --  than a similar traversal that we must do at the point of instantiation
 155 --  in order to initialize the attributes of all tasks. At least we only
 156 --  need to do these traversals if the type is controlled.
 157
 158 --  We chose to defer allocation of storage for attributes until the
 159 --  Reference function is called or the attribute is first set to a value
 160 --  different from the default initial one. This allows a potential
 161 --  savings in allocation, for attributes that are not used by all tasks.
 162
 163 --  For efficiency, we reserve space in the TCB for a fixed number of
 164 --  direct-access attributes. These are required to be of a size that
 165 --  fits in the space of an object of type System.Address. Because
 166 --  we must use unchecked bitwise copy operations on these values, they
 167 --  cannot be of a controlled type, but that is covered automatically
 168 --  since controlled objects are too large to fit in the spaces.
 169
 170 --  We originally deferred the initialization of these direct-access
 171 --  attributes, just as we do for the indirect-access attributes, and
 172 --  used a per-task bit vector to keep track of which attributes were
 173 --  currently defined for that task. We found that the overhead of
 174 --  maintaining this bit-vector seriously slowed down access to the
 175 --  attributes, and made the fetch operation non-atomic, so that even
 176 --  to read an attribute value required locking the TCB. Therefore,
 177 --  we now initialize such attributes for all existing tasks at the time
 178 --  of the attribute instantiation, and initialize existing attributes
 179 --  for each new task at the time it is created.
 180
 181 --  The latter initialization requires a list of all the instantiation
 182 --  descriptors. Updates to this list, as well as the bit-vector that
 183 --  is used to reserve slots for attributes in the TCB, require mutual
 184 --  exclusion. That is provided by the Lock/Unlock_RTS.
 185
 186 --  One special problem that added complexity to the design is that
 187 --  the per-task list of indirect attributes contains objects of
 188 --  different types. We use unchecked pointer conversion to link
 189 --  these nodes together and access them, but the records may not have
 190 --  identical internal structure. Initially, we thought it would be
 191 --  enough to allocate all the common components of the records at the
 192 --  front of each record, so that their positions would correspond.
 193 --  Unfortunately, GNAT adds "dope" information at the front of a record,
 194 --  if the record contains any controlled-type components.
 195 --
 196 --  This means that the offset of the fields we use to link the nodes is
 197 --  at different positions on nodes of different types. To get around this,
 198 --  each attribute storage record consists of a core node and wrapper.
 199 --  The core nodes are all of the same type, and it is these that are
 200 --  linked together and generally "seen" by the RTS. Each core node
 201 --  contains a pointer to its own wrapper, which is a record that contains
 202 --  the core node along with an attribute value, approximately
 203 --  as follows:
 204
 205 --    type Node;
 206 --    type Node_Access is access all Node;
 207 --    type Node_Access;
 208 --    type Access_Wrapper is access all Wrapper;
 209 --    type Node is record
 210 --       Next    : Node_Access;
 211 --       ...
 212 --       Wrapper : Access_Wrapper;
 213 --    end record;
 214 --    type Wrapper is record
 215 --       Noed    : aliased Node;
 216 --       Value   : aliased Attribute;  --  the generic formal type
 217 --    end record;
 218
 219 --  Another interesting problem is with the initialization of
 220 --  the instantiation descriptors. Originally, we did this all via
 221 --  the Initialize procedure of the descriptor type and code in the
 222 --  package body. It turned out that the Initialize procedure needed
 223 --  quite a bit of information, including the size of the attribute
 224 --  type, the initial value of the attribute (if it fits in the TCB),
 225 --  and a pointer to the deallocator procedure. These needed to be
 226 --  "passed" in via access discriminants. GNAT was having trouble
 227 --  with access discriminants, so all this work was moved to the
 228 --  package body.
 229
 230 with Ada.Task_Identification;
 231 --  used for Task_Id
 232 --           Null_Task_ID
 233 --           Current_Task
 234
 235 with System.Error_Reporting;
 236 --  used for Shutdown;
 237
 238 with System.Storage_Elements;
 239 --  used for Integer_Address
 240
 241 with System.Task_Primitives.Operations;
 242 --  used for Write_Lock
 243 --           Unlock
 244 --           Lock/Unlock_RTS
 245
 246 with System.Tasking;
 247 --  used for Access_Address
 248 --           Task_ID
 249 --           Direct_Index_Vector
 250 --           Direct_Index
 251
 252 with System.Tasking.Initialization;
 253 --  used for Defer_Abortion
 254 --           Undefer_Abortion
 255 --           Initialize_Attributes_Link
 256 --           Finalize_Attributes_Link
 257
 258 with System.Tasking.Task_Attributes;
 259 --  used for Access_Node
 260 --           Access_Dummy_Wrapper
 261 --           Deallocator
 262 --           Instance
 263 --           Node
 264 --           Access_Instance
 265
 266 with Ada.Exceptions;
 267 --  used for Raise_Exception
 268
 269 with Unchecked_Conversion;
 270 with Unchecked_Deallocation;
 271
 272 pragma Elaborate_All (System.Tasking.Task_Attributes);
 273 --  to ensure the initialization of object Local (below) will work
 274
 275 package body Ada.Task_Attributes is
 276
 277    use System.Error_Reporting,
 278        System.Tasking.Initialization,
 279        System.Tasking,
 280        System.Tasking.Task_Attributes,
 281        Ada.Exceptions;
 282
 283    use type System.Tasking.Access_Address;
 284
 285    package POP renames System.Task_Primitives.Operations;
 286
 287    ---------------------------
 288    -- Unchecked Conversions --
 289    ---------------------------
 290
 291    pragma Warnings (Off);
 292    --  These unchecked conversions can give warnings when alignments
 293    --  are incorrect, but they will not be used in such cases anyway,
 294    --  so the warnings can be safely ignored.
 295
 296    --  The following type corresponds to Dummy_Wrapper,
 297    --  declared in System.Tasking.Task_Attributes.
 298
 299    type Wrapper;
 300    type Access_Wrapper is access all Wrapper;
 301
 302    pragma Warnings (Off);
 303    --  We turn warnings off for the following declarations of the
 304    --  To_Attribute_Handle conversions, since these are used only
 305    --  for small attributes where we know that there are no problems
 306    --  with alignment, but the compiler will generate warnings for
 307    --  the occurrences in the large attribute case, even though
 308    --  they will not actually be used.
 309
 310    function To_Attribute_Handle is new Unchecked_Conversion
 311      (Access_Address, Attribute_Handle);
 312    --  For reference to directly addressed task attributes
 313
 314    type Access_Integer_Address is access all
 315      System.Storage_Elements.Integer_Address;
 316
 317    function To_Attribute_Handle is new Unchecked_Conversion
 318      (Access_Integer_Address, Attribute_Handle);
 319    --  For reference to directly addressed task attributes
 320
 321    pragma Warnings (On);
 322    --  End of warnings off region for directly addressed
 323    --  attribute conversion functions.
 324
 325    function To_Access_Address is new Unchecked_Conversion
 326      (Access_Node, Access_Address);
 327    --  To store pointer to list of indirect attributes
 328
 329    function To_Access_Node is new Unchecked_Conversion
 330      (Access_Address, Access_Node);
 331    --  To fetch pointer to list of indirect attributes
 332
 333    pragma Warnings (Off);
 334    function To_Access_Wrapper is new Unchecked_Conversion
 335      (Access_Dummy_Wrapper, Access_Wrapper);
 336    pragma Warnings (On);
 337    --  To fetch pointer to actual wrapper of attribute node. We turn off
 338    --  warnings since this may generate an alignment warning. The warning
 339    --  can be ignored since Dummy_Wrapper is only a non-generic standin
 340    --  for the real wrapper type (we never actually allocate objects of
 341    --  type Dummy_Wrapper).
 342
 343    function To_Access_Dummy_Wrapper is new Unchecked_Conversion
 344      (Access_Wrapper, Access_Dummy_Wrapper);
 345    --  To store pointer to actual wrapper of attribute node
 346
 347    function To_Task_ID is new Unchecked_Conversion
 348      (Task_Identification.Task_Id, Task_ID);
 349    --  To access TCB of identified task
 350
 351    Null_ID : constant Task_ID := To_Task_ID (Task_Identification.Null_Task_Id);
 352    --  ??? need comments on use and purpose
 353
 354    type Local_Deallocator is
 355       access procedure (P : in out Access_Node);
 356
 357    function To_Lib_Level_Deallocator is new Unchecked_Conversion
 358      (Local_Deallocator, Deallocator);
 359    --  To defeat accessibility check
 360
 361    pragma Warnings (On);
 362
 363    ------------------------
 364    -- Storage Management --
 365    ------------------------
 366
 367    procedure Deallocate (P : in out Access_Node);
 368    --  Passed to the RTS via unchecked conversion of a pointer to
 369    --  permit finalization and deallocation of attribute storage nodes
 370
 371    --------------------------
 372    -- Instantiation Record --
 373    --------------------------
 374
 375    Local : aliased Instance;
 376    --  Initialized in package body
 377
 378    type Wrapper is record
 379       Noed : aliased Node;
 380
 381       Value : aliased Attribute := Initial_Value;
 382       --  The generic formal type, may be controlled
 383    end record;
 384
 385    procedure Free is
 386       new Unchecked_Deallocation (Wrapper, Access_Wrapper);
 387
 388    procedure Deallocate (P : in out Access_Node) is
 389       T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
 390
 391    begin
 392       Free (T);
 393
 394    exception
 395       when others =>
 396          pragma Assert (Shutdown ("Exception in Deallocate")); null;
 397    end Deallocate;
 398
 399    ---------------
 400    -- Reference --
 401    ---------------
 402
 403    function Reference
 404      (T    : Task_Identification.Task_Id := Task_Identification.Current_Task)
 405       return Attribute_Handle
 406    is
 407       TT            : Task_ID := To_Task_ID (T);
 408       Error_Message : constant String := "Trying to get the reference of a";
 409
 410    begin
 411       if TT = Null_ID then
 412          Raise_Exception (Program_Error'Identity,
 413            Error_Message & "null task");
 414       end if;
 415
 416       if TT.Common.State = Terminated then
 417          Raise_Exception (Tasking_Error'Identity,
 418            Error_Message & "terminated task");
 419       end if;
 420
 421       begin
 422          Defer_Abortion;
 423          POP.Lock_RTS;
 424
 425          --  Directly addressed case
 426
 427          if Local.Index /= 0 then
 428             POP.Unlock_RTS;
 429             Undefer_Abortion;
 430
 431             --  Return the attribute handle. Warnings off because this return
 432             --  statement generates alignment warnings for large attributes
 433             --  (but will never be executed in this case anyway).
 434
 435             pragma Warnings (Off);
 436             return
 437               To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access);
 438             pragma Warnings (On);
 439
 440          --  Not directly addressed
 441
 442          else
 443             declare
 444                P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
 445                W : Access_Wrapper;
 446
 447             begin
 448                while P /= null loop
 449                   if P.Instance = Access_Instance'(Local'Unchecked_Access) then
 450                      POP.Unlock_RTS;
 451                      Undefer_Abortion;
 452                      return To_Access_Wrapper (P.Wrapper).Value'Access;
 453                   end if;
 454
 455                   P := P.Next;
 456                end loop;
 457
 458                --  Unlock the RTS here to follow the lock ordering rule
 459                --  that prevent us from using new (i.e the Global_Lock) while
 460                --  holding any other lock.
 461
 462                POP.Unlock_RTS;
 463                W := new Wrapper'
 464                      ((null, Local'Unchecked_Access, null), Initial_Value);
 465                POP.Lock_RTS;
 466
 467                P := W.Noed'Unchecked_Access;
 468                P.Wrapper := To_Access_Dummy_Wrapper (W);
 469                P.Next := To_Access_Node (TT.Indirect_Attributes);
 470                TT.Indirect_Attributes := To_Access_Address (P);
 471                POP.Unlock_RTS;
 472                Undefer_Abortion;
 473                return W.Value'Access;
 474             end;
 475          end if;
 476
 477          pragma Assert (Shutdown ("Should never get here in Reference"));
 478          return null;
 479
 480       exception
 481          when others =>
 482             POP.Unlock_RTS;
 483             Undefer_Abortion;
 484             raise;
 485       end;
 486
 487    exception
 488       when Tasking_Error | Program_Error =>
 489          raise;
 490
 491       when others =>
 492          raise Program_Error;
 493    end Reference;
 494
 495    ------------------
 496    -- Reinitialize --
 497    ------------------
 498
 499    procedure Reinitialize
 500      (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
 501    is
 502       TT : Task_ID := To_Task_ID (T);
 503       Error_Message : constant String := "Trying to Reinitialize a";
 504
 505    begin
 506       if TT = Null_ID then
 507          Raise_Exception (Program_Error'Identity,
 508            Error_Message & "null task");
 509       end if;
 510
 511       if TT.Common.State = Terminated then
 512          Raise_Exception (Tasking_Error'Identity,
 513            Error_Message & "terminated task");
 514       end if;
 515
 516       if Local.Index = 0 then
 517          declare
 518             P, Q : Access_Node;
 519             W    : Access_Wrapper;
 520
 521          begin
 522             Defer_Abortion;
 523             POP.Lock_RTS;
 524             Q := To_Access_Node (TT.Indirect_Attributes);
 525
 526             while Q /= null loop
 527                if Q.Instance = Access_Instance'(Local'Unchecked_Access) then
 528                   if P = null then
 529                      TT.Indirect_Attributes := To_Access_Address (Q.Next);
 530                   else
 531                      P.Next := Q.Next;
 532                   end if;
 533
 534                   W := To_Access_Wrapper (Q.Wrapper);
 535                   Free (W);
 536                   POP.Unlock_RTS;
 537                   Undefer_Abortion;
 538                   return;
 539                end if;
 540
 541                P := Q;
 542                Q := Q.Next;
 543             end loop;
 544
 545             POP.Unlock_RTS;
 546             Undefer_Abortion;
 547
 548          exception
 549             when others =>
 550                POP.Unlock_RTS;
 551                Undefer_Abortion;
 552          end;
 553
 554       else
 555          Set_Value (Initial_Value, T);
 556       end if;
 557
 558    exception
 559       when Tasking_Error | Program_Error =>
 560          raise;
 561
 562       when others =>
 563          raise Program_Error;
 564    end Reinitialize;
 565
 566    ---------------
 567    -- Set_Value --
 568    ---------------
 569
 570    procedure Set_Value
 571      (Val : Attribute;
 572       T   : Task_Identification.Task_Id := Task_Identification.Current_Task)
 573    is
 574       TT          : Task_ID := To_Task_ID (T);
 575       Error_Message : constant String := "Trying to Set the Value of a";
 576
 577    begin
 578       if TT = Null_ID then
 579          Raise_Exception (Program_Error'Identity,
 580            Error_Message & "null task");
 581       end if;
 582
 583       if TT.Common.State = Terminated then
 584          Raise_Exception (Tasking_Error'Identity,
 585            Error_Message & "terminated task");
 586       end if;
 587
 588       begin
 589          Defer_Abortion;
 590          POP.Lock_RTS;
 591
 592          --  Directly addressed case
 593
 594          if Local.Index /= 0 then
 595
 596             --  Set attribute handle, warnings off, because this code can
 597             --  generate alignment warnings with large attributes (but of
 598             --  course wil not be executed in this case, since we never
 599             --  have direct addressing in such cases).
 600
 601             pragma Warnings (Off);
 602             To_Attribute_Handle
 603                (TT.Direct_Attributes (Local.Index)'Access).all := Val;
 604             pragma Warnings (On);
 605             POP.Unlock_RTS;
 606             Undefer_Abortion;
 607             return;
 608
 609          --  Not directly addressed
 610
 611          else
 612             declare
 613                P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
 614                W : Access_Wrapper;
 615
 616             begin
 617                while P /= null loop
 618
 619                   if P.Instance = Access_Instance'(Local'Unchecked_Access) then
 620                      To_Access_Wrapper (P.Wrapper).Value := Val;
 621                      POP.Unlock_RTS;
 622                      Undefer_Abortion;
 623                      return;
 624                   end if;
 625
 626                   P := P.Next;
 627                end loop;
 628
 629                --  Unlock RTS here to follow the lock ordering rule that
 630                --  prevent us from using new (i.e the Global_Lock) while
 631                --  holding any other lock.
 632
 633                POP.Unlock_RTS;
 634                W := new Wrapper'
 635                      ((null, Local'Unchecked_Access, null), Val);
 636                POP.Lock_RTS;
 637                P := W.Noed'Unchecked_Access;
 638                P.Wrapper := To_Access_Dummy_Wrapper (W);
 639                P.Next := To_Access_Node (TT.Indirect_Attributes);
 640                TT.Indirect_Attributes := To_Access_Address (P);
 641             end;
 642          end if;
 643
 644          POP.Unlock_RTS;
 645          Undefer_Abortion;
 646
 647       exception
 648          when others =>
 649             POP.Unlock_RTS;
 650             Undefer_Abortion;
 651             raise;
 652       end;
 653
 654       return;
 655
 656    exception
 657       when Tasking_Error | Program_Error =>
 658          raise;
 659
 660       when others =>
 661          raise Program_Error;
 662
 663    end Set_Value;
 664
 665    -----------
 666    -- Value --
 667    -----------
 668
 669    function Value
 670      (T    : Task_Identification.Task_Id := Task_Identification.Current_Task)
 671       return Attribute
 672    is
 673       Result        : Attribute;
 674       TT            : Task_ID := To_Task_ID (T);
 675       Error_Message : constant String := "Trying to get the Value of a";
 676
 677    begin
 678       if TT = Null_ID then
 679          Raise_Exception
 680            (Program_Error'Identity, Error_Message & "null task");
 681       end if;
 682
 683       if TT.Common.State = Terminated then
 684          Raise_Exception
 685            (Program_Error'Identity, Error_Message & "terminated task");
 686       end if;
 687
 688       begin
 689          --  Directly addressed case
 690
 691          if Local.Index /= 0 then
 692
 693             --  Get value of attribute. Warnings off, because for large
 694             --  attributes, this code can generate alignment warnings.
 695             --  But of course large attributes are never directly addressed
 696             --  so in fact we will never execute the code in this case.
 697
 698             pragma Warnings (Off);
 699             Result :=
 700               To_Attribute_Handle
 701                 (TT.Direct_Attributes (Local.Index)'Access).all;
 702             pragma Warnings (On);
 703
 704          --  Not directly addressed
 705
 706          else
 707             declare
 708                P : Access_Node;
 709
 710             begin
 711                Defer_Abortion;
 712                POP.Lock_RTS;
 713                P := To_Access_Node (TT.Indirect_Attributes);
 714
 715                while P /= null loop
 716                   if P.Instance = Access_Instance'(Local'Unchecked_Access) then
 717                      POP.Unlock_RTS;
 718                      Undefer_Abortion;
 719                      return To_Access_Wrapper (P.Wrapper).Value;
 720                   end if;
 721
 722                   P := P.Next;
 723                end loop;
 724
 725                Result := Initial_Value;
 726                POP.Unlock_RTS;
 727                Undefer_Abortion;
 728
 729             exception
 730                when others =>
 731                   POP.Unlock_RTS;
 732                   Undefer_Abortion;
 733                   raise;
 734             end;
 735          end if;
 736
 737          return Result;
 738       end;
 739
 740    exception
 741       when Tasking_Error | Program_Error =>
 742          raise;
 743
 744       when others =>
 745          raise Program_Error;
 746    end Value;
 747
 748 --  Start of elaboration code for package Ada.Task_Attributes
 749
 750 begin
 751    --  This unchecked conversion can give warnings when alignments
 752    --  are incorrect, but they will not be used in such cases anyway,
 753    --  so the warnings can be safely ignored.
 754
 755    pragma Warnings (Off);
 756    Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access);
 757    pragma Warnings (On);
 758
 759    declare
 760       Two_To_J : Direct_Index_Vector;
 761    begin
 762       Defer_Abortion;
 763
 764       --  Need protection for updating links to per-task initialization and
 765       --  finalization routines, in case some task is being created or
 766       --  terminated concurrently.
 767
 768       POP.Lock_RTS;
 769
 770       --  Add this instantiation to the list of all instantiations.
 771
 772       Local.Next := System.Tasking.Task_Attributes.All_Attributes;
 773       System.Tasking.Task_Attributes.All_Attributes :=
 774         Local'Unchecked_Access;
 775
 776       --  Try to find space for the attribute in the TCB.
 777
 778       Local.Index := 0;
 779       Two_To_J := 2 ** Direct_Index'First;
 780
 781       if Attribute'Size <= System.Address'Size then
 782          for J in Direct_Index loop
 783             if (Two_To_J and In_Use) /= 0 then
 784
 785                --  Reserve location J for this attribute
 786
 787                In_Use := In_Use or Two_To_J;
 788                Local.Index := J;
 789
 790                --  This unchecked conversions can give a warning when the
 791                --  the alignment is incorrect, but it will not be used in
 792                --  such a case anyway, so the warning can be safely ignored.
 793
 794                pragma Warnings (Off);
 795                To_Attribute_Handle (Local.Initial_Value'Access).all :=
 796                  Initial_Value;
 797                pragma Warnings (On);
 798
 799                exit;
 800             end if;
 801
 802             Two_To_J := Two_To_J * 2;
 803          end loop;
 804       end if;
 805
 806       --  Attribute goes directly in the TCB
 807
 808       if Local.Index /= 0 then
 809
 810          --  Replace stub for initialization routine
 811          --  that is called at task creation.
 812
 813          Initialization.Initialize_Attributes_Link :=
 814            System.Tasking.Task_Attributes.Initialize_Attributes'Access;
 815
 816          --  Initialize the attribute, for all tasks.
 817
 818          declare
 819             C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List;
 820
 821          begin
 822             while C /= null loop
 823                POP.Write_Lock (C);
 824                C.Direct_Attributes (Local.Index) :=
 825                  System.Storage_Elements.To_Address (Local.Initial_Value);
 826                POP.Unlock (C);
 827                C := C.Common.All_Tasks_Link;
 828             end loop;
 829          end;
 830
 831       --  Attribute goes into a node onto a linked list
 832
 833       else
 834          --  Replace stub for finalization routine
 835          --  that is called at task termination.
 836
 837          Initialization.Finalize_Attributes_Link :=
 838            System.Tasking.Task_Attributes.Finalize_Attributes'Access;
 839
 840       end if;
 841
 842       POP.Unlock_RTS;
 843       Undefer_Abortion;
 844
 845    exception
 846       when others => null;
 847          pragma Assert (Shutdown ("Exception in task attribute initializer"));
 848
 849          --  If we later decide to allow exceptions to propagate, we need to
 850          --  not only release locks and undefer abortion, we also need to undo
 851          --  any initializations that succeeded up to this point, or we will
 852          --  risk a dangling reference when the task terminates.
 853    end;
 854 end Ada.Task_Attributes;