diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 47 | ||||
| -rw-r--r-- | gcc/ada/a-fihema.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 103 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 102 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 49 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 119 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 3 |
11 files changed, 423 insertions, 64 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b526c8282c3..0a1c510bc0b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,52 @@ 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): Rewritten to create the message strings when the exception is not raised by an abort during finalization. diff --git a/gcc/ada/a-fihema.adb b/gcc/ada/a-fihema.adb index cc800f38086..ab0e273cba1 100644 --- a/gcc/ada/a-fihema.adb +++ b/gcc/ada/a-fihema.adb @@ -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; -------------- diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index d2143c19387..0af6519a46d 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 95b23d8379a..fb7f3b04e9c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4f175f177f7..cba68fbf4d4 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 87403a5feeb..98b6ad07fa5 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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 diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 4fd7d2a7ac1..ad48e5a9233 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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 -- --------------- diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 9aa7b0a1192..5ed2a73eae3 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -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; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index b858c97fc6e..21585ad0840 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -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. diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 652ec29c61f..f34c569656e 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 73fbdfc4627..818cc8b6708 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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 + $; |