exp_ch13.adb: Add with and use clause for Targparm;
authorHristian Kirtchev <kirtchev@adacore.com>
Wed, 3 Aug 2011 14:42:53 +0000 (14:42 +0000)
committerArnaud Charlet <charlet@gcc.gnu.org>
Wed, 3 Aug 2011 14:42:53 +0000 (16:42 +0200)
2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>

* exp_ch13.adb: Add with and use clause for Targparm;
(Expand_N_Free_Statement): Prevent the generation of a custom
Deallocate on .NET/JVM targets since this requires pools and address
arithmetic.
* exp_ch4.adb (Expand_Allocator_Expression): When compiling for
.NET/JVM targets, attach the newly allocated object to the access
type's finalization collection. Do not generate a call to
Set_Finalize_Address_Ptr on .NET/JVM because this routine does not
exist in the runtime.
(Expand_N_Allocator): When compiling for .NET/JVM targets, do not
create a custom Allocate for object that do not require initialization.
Attach a newly allocated object to the access type's finalization
collection on .NET/JVM.
* exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add special processing for
assignment of controlled types on .NET/JVM. The two hidden pointers
Prev and Next and stored and later restored after the assignment takes
place.
* exp_ch6.adb (Expand_Call): Add local constant Curr_S. Add specialized
kludge for .NET/JVM to recognize a particular piece of code coming from
Heap_Management and change the call to Finalize into Deep_Finalize.
* exp_ch7.adb (Build_Finalization_Collection): Allow the creation of
finalization collections on .NET/JVM only for types derived from
Controlled. Separate the association of storage pools with a collection
and only allow it on non-.NET/JVM targets.
(Make_Attach_Call): New routine.
(Make_Detach_Call): New routine.
(Process_Object_Declarations): Suppress the generation of
build-in-place return object clean up code on .NET/JVM since it uses
pools.
* exp_ch7.ads (Make_Attach_Call): New routine.
(Make_Detach_Call): New routine.
* exp_intr.adb Add with and use clause for Targparm.
(Expand_Unc_Deallocation): Detach a controlled object from a collection
on .NET/JVM targets.
* rtsfind.ads: Add entries RE_Attach, RE_Detach and
RE_Root_Controlled_Ptr to tables RE_Id and RE_Unit_Table.
* snames.ads-tmpl: Add name Name_Prev. Move Name_Prev to the special
names used in finalization.

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

* a-fihema.adb: Add with and use clauses for System.Soft_Links.
(Attach, Detach): Lock the current task when chaining an object onto a
collection.

From-SVN: r177276

gcc/ada/ChangeLog
gcc/ada/a-fihema.adb
gcc/ada/exp_ch13.adb
gcc/ada/exp_ch4.adb
gcc/ada/exp_ch5.adb
gcc/ada/exp_ch6.adb
gcc/ada/exp_ch7.adb
gcc/ada/exp_ch7.ads
gcc/ada/exp_intr.adb
gcc/ada/rtsfind.ads
gcc/ada/snames.ads-tmpl

index b526c8282c34087da0df23baea2d48b041faf3ba..0a1c510bc0b09898d7654872ac691c553f23ff7a 100644 (file)
@@ -1,3 +1,50 @@
+2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_ch13.adb: Add with and use clause for Targparm;
+       (Expand_N_Free_Statement): Prevent the generation of a custom
+       Deallocate on .NET/JVM targets since this requires pools and address
+       arithmetic.
+       * exp_ch4.adb (Expand_Allocator_Expression): When compiling for
+       .NET/JVM targets, attach the newly allocated object to the access
+       type's finalization collection. Do not generate a call to
+       Set_Finalize_Address_Ptr on .NET/JVM because this routine does not
+       exist in the runtime.
+       (Expand_N_Allocator): When compiling for .NET/JVM targets, do not
+       create a custom Allocate for object that do not require initialization.
+       Attach a newly allocated object to the access type's finalization
+       collection on .NET/JVM.
+       * exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add special processing for
+       assignment of controlled types on .NET/JVM. The two hidden pointers
+       Prev and Next and stored and later restored after the assignment takes
+       place.
+       * exp_ch6.adb (Expand_Call): Add local constant Curr_S. Add specialized
+       kludge for .NET/JVM to recognize a particular piece of code coming from
+       Heap_Management and change the call to Finalize into Deep_Finalize.
+       * exp_ch7.adb (Build_Finalization_Collection): Allow the creation of
+       finalization collections on .NET/JVM only for types derived from
+       Controlled. Separate the association of storage pools with a collection
+       and only allow it on non-.NET/JVM targets.
+       (Make_Attach_Call): New routine.
+       (Make_Detach_Call): New routine.
+       (Process_Object_Declarations): Suppress the generation of
+       build-in-place return object clean up code on .NET/JVM since it uses
+       pools.
+       * exp_ch7.ads (Make_Attach_Call): New routine.
+       (Make_Detach_Call): New routine.
+       * exp_intr.adb Add with and use clause for Targparm.
+       (Expand_Unc_Deallocation): Detach a controlled object from a collection
+       on .NET/JVM targets.
+       * rtsfind.ads: Add entries RE_Attach, RE_Detach and
+       RE_Root_Controlled_Ptr to tables RE_Id and RE_Unit_Table.
+       * snames.ads-tmpl: Add name Name_Prev. Move Name_Prev to the special
+       names used in finalization.
+
+2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * a-fihema.adb: Add with and use clauses for System.Soft_Links.
+       (Attach, Detach): Lock the current task when chaining an object onto a
+       collection.
+
 2011-08-03  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * a-except.adb, a-except-2005.adb (Raise_From_Controlled_Operation):
index cc800f38086c6605c3d0b196f12cc173dd101a06..ab0e273cba135af18178d2c20ec31c0733fce569 100644 (file)
@@ -37,6 +37,7 @@ with GNAT.IO;                 use GNAT.IO;
 
 with System;                  use System;
 with System.Address_Image;
+with System.Soft_Links;       use System.Soft_Links;
 with System.Storage_Elements; use System.Storage_Elements;
 with System.Storage_Pools;    use System.Storage_Pools;
 
@@ -135,10 +136,18 @@ package body Ada.Finalization.Heap_Management is
 
    procedure Attach (N : Node_Ptr; L : Node_Ptr) is
    begin
+      Lock_Task.all;
+
       L.Next.Prev := N;
       N.Next := L.Next;
       L.Next := N;
       N.Prev := L;
+
+      Unlock_Task.all;
+   exception
+      when others =>
+         Unlock_Task.all;
+         raise;
    end Attach;
 
    ---------------
@@ -209,6 +218,8 @@ package body Ada.Finalization.Heap_Management is
 
    procedure Detach (N : Node_Ptr) is
    begin
+      Lock_Task.all;
+
       if N.Prev /= null
         and then N.Next /= null
       then
@@ -217,6 +228,12 @@ package body Ada.Finalization.Heap_Management is
          N.Prev := null;
          N.Next := null;
       end if;
+
+      Unlock_Task.all;
+   exception
+      when others =>
+         Unlock_Task.all;
+         raise;
    end Detach;
 
    --------------
index d2143c19387bedc54a77599dc887b797fcbfc745..0af6519a46d55461d6a830ec2c8b8de6c34538ba 100644 (file)
@@ -43,6 +43,7 @@ with Sem_Eval; use Sem_Eval;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
+with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 with Validsw;  use Validsw;
@@ -214,6 +215,13 @@ package body Exp_Ch13 is
       Typ  : Entity_Id := Etype (Expr);
 
    begin
+      --  Do not create a specialized Deallocate since .NET/JVM compilers do
+      --  not support pools and address arithmetic.
+
+      if VM_Target /= No_VM then
+         return;
+      end if;
+
       --  Use the base type to perform the collection check
 
       if Ekind (Typ) = E_Access_Subtype then
index 95b23d8379a2e7936427e3f04055b2204c84a104..fb7f3b04e9cc16178f39cc1ce109f65ac992a365 100644 (file)
@@ -840,6 +840,22 @@ package body Exp_Ch4 is
                Complete_Controlled_Allocation (Temp_Decl);
                Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
+               --  Attach the object to the associated finalization collection.
+               --  This is done manually on .NET/JVM since those compilers do
+               --  no support pools and can't benefit from internally generated
+               --  Allocate / Deallocate procedures.
+
+               if VM_Target /= No_VM
+                 and then Is_Controlled (DesigT)
+                 and then Present (Associated_Collection (PtrT))
+               then
+                  Insert_Action (N,
+                    Make_Attach_Call (
+                      Obj_Ref =>
+                        New_Reference_To (Temp, Loc),
+                      Ptr_Typ => PtrT));
+               end if;
+
             else
                Node := Relocate_Node (N);
                Set_Analyzed (Node);
@@ -853,6 +869,22 @@ package body Exp_Ch4 is
 
                Insert_Action (N, Temp_Decl);
                Complete_Controlled_Allocation (Temp_Decl);
+
+               --  Attach the object to the associated finalization collection.
+               --  This is done manually on .NET/JVM since those compilers do
+               --  no support pools and can't benefit from internally generated
+               --  Allocate / Deallocate procedures.
+
+               if VM_Target /= No_VM
+                 and then Is_Controlled (DesigT)
+                 and then Present (Associated_Collection (PtrT))
+               then
+                  Insert_Action (N,
+                    Make_Attach_Call (
+                      Obj_Ref =>
+                        New_Reference_To (Temp, Loc),
+                      Ptr_Typ => PtrT));
+               end if;
             end if;
 
          --  Ada 2005 (AI-251): Handle allocators whose designated type is an
@@ -1040,7 +1072,12 @@ package body Exp_Ch4 is
             --    Set_Finalize_Address_Ptr
             --      (Collection, <Finalize_Address>'Unrestricted_Access)
 
-            if Present (Associated_Collection (PtrT)) then
+            --  Since .NET/JVM compilers do not support address arithmetic,
+            --  this call is skipped.
+
+            if VM_Target = No_VM
+              and then Present (Associated_Collection (PtrT))
+            then
                Insert_Action (N,
                  Make_Set_Finalize_Address_Ptr_Call (
                    Loc     => Loc,
@@ -1085,6 +1122,22 @@ package body Exp_Ch4 is
          Complete_Controlled_Allocation (Temp_Decl);
          Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
 
+         --  Attach the object to the associated finalization collection. This
+         --  is done manually on .NET/JVM since those compilers do no support
+         --  pools and cannot benefit from internally generated Allocate and
+         --  Deallocate procedures.
+
+         if VM_Target /= No_VM
+           and then Is_Controlled (DesigT)
+           and then Present (Associated_Collection (PtrT))
+         then
+            Insert_Action (N,
+              Make_Attach_Call (
+                Obj_Ref =>
+                  New_Reference_To (Temp, Loc),
+                Ptr_Typ => PtrT));
+         end if;
+
          Rewrite (N, New_Reference_To (Temp, Loc));
          Analyze_And_Resolve (N, PtrT);
 
@@ -3477,9 +3530,12 @@ package body Exp_Ch4 is
          if No_Initialization (N) then
 
             --  Even though this might be a simple allocation, create a custom
-            --  Allocate if the context requires it.
+            --  Allocate if the context requires it. Since .NET/JVM compilers
+            --  do not support pools, this step is skipped.
 
-            if Present (Associated_Collection (PtrT)) then
+            if VM_Target = No_VM
+              and then Present (Associated_Collection (PtrT))
+            then
                Build_Allocate_Deallocate_Proc
                  (N           => Parent (N),
                   Is_Allocate => True);
@@ -3759,7 +3815,8 @@ package body Exp_Ch4 is
                else
                   Insert_Action (N,
                     Make_Procedure_Call_Statement (Loc,
-                      Name                   => New_Reference_To (Init, Loc),
+                      Name =>
+                        New_Reference_To (Init, Loc),
                       Parameter_Associations => Args));
                end if;
 
@@ -3773,16 +3830,36 @@ package body Exp_Ch4 is
                       Obj_Ref => New_Copy_Tree (Init_Arg1),
                       Typ     => T));
 
-                  --  Generate:
-                  --    Set_Finalize_Address_Ptr
-                  --      (Pool, <Finalize_Address>'Unrestricted_Access)
-
                   if Present (Associated_Collection (PtrT)) then
-                     Insert_Action (N,
-                       Make_Set_Finalize_Address_Ptr_Call (
-                         Loc     => Loc,
-                         Typ     => T,
-                         Ptr_Typ => PtrT));
+
+                     --  Special processing for .NET/JVM, the allocated object
+                     --  is attached to the finalization collection. Generate:
+
+                     --    Attach (<PtrT>FC, Root_Controlled_Ptr (Init_Arg1));
+
+                     --  Types derived from [Limited_]Controlled are the only
+                     --  ones considered since they have fields Prev and Next.
+
+                     if VM_Target /= No_VM then
+                        if Is_Controlled (T) then
+                           Insert_Action (N,
+                             Make_Attach_Call (
+                               Obj_Ref => New_Copy_Tree (Init_Arg1),
+                               Ptr_Typ => PtrT));
+                        end if;
+
+                     --  Default case, generate:
+
+                     --    Set_Finalize_Address_Ptr
+                     --      (Pool, <Finalize_Address>'Unrestricted_Access)
+
+                     else
+                        Insert_Action (N,
+                          Make_Set_Finalize_Address_Ptr_Call (
+                            Loc     => Loc,
+                            Typ     => T,
+                            Ptr_Typ => PtrT));
+                     end if;
                   end if;
                end if;
 
index 4f175f177f76ea387ac5699259272f3ccea8938e..cba68fbf4d444f1534fce2ac2a6f335f9c505569 100644 (file)
@@ -3496,7 +3496,9 @@ package body Exp_Ch5 is
       --  Tags are not saved and restored when VM_Target because VM tags are
       --  represented implicitly in objects.
 
-      Tag_Tmp : Entity_Id;
+      Next_Id : Entity_Id;
+      Prev_Id : Entity_Id;
+      Tag_Id  : Entity_Id;
 
    begin
       --  Finalize the target of the assignment when controlled
@@ -3535,14 +3537,14 @@ package body Exp_Ch5 is
              Typ     => Etype (L)));
       end if;
 
-      --  Save the Tag in a local variable Tag_Tmp
+      --  Save the Tag in a local variable Tag_Id
 
       if Save_Tag then
-         Tag_Tmp := Make_Temporary (Loc, 'A');
+         Tag_Id := Make_Temporary (Loc, 'A');
 
          Append_To (Res,
            Make_Object_Declaration (Loc,
-             Defining_Identifier => Tag_Tmp,
+             Defining_Identifier => Tag_Id,
              Object_Definition =>
                New_Reference_To (RTE (RE_Tag), Loc),
              Expression =>
@@ -3552,10 +3554,52 @@ package body Exp_Ch5 is
                  Selector_Name =>
                    New_Reference_To (First_Tag_Component (T), Loc))));
 
-      --  Otherwise Tag_Tmp not used
+      --  Otherwise Tag_Id is not used
 
       else
-         Tag_Tmp := Empty;
+         Tag_Id := Empty;
+      end if;
+
+      --  Save the Prev and Next fields on .NET/JVM. This is not needed on non
+      --  VM targets since the fields are not part of the object.
+
+      if VM_Target /= No_VM
+        and then Is_Controlled (T)
+      then
+         Prev_Id := Make_Temporary (Loc, 'P');
+         Next_Id := Make_Temporary (Loc, 'N');
+
+         --  Generate:
+         --    Pnn : Root_Controlled_Ptr := Root_Controlled (L).Prev;
+
+         Append_To (Res,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Prev_Id,
+             Object_Definition =>
+               New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
+             Expression =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Prev))));
+
+         --  Generate:
+         --    Nnn : Root_Controlled_Ptr := Root_Controlled (L).Next;
+
+         Append_To (Res,
+           Make_Object_Declaration (Loc,
+             Defining_Identifier => Next_Id,
+             Object_Definition =>
+               New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
+             Expression =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Next))));
       end if;
 
       --  If the tagged type has a full rep clause, expand the assignment into
@@ -3577,10 +3621,48 @@ package body Exp_Ch5 is
            Make_Assignment_Statement (Loc,
              Name =>
                Make_Selected_Component (Loc,
-                 Prefix        => Duplicate_Subexpr_No_Checks (L),
-                 Selector_Name => New_Reference_To (First_Tag_Component (T),
-                                                    Loc)),
-             Expression => New_Reference_To (Tag_Tmp, Loc)));
+                 Prefix =>
+                   Duplicate_Subexpr_No_Checks (L),
+                 Selector_Name =>
+                   New_Reference_To (First_Tag_Component (T), Loc)),
+             Expression =>
+               New_Reference_To (Tag_Id, Loc)));
+      end if;
+
+      --  Restore the Prev and Next fields on .NET/JVM
+
+      if VM_Target /= No_VM
+        and then Is_Controlled (T)
+      then
+         --  Generate:
+         --    Root_Controlled (L).Prev := Prev_Id;
+
+         Append_To (Res,
+           Make_Assignment_Statement (Loc,
+             Name =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Prev)),
+             Expression =>
+               New_Reference_To (Prev_Id, Loc)));
+
+         --  Generate:
+         --    Root_Controlled (L).Next := Next_Id;
+
+         Append_To (Res,
+           Make_Assignment_Statement (Loc,
+             Name =>
+               Make_Selected_Component (Loc,
+                 Prefix =>
+                   Unchecked_Convert_To
+                     (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+                 Selector_Name =>
+                   Make_Identifier (Loc, Name_Next)),
+             Expression =>
+               New_Reference_To (Next_Id, Loc)));
       end if;
 
       --  Adjust the target after the assignment when controlled (not in the
index 87403a5feeb35f24101c153e09f188b2ab0a3a26..98b6ad07fa563a7cd47219c1db917118b2072274 100644 (file)
@@ -2015,7 +2015,8 @@ package body Exp_Ch6 is
 
       --  Local variables
 
-      Remote        : constant Boolean := Is_Remote_Call (Call_Node);
+      Curr_S        : constant Entity_Id := Current_Scope;
+      Remote        : constant Boolean   := Is_Remote_Call (Call_Node);
       Actual        : Node_Id;
       Formal        : Entity_Id;
       Orig_Subp     : Entity_Id := Empty;
@@ -2105,6 +2106,52 @@ package body Exp_Ch6 is
          end if;
       end if;
 
+      --  Detect the following code in Ada.Finalization.Heap_Management only
+      --  on .NET/JVM targets:
+      --
+      --    procedure Finalize (Collection : in out Finalization_Collection) is
+      --    begin
+      --       . . .
+      --       begin
+      --          Finalize (Curr_Ptr.all);
+      --
+      --  Since .NET/JVM compilers lack address arithmetic and Deep_Finalize
+      --  cannot be named in library or user code, the compiler has to install
+      --  a kludge and transform the call to Finalize into Deep_Finalize.
+
+      if VM_Target /= No_VM
+        and then Chars (Subp) = Name_Finalize
+        and then Ekind (Curr_S) = E_Block
+        and then Ekind (Scope (Curr_S)) = E_Procedure
+        and then Chars (Scope (Curr_S)) = Name_Finalize
+        and then Etype (First_Formal (Scope (Curr_S))) =
+                   RTE (RE_Finalization_Collection)
+      then
+         declare
+            Deep_Fin : constant Entity_Id :=
+                         Find_Prim_Op (RTE (RE_Root_Controlled),
+                                       TSS_Deep_Finalize);
+         begin
+            --  Since Root_Controlled is a tagged type, the compiler should
+            --  always generate Deep_Finalize for it.
+
+            pragma Assert (Present (Deep_Fin));
+
+            --  Generate:
+            --    Deep_Finalize (Curr_Ptr.all);
+
+            Rewrite (N,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  New_Reference_To (Deep_Fin, Loc),
+                Parameter_Associations =>
+                  New_Copy_List_Tree (Parameter_Associations (N))));
+
+            Analyze (N);
+            return;
+         end;
+      end if;
+
       --  Ada 2005 (AI-345): We have a procedure call as a triggering
       --  alternative in an asynchronous select or as an entry call in
       --  a conditional or timed select. Check whether the procedure call
index 4fd7d2a7ac1781749392e4d0604c7e877a6e0c09..ad48e5a9233eb42b9941f0824462818e60750416 100644 (file)
@@ -896,9 +896,13 @@ package body Exp_Ch7 is
       then
          return;
 
-      --  Do not process access-to-controlled types on .NET/JVM targets
+      --  For .NET/JVM targets, allow the processing of access-to-controlled
+      --  types where the designated type is explicitly derived from [Limited_]
+      --  Controlled.
 
-      elsif VM_Target /= No_VM then
+      elsif VM_Target /= No_VM
+        and then not Is_Controlled (Desig_Typ)
+      then
          return;
       end if;
 
@@ -933,47 +937,54 @@ package body Exp_Ch7 is
              Object_Definition =>
                New_Reference_To (RTE (RE_Finalization_Collection), Loc)));
 
-         --  If the access type has a user-defined pool, use it as the base
-         --  storage medium for the finalization pool.
+         --  Storage pool selection and attribute decoration of the generated
+         --  collection. Since .NET/JVM compilers do not support pools, this
+         --  step is skipped.
 
-         if Present (Associated_Storage_Pool (Typ)) then
-            Pool_Id := Associated_Storage_Pool (Typ);
+         if VM_Target = No_VM then
 
-         --  Access subtypes must use the storage pool of their base type
+            --  If the access type has a user-defined pool, use it as the base
+            --  storage medium for the finalization pool.
 
-         elsif Ekind (Typ) = E_Access_Subtype then
-            declare
-               Base_Typ : constant Entity_Id := Base_Type (Typ);
+            if Present (Associated_Storage_Pool (Typ)) then
+               Pool_Id := Associated_Storage_Pool (Typ);
 
-            begin
-               if No (Associated_Storage_Pool (Base_Typ)) then
-                  Pool_Id := RTE (RE_Global_Pool_Object);
-                  Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
-               else
-                  Pool_Id := Associated_Storage_Pool (Base_Typ);
-               end if;
-            end;
+            --  Access subtypes must use the storage pool of their base type
 
-         --  The default choice is the global pool
+            elsif Ekind (Typ) = E_Access_Subtype then
+               declare
+                  Base_Typ : constant Entity_Id := Base_Type (Typ);
 
-         else
-            Pool_Id := RTE (RE_Global_Pool_Object);
-            Set_Associated_Storage_Pool (Typ, Pool_Id);
-         end if;
+               begin
+                  if No (Associated_Storage_Pool (Base_Typ)) then
+                     Pool_Id := RTE (RE_Global_Pool_Object);
+                     Set_Associated_Storage_Pool (Base_Typ, Pool_Id);
+                  else
+                     Pool_Id := Associated_Storage_Pool (Base_Typ);
+                  end if;
+               end;
 
-         --  Generate:
-         --    Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
+            --  The default choice is the global pool
 
-         Append_To (Actions,
-           Make_Procedure_Call_Statement (Loc,
-             Name =>
-               New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
-             Parameter_Associations => New_List (
-               New_Reference_To (Coll_Id, Loc),
-               Make_Attribute_Reference (Loc,
-                 Prefix =>
-                   New_Reference_To (Pool_Id, Loc),
-                 Attribute_Name => Name_Unrestricted_Access))));
+            else
+               Pool_Id := RTE (RE_Global_Pool_Object);
+               Set_Associated_Storage_Pool (Typ, Pool_Id);
+            end if;
+
+            --  Generate:
+            --    Set_Storage_Pool_Ptr (Fnn, Pool_Id'Unchecked_Access);
+
+            Append_To (Actions,
+              Make_Procedure_Call_Statement (Loc,
+                Name =>
+                  New_Reference_To (RTE (RE_Set_Storage_Pool_Ptr), Loc),
+                Parameter_Associations => New_List (
+                  New_Reference_To (Coll_Id, Loc),
+                  Make_Attribute_Reference (Loc,
+                    Prefix =>
+                      New_Reference_To (Pool_Id, Loc),
+                    Attribute_Name => Name_Unrestricted_Access))));
+         end if;
 
          Set_Associated_Collection (Typ, Coll_Id);
 
@@ -2586,6 +2597,8 @@ package body Exp_Ch7 is
             --  caller finalization chain and deallocates the object. This is
             --  disabled on .NET/JVM because pools are not supported.
 
+            --  H505-021 This needs to be revisited on .NET/JVM
+
             if VM_Target = No_VM
               and then Is_Return_Object (Obj_Id)
             then
@@ -4429,6 +4442,42 @@ package body Exp_Ch7 is
       end if;
    end Make_Adjust_Call;
 
+   ----------------------
+   -- Make_Attach_Call --
+   ----------------------
+
+   function Make_Attach_Call
+     (Obj_Ref : Node_Id;
+      Ptr_Typ : Entity_Id) return Node_Id
+   is
+      Loc : constant Source_Ptr := Sloc (Obj_Ref);
+
+   begin
+      return
+        Make_Procedure_Call_Statement (Loc,
+          Name =>
+            New_Reference_To (RTE (RE_Attach), Loc),
+          Parameter_Associations => New_List (
+            New_Reference_To (Associated_Collection (Ptr_Typ), Loc),
+            Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
+   end Make_Attach_Call;
+
+   ----------------------
+   -- Make_Detach_Call --
+   ----------------------
+
+   function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id is
+      Loc : constant Source_Ptr := Sloc (Obj_Ref);
+
+   begin
+      return
+        Make_Procedure_Call_Statement (Loc,
+          Name =>
+            New_Reference_To (RTE (RE_Detach), Loc),
+          Parameter_Associations => New_List (
+            Unchecked_Convert_To (RTE (RE_Root_Controlled_Ptr), Obj_Ref)));
+   end Make_Detach_Call;
+
    ---------------
    -- Make_Call --
    ---------------
index 9aa7b0a1192ef07bd8f072f6936f977f92d93172..5ed2a73eae317ec83d3aad786ba07d05cb35e511 100644 (file)
@@ -93,6 +93,24 @@ package Exp_Ch7 is
    --  adjusted. Typ is the expected type of Obj_Ref. Flag For_Parent must be
    --  set when an adjustment call is being created for field _parent.
 
+   function Make_Attach_Call
+     (Obj_Ref : Node_Id;
+      Ptr_Typ : Entity_Id) return Node_Id;
+   --  Create a call to prepend an object to a finalization collection. Obj_Ref
+   --  is the object, Ptr_Typ is the access type that owns the collection.
+   --  Generate the following:
+
+   --    Ada.Finalization.Heap_Managment.Attach
+   --      (<Ptr_Typ>FC,
+   --       System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
+
+   function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id;
+   --  Create a call to unhook an object from an arbitrary list. Obj_Ref is the
+   --  object. Generate the following:
+
+   --    Ada.Finalization.Heap_Management.Detach
+   --      (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
+
    function Make_Final_Call
      (Obj_Ref    : Node_Id;
       Typ        : Entity_Id;
index b858c97fc6e8513f0f9e9f3df9231f4b4fef0b7a..21585ad0840110bfd089277df7a1a538711b9564 100644 (file)
@@ -53,6 +53,7 @@ with Sinput;   use Sinput;
 with Snames;   use Snames;
 with Stand;    use Stand;
 with Stringt;  use Stringt;
+with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 with Urealp;   use Urealp;
@@ -1009,6 +1010,16 @@ package body Exp_Intr is
                                          (RTE (RE_Get_Current_Excep),
                                           Loc))))))))))));
 
+         --  For .NET/JVM, detach the object from the containing finalization
+         --  collection before finalizing it.
+
+         if VM_Target /= No_VM
+           and then Is_Controlled (Desig_T)
+         then
+            Prepend_To (Final_Code,
+              Make_Detach_Call (New_Copy_Tree (Arg)));
+         end if;
+
          --  If aborts are allowed, then the finalization code must be
          --  protected by an abort defer/undefer pair.
 
index 652ec29c61f124f72ac71f273b5b7603f1f16cbb..f34c569656e26b84a13e4c3bbea44f1db182bf7a 100644 (file)
@@ -517,8 +517,10 @@ package Rtsfind is
 
      RE_Add_Offset_To_Address,           -- Ada.Finalization.Heap_Management
      RE_Allocate,                        -- Ada.Finalization.Heap_Management
+     RE_Attach,                          -- Ada.Finalization.Heap_Management
      RE_Base_Pool,                       -- Ada.Finalization.Heap_Management
      RE_Deallocate,                      -- Ada.Finalization.Heap_Management
+     RE_Detach,                          -- Ada.Finalization.Heap_Management
      RE_Finalization_Collection,         -- Ada.Finalization.Heap_Management
      RE_Finalization_Collection_Ptr,     -- Ada.Finalization.Heap_Management
      RE_Set_Finalize_Address_Ptr,        -- Ada.Finalization.Heap_Management
@@ -796,8 +798,7 @@ package Rtsfind is
      RE_Fat_VAX_G,                       -- System.Fat_VAX_G_Float
 
      RE_Root_Controlled,                 -- System.Finalization_Root
-     RE_Finalizable,                     -- System.Finalization_Root
-     RE_Finalizable_Ptr,                 -- System.Finalization_Root
+     RE_Root_Controlled_Ptr,             -- System.Finalization_Root
 
      RE_Fore,                            -- System.Fore
 
@@ -1694,8 +1695,10 @@ package Rtsfind is
 
      RE_Add_Offset_To_Address            => Ada_Finalization_Heap_Management,
      RE_Allocate                         => Ada_Finalization_Heap_Management,
+     RE_Attach                           => Ada_Finalization_Heap_Management,
      RE_Base_Pool                        => Ada_Finalization_Heap_Management,
      RE_Deallocate                       => Ada_Finalization_Heap_Management,
+     RE_Detach                           => Ada_Finalization_Heap_Management,
      RE_Finalization_Collection          => Ada_Finalization_Heap_Management,
      RE_Finalization_Collection_Ptr      => Ada_Finalization_Heap_Management,
      RE_Set_Finalize_Address_Ptr         => Ada_Finalization_Heap_Management,
@@ -1973,8 +1976,7 @@ package Rtsfind is
      RE_Fat_VAX_G                        => System_Fat_VAX_G_Float,
 
      RE_Root_Controlled                  => System_Finalization_Root,
-     RE_Finalizable                      => System_Finalization_Root,
-     RE_Finalizable_Ptr                  => System_Finalization_Root,
+     RE_Root_Controlled_Ptr              => System_Finalization_Root,
 
      RE_Fore                             => System_Fore,
 
index 73fbdfc462731b02071ac09efaad7eb6f83ffbbb..818cc8b6708cf5d61ee9feb8a0976315ae93b6db 100644 (file)
@@ -195,6 +195,8 @@ package Snames is
    Name_Adjust                         : constant Name_Id := N + $;
    Name_Finalize                       : constant Name_Id := N + $;
    Name_Finalize_Address               : constant Name_Id := N + $;
+   Name_Next                           : constant Name_Id := N + $;
+   Name_Prev                           : constant Name_Id := N + $;
 
    --  Names of allocation routines, also needed by expander
 
@@ -1202,7 +1204,6 @@ package Snames is
    Name_Cursor                           : constant Name_Id := N + $;
    Name_Element                          : constant Name_Id := N + $;
    Name_Element_Type                     : constant Name_Id := N + $;
-   Name_Next                             : constant Name_Id := N + $;
    Name_No_Element                       : constant Name_Id := N + $;
    Name_Previous                         : constant Name_Id := N + $;