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