URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc1/] [gcc/] [ada/] [a-tasatt.adb] - Rev 338
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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-2009, AdaCore -- -- -- -- GNARL 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 2, or (at your option) any later ver- -- -- sion. GNARL 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNARL; see file COPYING. If not, write -- -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- -- Boston, MA 02110-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- 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;