exp_ch3.adb (Expand_Freeze_Array_Type): Correct the call to…

exp_ch3.adb (Expand_Freeze_Array_Type): Correct the call to Build_Finalization_Master by supplying an insertion node...

2011-08-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch3.adb (Expand_Freeze_Array_Type): Correct the call to
	Build_Finalization_Master by supplying an insertion node and enclosing
	scope. In its old version, the call did not generate a finalization
	master.
	(Expand_Freeze_Record_Type): Add local variable Has_AACC. Add code to
	recognize anonymous access-to-controlled components. Rewrite the
	machinery which creates finalization masters to service anonymous
	access-to-controlled components of a record type. In its current state,
	only one heterogeneous master is necessary to handle multiple anonymous
	components.
	(Freeze_Type): Comment reformatting.
	* rtsfind.ads: Add RE_Set_Is_Heterogeneous to tables RE_Id and
	RE_Unit_Table.
	* s-stposu.adb (Allocate_Any_Controlled): Rewrite the machinery which
	associates TSS primitive Finalize_Address with either the master itself
	or with the internal hash table depending on the mode of operation of
	the master.

From-SVN: r178301

gcc/ada/ChangeLog

+2011-08-30  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* exp_ch3.adb (Expand_Freeze_Array_Type): Correct the call to
+	Build_Finalization_Master by supplying an insertion node and enclosing
+	scope. In its old version, the call did not generate a finalization
+	master.
+	(Expand_Freeze_Record_Type): Add local variable Has_AACC. Add code to
+	recognize anonymous access-to-controlled components. Rewrite the
+	machinery which creates finalization masters to service anonymous
+	access-to-controlled components of a record type. In its current state,
+	only one heterogeneous master is necessary to handle multiple anonymous
+	components.
+	(Freeze_Type): Comment reformatting.
+	* rtsfind.ads: Add RE_Set_Is_Heterogeneous to tables RE_Id and
+	RE_Unit_Table.
+	* s-stposu.adb (Allocate_Any_Controlled): Rewrite the machinery which
+	associates TSS primitive Finalize_Address with either the master itself
+	or with the internal hash table depending on the mode of operation of
+	the master.
+
 2011-08-30  Javier Miranda  <miranda@adacore.com>
 
 	* exp_ch3.adb (Make_Eq_If): If the etype of the _parent component is an

gcc/ada/exp_ch3.adb

@@ -5522,14 +5522,18 @@ package body Exp_Ch3 is
                then
                   Build_Slice_Assignment (Typ);
                end if;
+            end if;
 
-            --  ??? Now that masters acts as heterogeneous lists, it might be
-            --  worthwhile to revisit the global master approach.
+            --  Create a finalization master to service the anonymous access
+            --  components of the array.
 
-            elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
-              and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
+            if Ekind (Comp_Typ) = E_Anonymous_Access_Type
+              and then Needs_Finalization (Designated_Type (Comp_Typ))
             then
-               Build_Finalization_Master (Comp_Typ);
+               Build_Finalization_Master
+                 (Typ        => Comp_Typ,
+                  Ins_Node   => Parent (Typ),
+                  Encl_Scope => Scope (Typ));
             end if;
          end if;
 
@@ -5943,6 +5947,7 @@ package body Exp_Ch3 is
       Type_Decl   : constant Node_Id := Parent (Def_Id);
       Comp        : Entity_Id;
       Comp_Typ    : Entity_Id;
+      Has_AACC    : Boolean;
       Predef_List : List_Id;
 
       Renamed_Eq : Node_Id := Empty;
@@ -6011,8 +6016,9 @@ package body Exp_Ch3 is
 
       --  Update task and controlled component flags, because some of the
       --  component types may have been private at the point of the record
-      --  declaration.
+      --  declaration. Detect anonymous access-to-controlled components.
 
+      Has_AACC := False;
       Comp := First_Component (Def_Id);
       while Present (Comp) loop
          Comp_Typ := Etype (Comp);
@@ -6029,6 +6035,14 @@ package body Exp_Ch3 is
                                 and then Is_Controlled (Comp_Typ)))
          then
             Set_Has_Controlled_Component (Def_Id);
+
+         --  Non self-referential anonymous access-to-controlled component
+
+         elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
+           and then Needs_Finalization (Designated_Type (Comp_Typ))
+           and then Designated_Type (Comp_Typ) /= Def_Id
+         then
+            Has_AACC := True;
          end if;
 
          Next_Component (Comp);
@@ -6396,28 +6410,103 @@ package body Exp_Ch3 is
          end;
       end if;
 
-      --  Processing for components of anonymous access type that designate
-      --  a controlled type.
+      --  Create a heterogeneous finalization master to service the anonymous
+      --  access-to-controlled components of the record type.
 
-      Comp := First_Component (Def_Id);
-      while Present (Comp) loop
-         Comp_Typ := Etype (Comp);
+      if Has_AACC then
+         declare
+            Encl_Scope : constant Entity_Id  := Scope (Def_Id);
+            Ins_Node   : constant Node_Id    := Parent (Def_Id);
+            Loc        : constant Source_Ptr := Sloc (Def_Id);
+            Fin_Mas_Id : Entity_Id;
+
+            Attributes_Set : Boolean := False;
+            Master_Built   : Boolean := False;
+            --  Two flags which control the creation and initialization of a
+            --  common heterogeneous master.
+
+         begin
+            Comp := First_Component (Def_Id);
+            while Present (Comp) loop
+               Comp_Typ := Etype (Comp);
 
-         if Ekind (Comp_Typ) = E_Anonymous_Access_Type
-           and then Needs_Finalization (Directly_Designated_Type (Comp_Typ))
+               --  A non self-referential anonymous access-to-controlled
+               --  component.
 
-            --  Avoid self-references
+               if Ekind (Comp_Typ) = E_Anonymous_Access_Type
+                 and then Needs_Finalization (Designated_Type (Comp_Typ))
+                 and then Designated_Type (Comp_Typ) /= Def_Id
+               then
+                  if VM_Target = No_VM then
 
-           and then Directly_Designated_Type (Comp_Typ) /= Def_Id
-         then
-            Build_Finalization_Master
-             (Typ        => Comp_Typ,
-              Ins_Node   => Parent (Def_Id),
-              Encl_Scope => Scope (Def_Id));
-         end if;
+                     --  Build a homogeneous master for the first anonymous
+                     --  access-to-controlled component. This master may be
+                     --  converted into a heterogeneous collection if more
+                     --  components are to follow.
 
-         Next_Component (Comp);
-      end loop;
+                     if not Master_Built then
+                        Master_Built := True;
+
+                        --  All anonymous access-to-controlled types allocate
+                        --  on the global pool.
+
+                        Set_Associated_Storage_Pool (Comp_Typ,
+                          Get_Global_Pool_For_Access_Type (Comp_Typ));
+
+                        Build_Finalization_Master
+                          (Typ        => Comp_Typ,
+                           Ins_Node   => Ins_Node,
+                           Encl_Scope => Encl_Scope);
+
+                        Fin_Mas_Id := Finalization_Master (Comp_Typ);
+
+                     --  Subsequent anonymous access-to-controlled components
+                     --  reuse the already available master.
+
+                     else
+                        --  All anonymous access-to-controlled types allocate
+                        --  on the global pool.
+
+                        Set_Associated_Storage_Pool (Comp_Typ,
+                          Get_Global_Pool_For_Access_Type (Comp_Typ));
+
+                        --  Shared the master among multiple components
+
+                        Set_Finalization_Master (Comp_Typ, Fin_Mas_Id);
+
+                        --  Convert the master into a heterogeneous collection.
+                        --  Generate:
+                        --
+                        --    Set_Is_Heterogeneous (<Fin_Mas_Id>);
+
+                        if not Attributes_Set then
+                           Attributes_Set := True;
+
+                           Insert_Action (Ins_Node,
+                             Make_Procedure_Call_Statement (Loc,
+                               Name =>
+                                 New_Reference_To
+                                   (RTE (RE_Set_Is_Heterogeneous), Loc),
+                               Parameter_Associations => New_List (
+                                 New_Reference_To (Fin_Mas_Id, Loc))));
+                        end if;
+                     end if;
+
+                  --  Since .NET/JVM targets do not support heterogeneous
+                  --  masters, each component must have its own master.
+
+                  else
+                     Build_Finalization_Master
+                       (Typ        => Comp_Typ,
+                        Ins_Node   => Ins_Node,
+                        Encl_Scope => Encl_Scope);
+                  end if;
+               end if;
+
+               Next_Component (Comp);
+            end loop;
+         end;
+      end if;
    end Expand_Freeze_Record_Type;
 
    ------------------------------
@@ -6738,8 +6827,8 @@ package body Exp_Ch3 is
             then
                null;
 
-            --  The machinery assumes that incomplete or private types are
-            --  always completed by a controlled full vies.
+            --  Assume that incomplete and private types are always completed
+            --  by a controlled full view.
 
             elsif Needs_Finalization (Desig_Type)
               or else

gcc/ada/rtsfind.ads

@@ -803,6 +803,7 @@ package Rtsfind is
      RE_Finalization_Master_Ptr,         -- System.Finalization_Masters
      RE_Set_Base_Pool,                   -- System.Finalization_Masters
      RE_Set_Finalize_Address,            -- System.Finalization_Masters
+     RE_Set_Is_Heterogeneous,            -- System.Finalization_Masters
 
      RE_Root_Controlled,                 -- System.Finalization_Root
      RE_Root_Controlled_Ptr,             -- System.Finalization_Root
@@ -1991,6 +1992,7 @@ package Rtsfind is
      RE_Finalization_Master_Ptr          => System_Finalization_Masters,
      RE_Set_Base_Pool                    => System_Finalization_Masters,
      RE_Set_Finalize_Address             => System_Finalization_Masters,
+     RE_Set_Is_Heterogeneous             => System_Finalization_Masters,
 
      RE_Root_Controlled                  => System_Finalization_Root,
      RE_Root_Controlled_Ptr              => System_Finalization_Root,

gcc/ada/s-stposu.adb

@@ -269,25 +269,25 @@ package body System.Storage_Pools.Subpools is
 
          Addr := N_Addr + Header_And_Padding;
 
-         --  Subpool allocations use heterogeneous masters to manage various
-         --  controlled objects. Associate a Finalize_Address with the object.
-         --  This relation pair is deleted when the object is deallocated or
-         --  when the associated master is finalized.
-
-         if Is_Subpool_Allocation then
-            pragma Assert (not Master.Is_Homogeneous);
-
-            Set_Finalize_Address (Addr, Fin_Address);
-            Finalize_Address_Table_In_Use := True;
-
-         --  Normal allocations chain objects on homogeneous collections
-
-         else
-            pragma Assert (Master.Is_Homogeneous);
+         --  Homogeneous masters service the following:
+         --
+         --    1) Allocations on / Deallocations from regular pools
+         --    2) Named access types
+         --    3) Most cases of anonymous access types usage
 
+         if Master.Is_Homogeneous then
             if Finalize_Address (Master.all) = null then
                Set_Finalize_Address (Master.all, Fin_Address);
             end if;
+
+         --  Heterogeneous masters service the following:
+         --
+         --    1) Allocations on / Deallocations from subpools
+         --    2) Certain cases of anonymous access types usage
+
+         else
+            Set_Finalize_Address (Addr, Fin_Address);
+            Finalize_Address_Table_In_Use := True;
          end if;
 
       --  Non-controlled allocation