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