OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r213265
This commit is contained in:
Arnaud Charlet 2014-07-30 15:43:32 +02:00
parent 4bd4bb7f0c
commit 8071b77126
18 changed files with 458 additions and 801 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
gcc/ada/ChangeLog
View File

@ -1,3 +1,37 @@
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

592
gcc/ada/a-tasatt.adb
View File

@ -6,8 +6,7 @@
-- --
-- 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- --
@ -30,213 +29,189 @@
-- --
------------------------------------------------------------------------------
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 Ada.Exceptions;
with System.Task_Primitives.Operations;
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 POP renames System.Task_Primitives.Operations;
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
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 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.
type Wrapper;
type Access_Wrapper is access all Wrapper;
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 --
--------------------------
Local : aliased Instance;
-- Initialized in package body
type Wrapper is record
Dummy_Node : aliased Node;
Value : aliased Attribute := Initial_Value;
-- The generic formal type, may be controlled
end record;
-- A number of unchecked conversions involving Wrapper_Access sources are
-- performed in this unit. We have to ensure that the designated object is
-- always strictly enough aligned.
for Wrapper'Alignment use Standard'Maximum_Alignment;
procedure Free is
new Ada.Unchecked_Deallocation (Wrapper, Access_Wrapper);
procedure Deallocate (P : in out Access_Node) is
T : Access_Wrapper := To_Access_Wrapper (P.Wrapper);
procedure Finalize (Cleanup : in out Attribute_Cleanup) is
pragma Unreferenced (Cleanup);
begin
Free (T);
STPO.Lock_RTS;
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;
STPO.Unlock (C);
C := C.Common.All_Tasks_Link;
end loop;
end;
Finalize (Index);
STPO.Unlock_RTS;
end Finalize;
----------------
-- Deallocate --
----------------
procedure Deallocate (Ptr : Atomic_Address) is
Obj : Real_Attribute_Access := To_Real_Attribute (Ptr);
begin
Free (Obj);
end Deallocate;
-------------------
-- New_Attribute --
-------------------
function New_Attribute (Val : Attribute) return Atomic_Address is
Tmp : Real_Attribute_Access;
begin
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;
if TT.Attributes (Index) = 0 then
TT.Attributes (Index) := New_Attribute (Initial_Value);
end if;
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;
Result := To_Handle
(To_Real_Attribute (TT.Attributes (Index)).Value'Address);
Task_Unlock (Self_Id);
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;
return Result;
end if;
exception
when Tasking_Error | Program_Error =>
raise;
when others =>
raise Program_Error;
end Reference;
------------------
@ -246,68 +221,37 @@ package body Ada.Task_Attributes is
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
Self_Id := STPO.Self;
Task_Lock (Self_Id);
declare
P, Q : Access_Node;
W : Access_Wrapper;
Self_Id : constant Task_Id := POP.Self;
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;
Task_Unlock (Self_Id);
end if;
exception
when Tasking_Error | Program_Error =>
raise;
when others =>
raise Program_Error;
end Reinitialize;
---------------
@ -318,85 +262,38 @@ package body Ada.Task_Attributes is
(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 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 Local.Index /= 0 then
-- Set attribute handle, warnings off, because this code can generate
-- alignment warnings with large attributes (but of course will not
-- be executed in this case, since we never have direct addressing in
-- such cases).
pragma Warnings (Off);
To_Attribute_Handle
(TT.Direct_Attributes (Local.Index)'Address).all := Val;
pragma Warnings (On);
return;
end if;
-- Not directly addressed
declare
P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
W : Access_Wrapper;
Self_Id : constant Task_Id := POP.Self;
begin
Defer_Abort (Self_Id);
POP.Lock_RTS;
while P /= null loop
if P.Instance = Access_Instance'(Local'Unchecked_Access) then
To_Access_Wrapper (P.Wrapper).Value := Val;
POP.Unlock_RTS;
Undefer_Abort (Self_Id);
return;
declare
Attr : Atomic_Address renames TT.Attributes (Index);
begin
if Attr /= 0 then
Deallocate (Attr);
end if;
P := P.Next;
end loop;
Attr := New_Attribute (Val);
end;
-- Unlock RTS here to follow the lock ordering rule that prevent us
-- from using new (i.e the Global_Lock) while holding any other lock.
POP.Unlock_RTS;
W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
POP.Lock_RTS;
P := W.Dummy_Node'Unchecked_Access;
P.Wrapper := To_Access_Dummy_Wrapper (W);
P.Next := To_Access_Node (TT.Indirect_Attributes);
TT.Indirect_Attributes := To_Access_Address (P);
POP.Unlock_RTS;
Undefer_Abort (Self_Id);
exception
when others =>
POP.Unlock_RTS;
Undefer_Abort (Self_Id);
raise;
end;
exception
when Tasking_Error | Program_Error =>
raise;
when others =>
raise Program_Error;
Task_Unlock (Self_Id);
end if;
end Set_Value;
-----------
@ -407,167 +304,42 @@ package body Ada.Task_Attributes is
(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;

48
gcc/ada/exp_ch7.adb
View File

@ -130,9 +130,10 @@ package body Exp_Ch7 is
-- 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;
@ -4589,11 +4590,13 @@ package body Exp_Ch7 is
-- 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.
@ -4930,6 +4933,14 @@ package body Exp_Ch7 is
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);
@ -4944,7 +4955,7 @@ package body Exp_Ch7 is
-- 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;
@ -5011,14 +5022,13 @@ package body Exp_Ch7 is
-- Reset the action lists
if Present (Act_Before) 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 (Before) := No_List;
end if;
if Present (Act_After) 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;
@ -8005,9 +8015,10 @@ package body Exp_Ch7 is
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
@ -8117,7 +8128,7 @@ package body Exp_Ch7 is
-- 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.
@ -8141,9 +8152,10 @@ package body Exp_Ch7 is
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.

123
gcc/ada/exp_smem.adb
View File

@ -25,6 +25,7 @@
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;
@ -133,61 +134,127 @@ package body Exp_Smem is
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,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc))));
Append_To (Aft, Build_Shared_Var_Lock_Call (RE_Shared_Var_Unlock));
-- 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;

5
gcc/ada/s-parame-hpux.ads
View File

@ -180,9 +180,8 @@ package System.Parameters is
-- 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 --

7
gcc/ada/s-parame-vms-alpha.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -183,9 +183,8 @@ package System.Parameters is
-- 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 --

5
gcc/ada/s-parame-vms-ia64.ads
View File

@ -183,9 +183,8 @@ package System.Parameters is
-- 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 --

7
gcc/ada/s-parame-vxworks.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -182,9 +182,8 @@ package System.Parameters is
-- 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 --

5
gcc/ada/s-parame.ads
View File

@ -182,9 +182,8 @@ package System.Parameters is
-- 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 --

29
gcc/ada/s-tasini.adb
View File

@ -45,6 +45,7 @@ with System.Task_Primitives.Operations;
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;
@ -807,26 +808,22 @@ package body System.Tasking.Initialization is
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;

24
gcc/ada/s-tasini.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -37,27 +37,15 @@ package System.Tasking.Initialization is
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 --
-------------------------

34
gcc/ada/s-taskin.ads
View File

@ -938,22 +938,13 @@ package System.Tasking is
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
@ -1139,15 +1130,8 @@ package System.Tasking is
-- 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

5
gcc/ada/s-tassta.adb
View File

@ -707,7 +707,6 @@ package body System.Tasking.Stages is
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);
@ -953,7 +952,7 @@ package body System.Tasking.Stages is
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;
@ -2076,7 +2075,7 @@ package body System.Tasking.Stages is
end if;
Write_Lock (T);
Initialization.Finalize_Attributes_Link.all (T);
Initialization.Finalize_Attributes (T);
Unlock (T);
if Single_Lock then

216
gcc/ada/s-tataat.adb
View File

@ -6,8 +6,7 @@
-- --
-- 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- --
@ -30,189 +29,60 @@
-- --
------------------------------------------------------------------------------
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.
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
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 loop;
Task_Unlock (Self_Id);
raise Storage_Error with "Out of task attributes";
end Next_Index;
--------------
-- Finalize --
--------------
procedure Finalize (X : in out Instance) is
Q, To_Be_Freed : Access_Node;
Self_Id : constant Task_Id := Self;
procedure Finalize (Index : 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;
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);
exception
when others =>
null;
pragma Assert (False,
"Exception in task attribute instance finalization");
pragma Assert (Index in Index_Array'Range);
Task_Lock (Self_Id);
Index_Array (Index).Used := False;
Task_Unlock (Self_Id);
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);
function Require_Finalization (Index : Integer) return Boolean is
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
procedure Initialize_Attributes (T : Task_Id) is
P : Access_Instance;
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);
exception
when others =>
null;
pragma Assert (False);
end Initialize_Attributes;
pragma Assert (Index in Index_Array'Range);
return Index_Array (Index).Require_Finalization;
end Require_Finalization;
end System.Tasking.Task_Attributes;

110
gcc/ada/s-tataat.ads
View File

@ -6,8 +6,7 @@
-- --
-- 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- --
@ -32,96 +31,41 @@
-- 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 Deallocator is access procedure (Ptr : Atomic_Address);
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 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;
-- The real type is declared in Ada.Task_Attributes body: Real_Attribute
-- As long as the first field is the deallocator we are good.
procedure Finalize (X : in out Instance);
type Attribute_Access is access all Attribute_Record;
pragma No_Strict_Aliasing (Attribute_Access);
type Node is record
Wrapper : Access_Dummy_Wrapper;
Instance : Access_Instance;
Next : Access_Node;
end record;
function To_Attribute is new
Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access);
-- The following type is a stand-in for the actual wrapper type, which is
-- different for each instantiation of Ada.Task_Attributes.
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.
type Dummy_Wrapper is record
Dummy_Node : aliased Node;
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.
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.
procedure Finalize (Index : Integer);
-- Finalize given Index, possibly allowing future reuse
private
pragma Inline (Finalize);
pragma Inline (Require_Finalization);
end System.Tasking.Task_Attributes;

11
gcc/ada/s-tporft.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -94,15 +94,6 @@ begin
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;

3
gcc/ada/sem.ads
View File

@ -538,6 +538,9 @@ package Sem is
-- 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 (

1
gcc/ada/sem_ch8.adb
View File

@ -7646,6 +7646,7 @@ package body Sem_Ch8 is
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