Patchwork [Ada] Incorrect finalization of build-in-place function result

login
register
mail settings
Submitter Arnaud Charlet
Date March 30, 2012, 9:21 a.m.
Message ID <20120330092155.GA22591@adacore.com>
Download mbox | patch
Permalink /patch/149593/
State New
Headers show

Comments

Arnaud Charlet - March 30, 2012, 9:21 a.m.
This patch updates the mechanism which detects build-in-place function calls
returning controlled results on the secondary stack.

------------
-- Source --
------------

--  types.ads

with Ada.Finalization; use Ada.Finalization;
package Types is
   type Ctrl_Comp is new Limited_Controlled with null record;
   procedure Finalize (Obj : in out Ctrl_Comp);
   type Root is tagged limited null record;
   type Root_Ptr is access all Root'Class;
   function Create (Ctrl : Boolean) return Root'Class;
   type Empty_Child is new Root with null record;
   type Ctrl_Child is new Root with record
      Comp : Ctrl_Comp;
   end record;
end Types;

--  types.adb

with Ada.Text_IO; use Ada.Text_IO;
package body Types is
   function Create (Ctrl : Boolean) return Root'Class is
   begin
      if Ctrl then
         return Result : Ctrl_Child;
      else
         return Result : Empty_Child;
      end if;
   end Create;
   procedure Finalize (Obj : in out Ctrl_Comp) is
   begin
      Put_Line ("  Finalize");
   end Finalize;
end Types;

--  main.adb

with Ada.Text_IO; use Ada.Text_IO;
with Types;       use Types;
procedure Main is
   pragma Suppress (Accessibility_Check);
begin
   Put_Line ("Empty child");
   declare
      Obj : Root_Ptr := new Root'Class'(Create (False));
   begin
      Put_Line ("Empty child allocated");
   end;
   Put_Line ("Ctrl child");
   declare
      Obj : Root_Ptr := new Root'Class'(Create (True));
   begin
      Put_Line ("Ctrl child allocated");
   end;
   Put_Line ("End");
end Main;

-------------------------------------
-- Compilation and expected output --
-------------------------------------

$ gnatmake -q -gnat05 main.adb
$ ./main
Empty child
Empty child allocated
Ctrl child
Ctrl child allocated
End
  Finalize

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-03-30  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Replace
	the call to Is_Null_Access_BIP_Func_Call with
	Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
	* exp_util.adb (Is_Null_Access_BIP_Func_Call): Removed.
	(Is_Secondary_Stack_BIP_Func_Call): New routine.
	(Requires_Cleanup_Actions): Replace
	the call to Is_Null_Access_BIP_Func_Call with
	Is_Secondary_Stack_BIP_Func_Call. Update the related comment.
	* exp_util.ads (Is_Null_Access_BIP_Func_Call): Removed.
	(Is_Secondary_Stack_BIP_Func_Call): New routine.

Patch

Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 185995)
+++ exp_ch7.adb	(working copy)
@@ -1824,15 +1824,14 @@ 
                --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
 
                --    Obj : Access_Typ :=
-               --            BIP_Function_Call
-               --              (..., BIPaccess => null, ...)'reference;
+               --            BIP_Function_Call (BIPalloc => 2, ...)'reference;
 
                elsif Is_Access_Type (Obj_Typ)
                  and then Needs_Finalization
                             (Available_View (Designated_Type (Obj_Typ)))
                  and then Present (Expr)
                  and then
-                   (Is_Null_Access_BIP_Func_Call (Expr)
+                   (Is_Secondary_Stack_BIP_Func_Call (Expr)
                      or else
                        (Is_Non_BIP_Func_Call (Expr)
                          and then not Is_Related_To_Func_Return (Obj_Id)))
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 185995)
+++ exp_util.adb	(working copy)
@@ -4475,74 +4475,6 @@ 
         and then Is_Library_Level_Entity (Typ);
    end Is_Library_Level_Tagged_Type;
 
-   ----------------------------------
-   -- Is_Null_Access_BIP_Func_Call --
-   ----------------------------------
-
-   function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
-      Call : Node_Id := Expr;
-
-   begin
-      --  Build-in-place calls usually appear in 'reference format
-
-      if Nkind (Call) = N_Reference then
-         Call := Prefix (Call);
-      end if;
-
-      if Nkind_In (Call, N_Qualified_Expression,
-                         N_Unchecked_Type_Conversion)
-      then
-         Call := Expression (Call);
-      end if;
-
-      if Is_Build_In_Place_Function_Call (Call) then
-         declare
-            Access_Nam : Name_Id := No_Name;
-            Actual     : Node_Id;
-            Param      : Node_Id;
-            Formal     : Node_Id;
-
-         begin
-            --  Examine all parameter associations of the function call
-
-            Param := First (Parameter_Associations (Call));
-            while Present (Param) loop
-               if Nkind (Param) = N_Parameter_Association
-                 and then Nkind (Selector_Name (Param)) = N_Identifier
-               then
-                  Formal := Selector_Name (Param);
-                  Actual := Explicit_Actual_Parameter (Param);
-
-                  --  Construct the name of formal BIPaccess. It is much easier
-                  --  to extract the name of the function using an arbitrary
-                  --  formal's scope rather than the Name field of Call.
-
-                  if Access_Nam = No_Name
-                    and then Present (Entity (Formal))
-                  then
-                     Access_Nam :=
-                       New_External_Name
-                         (Chars (Scope (Entity (Formal))),
-                          BIP_Formal_Suffix (BIP_Object_Access));
-                  end if;
-
-                  --  A match for BIPaccess => null has been found
-
-                  if Chars (Formal) = Access_Nam
-                    and then Nkind (Actual) = N_Null
-                  then
-                     return True;
-                  end if;
-               end if;
-
-               Next (Param);
-            end loop;
-         end;
-      end if;
-
-      return False;
-   end Is_Null_Access_BIP_Func_Call;
-
    --------------------------
    -- Is_Non_BIP_Func_Call --
    --------------------------
@@ -4949,6 +4881,75 @@ 
       end if;
    end Is_Renamed_Object;
 
+   --------------------------------------
+   -- Is_Secondary_Stack_BIP_Func_Call --
+   --------------------------------------
+
+   function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
+      Call : Node_Id := Expr;
+
+   begin
+      --  Build-in-place calls usually appear in 'reference format
+
+      if Nkind (Call) = N_Reference then
+         Call := Prefix (Call);
+      end if;
+
+      if Nkind_In (Call, N_Qualified_Expression,
+                         N_Unchecked_Type_Conversion)
+      then
+         Call := Expression (Call);
+      end if;
+
+      if Is_Build_In_Place_Function_Call (Call) then
+         declare
+            Access_Nam : Name_Id := No_Name;
+            Actual     : Node_Id;
+            Param      : Node_Id;
+            Formal     : Node_Id;
+
+         begin
+            --  Examine all parameter associations of the function call
+
+            Param := First (Parameter_Associations (Call));
+            while Present (Param) loop
+               if Nkind (Param) = N_Parameter_Association
+                 and then Nkind (Selector_Name (Param)) = N_Identifier
+               then
+                  Formal := Selector_Name (Param);
+                  Actual := Explicit_Actual_Parameter (Param);
+
+                  --  Construct the name of formal BIPalloc. It is much easier
+                  --  to extract the name of the function using an arbitrary
+                  --  formal's scope rather than the Name field of Call.
+
+                  if Access_Nam = No_Name
+                    and then Present (Entity (Formal))
+                  then
+                     Access_Nam :=
+                       New_External_Name
+                         (Chars (Scope (Entity (Formal))),
+                          BIP_Formal_Suffix (BIP_Alloc_Form));
+                  end if;
+
+                  --  A match for BIPalloc => 2 has been found
+
+                  if Chars (Formal) = Access_Nam
+                    and then Nkind (Actual) = N_Integer_Literal
+                    and then Intval (Actual) = Uint_2
+                  then
+                     return True;
+                  end if;
+               end if;
+
+               Next (Param);
+            end loop;
+         end;
+      end if;
+
+      return False;
+   end Is_Secondary_Stack_BIP_Func_Call;
+
    -------------------------------------
    -- Is_Tag_To_Class_Wide_Conversion --
    -------------------------------------
@@ -7123,18 +7124,17 @@ 
             --    Obj : Access_Typ := Non_BIP_Function_Call'reference;
             --
             --    Obj : Access_Typ :=
-            --            BIP_Function_Call
-            --              (..., BIPaccess => null, ...)'reference;
+            --            BIP_Function_Call (BIPalloc => 2, ...)'reference;
 
             elsif Is_Access_Type (Obj_Typ)
               and then Needs_Finalization
                          (Available_View (Designated_Type (Obj_Typ)))
               and then Present (Expr)
               and then
-                (Is_Null_Access_BIP_Func_Call (Expr)
-                   or else
-                (Is_Non_BIP_Func_Call (Expr)
-                   and then not Is_Related_To_Func_Return (Obj_Id)))
+                (Is_Secondary_Stack_BIP_Func_Call (Expr)
+                  or else
+                    (Is_Non_BIP_Func_Call (Expr)
+                      and then not Is_Related_To_Func_Return (Obj_Id)))
             then
                return True;
 
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 185995)
+++ exp_util.ads	(working copy)
@@ -548,13 +548,20 @@ 
    --  Return True if Typ is a library level tagged type. Currently we use
    --  this information to build statically allocated dispatch tables.
 
-   function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean;
-   --  Determine whether node Expr denotes a build-in-place function call with
-   --  a value of "null" for extra formal BIPaccess.
-
    function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean;
    --  Determine whether node Expr denotes a non build-in-place function call
 
+   function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
+   --  Node N is an object reference. This function returns True if it is
+   --  possible that the object may not be aligned according to the normal
+   --  default alignment requirement for its type (e.g. if it appears in a
+   --  packed record, or as part of a component that has a component clause.)
+
+   function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean;
+   --  Determine whether the node P is a slice of an array where the slice
+   --  result may cause alignment problems because it has an alignment that
+   --  is not compatible with the type. Return True if so.
+
    function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean;
    --  Determine whether the node P is a reference to a bit packed array, i.e.
    --  whether the designated object is a component of a bit packed array, or a
@@ -571,17 +578,6 @@ 
    --  Determine whether object Id is related to an expanded return statement.
    --  The case concerned is "return Id.all;".
 
-   function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean;
-   --  Determine whether the node P is a slice of an array where the slice
-   --  result may cause alignment problems because it has an alignment that
-   --  is not compatible with the type. Return True if so.
-
-   function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean;
-   --  Node N is an object reference. This function returns True if it is
-   --  possible that the object may not be aligned according to the normal
-   --  default alignment requirement for its type (e.g. if it appears in a
-   --  packed record, or as part of a component that has a component clause.)
-
    function Is_Renamed_Object (N : Node_Id) return Boolean;
    --  Returns True if the node N is a renamed object. An expression is
    --  considered to be a renamed object if either it is the Name of an object
@@ -593,6 +589,10 @@ 
    --  We consider that a (1 .. 2) is a renamed object since it is the prefix
    --  of the name in the renaming declaration.
 
+   function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean;
+   --  Determine whether Expr denotes a build-in-place function which returns
+   --  its result on the secondary stack.
+
    function Is_Tag_To_Class_Wide_Conversion
      (Obj_Id : Entity_Id) return Boolean;
    --  Determine whether object Obj_Id is the result of a tag-to-class-wide