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