-- --
-- B o d y --
-- --
--- $Revision: 1.1 $
--- --
--- Copyright (C) 1991-2000 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2004, Ada Core Technologies --
-- --
-- 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- --
-- 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). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- 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
+-- - 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,
-- 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
+-- 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
-- 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.
+-- 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
with Ada.Task_Identification;
-- used for Task_Id
--- Null_Task_ID
+-- Null_Task_Id
-- Current_Task
with System.Error_Reporting;
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Unlock
--- Lock/Unlock_All_Tasks_List
+-- Lock/Unlock_RTS
with System.Tasking;
-- used for Access_Address
--- Task_ID
+-- Task_Id
-- Direct_Index_Vector
-- Direct_Index
-- 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;
+ pragma Warnings (Off);
+ -- We turn warnings off for the following declarations of the
+ -- 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 Unchecked_Conversion
- (Access_Address, Attribute_Handle);
+ (System.Address, Attribute_Handle);
+ function To_Direct_Attribute_Element is new Unchecked_Conversion
+ (System.Address, Direct_Attribute_Element);
-- For reference to directly addressed task attributes
type Access_Integer_Address is access all
(Access_Integer_Address, Attribute_Handle);
-- For reference to directly addressed task attributes
+ pragma Warnings (On);
+ -- End of warnings off region for directly addressed
+ -- attribute conversion functions.
+
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
-
+ pragma Warnings (Off);
function To_Access_Wrapper is new Unchecked_Conversion
(Access_Dummy_Wrapper, Access_Wrapper);
- -- To fetch pointer to actual wrapper of attribute node
+ 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 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);
+ 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);
+ type Local_Deallocator is access procedure (P : in out Access_Node);
function To_Lib_Level_Deallocator is new Unchecked_Conversion
(Local_Deallocator, Deallocator);
-- 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 Unchecked_Deallocation (Wrapper, Access_Wrapper);
begin
Free (T);
-
- exception
- when others =>
- pragma Assert (Shutdown ("Exception in Deallocate")); null;
end Deallocate;
---------------
(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";
+ TT : constant 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");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
Error_Message & "terminated task");
end if;
- begin
- Defer_Abortion;
- POP.Write_Lock (All_Attrs_L'Access);
+ -- Directly addressed case
- 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;
+ if Local.Index /= 0 then
- P := P.Next;
- end loop;
+ -- 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).
- -- 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.
+ pragma Warnings (Off);
+ return
+ To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address);
+ pragma Warnings (On);
- POP.Unlock (All_Attrs_L'Access);
- W := new Wrapper'
- ((null, Local'Unchecked_Access, null), Initial_Value);
- POP.Write_Lock (All_Attrs_L'Access);
+ -- Not directly addressed
- 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;
+ else
+ declare
+ P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
+ W : Access_Wrapper;
- pragma Assert (Shutdown ("Should never get here in Reference"));
- return null;
+ begin
+ Defer_Abortion;
+ POP.Lock_RTS;
- exception
- when others =>
- POP.Unlock (All_Attrs_L'Access);
+ while P /= null loop
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ 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.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_RTS;
Undefer_Abortion;
- raise;
- end;
+ return W.Value'Access;
+
+ exception
+ when others =>
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ raise;
+ end;
+ end if;
+
+ pragma Assert (Shutdown ("Should never get here in Reference"));
+ return null;
exception
when Tasking_Error | Program_Error =>
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";
+ TT : constant 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");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
Error_Message & "terminated task");
end if;
- if Local.Index = 0 then
+ if Local.Index /= 0 then
+ Set_Value (Initial_Value, T);
+ else
declare
P, Q : Access_Node;
W : Access_Wrapper;
-
begin
Defer_Abortion;
- POP.Write_Lock (All_Attrs_L'Access);
-
+ 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
W := To_Access_Wrapper (Q.Wrapper);
Free (W);
- POP.Unlock (All_Attrs_L'Access);
+ POP.Unlock_RTS;
Undefer_Abortion;
return;
end if;
Q := Q.Next;
end loop;
- POP.Unlock (All_Attrs_L'Access);
+ POP.Unlock_RTS;
Undefer_Abortion;
exception
when others =>
- POP.Unlock (All_Attrs_L'Access);
+ POP.Unlock_RTS;
Undefer_Abortion;
+ raise;
end;
-
- else
- Set_Value (Initial_Value, T);
end if;
exception
(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";
+ TT : constant 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");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
Error_Message & "terminated task");
end if;
- begin
- Defer_Abortion;
- POP.Write_Lock (All_Attrs_L'Access);
+ -- Directly addressed case
- 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;
+ 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).
- else
- declare
- P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
- W : Access_Wrapper;
+ pragma Warnings (Off);
+ To_Attribute_Handle
+ (TT.Direct_Attributes (Local.Index)'Address).all := Val;
+ pragma Warnings (On);
+ return;
+ end if;
- begin
- while P /= null loop
+ -- Not directly addressed
- 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;
+ declare
+ P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
+ W : Access_Wrapper;
- P := P.Next;
- end loop;
+ begin
+ Defer_Abortion;
+ POP.Lock_RTS;
- -- 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.
+ while P /= null loop
- POP.Unlock (All_Attrs_L'Access);
- W := new Wrapper'
- ((null, Local'Unchecked_Access, null), Val);
- POP.Write_Lock (All_Attrs_L'Access);
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ To_Access_Wrapper (P.Wrapper).Value := Val;
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ return;
+ end if;
- 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;
+ P := P.Next;
+ end loop;
- POP.Unlock (All_Attrs_L'Access);
+ -- 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.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_RTS;
Undefer_Abortion;
exception
when others =>
- POP.Unlock (All_Attrs_L'Access);
+ POP.Unlock_RTS;
Undefer_Abortion;
raise;
end;
- return;
-
exception
when Tasking_Error | Program_Error =>
raise;
when others =>
raise Program_Error;
-
end Set_Value;
-----------
-----------
function Value
- (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
+ (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";
+ TT : constant 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");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
(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;
+ -- Directly addressed case
+
+ if Local.Index /= 0 then
+
+ -- Get value of attribute. 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.
- P := P.Next;
- end loop;
+ pragma Warnings (Off);
+ return To_Attribute_Handle
+ (TT.Direct_Attributes (Local.Index)'Address).all;
+ pragma Warnings (On);
+ end if;
- Result := Initial_Value;
- POP.Unlock (All_Attrs_L'Access);
+ -- Not directly addressed
+
+ declare
+ P : Access_Node;
+ Result : Attribute;
+
+ begin
+ Defer_Abortion;
+ 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_Abortion;
+ return Result;
+ end if;
- exception
- when others =>
- POP.Unlock (All_Attrs_L'Access);
- Undefer_Abortion;
- raise;
- end;
- end if;
+ P := P.Next;
+ end loop;
+
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ return Initial_Value;
- return Result;
+ exception
+ when others =>
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ raise;
end;
exception
pragma Warnings (On);
declare
- Two_To_J : Direct_Index_Vector;
-
+ Two_To_J : Direct_Index_Vector;
begin
Defer_Abortion;
- POP.Write_Lock (All_Attrs_L'Access);
+
+ -- 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.
-- Try to find space for the attribute in the TCB.
Local.Index := 0;
- Two_To_J := 2 ** Direct_Index'First;
+ Two_To_J := 1;
if Attribute'Size <= System.Address'Size then
- for J in Direct_Index loop
- if (Two_To_J and In_Use) /= 0 then
+ for J in Direct_Index_Range loop
+ if (Two_To_J and In_Use) = 0 then
-- Reserve location J for this attribute
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.
-- Initialize the attribute, for all tasks.
declare
- C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List;
-
+ 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);
+ To_Direct_Attribute_Element
+ (System.Storage_Elements.To_Address (Local.Initial_Value));
C := C.Common.All_Tasks_Link;
end loop;
end;
Initialization.Finalize_Attributes_Link :=
System.Tasking.Task_Attributes.Finalize_Attributes'Access;
-
end if;
- POP.Unlock_All_Tasks_List;
- POP.Unlock (All_Attrs_L'Access);
+ POP.Unlock_RTS;
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;
OSDN Git Service
