The following patch adds partial support for controlled objects allocated on the heap for .NET/JVM compilation environments.
Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-03 Hristian Kirtchev <kirtc...@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.
Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 177275) +++ exp_ch5.adb (working copy) @@ -3496,7 +3496,9 @@ -- 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 @@ 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,12 +3554,54 @@ 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 -- component-wise assignments. Mark the node as unanalyzed in order to -- generate the proper code and propagate this scenario by setting a @@ -3577,12 +3621,50 @@ 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 -- init proc since it is an initialization more than an assignment). Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 177275) +++ exp_ch7.adb (working copy) @@ -896,9 +896,13 @@ 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,48 +937,55 @@ 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); -- A finalization collection created for an anonymous access type @@ -2586,6 +2597,8 @@ -- 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 @@ 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: exp_ch7.ads =================================================================== --- exp_ch7.ads (revision 177275) +++ exp_ch7.ads (working copy) @@ -93,6 +93,24 @@ -- 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: rtsfind.ads =================================================================== --- rtsfind.ads (revision 177275) +++ rtsfind.ads (working copy) @@ -517,8 +517,10 @@ 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 @@ 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 @@ 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 @@ 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: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 177275) +++ exp_ch4.adb (working copy) @@ -840,6 +840,22 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ 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 - 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: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 177275) +++ exp_ch6.adb (working copy) @@ -2015,7 +2015,8 @@ -- 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 @@ 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: exp_ch13.adb =================================================================== --- exp_ch13.adb (revision 177275) +++ exp_ch13.adb (working copy) @@ -43,6 +43,7 @@ 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 @@ 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: exp_intr.adb =================================================================== --- exp_intr.adb (revision 177275) +++ exp_intr.adb (working copy) @@ -53,6 +53,7 @@ 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 @@ (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: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 177275) +++ snames.ads-tmpl (working copy) @@ -195,6 +195,8 @@ 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 @@ 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 + $;