+2014-07-30 Thomas Quinot <quinot@adacore.com>
+
+ * sem.ads (Scope_Table_Entry): New component Locked_Shared_Objects.
+ * sem_ch8.adb (Push_Scope): Initialize Locked_Shared_Objects.
+ * exp_smem.adb (Add_Shared_Var_Lock_Procs): Handle the case where
+ the call returns an unconstrained type: in this case there is
+ already a transient scope, and we should not establish a new one.
+ * exp_ch7.adb (Insert_Actions_In_Scope_Around): New formal Clean. If
+ True, also insert cleanup actions in the tree.
+ (Wrap_Transient_Declaration): Call Insert_Actions_In_Scope_Around
+ with Clean set True.
+
+2014-07-30 Arnaud Charlet <charlet@adacore.com>
+
+ * s-taskin.ads (Direct_Index, Direct_Index_Range,
+ Direct_Attribute_Element, Direct_Attribute_Array,
+ Direct_Index_Vector, Direct_Attributes, Is_Defined,
+ Indirect_Attributes): Removed. (Atomic_Address,
+ Attribute_Array, Attributes): New.
+ * s-tasini.ads, s-tasini.adb (Proc_T, Initialize_Attributes,
+ Finalize_Attributes_Link, Initialize_Attributes_Link): Removed.
+ (Finalize_Attributes): Reimplement.
+ * s-tassta.adb (Create_Task): Remove call to
+ Initialize_Attributes_Link (Free_Task, Vulnerable_Free_Task):
+ Replace Finalize_Attributes_Link by Finalize_Attributes.
+ * a-tasatt.ads, a-tasatt.adb, s-tataat.ads, s-tataat.adb:
+ Reimplement from scratch, using a simpler and more efficient
+ implementation.
+ * s-tporft.adb (Register_Foreign_Thread): Remove now obsolete comment.
+ * s-parame.ads, s-parame-hpux.ads,
+ * s-parame-vms-alpha.ads, s-parame-vms-ia64.ads,
+ * s-parame-vxworks.ads (Max_Attribute_Count): New, replace
+ Default_Attribute_Count.
+
2014-07-30 Olivier Hainque <hainque@adacore.com>
* vxworks-ppc-link.spec: New file. Extra link
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2014, AdaCore --
+-- Copyright (C) 1995-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-with System.Storage_Elements;
-with System.Task_Primitives.Operations;
with System.Tasking;
with System.Tasking.Initialization;
with System.Tasking.Task_Attributes;
+pragma Elaborate_All (System.Tasking.Task_Attributes);
+
+with System.Task_Primitives.Operations;
-with Ada.Exceptions;
+with Ada.Finalization; use Ada.Finalization;
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,
+ use System,
+ System.Tasking.Initialization,
System.Tasking,
- System.Tasking.Task_Attributes,
- Ada.Exceptions;
+ System.Tasking.Task_Attributes;
+
+ package STPO renames System.Task_Primitives.Operations;
+
+ type Attribute_Cleanup is new Limited_Controlled with null record;
+ procedure Finalize (Cleanup : in out Attribute_Cleanup);
+ -- Finalize all tasks' attribute for this package
- package POP renames System.Task_Primitives.Operations;
+ Cleanup : Attribute_Cleanup;
+ pragma Unreferenced (Cleanup);
+ -- Will call Finalize when this instantiation gets out of scope
---------------------------
-- Unchecked Conversions --
---------------------------
- -- The following type corresponds to Dummy_Wrapper, declared in
- -- System.Tasking.Task_Attributes.
-
- type Wrapper;
- type Access_Wrapper is access all Wrapper;
-
+ type Real_Attribute is record
+ Free : Deallocator;
+ Value : Attribute;
+ end record;
+ type Real_Attribute_Access is access all Real_Attribute;
+ pragma No_Strict_Aliasing (Real_Attribute_Access);
+ -- Each value in the task control block's Attributes array is either
+ -- mapped to the attribute value directly if Fast_Path is True, or
+ -- is in effect a Real_Attribute_Access.
+ -- Note: the Deallocator field must be first, for compatibility with
+ -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked
+ -- conversions between Attribute_Access and Real_Attribute_Access.
+
+ function New_Attribute (Val : Attribute) return Atomic_Address;
+ -- Create a new Real_Attribute using Val, and return its address.
+ -- The returned value can be converted via To_Real_Attribute.
+
+ procedure Deallocate (Ptr : Atomic_Address);
+ -- Free memory associated with Ptr, a Real_Attribute_Access in reality
+
+ function To_Real_Attribute is new
+ Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access);
+
+ -- Kill warning about possible size mismatch
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
-
+ function To_Address is new
+ Ada.Unchecked_Conversion (Attribute, Atomic_Address);
+ function To_Attribute is new
+ Ada.Unchecked_Conversion (Atomic_Address, Attribute);
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
+ function To_Address is new
+ Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address);
+ -- Kill warning about possible aliasing
pragma Warnings (Off);
- function To_Access_Wrapper is new Ada.Unchecked_Conversion
- (Access_Dummy_Wrapper, Access_Wrapper);
+ function To_Handle is new
+ Ada.Unchecked_Conversion (System.Address, Attribute_Handle);
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);
+ procedure Free is new
+ Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access);
- function To_Lib_Level_Deallocator is new Ada.Unchecked_Conversion
- (Local_Deallocator, Deallocator);
- -- To defeat accessibility check
+ Fast_Path : constant Boolean :=
+ Attribute'Size <= Atomic_Address'Size and then
+ To_Address (Initial_Value) = 0;
+ -- If the attribute fits in an Atomic_Address and Initial_Value is 0 (or
+ -- null), then we will map the attribute directly into
+ -- ATCB.Attributes (Index), otherwise we will create a level of indirection
+ -- and instead use Attributes (Index) as a Real_Attribute_Access.
- ------------------------
- -- Storage Management --
- ------------------------
+ Index : constant Integer :=
+ Next_Index (Require_Finalization => not Fast_Path);
+ -- Index in the task control block's Attributes array
- 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.
+ --------------
+ -- Finalize --
+ --------------
- --------------------------
- -- Instantiation Record --
- --------------------------
+ procedure Finalize (Cleanup : in out Attribute_Cleanup) is
+ pragma Unreferenced (Cleanup);
+ begin
+ STPO.Lock_RTS;
- Local : aliased Instance;
- -- Initialized in package body
+ declare
+ C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
+ begin
+ while C /= null loop
+ STPO.Write_Lock (C);
+
+ if C.Attributes (Index) /= 0
+ and then Require_Finalization (Index)
+ then
+ Deallocate (C.Attributes (Index));
+ C.Attributes (Index) := 0;
+ end if;
- type Wrapper is record
- Dummy_Node : aliased Node;
+ STPO.Unlock (C);
+ C := C.Common.All_Tasks_Link;
+ end loop;
+ end;
- Value : aliased Attribute := Initial_Value;
- -- The generic formal type, may be controlled
- end record;
+ Finalize (Index);
+ STPO.Unlock_RTS;
+ end Finalize;
- -- 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.
+ ----------------
+ -- Deallocate --
+ ----------------
- for Wrapper'Alignment use Standard'Maximum_Alignment;
+ procedure Deallocate (Ptr : Atomic_Address) is
+ Obj : Real_Attribute_Access := To_Real_Attribute (Ptr);
+ begin
+ Free (Obj);
+ end Deallocate;
- procedure Free is
- new Ada.Unchecked_Deallocation (Wrapper, Access_Wrapper);
+ -------------------
+ -- New_Attribute --
+ -------------------
- procedure Deallocate (P : in out Access_Node) is
- T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
+ function New_Attribute (Val : Attribute) return Atomic_Address is
+ Tmp : Real_Attribute_Access;
begin
- Free (T);
- end Deallocate;
+ Tmp := new Real_Attribute'
+ (Free => Deallocate'Unrestricted_Access,
+ Value => Val);
+ return To_Address (Tmp);
+ end New_Attribute;
---------------
-- Reference --
---------------
function Reference
- (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
+ (T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute_Handle
is
+ Self_Id : Task_Id;
TT : constant Task_Id := To_Task_Id (T);
Error_Message : constant String := "Trying to get the reference of a ";
+ Result : Attribute_Handle;
begin
if TT = null then
- Raise_Exception (Program_Error'Identity, Error_Message & "null task");
+ raise Program_Error with Error_Message & "null task";
end if;
if TT.Common.State = Terminated then
- Raise_Exception (Tasking_Error'Identity,
- Error_Message & "terminated task");
+ raise Tasking_Error with 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
-
+ if Fast_Path then
+ return To_Handle (TT.Attributes (Index)'Address);
else
- declare
- P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
- W : Access_Wrapper;
- Self_Id : constant Task_Id := POP.Self;
+ Self_Id := STPO.Self;
+ Task_Lock (Self_Id);
- 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;
+ if TT.Attributes (Index) = 0 then
+ TT.Attributes (Index) := New_Attribute (Initial_Value);
+ end if;
- exception
- when Tasking_Error | Program_Error =>
- raise;
+ Result := To_Handle
+ (To_Real_Attribute (TT.Attributes (Index)).Value'Address);
+ Task_Unlock (Self_Id);
- when others =>
- raise Program_Error;
+ return Result;
+ end if;
end Reference;
------------------
procedure Reinitialize
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
+ Self_Id : Task_Id;
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");
+ raise Program_Error with Error_Message & "null task";
end if;
if TT.Common.State = Terminated then
- Raise_Exception (Tasking_Error'Identity,
- Error_Message & "terminated task");
+ raise Tasking_Error with Error_Message & "terminated task";
end if;
- if Local.Index /= 0 then
- Set_Value (Initial_Value, T);
+ if Fast_Path then
+ -- No finalization needed, simply reset to Initial_Value
+ TT.Attributes (Index) := To_Address (Initial_Value);
else
- declare
- P, Q : Access_Node;
- W : Access_Wrapper;
- Self_Id : constant Task_Id := POP.Self;
+ Self_Id := STPO.Self;
+ Task_Lock (Self_Id);
+ declare
+ Attr : Atomic_Address renames TT.Attributes (Index);
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;
+ if Attr /= 0 then
+ Deallocate (Attr);
+ Attr := 0;
+ end if;
end;
- end if;
-
- exception
- when Tasking_Error | Program_Error =>
- raise;
- when others =>
- raise Program_Error;
+ Task_Unlock (Self_Id);
+ end if;
end Reinitialize;
---------------
(Val : Attribute;
T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
+ Self_Id : Task_Id;
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");
+ raise Program_Error with Error_Message & "null task";
end if;
if TT.Common.State = Terminated then
- Raise_Exception (Tasking_Error'Identity,
- Error_Message & "terminated task");
+ raise Tasking_Error with 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 Fast_Path then
+ -- No finalization needed, simply set to Val
+ TT.Attributes (Index) := To_Address (Val);
+ else
+ Self_Id := STPO.Self;
+ Task_Lock (Self_Id);
- if P.Instance = Access_Instance'(Local'Unchecked_Access) then
- To_Access_Wrapper (P.Wrapper).Value := Val;
- POP.Unlock_RTS;
- Undefer_Abort (Self_Id);
- return;
+ declare
+ Attr : Atomic_Address renames TT.Attributes (Index);
+ begin
+ if Attr /= 0 then
+ Deallocate (Attr);
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;
+ Attr := New_Attribute (Val);
+ end;
- when others =>
- raise Program_Error;
+ Task_Unlock (Self_Id);
+ end if;
end Set_Value;
-----------
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute
is
+ Self_Id : Task_Id;
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");
+ raise Program_Error with Error_Message & "null task";
end if;
if TT.Common.State = Terminated then
- Raise_Exception
- (Program_Error'Identity, Error_Message & "terminated task");
+ raise Tasking_Error with 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
+ if Fast_Path then
+ return To_Attribute (TT.Attributes (Index));
+ else
+ Self_Id := STPO.Self;
+ Task_Lock (Self_Id);
declare
- C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List;
+ Attr : Atomic_Address renames TT.Attributes (Index);
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;
+ if Attr = 0 then
+ Task_Unlock (Self_Id);
+ return Initial_Value;
+ else
+ declare
+ Result : constant Attribute :=
+ To_Real_Attribute (Attr).Value;
+ begin
+ Task_Unlock (Self_Id);
+ return Result;
+ end;
+ end if;
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;
+ end Value;
- POP.Unlock_RTS;
- Undefer_Abort (Self_Id);
- end;
end Ada.Task_Attributes;
-- pointers of N until it find the appropriate node to wrap. If it returns
-- Empty, it means that no transient scope is needed in this context.
- procedure Insert_Actions_In_Scope_Around (N : Node_Id);
+ procedure Insert_Actions_In_Scope_Around (N : Node_Id; Clean : Boolean);
-- Insert the before-actions kept in the scope stack before N, and the
- -- after-actions after N, which must be a member of a list.
+ -- after-actions after N, which must be a member of a list. If Clean is
+ -- True, also insert the cleanup actions.
function Make_Transient_Block
(Loc : Source_Ptr;
-- Insert_Actions_In_Scope_Around --
------------------------------------
- procedure Insert_Actions_In_Scope_Around (N : Node_Id) is
- Act_After : constant List_Id :=
- Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
+ procedure Insert_Actions_In_Scope_Around (N : Node_Id; Clean : Boolean) is
Act_Before : constant List_Id :=
Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before);
+ Act_After : constant List_Id :=
+ Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After);
+ Act_Cleanup : constant List_Id :=
+ Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
-- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
-- Last), but this was incorrect as Process_Transient_Object may
-- introduce new scopes and cause a reallocation of Scope_Stack.Table.
Next (Stmt);
end loop;
+ if Clean then
+ if Present (Prev_Fin) then
+ Insert_List_Before_And_Analyze (Prev_Fin, Act_Cleanup);
+ else
+ Insert_List_After_And_Analyze (Fin_Insrt, Act_Cleanup);
+ end if;
+ end if;
+
-- Generate:
-- if Raised and then not Abort then
-- Raise_From_Controlled_Operation (E);
-- Start of processing for Insert_Actions_In_Scope_Around
begin
- if No (Act_Before) and then No (Act_After) then
+ if No (Act_Before) and then No (Act_After) and then No (Act_Cleanup) then
return;
end if;
-- Reset the action lists
- if Present (Act_Before) then
- Scope_Stack.Table (Scope_Stack.Last).
- Actions_To_Be_Wrapped (Before) := No_List;
- end if;
-
- if Present (Act_After) then
+ Scope_Stack.Table (Scope_Stack.Last).
+ Actions_To_Be_Wrapped (Before) := No_List;
+ Scope_Stack.Table (Scope_Stack.Last).
+ Actions_To_Be_Wrapped (After) := No_List;
+ if Clean then
Scope_Stack.Table (Scope_Stack.Last).
- Actions_To_Be_Wrapped (After) := No_List;
+ Actions_To_Be_Wrapped (Cleanup) := No_List;
end if;
end;
end Insert_Actions_In_Scope_Around;
Set_Parent (Block, Par);
-- Insert actions stuck in the transient scopes as well as all freezing
- -- nodes needed by those actions.
+ -- nodes needed by those actions. Do not insert cleanup actions here,
+ -- they will be transferred to the newly created block.
- Insert_Actions_In_Scope_Around (Action);
+ Insert_Actions_In_Scope_Around (Action, Clean => False);
Insert := Prev (Action);
if Present (Insert) then
-- declaration into a transient block as usual case, otherwise the object
-- would be itself declared in the wrong scope. Therefore, all entities (if
-- any) defined in the transient block are moved to the proper enclosing
- -- scope, furthermore, if they are controlled variables they are finalized
+ -- scope. Furthermore, if they are controlled variables they are finalized
-- right after the declaration. The finalization list of the transient
-- scope is defined as a renaming of the enclosing one so during their
-- initialization they will be attached to the proper finalization list.
S := Current_Scope;
Encl_S := Scope (S);
- -- Insert Actions kept in the Scope stack
+ -- Insert Actions kept in the Scope stack. Since we are not generating
+ -- a block, we must also insert the cleanup actions in the tree now.
- Insert_Actions_In_Scope_Around (N);
+ Insert_Actions_In_Scope_Around (N, Clean => True);
-- If the declaration is consuming some secondary stack, mark the
-- enclosing scope appropriately.
with Atree; use Atree;
with Einfo; use Einfo;
+with Elists; use Elists;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Tss; use Exp_Tss;
Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
Vnm : String_Id;
Vid : Entity_Id;
+ Vde : Node_Id;
Aft : constant List_Id := New_List;
+ In_Transient : constant Boolean := Scope_Is_Transient;
+
+ function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id;
+ -- Return a procedure call statement for lock proc RTE
+
+ --------------------------------
+ -- Build_Shared_Var_Lock_Call --
+ --------------------------------
+
+ function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id is
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE), Loc),
+ Parameter_Associations =>
+ New_List (New_Occurrence_Of (Vid, Loc)));
+ end Build_Shared_Var_Lock_Call;
+
+ -- Start of processing for Add_Shared_Var_Lock_Procs
+
begin
+ -- Discussion of transient scopes: we need to have a transient scope
+ -- to hold the required lock/unlock actions. Either the current scope
+ -- is transient, in which case we reuse it, or we establish a new
+ -- transient scope. If this is a function call with unconstrained
+ -- return type, we can't introduce a transient scope here (because
+ -- Wrap_Transient_Expression would need to declare a temporary with
+ -- the unconstrained type outside of the transient block), but in that
+ -- case we know that we have already established one at an outer level
+ -- for secondary stack management purposes.
+
+ -- If the lock/read/write/unlock actions for this object have already
+ -- been emitted in the current scope, no need to perform them anew.
+
+ if In_Transient
+ and then Contains (Scope_Stack.Table (Scope_Stack.Last)
+ .Locked_Shared_Objects,
+ Obj)
+ then
+ return;
+ end if;
+
Build_Full_Name (Obj, Vnm);
- -- Create constant string. Note that this must be done prior to
- -- establishing the transient scope, as the finalizer needs to have
- -- access to this object.
+ -- Declare a constant string to hold the name of the shared object.
+ -- Note that this must occur outside of the transient scope, as the
+ -- scope's finalizer needs to have access to this object. Also, it
+ -- appears that GIGI does not support elaborating string literal
+ -- subtypes in transient scopes.
Vid := Make_Temporary (Loc, 'N', Obj);
- Insert_Action (N,
- Make_Object_Declaration (Loc,
+ Vde := Make_Object_Declaration (Loc,
Defining_Identifier => Vid,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => Make_String_Literal (Loc, Vnm)));
+ Expression => Make_String_Literal (Loc, Vnm));
- -- Now set up a transient scope around the call, which will hold the
- -- required lock/unlock actions.
+ if In_Transient then
- Establish_Transient_Scope (N, Sec_Stack => False);
+ -- Already in a transient scope: make sure we insert Vde outside
+ -- that scope.
+
+ Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde);
+
+ else
+ -- Not in a transient scope yet: insert Vde as an action on N prio
+ -- to establishing one.
+
+ Insert_Action (N, Vde);
+
+ Establish_Transient_Scope (N, Sec_Stack => False);
+ end if;
+
+ -- Mark object as locked in the current (transient) scope
+
+ declare
+ Locked_Shared_Objects : Elist_Id renames
+ Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects;
+ begin
+ if Locked_Shared_Objects = No_Elist then
+ Locked_Shared_Objects := New_Elmt_List;
+ end if;
+
+ Append_Elmt (Obj, To => Locked_Shared_Objects);
+ end;
-- First insert the Lock call before
- Insert_Action (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
- Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc))));
+ Insert_Action (N, Build_Shared_Var_Lock_Call (RE_Shared_Var_Lock));
-- Now, right after the Lock, insert a call to read the object
- Insert_Action (N,
- Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
+ Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
- -- Now for a procedure call, but not a function call, insert the
- -- call to write the object just before the unlock.
+ -- For a procedure call only, insert the call to write the object prior
+ -- to unlocking.
if Nkind (N) = N_Procedure_Call_Statement then
- Append_To (Aft,
- Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
+ Append_To (Aft, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
end if;
- -- Finally insert the Unlock call after
+ -- Finally insert the Unlock call
+
+ Append_To (Aft, Build_Shared_Var_Lock_Call (RE_Shared_Var_Unlock));
- Append_To (Aft,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
- Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc))));
+ -- Store cleanup actions in transient scope
Store_Cleanup_Actions_In_Scope (Aft);
- if Nkind (N) = N_Procedure_Call_Statement then
- Wrap_Transient_Statement (N);
- else
- Wrap_Transient_Expression (N);
+ -- If we have established a transient scope here, wrap it now
+
+ if not In_Transient then
+ if Nkind (N) = N_Procedure_Call_Statement then
+ Wrap_Transient_Statement (N);
+ else
+ Wrap_Transient_Expression (N);
+ end if;
end if;
end Add_Shared_Var_Lock_Procs;
-- Task Attributes --
---------------------
- Default_Attribute_Count : constant := 16;
- -- Number of pre-allocated Address-sized task attributes stored in the
- -- task control block.
+ Max_Attribute_Count : constant := 32;
+ -- Number of task attributes stored in the task control block.
--------------------
-- Runtime Traces --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
-- Task Attributes --
---------------------
- Default_Attribute_Count : constant := 4;
- -- Number of pre-allocated Address-sized task attributes stored in the
- -- task control block.
+ Max_Attribute_Count : constant := 32;
+ -- Number of task attributes stored in the task control block.
--------------------
-- Runtime Traces --
-- Task Attributes --
---------------------
- Default_Attribute_Count : constant := 16;
- -- Number of pre-allocated Address-sized task attributes stored in the
- -- task control block.
+ Max_Attribute_Count : constant := 32;
+ -- Number of task attributes stored in the task control block.
--------------------
-- Runtime Traces --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
-- Task Attributes --
---------------------
- Default_Attribute_Count : constant := 4;
- -- Number of pre-allocated Address-sized task attributes stored in the
- -- task control block.
+ Max_Attribute_Count : constant := 16;
+ -- Number of task attributes stored in the task control block.
--------------------
-- Runtime Traces --
-- Task Attributes --
---------------------
- Default_Attribute_Count : constant := 16;
- -- Number of pre-allocated Address-sized task attributes stored in the
- -- task control block.
+ Max_Attribute_Count : constant := 32;
+ -- Number of task attributes stored in the task control block.
--------------------
-- Runtime Traces --
with System.Soft_Links;
with System.Soft_Links.Tasking;
with System.Tasking.Debug;
+with System.Tasking.Task_Attributes;
with System.Parameters;
with System.Secondary_Stack;
end if;
end Wakeup_Entry_Caller;
- -----------------------
- -- Soft-Link Dummies --
- -----------------------
-
- -- These are dummies for subprograms that are only needed by certain
- -- optional run-time system packages. If they are needed, the soft links
- -- will be redirected to the real subprogram by elaboration of the
- -- subprogram body where the real subprogram is declared.
+ -------------------------
+ -- Finalize_Attributes --
+ -------------------------
procedure Finalize_Attributes (T : Task_Id) is
- pragma Unreferenced (T);
+ Attr : Atomic_Address;
begin
- null;
- end Finalize_Attributes;
+ for J in T.Attributes'Range loop
+ Attr := T.Attributes (J);
- procedure Initialize_Attributes (T : Task_Id) is
- pragma Unreferenced (T);
- begin
- null;
- end Initialize_Attributes;
+ if Attr /= 0 and then Task_Attributes.Require_Finalization (J) then
+ Task_Attributes.To_Attribute (Attr).Free (Attr);
+ T.Attributes (J) := 0;
+ end if;
+ end loop;
+ end Finalize_Attributes;
begin
Init_RTS;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
procedure Remove_From_All_Tasks_List (T : Task_Id);
-- Remove T from All_Tasks_List. Call this function with RTS_Lock taken
+ procedure Finalize_Attributes (T : Task_Id);
+ -- Finalize all attributes from T
+ -- This is to be called just before the ATCB is deallocated.
+ -- It relies on the caller holding T.L write-lock on entry.
+
---------------------------------
-- Tasking-Specific Soft Links --
---------------------------------
- -- These permit us to leave out certain portions of the tasking
- -- run-time system if they are not used. They are only used internally
- -- by the tasking run-time system.
-
- -- So far, the only example is support for Ada.Task_Attributes
-
- type Proc_T is access procedure (T : Task_Id);
-
- procedure Finalize_Attributes (T : Task_Id);
- procedure Initialize_Attributes (T : Task_Id);
-
- Finalize_Attributes_Link : Proc_T := Finalize_Attributes'Access;
- -- should be called with abort deferred and T.L write-locked
-
- Initialize_Attributes_Link : Proc_T := Initialize_Attributes'Access;
- -- should be called with abort deferred, but holding no locks
-
-------------------------
-- Abort Defer/Undefer --
-------------------------
type Entry_Call_Array is array (ATC_Level_Index) of
aliased Entry_Call_Record;
- type Direct_Index is range 0 .. Parameters.Default_Attribute_Count;
- subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last;
- -- Attributes with indexes in this range are stored directly in the task
- -- control block. Such attributes must be Address-sized. Other attributes
- -- will be held in dynamically allocated records chained off of the task
- -- control block.
-
- type Direct_Attribute_Element is mod Memory_Size;
- pragma Atomic (Direct_Attribute_Element);
-
- type Direct_Attribute_Array is
- array (Direct_Index_Range) of aliased Direct_Attribute_Element;
-
- type Direct_Index_Vector is mod 2 ** Parameters.Default_Attribute_Count;
- -- This is a bit-vector type, used to store information about
- -- the usage of the direct attribute fields.
+ type Atomic_Address is mod Memory_Size;
+ pragma Atomic (Atomic_Address);
+ type Attribute_Array is
+ array (1 .. Parameters.Max_Attribute_Count) of Atomic_Address;
+ -- Array of task attributes.
+ -- The value (Atomic_Address) will either be converted to a task
+ -- attribute if it fits, or to a pointer to a record by Ada.Task_Attributes
type Task_Serial_Number is mod 2 ** 64;
-- Used to give each task a unique serial number
-- User-writeable location, for use in debugging tasks; also provides a
-- simple task specific data.
- Direct_Attributes : Direct_Attribute_Array;
- -- For task attributes that have same size as Address
-
- Is_Defined : Direct_Index_Vector := 0;
- -- Bit I is 1 iff Direct_Attributes (I) is defined
-
- Indirect_Attributes : Access_Address;
- -- A pointer to chain of records for other attributes that are not
- -- address-sized, including all tagged types.
+ Attributes : Attribute_Array := (others => 0);
+ -- Task attributes
Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num);
-- An array of task entry queues
SSL.Create_TSD (T.Common.Compiler_Data);
T.Common.Activation_Link := Chain.T_ID;
Chain.T_ID := T;
- Initialization.Initialize_Attributes_Link.all (T);
Created_Task := T;
Initialization.Undefer_Abort_Nestable (Self_ID);
Initialization.Task_Lock (Self_Id);
Lock_RTS;
- Initialization.Finalize_Attributes_Link.all (T);
+ Initialization.Finalize_Attributes (T);
Initialization.Remove_From_All_Tasks_List (T);
Unlock_RTS;
end if;
Write_Lock (T);
- Initialization.Finalize_Attributes_Link.all (T);
+ Initialization.Finalize_Attributes (T);
Unlock (T);
if Single_Lock then
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2013, AdaCore --
+-- Copyright (C) 1995-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Conversion;
-
-with System.Task_Primitives.Operations;
-with System.Tasking.Initialization;
+with System.Parameters; use System.Parameters;
+with System.Tasking.Initialization; use System.Tasking.Initialization;
package body System.Tasking.Task_Attributes is
- use Task_Primitives.Operations;
- use Tasking.Initialization;
+ ----------------
+ -- Next_Index --
+ ----------------
- function To_Access_Address is new Ada.Unchecked_Conversion
- (Access_Node, Access_Address);
- -- Store pointer to indirect attribute list
+ type Index_Info is record
+ Used, Require_Finalization : Boolean;
+ end record;
+ -- Used is True if a given index is used by an instantiation of
+ -- Ada.Task_Attributes, False otherwise.
+ -- Require_Finalization is True is the attribute requires finalization.
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (X : in out Instance) is
- Q, To_Be_Freed : Access_Node;
- Self_Id : constant Task_Id := Self;
+ Index_Array : array (1 .. Max_Attribute_Count) of Index_Info :=
+ (others => (False, False));
+ function Next_Index (Require_Finalization : Boolean) return Integer is
+ Self_Id : constant Task_Id := Self;
begin
- -- Defer abort. Note that we use the nestable versions of Defer_Abort
- -- and Undefer_Abort, because abort can already deferred when this is
- -- called during finalization, which would cause an assert failure
- -- in Defer_Abort.
-
- Defer_Abort_Nestable (Self_Id);
- Lock_RTS;
-
- -- Remove this instantiation from the list of all instantiations
-
- declare
- P : Access_Instance;
- Q : Access_Instance := All_Attributes;
-
- begin
- while Q /= null and then Q /= X'Unchecked_Access loop
- P := Q; Q := Q.Next;
- end loop;
-
- pragma Assert (Q /= null);
-
- if P = null then
- All_Attributes := Q.Next;
- else
- P.Next := Q.Next;
+ Task_Lock (Self_Id);
+
+ for J in Index_Array'Range loop
+ if not Index_Array (J).Used then
+ Index_Array (J).Used := True;
+ Index_Array (J).Require_Finalization := Require_Finalization;
+ Task_Unlock (Self_Id);
+ return J;
end if;
- end;
-
- if X.Index /= 0 then
-
- -- Free location of this attribute, for reuse
-
- In_Use := In_Use and not (2**Natural (X.Index));
-
- -- There is no need for finalization in this case, since controlled
- -- types are too big to fit in the TCB.
-
- else
- -- Remove nodes for this attribute from the lists of all tasks,
- -- and deallocate the nodes. Deallocation does finalization, if
- -- necessary.
-
- declare
- C : System.Tasking.Task_Id := All_Tasks_List;
- P : Access_Node;
-
- begin
- while C /= null loop
- Write_Lock (C);
-
- Q := To_Access_Node (C.Indirect_Attributes);
- while Q /= null
- and then Q.Instance /= X'Unchecked_Access
- loop
- P := Q;
- Q := Q.Next;
- end loop;
-
- if Q /= null then
- if P = null then
- C.Indirect_Attributes := To_Access_Address (Q.Next);
- else
- P.Next := Q.Next;
- end if;
-
- -- Can't Deallocate now since we are holding RTS_Lock
-
- Q.Next := To_Be_Freed;
- To_Be_Freed := Q;
- end if;
-
- Unlock (C);
- C := C.Common.All_Tasks_Link;
- end loop;
- end;
- end if;
-
- Unlock_RTS;
-
- while To_Be_Freed /= null loop
- Q := To_Be_Freed;
- To_Be_Freed := To_Be_Freed.Next;
- X.Deallocate.all (Q);
end loop;
- Undefer_Abort_Nestable (Self_Id);
+ Task_Unlock (Self_Id);
+ raise Storage_Error with "Out of task attributes";
+ end Next_Index;
- exception
- when others =>
- null;
- pragma Assert (False,
- "Exception in task attribute instance finalization");
- end Finalize;
-
- -------------------------
- -- Finalize Attributes --
- -------------------------
-
- -- This is to be called just before the ATCB is deallocated.
- -- It relies on the caller holding T.L write-lock on entry.
-
- procedure Finalize_Attributes (T : Task_Id) is
- P : Access_Node;
- Q : Access_Node := To_Access_Node (T.Indirect_Attributes);
-
- begin
- -- Deallocate all the indirect attributes of this task
-
- while Q /= null loop
- P := Q;
- Q := Q.Next; P.Instance.Deallocate.all (P);
- end loop;
-
- T.Indirect_Attributes := null;
-
- exception
- when others =>
- null;
- pragma Assert (False,
- "Exception in per-task attributes finalization");
- end Finalize_Attributes;
-
- ---------------------------
- -- Initialize Attributes --
- ---------------------------
-
- -- This is to be called by System.Tasking.Stages.Create_Task
+ --------------
+ -- Finalize --
+ --------------
- procedure Initialize_Attributes (T : Task_Id) is
- P : Access_Instance;
+ procedure Finalize (Index : Integer) is
Self_Id : constant Task_Id := Self;
-
begin
- -- Note: we call [Un]Defer_Abort_Nestable, rather than [Un]Defer_Abort,
- -- because Abort might already be deferred in Create_Task.
-
- Defer_Abort_Nestable (Self_Id);
- Lock_RTS;
-
- -- Initialize all the direct-access attributes of this task
-
- P := All_Attributes;
-
- while P /= null loop
- if P.Index /= 0 then
- T.Direct_Attributes (P.Index) :=
- Direct_Attribute_Element
- (System.Storage_Elements.To_Address (P.Initial_Value));
- end if;
-
- P := P.Next;
- end loop;
-
- Unlock_RTS;
- Undefer_Abort_Nestable (Self_Id);
+ pragma Assert (Index in Index_Array'Range);
+ Task_Lock (Self_Id);
+ Index_Array (Index).Used := False;
+ Task_Unlock (Self_Id);
+ end Finalize;
- exception
- when others =>
- null;
- pragma Assert (False);
- end Initialize_Attributes;
+ function Require_Finalization (Index : Integer) return Boolean is
+ begin
+ pragma Assert (Index in Index_Array'Range);
+ return Index_Array (Index).Require_Finalization;
+ end Require_Finalization;
end System.Tasking.Task_Attributes;
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2010, AdaCore --
+-- Copyright (C) 1995-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
-- This package provides support for the body of Ada.Task_Attributes
-with Ada.Finalization;
-
-with System.Storage_Elements;
+with Ada.Unchecked_Conversion;
package System.Tasking.Task_Attributes is
- type Attribute is new Integer;
- -- A stand-in for the generic formal type of Ada.Task_Attributes
- -- in the following declarations.
-
- type Node;
- type Access_Node is access all Node;
- -- This needs comments ???
-
- function To_Access_Node is new Ada.Unchecked_Conversion
- (Access_Address, Access_Node);
- -- Used to fetch pointer to indirect attribute list. Declaration is in
- -- spec to avoid any problems with aliasing assumptions.
-
- type Dummy_Wrapper;
- type Access_Dummy_Wrapper is access all Dummy_Wrapper;
- pragma No_Strict_Aliasing (Access_Dummy_Wrapper);
- -- Needed to avoid possible incorrect aliasing situations from
- -- instantiation of Unchecked_Conversion in body of Ada.Task_Attributes.
-
- for Access_Dummy_Wrapper'Storage_Size use 0;
- -- Access_Dummy_Wrapper is a stand-in for the generic type Wrapper defined
- -- in Ada.Task_Attributes. The real objects allocated are always
- -- of type Wrapper, no Dummy_Wrapper objects are ever created.
-
- type Deallocator is access procedure (P : in out Access_Node);
- -- Called to deallocate an Wrapper. P is a pointer to a Node within
+ type Deallocator is access procedure (Ptr : Atomic_Address);
- type Instance;
-
- type Access_Instance is access all Instance;
-
- type Instance is new Ada.Finalization.Limited_Controlled with record
- Deallocate : Deallocator;
- Initial_Value : aliased System.Storage_Elements.Integer_Address;
-
- Index : Direct_Index;
- -- The index of the TCB location used by this instantiation, if it is
- -- stored in the TCB, otherwise zero.
-
- Next : Access_Instance;
- -- Next instance in All_Attributes list
+ type Attribute_Record is record
+ Free : Deallocator;
end record;
-
- procedure Finalize (X : in out Instance);
-
- type Node is record
- Wrapper : Access_Dummy_Wrapper;
- Instance : Access_Instance;
- Next : Access_Node;
- end record;
-
- -- The following type is a stand-in for the actual wrapper type, which is
- -- different for each instantiation of Ada.Task_Attributes.
-
- type Dummy_Wrapper is record
- Dummy_Node : aliased Node;
-
- Value : aliased Attribute;
- -- The generic formal type, may be controlled
- end record;
-
- for Dummy_Wrapper'Alignment use Standard'Maximum_Alignment;
- -- A number of unchecked conversions involving Dummy_Wrapper_Access
- -- sources are performed in other units (e.g. Ada.Task_Attributes).
- -- Ensure that the designated object is always strictly enough aligned.
-
- In_Use : Direct_Index_Vector := 0;
- -- Set True for direct indexes that are already used (True??? type???)
-
- All_Attributes : Access_Instance;
- -- A linked list of all indirectly access attributes, which includes all
- -- those that require finalization.
-
- procedure Initialize_Attributes (T : Task_Id);
- -- Initialize all attributes created via Ada.Task_Attributes for T. This
- -- must be called by the creator of the task, inside Create_Task, via
- -- soft-link Initialize_Attributes_Link. On entry, abort must be deferred
- -- and the caller must hold no locks
-
- procedure Finalize_Attributes (T : Task_Id);
- -- Finalize all attributes created via Ada.Task_Attributes for T.
- -- This is to be called by the task after it is marked as terminated
- -- (and before it actually dies), inside Vulnerable_Free_Task, via the
- -- soft-link Finalize_Attributes_Link. On entry, abort must be deferred
- -- and T.L must be write-locked.
-
+ -- The real type is declared in Ada.Task_Attributes body: Real_Attribute
+ -- As long as the first field is the deallocator we are good.
+
+ type Attribute_Access is access all Attribute_Record;
+ pragma No_Strict_Aliasing (Attribute_Access);
+
+ function To_Attribute is new
+ Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access);
+
+ function Next_Index (Require_Finalization : Boolean) return Integer;
+ -- Return the next attribute index available.
+ -- Require_Finalization is True if the attribute requires finalization
+ -- and in particular its deallocator (Free field in Attribute_Record)
+ -- should be called.
+ -- Raise Storage_Error if no index is available.
+
+ function Require_Finalization (Index : Integer) return Boolean;
+ -- Return True if a given attribute index requires call to Free.
+ -- This call is not protected against concurrent access, should only
+ -- be called during finalization of the corresponding instantiation of
+ -- Ada.Task_Attributes, or during finalization of a task.
+
+ procedure Finalize (Index : Integer);
+ -- Finalize given Index, possibly allowing future reuse
+
+private
+ pragma Inline (Finalize);
+ pragma Inline (Require_Finalization);
end System.Tasking.Task_Attributes;
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2014, Free Software Foundation, Inc. --
-- --
-- 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- --
System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data);
- -- ???
- -- The following call is commented out to avoid dependence on the
- -- System.Tasking.Initialization package. It seems that if we want
- -- Ada.Task_Attributes to work correctly for C threads we will need to
- -- raise the visibility of this soft link to System.Soft_Links. We are
- -- putting that off until this new functionality is otherwise stable.
-
- -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
-
Enter_Task (Self_Id);
return Self_Id;
-- Standard_Standard can be pushed anew on the scope stack to start a
-- new active section (see comment above).
+ Locked_Shared_Objects : Elist_Id;
+ -- List of shared passive protected objects that have been locked in
+ -- this transient scope (always No_Elist for non-transient scopes).
end record;
package Scope_Stack is new Table.Table (
SST.First_Use_Clause := Empty;
SST.Is_Active_Stack_Base := False;
SST.Previous_Visibility := False;
+ SST.Locked_Shared_Objects := No_Elist;
end;
if Debug_Flag_W then
projects / gcc.git / commitdiff