| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- A D A . T A S K _ A T T R I B U T E S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1991-1994, Florida State University -- |
| -- Copyright (C) 1995-2010, AdaCore -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNARL was developed by the GNARL team at Florida State University. -- |
| -- Extensive contributions were provided by Ada Core Technologies, Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- The following notes are provided in case someone decides the implementation |
| -- of this package is too complicated, or too slow. Please read this before |
| -- making any "simplifications". |
| |
| -- Correct implementation of this package is more difficult than one might |
| -- expect. After considering (and coding) several alternatives, we settled on |
| -- the present compromise. Things we do not like about this implementation |
| -- include: |
| |
| -- - It is vulnerable to bad Task_Id values, to the extent of possibly |
| -- trashing memory and crashing the runtime system. |
| |
| -- - It requires dynamic storage allocation for each new attribute value, |
| -- except for types that happen to be the same size as System.Address, or |
| -- shorter. |
| |
| -- - Instantiations at other than the library level rely on being able to |
| -- do down-level calls to a procedure declared in the generic package body. |
| -- This makes it potentially vulnerable to compiler changes. |
| |
| -- The main implementation issue here is that the connection from task to |
| -- attribute is a potential source of dangling references. |
| |
| -- When a task goes away, we want to be able to recover all the storage |
| -- associated with its attributes. The Ada mechanism for this is finalization, |
| -- via controlled attribute types. For this reason, the ARM requires |
| -- finalization of attribute values when the associated task terminates. |
| |
| -- This finalization must be triggered by the tasking runtime system, during |
| -- termination of the task. Given the active set of instantiations of |
| -- Ada.Task_Attributes is dynamic, the number and types of attributes |
| -- belonging to a task will not be known until the task actually terminates. |
| -- Some of these types may be controlled and some may not. The RTS must find |
| -- some way to determine which of these attributes need finalization, and |
| -- invoke the appropriate finalization on them. |
| |
| -- One way this might be done is to create a special finalization chain for |
| -- each task, similar to the finalization chain that is used for controlled |
| -- objects within the task. This would differ from the usual finalization |
| -- chain in that it would not have a LIFO structure, since attributes may be |
| -- added to a task at any time during its lifetime. This might be the right |
| -- way to go for the longer term, but at present this approach is not open, |
| -- since GNAT does not provide such special finalization support. |
| |
| -- Lacking special compiler support, the RTS is limited to the normal ways an |
| -- application invokes finalization, i.e. |
| |
| -- a) Explicit call to the procedure Finalize, if we know the type has this |
| -- operation defined on it. This is not sufficient, since we have no way |
| -- of determining whether a given generic formal Attribute type is |
| -- controlled, and no visibility of the associated Finalize procedure, in |
| -- the generic body. |
| |
| -- b) Leaving the scope of a local object of a controlled type. This does not |
| -- help, since the lifetime of an instantiation of Ada.Task_Attributes |
| -- does not correspond to the lifetimes of the various tasks which may |
| -- have that attribute. |
| |
| -- c) Assignment of another value to the object. This would not help, since |
| -- we then have to finalize the new value of the object. |
| |
| -- d) Unchecked deallocation of an object of a controlled type. This seems to |
| -- be the only mechanism available to the runtime system for finalization |
| -- of task attributes. |
| |
| -- We considered two ways of using unchecked deallocation, both based on a |
| -- linked list of that would hang from the task control block. |
| |
| -- In the first approach the objects on the attribute list are all derived |
| -- from one controlled type, say T, and are linked using an access type to |
| -- T'Class. The runtime system has an Ada.Unchecked_Deallocation for T'Class |
| -- with access type T'Class, and uses this to deallocate and finalize all the |
| -- items in the list. The limitation of this approach is that each |
| -- instantiation of the package Ada.Task_Attributes derives a new record |
| -- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is |
| -- only allowed at the library level. |
| |
| -- In the second approach the objects on the attribute list are of unrelated |
| -- but structurally similar types. Unchecked conversion is used to circument |
| -- Ada type checking. Each attribute-storage node contains not only the |
| -- attribute value and a link for chaining, but also a pointer to descriptor |
| -- for the corresponding instantiation of Task_Attributes. The instantiation |
| -- descriptor contains pointer to a procedure that can do the correct |
| -- deallocation and finalization for that type of attribute. On task |
| -- termination, the runtime system uses the pointer to call the appropriate |
| -- deallocator. |
| |
| -- While this gets around the limitation that instantations be at the library |
| -- level, it relies on an implementation feature that may not always be safe, |
| -- i.e. that it is safe to call the Deallocate procedure for an instantiation |
| -- of Ada.Task_Attributes that no longer exists. In general, it seems this |
| -- might result in dangling references. |
| |
| -- Another problem with instantiations deeper than the library level is that |
| -- there is risk of storage leakage, or dangling references to reused storage. |
| -- That is, if an instantiation of Ada.Task_Attributes is made within a |
| -- procedure, what happens to the storage allocated for attributes, when the |
| -- procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be |
| -- finalized, since they will no longer be accessible, and in general one |
| -- would expect that the storage they occupy would be recovered for later |
| -- reuse. (If not, we would have a case of storage leakage.) Assuming the |
| -- storage is recovered and later reused, we have potentially dangerous |
| -- dangling references. When the procedure containing the instantiation of |
| -- Ada.Task_Attributes returns, there may still be unterminated tasks with |
| -- associated attribute values for that instantiation. When such tasks |
| -- eventually terminate, the RTS will attempt to call the Deallocate procedure |
| -- on them. If the corresponding storage has already been deallocated, when |
| -- the master of the access type was left, we have a potential disaster. This |
| -- disaster is compounded since the pointer to Deallocate is probably through |
| -- a "trampoline" which will also have been destroyed. |
| |
| -- For this reason, we arrange to remove all dangling references before |
| -- leaving the scope of an instantiation. This is ugly, since it requires |
| -- traversing the list of all tasks, but it is no more ugly than a similar |
| -- traversal that we must do at the point of instantiation in order to |
| -- initialize the attributes of all tasks. At least we only need to do these |
| -- traversals if the type is controlled. |
| |
| -- We chose to defer allocation of storage for attributes until the Reference |
| -- function is called or the attribute is first set to a value different from |
| -- the default initial one. This allows a potential savings in allocation, |
| -- for attributes that are not used by all tasks. |
| |
| -- For efficiency, we reserve space in the TCB for a fixed number of direct- |
| -- access attributes. These are required to be of a size that fits in the |
| -- space of an object of type System.Address. Because we must use unchecked |
| -- bitwise copy operations on these values, they cannot be of a controlled |
| -- type, but that is covered automatically since controlled objects are too |
| -- large to fit in the spaces. |
| |
| -- We originally deferred initialization of these direct-access attributes, |
| -- just as we do for the indirect-access attributes, and used a per-task bit |
| -- vector to keep track of which attributes were currently defined for that |
| -- task. We found that the overhead of maintaining this bit-vector seriously |
| -- slowed down access to the attributes, and made the fetch operation non- |
| -- atomic, so that even to read an attribute value required locking the TCB. |
| -- Therefore, we now initialize such attributes for all existing tasks at the |
| -- time of the attribute instantiation, and initialize existing attributes for |
| -- each new task at the time it is created. |
| |
| -- The latter initialization requires a list of all the instantiation |
| -- descriptors. Updates to this list, as well as the bit-vector that is used |
| -- to reserve slots for attributes in the TCB, require mutual exclusion. That |
| -- is provided by the Lock/Unlock_RTS. |
| |
| -- One special problem that added complexity to the design is that the per- |
| -- task list of indirect attributes contains objects of different types. We |
| -- use unchecked pointer conversion to link these nodes together and access |
| -- them, but the records may not have identical internal structure. Initially, |
| -- we thought it would be enough to allocate all the common components of |
| -- the records at the front of each record, so that their positions would |
| -- correspond. Unfortunately, GNAT adds "dope" information at the front |
| -- of a record, if the record contains any controlled-type components. |
| -- |
| -- This means that the offset of the fields we use to link the nodes is at |
| -- different positions on nodes of different types. To get around this, each |
| -- attribute storage record consists of a core node and wrapper. The core |
| -- nodes are all of the same type, and it is these that are linked together |
| -- and generally "seen" by the RTS. Each core node contains a pointer to its |
| -- own wrapper, which is a record that contains the core node along with an |
| -- attribute value, approximately as follows: |
| |
| -- type Node; |
| -- type Node_Access is access all Node; |
| -- type Wrapper; |
| -- type Access_Wrapper is access all Wrapper; |
| -- type Node is record |
| -- Next : Node_Access; |
| -- ... |
| -- Wrapper : Access_Wrapper; |
| -- end record; |
| -- type Wrapper is record |
| -- Dummy_Node : aliased Node; |
| -- Value : aliased Attribute; -- the generic formal type |
| -- end record; |
| |
| -- Another interesting problem is with the initialization of the instantiation |
| -- descriptors. Originally, we did this all via the Initialize procedure of |
| -- the descriptor type and code in the package body. It turned out that the |
| -- Initialize procedure needed quite a bit of information, including the size |
| -- of the attribute type, the initial value of the attribute (if it fits in |
| -- the TCB), and a pointer to the deallocator procedure. These needed to be |
| -- "passed" in via access discriminants. GNAT was having trouble with access |
| -- discriminants, so all this work was moved to the package body. |
| |
| -- Note that references to objects declared in this package body must in |
| -- general use 'Unchecked_Access instead of 'Access as the package can be |
| -- instantiated from within a local context. |
| |
| with System.Storage_Elements; |
| with System.Task_Primitives.Operations; |
| with System.Tasking; |
| with System.Tasking.Initialization; |
| with System.Tasking.Task_Attributes; |
| |
| with Ada.Exceptions; |
| with Ada.Unchecked_Conversion; |
| with Ada.Unchecked_Deallocation; |
| |
| pragma Elaborate_All (System.Tasking.Task_Attributes); |
| -- To ensure the initialization of object Local (below) will work |
| |
| package body Ada.Task_Attributes is |
| |
| use System.Tasking.Initialization, |
| System.Tasking, |
| System.Tasking.Task_Attributes, |
| Ada.Exceptions; |
| |
| package POP renames System.Task_Primitives.Operations; |
| |
| --------------------------- |
| -- Unchecked Conversions -- |
| --------------------------- |
| |
| -- The following type corresponds to Dummy_Wrapper, declared in |
| -- System.Tasking.Task_Attributes. |
| |
| type Wrapper; |
| type Access_Wrapper is access all Wrapper; |
| |
| pragma Warnings (Off); |
| -- We turn warnings off for the following To_Attribute_Handle conversions, |
| -- since these are used only for small attributes where we know that there |
| -- are no problems with alignment, but the compiler will generate warnings |
| -- for the occurrences in the large attribute case, even though they will |
| -- not actually be used. |
| |
| function To_Attribute_Handle is new Ada.Unchecked_Conversion |
| (System.Address, Attribute_Handle); |
| function To_Direct_Attribute_Element is new Ada.Unchecked_Conversion |
| (System.Address, Direct_Attribute_Element); |
| -- For reference to directly addressed task attributes |
| |
| type Access_Integer_Address is access all |
| System.Storage_Elements.Integer_Address; |
| |
| function To_Attribute_Handle is new Ada.Unchecked_Conversion |
| (Access_Integer_Address, Attribute_Handle); |
| -- For reference to directly addressed task attributes |
| |
| pragma Warnings (On); |
| -- End warnings off region for directly addressed attribute conversions |
| |
| function To_Access_Address is new Ada.Unchecked_Conversion |
| (Access_Node, Access_Address); |
| -- To store pointer to list of indirect attributes |
| |
| pragma Warnings (Off); |
| function To_Access_Wrapper is new Ada.Unchecked_Conversion |
| (Access_Dummy_Wrapper, Access_Wrapper); |
| pragma Warnings (On); |
| -- To fetch pointer to actual wrapper of attribute node. We turn off |
| -- warnings since this may generate an alignment warning. The warning can |
| -- be ignored since Dummy_Wrapper is only a non-generic standin for the |
| -- real wrapper type (we never actually allocate objects of type |
| -- Dummy_Wrapper). |
| |
| function To_Access_Dummy_Wrapper is new Ada.Unchecked_Conversion |
| (Access_Wrapper, Access_Dummy_Wrapper); |
| -- To store pointer to actual wrapper of attribute node |
| |
| function To_Task_Id is new Ada.Unchecked_Conversion |
| (Task_Identification.Task_Id, Task_Id); |
| -- To access TCB of identified task |
| |
| type Local_Deallocator is access procedure (P : in out Access_Node); |
| |
| function To_Lib_Level_Deallocator is new Ada.Unchecked_Conversion |
| (Local_Deallocator, Deallocator); |
| -- To defeat accessibility check |
| |
| ------------------------ |
| -- Storage Management -- |
| ------------------------ |
| |
| procedure Deallocate (P : in out Access_Node); |
| -- Passed to the RTS via unchecked conversion of a pointer to permit |
| -- finalization and deallocation of attribute storage nodes. |
| |
| -------------------------- |
| -- Instantiation Record -- |
| -------------------------- |
| |
| Local : aliased Instance; |
| -- Initialized in package body |
| |
| type Wrapper is record |
| Dummy_Node : aliased Node; |
| |
| Value : aliased Attribute := Initial_Value; |
| -- The generic formal type, may be controlled |
| end record; |
| |
| -- A number of unchecked conversions involving Wrapper_Access sources are |
| -- performed in this unit. We have to ensure that the designated object is |
| -- always strictly enough aligned. |
| |
| for Wrapper'Alignment use Standard'Maximum_Alignment; |
| |
| procedure Free is |
| new Ada.Unchecked_Deallocation (Wrapper, Access_Wrapper); |
| |
| procedure Deallocate (P : in out Access_Node) is |
| T : Access_Wrapper := To_Access_Wrapper (P.Wrapper); |
| begin |
| Free (T); |
| end Deallocate; |
| |
| --------------- |
| -- Reference -- |
| --------------- |
| |
| function Reference |
| (T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| return Attribute_Handle |
| is |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "Trying to get the reference of a "; |
| |
| begin |
| if TT = null then |
| Raise_Exception (Program_Error'Identity, Error_Message & "null task"); |
| end if; |
| |
| if TT.Common.State = Terminated then |
| Raise_Exception (Tasking_Error'Identity, |
| Error_Message & "terminated task"); |
| end if; |
| |
| -- Directly addressed case |
| |
| if Local.Index /= 0 then |
| |
| -- Return the attribute handle. Warnings off because this return |
| -- statement generates alignment warnings for large attributes |
| -- (but will never be executed in this case anyway). |
| |
| pragma Warnings (Off); |
| return |
| To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address); |
| pragma Warnings (On); |
| |
| -- Not directly addressed |
| |
| else |
| declare |
| P : Access_Node := To_Access_Node (TT.Indirect_Attributes); |
| W : Access_Wrapper; |
| Self_Id : constant Task_Id := POP.Self; |
| |
| begin |
| Defer_Abort (Self_Id); |
| POP.Lock_RTS; |
| |
| while P /= null loop |
| if P.Instance = Access_Instance'(Local'Unchecked_Access) then |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| return To_Access_Wrapper (P.Wrapper).Value'Access; |
| end if; |
| |
| P := P.Next; |
| end loop; |
| |
| -- Unlock the RTS here to follow the lock ordering rule that |
| -- prevent us from using new (i.e the Global_Lock) while holding |
| -- any other lock. |
| |
| POP.Unlock_RTS; |
| W := new Wrapper' |
| ((null, Local'Unchecked_Access, null), Initial_Value); |
| POP.Lock_RTS; |
| |
| P := W.Dummy_Node'Unchecked_Access; |
| P.Wrapper := To_Access_Dummy_Wrapper (W); |
| P.Next := To_Access_Node (TT.Indirect_Attributes); |
| TT.Indirect_Attributes := To_Access_Address (P); |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| return W.Value'Access; |
| |
| exception |
| when others => |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| raise; |
| end; |
| end if; |
| |
| exception |
| when Tasking_Error | Program_Error => |
| raise; |
| |
| when others => |
| raise Program_Error; |
| end Reference; |
| |
| ------------------ |
| -- Reinitialize -- |
| ------------------ |
| |
| procedure Reinitialize |
| (T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| is |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "Trying to Reinitialize a "; |
| |
| begin |
| if TT = null then |
| Raise_Exception (Program_Error'Identity, Error_Message & "null task"); |
| end if; |
| |
| if TT.Common.State = Terminated then |
| Raise_Exception (Tasking_Error'Identity, |
| Error_Message & "terminated task"); |
| end if; |
| |
| if Local.Index /= 0 then |
| Set_Value (Initial_Value, T); |
| else |
| declare |
| P, Q : Access_Node; |
| W : Access_Wrapper; |
| Self_Id : constant Task_Id := POP.Self; |
| |
| begin |
| Defer_Abort (Self_Id); |
| POP.Lock_RTS; |
| Q := To_Access_Node (TT.Indirect_Attributes); |
| |
| while Q /= null loop |
| if Q.Instance = Access_Instance'(Local'Unchecked_Access) then |
| if P = null then |
| TT.Indirect_Attributes := To_Access_Address (Q.Next); |
| else |
| P.Next := Q.Next; |
| end if; |
| |
| W := To_Access_Wrapper (Q.Wrapper); |
| Free (W); |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| return; |
| end if; |
| |
| P := Q; |
| Q := Q.Next; |
| end loop; |
| |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| |
| exception |
| when others => |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| raise; |
| end; |
| end if; |
| |
| exception |
| when Tasking_Error | Program_Error => |
| raise; |
| |
| when others => |
| raise Program_Error; |
| end Reinitialize; |
| |
| --------------- |
| -- Set_Value -- |
| --------------- |
| |
| procedure Set_Value |
| (Val : Attribute; |
| T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| is |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "Trying to Set the Value of a "; |
| |
| begin |
| if TT = null then |
| Raise_Exception (Program_Error'Identity, Error_Message & "null task"); |
| end if; |
| |
| if TT.Common.State = Terminated then |
| Raise_Exception (Tasking_Error'Identity, |
| Error_Message & "terminated task"); |
| end if; |
| |
| -- Directly addressed case |
| |
| if Local.Index /= 0 then |
| |
| -- Set attribute handle, warnings off, because this code can generate |
| -- alignment warnings with large attributes (but of course will not |
| -- be executed in this case, since we never have direct addressing in |
| -- such cases). |
| |
| pragma Warnings (Off); |
| To_Attribute_Handle |
| (TT.Direct_Attributes (Local.Index)'Address).all := Val; |
| pragma Warnings (On); |
| return; |
| end if; |
| |
| -- Not directly addressed |
| |
| declare |
| P : Access_Node := To_Access_Node (TT.Indirect_Attributes); |
| W : Access_Wrapper; |
| Self_Id : constant Task_Id := POP.Self; |
| |
| begin |
| Defer_Abort (Self_Id); |
| POP.Lock_RTS; |
| |
| while P /= null loop |
| |
| if P.Instance = Access_Instance'(Local'Unchecked_Access) then |
| To_Access_Wrapper (P.Wrapper).Value := Val; |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| return; |
| end if; |
| |
| P := P.Next; |
| end loop; |
| |
| -- Unlock RTS here to follow the lock ordering rule that prevent us |
| -- from using new (i.e the Global_Lock) while holding any other lock. |
| |
| POP.Unlock_RTS; |
| W := new Wrapper'((null, Local'Unchecked_Access, null), Val); |
| POP.Lock_RTS; |
| P := W.Dummy_Node'Unchecked_Access; |
| P.Wrapper := To_Access_Dummy_Wrapper (W); |
| P.Next := To_Access_Node (TT.Indirect_Attributes); |
| TT.Indirect_Attributes := To_Access_Address (P); |
| |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| |
| exception |
| when others => |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| raise; |
| end; |
| |
| exception |
| when Tasking_Error | Program_Error => |
| raise; |
| |
| when others => |
| raise Program_Error; |
| end Set_Value; |
| |
| ----------- |
| -- Value -- |
| ----------- |
| |
| function Value |
| (T : Task_Identification.Task_Id := Task_Identification.Current_Task) |
| return Attribute |
| is |
| TT : constant Task_Id := To_Task_Id (T); |
| Error_Message : constant String := "Trying to get the Value of a "; |
| |
| begin |
| if TT = null then |
| Raise_Exception (Program_Error'Identity, Error_Message & "null task"); |
| end if; |
| |
| if TT.Common.State = Terminated then |
| Raise_Exception |
| (Program_Error'Identity, Error_Message & "terminated task"); |
| end if; |
| |
| -- Directly addressed case |
| |
| if Local.Index /= 0 then |
| |
| -- Get value of attribute. We turn Warnings off, because for large |
| -- attributes, this code can generate alignment warnings. But of |
| -- course large attributes are never directly addressed so in fact |
| -- we will never execute the code in this case. |
| |
| pragma Warnings (Off); |
| return To_Attribute_Handle |
| (TT.Direct_Attributes (Local.Index)'Address).all; |
| pragma Warnings (On); |
| end if; |
| |
| -- Not directly addressed |
| |
| declare |
| P : Access_Node; |
| Result : Attribute; |
| Self_Id : constant Task_Id := POP.Self; |
| |
| begin |
| Defer_Abort (Self_Id); |
| POP.Lock_RTS; |
| P := To_Access_Node (TT.Indirect_Attributes); |
| |
| while P /= null loop |
| if P.Instance = Access_Instance'(Local'Unchecked_Access) then |
| Result := To_Access_Wrapper (P.Wrapper).Value; |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| return Result; |
| end if; |
| |
| P := P.Next; |
| end loop; |
| |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| return Initial_Value; |
| |
| exception |
| when others => |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| raise; |
| end; |
| |
| exception |
| when Tasking_Error | Program_Error => |
| raise; |
| |
| when others => |
| raise Program_Error; |
| end Value; |
| |
| -- Start of elaboration code for package Ada.Task_Attributes |
| |
| begin |
| -- This unchecked conversion can give warnings when alignments are |
| -- incorrect, but they will not be used in such cases anyway, so the |
| -- warnings can be safely ignored. |
| |
| pragma Warnings (Off); |
| Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access); |
| pragma Warnings (On); |
| |
| declare |
| Two_To_J : Direct_Index_Vector; |
| Self_Id : constant Task_Id := POP.Self; |
| begin |
| Defer_Abort (Self_Id); |
| |
| -- Need protection for updating links to per-task initialization and |
| -- finalization routines, in case some task is being created or |
| -- terminated concurrently. |
| |
| POP.Lock_RTS; |
| |
| -- Add this instantiation to the list of all instantiations |
| |
| Local.Next := System.Tasking.Task_Attributes.All_Attributes; |
| System.Tasking.Task_Attributes.All_Attributes := |
| Local'Unchecked_Access; |
| |
| -- Try to find space for the attribute in the TCB |
| |
| Local.Index := 0; |
| Two_To_J := 1; |
| |
| if Attribute'Size <= System.Address'Size then |
| for J in Direct_Index_Range loop |
| if (Two_To_J and In_Use) = 0 then |
| |
| -- Reserve location J for this attribute |
| |
| In_Use := In_Use or Two_To_J; |
| Local.Index := J; |
| |
| -- This unchecked conversion can give a warning when the |
| -- alignment is incorrect, but it will not be used in such |
| -- a case anyway, so the warning can be safely ignored. |
| |
| pragma Warnings (Off); |
| To_Attribute_Handle (Local.Initial_Value'Access).all := |
| Initial_Value; |
| pragma Warnings (On); |
| |
| exit; |
| end if; |
| |
| Two_To_J := Two_To_J * 2; |
| end loop; |
| end if; |
| |
| -- Attribute goes directly in the TCB |
| |
| if Local.Index /= 0 then |
| -- Replace stub for initialization routine that is called at task |
| -- creation. |
| |
| Initialization.Initialize_Attributes_Link := |
| System.Tasking.Task_Attributes.Initialize_Attributes'Access; |
| |
| -- Initialize the attribute, for all tasks |
| |
| declare |
| C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; |
| begin |
| while C /= null loop |
| C.Direct_Attributes (Local.Index) := |
| To_Direct_Attribute_Element |
| (System.Storage_Elements.To_Address (Local.Initial_Value)); |
| C := C.Common.All_Tasks_Link; |
| end loop; |
| end; |
| |
| -- Attribute goes into a node onto a linked list |
| |
| else |
| -- Replace stub for finalization routine called at task termination |
| |
| Initialization.Finalize_Attributes_Link := |
| System.Tasking.Task_Attributes.Finalize_Attributes'Access; |
| end if; |
| |
| POP.Unlock_RTS; |
| Undefer_Abort (Self_Id); |
| end; |
| end Ada.Task_Attributes; |
