[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

gcc/ada/ChangeLog

+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

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.

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;
 

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 --

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 --

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 --

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 --

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 --

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;

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 --
    -------------------------

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

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

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;

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;

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;

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 (

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