[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

18 files changed, 459 insertions, 802 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4c260ca..499853e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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
diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb
index ae2a715..bd7f4a7 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 9649505..32b254f 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 819de1d..a870660 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 1b3142c..b5e5d32 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 359e694..a76048d 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 ed3cd6c..f64b0bb 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 748e7d8..73007b9 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 a0b87fd..4ba0880 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 45c99cd..66734b1 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 70dd867..831961a 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 fc9975c..9a47c6a 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 f8a8a71..b116569 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 e812d14..1444026 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 25cd2e5..878dc40 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 1da2290..32bb1f0 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 681df14..f70c056 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 ccfc208..03e59d6 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