[Ada] Unchecked_Deallocation fails to free a class-wide object
Arnaud Charlet
charlet@adacore.com
Fri Jan 31 16:12:00 GMT 2014
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 <kirtchev@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.
-------------- next part --------------
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;
More information about the Gcc-patches
mailing list