This patch corrects the treatment of a deallocation call where the designated type is class-wide and also acts as a generic actual in an instantiation, to perform a runtime check when trying to determine the controlled-ness of the deallocated object.
------------ -- Source -- ------------ -- deallocator.ads package Deallocator is procedure Execute; end Deallocator; -- deallocator.adb with Ada.Unchecked_Deallocation; package body Deallocator is type Typ is tagged limited null record; type Any_Typ_Ptr is access all Typ'Class; generic type Item_Typ (<>) is limited private; package Gen is type Item_Ptr is access all Item_Typ; procedure Deallocate (Ptr : in out Item_Ptr); end Gen; package body Gen is procedure Free is new Ada.Unchecked_Deallocation (Item_Typ, Item_Ptr); procedure Deallocate (Ptr : in out Item_Ptr) is begin Free (Ptr); end Deallocate; end Gen; package Inst is new Gen (Typ'Class); procedure Execute is Obj : Any_Typ_Ptr := new Typ; begin Inst.Deallocate (Inst.Item_Ptr (Obj)); end Execute; end Deallocator; -- main.adb with Deallocator; procedure Main is begin Deallocator.Execute; end Main; ----------------- -- Compilation -- ----------------- $ gnatmake -q main.adb $ ./main Tested on x86_64-pc-linux-gnu, committed on trunk 2014-01-31 Hristian Kirtchev <kirtc...@adacore.com> * exp_util.adb (Build_Allocate_Deallocate_Proc): Rewrite the logic that generates a runtime check to determine the controlled status of the object about to be allocated or deallocated. Class-wide types now always use a runtime check even if they appear as generic actuals. (Find_Object): Detect a special case that involves interface class-wide types because the object appears as a complex expression.
Index: exp_util.adb =================================================================== --- exp_util.adb (revision 207349) +++ exp_util.adb (working copy) @@ -511,14 +511,33 @@ Expr := E; loop - if Nkind_In (Expr, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then + if Nkind (Expr) = N_Explicit_Dereference then + Expr := Prefix (Expr); + + elsif Nkind (Expr) = N_Qualified_Expression then Expr := Expression (Expr); - elsif Nkind (Expr) = N_Explicit_Dereference then - Expr := Prefix (Expr); + elsif Nkind (Expr) = N_Unchecked_Type_Conversion then + -- When interface class-wide types are involved in allocation, + -- the expander introduces several levels of address arithmetic + -- to perform dispatch table displacement. In this scenario the + -- object appears as: + -- + -- Tag_Ptr (Base_Address (<object>'Address)) + -- + -- Detect this case and utilize the whole expression as the + -- "object" since it now points to the proper dispatch table. + + if Is_RTE (Etype (Expr), RE_Tag_Ptr) then + exit; + + -- Continue to strip the object + + else + Expr := Expression (Expr); + end if; + else exit; end if; @@ -790,102 +809,106 @@ -- h) Is_Controlled - -- Generate a run-time check to determine whether a class-wide object - -- is truly controlled. - if Needs_Finalization (Desig_Typ) then - if Is_Class_Wide_Type (Desig_Typ) - or else Is_Generic_Actual_Type (Desig_Typ) - then - declare - Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F'); - Flag_Expr : Node_Id; - Param : Node_Id; - Temp : Node_Id; + declare + Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F'); + Flag_Expr : Node_Id; + Param : Node_Id; + Temp : Node_Id; - begin - if Is_Allocate then - Temp := Find_Object (Expression (Expr)); - else - Temp := Expr; - end if; + begin + if Is_Allocate then + Temp := Find_Object (Expression (Expr)); + else + Temp := Expr; + end if; - -- Processing for generic actuals + -- Processing for allocations where the expression is a subtype + -- indication. - if Is_Generic_Actual_Type (Desig_Typ) then - Flag_Expr := - New_Reference_To (Boolean_Literals - (Needs_Finalization (Base_Type (Desig_Typ))), Loc); + if Is_Allocate + and then Is_Entity_Name (Temp) + and then Is_Type (Entity (Temp)) + then + Flag_Expr := + New_Reference_To (Boolean_Literals + (Needs_Finalization (Entity (Temp))), Loc); - -- Processing for subtype indications + -- The allocation / deallocation of a class-wide object relies + -- on a runtime check to determine whether the object is truly + -- controlled or not. Depending on this check, the finalization + -- machinery will request or reclaim extra storage reserved for + -- a list header. - elsif Nkind (Temp) in N_Has_Entity - and then Is_Type (Entity (Temp)) - then - Flag_Expr := - New_Reference_To (Boolean_Literals - (Needs_Finalization (Entity (Temp))), Loc); + elsif Is_Class_Wide_Type (Desig_Typ) then - -- Generate a runtime check to test the controlled state of - -- an object for the purposes of allocation / deallocation. + -- Detect a special case where interface class-wide types + -- are involved as the object appears as: + -- + -- Tag_Ptr (Base_Address (<object>'Address)) + -- + -- The expression already yields the proper tag, generate: + -- + -- Temp.all + if Is_RTE (Etype (Temp), RE_Tag_Ptr) then + Param := + Make_Explicit_Dereference (Loc, + Prefix => Relocate_Node (Temp)); + + -- In the default case, obtain the tag of the object about + -- to be allocated / deallocated. Generate: + -- + -- Temp'Tag + else - -- The following case arises when allocating through an - -- interface class-wide type, generate: - -- - -- Temp.all + Param := + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Temp), + Attribute_Name => Name_Tag); + end if; - if Is_RTE (Etype (Temp), RE_Tag_Ptr) then - Param := - Make_Explicit_Dereference (Loc, - Prefix => - Relocate_Node (Temp)); + -- Generate: + -- Needs_Finalization (<Param>) - -- Generate: - -- Temp'Tag + Flag_Expr := + Make_Function_Call (Loc, + Name => + New_Reference_To (RTE (RE_Needs_Finalization), Loc), + Parameter_Associations => New_List (Param)); - else - Param := - Make_Attribute_Reference (Loc, - Prefix => - Relocate_Node (Temp), - Attribute_Name => Name_Tag); - end if; + -- Processing for generic actuals - -- Generate: - -- Needs_Finalization (<Param>) + elsif Is_Generic_Actual_Type (Desig_Typ) then + Flag_Expr := + New_Reference_To (Boolean_Literals + (Needs_Finalization (Base_Type (Desig_Typ))), Loc); - Flag_Expr := - Make_Function_Call (Loc, - Name => - New_Reference_To (RTE (RE_Needs_Finalization), Loc), - Parameter_Associations => New_List (Param)); - end if; + -- The object does not require any specialized checks, it is + -- known to be controlled. - -- Create the temporary which represents the finalization - -- state of the expression. Generate: - -- - -- F : constant Boolean := <Flag_Expr>; + else + Flag_Expr := New_Reference_To (Standard_True, Loc); + end if; - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Flag_Id, - Constant_Present => True, - Object_Definition => - New_Reference_To (Standard_Boolean, Loc), - Expression => Flag_Expr)); + -- Create the temporary which represents the finalization state + -- of the expression. Generate: + -- + -- F : constant Boolean := <Flag_Expr>; - -- The flag acts as the last actual + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => Flag_Expr)); - Append_To (Actuals, New_Reference_To (Flag_Id, Loc)); - end; + Append_To (Actuals, New_Reference_To (Flag_Id, Loc)); + end; - -- The object is statically known to be controlled + -- The object is not controlled - else - Append_To (Actuals, New_Reference_To (Standard_True, Loc)); - end if; - else Append_To (Actuals, New_Reference_To (Standard_False, Loc)); end if;