From 8071b771263555ea070313762f0d6c552934bc10 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 30 Jul 2014 15:43:32 +0200 Subject: [PATCH] [multiple changes] 2014-07-30 Thomas Quinot * 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 * 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 --- gcc/ada/ChangeLog | 34 ++ gcc/ada/a-tasatt.adb | 586 ++++++++++----------------------- gcc/ada/exp_ch7.adb | 48 ++- gcc/ada/exp_smem.adb | 123 +++++-- gcc/ada/s-parame-hpux.ads | 5 +- gcc/ada/s-parame-vms-alpha.ads | 7 +- gcc/ada/s-parame-vms-ia64.ads | 5 +- gcc/ada/s-parame-vxworks.ads | 7 +- gcc/ada/s-parame.ads | 5 +- gcc/ada/s-tasini.adb | 29 +- gcc/ada/s-tasini.ads | 24 +- gcc/ada/s-taskin.ads | 34 +- gcc/ada/s-tassta.adb | 5 +- gcc/ada/s-tataat.adb | 212 +++--------- gcc/ada/s-tataat.ads | 122 ++----- gcc/ada/s-tporft.adb | 11 +- gcc/ada/sem.ads | 3 + gcc/ada/sem_ch8.adb | 1 + 18 files changed, 459 insertions(+), 802 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4c260cac39e..499853eb9df 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2014-07-30 Thomas Quinot + + * 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 + + * 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 * vxworks-ppc-link.spec: New file. Extra link diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb index ae2a715d601..bd7f4a74e90 100644 --- a/gcc/ada/a-tasatt.adb +++ b/gcc/ada/a-tasatt.adb @@ -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 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; ------------------ @@ -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 - 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; --------------- @@ -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 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; ----------- @@ -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; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 9649505134a..32b254f3e7d 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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; - 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; @@ -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. diff --git a/gcc/ada/exp_smem.adb b/gcc/ada/exp_smem.adb index 819de1d9e5f..a8706603724 100644 --- a/gcc/ada/exp_smem.adb +++ b/gcc/ada/exp_smem.adb @@ -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, 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; diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads index 1b3142ca789..b5e5d32fb5e 100644 --- a/gcc/ada/s-parame-hpux.ads +++ b/gcc/ada/s-parame-hpux.ads @@ -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 -- diff --git a/gcc/ada/s-parame-vms-alpha.ads b/gcc/ada/s-parame-vms-alpha.ads index 359e694d4c5..a76048d2157 100644 --- a/gcc/ada/s-parame-vms-alpha.ads +++ b/gcc/ada/s-parame-vms-alpha.ads @@ -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 -- diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads index ed3cd6c9157..f64b0bb218e 100644 --- a/gcc/ada/s-parame-vms-ia64.ads +++ b/gcc/ada/s-parame-vms-ia64.ads @@ -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 -- diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads index 748e7d81b39..73007b9b0ad 100644 --- a/gcc/ada/s-parame-vxworks.ads +++ b/gcc/ada/s-parame-vxworks.ads @@ -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 -- diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads index a0b87fd831e..4ba08803d9b 100644 --- a/gcc/ada/s-parame.ads +++ b/gcc/ada/s-parame.ads @@ -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 -- diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 45c99cdadce..66734b1651f 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -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; diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads index 70dd867a342..831961a44bf 100644 --- a/gcc/ada/s-tasini.ads +++ b/gcc/ada/s-tasini.ads @@ -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 -- ------------------------- diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index fc9975c661f..9a47c6abe44 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -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 diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index f8a8a71a6d9..b11656970bd 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -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 diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb index e812d1415cb..14440263fb4 100644 --- a/gcc/ada/s-tataat.adb +++ b/gcc/ada/s-tataat.adb @@ -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. - -------------- - -- 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; diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads index 25cd2e5b3db..878dc40d34d 100644 --- a/gcc/ada/s-tataat.ads +++ b/gcc/ada/s-tataat.ads @@ -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 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; diff --git a/gcc/ada/s-tporft.adb b/gcc/ada/s-tporft.adb index 1da22901997..32bb1f08db9 100644 --- a/gcc/ada/s-tporft.adb +++ b/gcc/ada/s-tporft.adb @@ -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; diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 681df14671a..f70c0568554 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -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 ( diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index ccfc2084bf4..03e59d6634d 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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 -- 2.30.2