blob: 18c11d34d68dbe04e21daadae02c8ba79173f873 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- 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 --
-- --
-- $Revision: 1.1 $
-- --
-- Copyright (C) 1991-2000 Florida State University --
-- --
-- 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, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, 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. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- 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 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 a descriptor for the corresponding instantiation
-- of Task_Attributes. The instantiation-descriptor contains a
-- 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 instantiations 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 the 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
-- System.Tasking.Task_Attributes.All_Attrs_L.
-- 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 Node_Access;
-- type Access_Wrapper is access all Wrapper;
-- type Node is record
-- Next : Node_Access;
-- ...
-- Wrapper : Access_Wrapper;
-- end record;
-- type Wrapper is record
-- Noed : 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.
with Ada.Task_Identification;
-- used for Task_Id
-- Null_Task_ID
-- Current_Task
with System.Error_Reporting;
-- used for Shutdown;
with System.Storage_Elements;
-- used for Integer_Address
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Unlock
-- Lock/Unlock_All_Tasks_List
with System.Tasking;
-- used for Access_Address
-- Task_ID
-- Direct_Index_Vector
-- Direct_Index
with System.Tasking.Initialization;
-- used for Defer_Abortion
-- Undefer_Abortion
-- Initialize_Attributes_Link
-- Finalize_Attributes_Link
with System.Tasking.Task_Attributes;
-- used for Access_Node
-- Access_Dummy_Wrapper
-- Deallocator
-- Instance
-- Node
-- Access_Instance
with Ada.Exceptions;
-- used for Raise_Exception
with Unchecked_Conversion;
with 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.Error_Reporting,
System.Tasking.Initialization,
System.Tasking,
System.Tasking.Task_Attributes,
Ada.Exceptions;
use type System.Tasking.Access_Address;
package POP renames System.Task_Primitives.Operations;
---------------------------
-- Unchecked Conversions --
---------------------------
pragma Warnings (Off);
-- These unchecked conversions can give warnings when alignments
-- are incorrect, but they will not be used in such cases anyway,
-- so the warnings can be safely ignored.
-- The following type corresponds to Dummy_Wrapper,
-- declared in System.Tasking.Task_Attributes.
type Wrapper;
type Access_Wrapper is access all Wrapper;
function To_Attribute_Handle is new Unchecked_Conversion
(Access_Address, Attribute_Handle);
-- 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 Unchecked_Conversion
(Access_Integer_Address, Attribute_Handle);
-- For reference to directly addressed task attributes
function To_Access_Address is new Unchecked_Conversion
(Access_Node, Access_Address);
-- To store pointer to list of indirect attributes
function To_Access_Node is new Unchecked_Conversion
(Access_Address, Access_Node);
-- To fetch pointer to list of indirect attributes
function To_Access_Wrapper is new Unchecked_Conversion
(Access_Dummy_Wrapper, Access_Wrapper);
-- To fetch pointer to actual wrapper of attribute node
function To_Access_Dummy_Wrapper is new Unchecked_Conversion
(Access_Wrapper, Access_Dummy_Wrapper);
-- To store pointer to actual wrapper of attribute node
function To_Task_ID is new Unchecked_Conversion
(Task_Identification.Task_Id, Task_ID);
-- To access TCB of identified task
Null_ID : constant Task_ID := To_Task_ID (Task_Identification.Null_Task_Id);
-- ??? need comments on use and purpose
type Local_Deallocator is
access procedure (P : in out Access_Node);
function To_Lib_Level_Deallocator is new Unchecked_Conversion
(Local_Deallocator, Deallocator);
-- To defeat accessibility check
pragma Warnings (On);
------------------------
-- 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
Noed : aliased Node;
Value : aliased Attribute := Initial_Value;
-- The generic formal type, may be controlled
end record;
procedure Free is
new Unchecked_Deallocation (Wrapper, Access_Wrapper);
procedure Deallocate (P : in out Access_Node) is
T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
begin
Free (T);
exception
when others =>
pragma Assert (Shutdown ("Exception in Deallocate")); null;
end Deallocate;
---------------
-- Reference --
---------------
function Reference
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute_Handle
is
TT : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to get the reference of a";
begin
if TT = Null_ID 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;
begin
Defer_Abortion;
POP.Write_Lock (All_Attrs_L'Access);
if Local.Index /= 0 then
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
return
To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access);
else
declare
P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
W : Access_Wrapper;
begin
while P /= null loop
if P.Instance = Access_Instance'(Local'Unchecked_Access) then
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
return To_Access_Wrapper (P.Wrapper).Value'Access;
end if;
P := P.Next;
end loop;
-- Unlock All_Attrs_L 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 (All_Attrs_L'Access);
W := new Wrapper'
((null, Local'Unchecked_Access, null), Initial_Value);
POP.Write_Lock (All_Attrs_L'Access);
P := W.Noed'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 (All_Attrs_L'Access);
Undefer_Abortion;
return W.Value'Access;
end;
end if;
pragma Assert (Shutdown ("Should never get here in Reference"));
return null;
exception
when others =>
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
raise;
end;
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 : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to Reinitialize a";
begin
if TT = Null_ID 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
declare
P, Q : Access_Node;
W : Access_Wrapper;
begin
Defer_Abortion;
POP.Write_Lock (All_Attrs_L'Access);
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 (All_Attrs_L'Access);
Undefer_Abortion;
return;
end if;
P := Q;
Q := Q.Next;
end loop;
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
exception
when others =>
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
end;
else
Set_Value (Initial_Value, T);
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 : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to Set the Value of a";
begin
if TT = Null_ID 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;
begin
Defer_Abortion;
POP.Write_Lock (All_Attrs_L'Access);
if Local.Index /= 0 then
To_Attribute_Handle
(TT.Direct_Attributes (Local.Index)'Access).all := Val;
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
return;
else
declare
P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
W : Access_Wrapper;
begin
while P /= null loop
if P.Instance = Access_Instance'(Local'Unchecked_Access) then
To_Access_Wrapper (P.Wrapper).Value := Val;
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
return;
end if;
P := P.Next;
end loop;
-- Unlock TT 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 (All_Attrs_L'Access);
W := new Wrapper'
((null, Local'Unchecked_Access, null), Val);
POP.Write_Lock (All_Attrs_L'Access);
P := W.Noed'Unchecked_Access;
P.Wrapper := To_Access_Dummy_Wrapper (W);
P.Next := To_Access_Node (TT.Indirect_Attributes);
TT.Indirect_Attributes := To_Access_Address (P);
end;
end if;
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
exception
when others =>
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
raise;
end;
return;
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
Result : Attribute;
TT : Task_ID := To_Task_ID (T);
Error_Message : constant String := "Trying to get the Value of a";
begin
if TT = Null_ID 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;
begin
if Local.Index /= 0 then
Result :=
To_Attribute_Handle
(TT.Direct_Attributes (Local.Index)'Access).all;
else
declare
P : Access_Node;
begin
Defer_Abortion;
POP.Write_Lock (All_Attrs_L'Access);
P := To_Access_Node (TT.Indirect_Attributes);
while P /= null loop
if P.Instance = Access_Instance'(Local'Unchecked_Access) then
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
return To_Access_Wrapper (P.Wrapper).Value;
end if;
P := P.Next;
end loop;
Result := Initial_Value;
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
exception
when others =>
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
raise;
end;
end if;
return Result;
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;
begin
Defer_Abortion;
POP.Write_Lock (All_Attrs_L'Access);
-- 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 := 2 ** Direct_Index'First;
if Attribute'Size <= System.Address'Size then
for J in Direct_Index 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 conversions can give a warning when the
-- 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;
-- Need protection of All_Tasks_L for updating links to
-- per-task initialization and finalization routines,
-- in case some task is being created or terminated concurrently.
POP.Lock_All_Tasks_List;
-- 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
POP.Write_Lock (C);
C.Direct_Attributes (Local.Index) :=
System.Storage_Elements.To_Address (Local.Initial_Value);
POP.Unlock (C);
C := C.Common.All_Tasks_Link;
end loop;
end;
-- Attribute goes into a node onto a linked list
else
-- Replace stub for finalization routine
-- that is called at task termination.
Initialization.Finalize_Attributes_Link :=
System.Tasking.Task_Attributes.Finalize_Attributes'Access;
end if;
POP.Unlock_All_Tasks_List;
POP.Unlock (All_Attrs_L'Access);
Undefer_Abortion;
exception
when others => null;
pragma Assert (Shutdown ("Exception in task attribute initializer"));
-- If we later decide to allow exceptions to propagate, we need to
-- not only release locks and undefer abortion, we also need to undo
-- any initializations that succeeded up to this point, or we will
-- risk a dangling reference when the task terminates.
end;
end Ada.Task_Attributes;