Patchwork [Ada] Finalization of controlled object in instance

login
register
mail settings
Submitter Arnaud Charlet
Date April 26, 2012, 9:49 a.m.
Message ID <20120426094948.GA17159@adacore.com>
Download mbox | patch
Permalink /patch/155214/
State New
Headers show

Comments

Arnaud Charlet - April 26, 2012, 9:49 a.m.
This patch corrects the mechanism which determines whether a construct appears
at the library level. This in turn allows for proper detection of cases where
a Finalize_Storage_Only object appears in a nested scope and requires
finalization.

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

--  main.adb

with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;

procedure Main is
   generic
   package Memory_File is
      File     : Unbounded_String;
      procedure Add_String (S : String);
      procedure Add_New_Line;
   end Memory_File;

   package body Memory_File is
      procedure Add_String (S : String) is
      begin
         Append (File, S);
      end Add_String;
      procedure Add_New_Line is
      begin
         Add_String (ASCII.CR & ASCII.LF);
      end Add_New_Line;
   end Memory_File;

   function Leak return String is
      package Mem is new Memory_File;
      use Mem;
   begin
      Add_String ("This is a test");
      Add_New_Line;
      return To_String (File);
   end Leak;

begin
   for Index in 1 .. 100 loop
      declare
         Result : String := Leak;
         pragma Warnings (Off, Result);
      begin
         null;
      end;
   end loop;
end Main;

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

$ gnatmake -q main.adb -largs -lgmem
$ ./main
$ gnatmem ./main
$ Global information
$ ------------------
$    Total number of allocations        : 100
$    Total number of deallocations      : 100
$    Final Water Mark (non freed mem)   :   0 Bytes
$    High Water Mark                    :  48 Bytes

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

2012-04-26  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Expand_Cleanup_Actions): Update the call to
	Requires_Cleanup_Actions.
	* exp_util.adb (Requires_Cleanup_Actions (List_Id; Boolean;
	Boolean)): Rename formal parameter For_Package to Lib_Level to
	better reflect its purpose. Update the related comment and all
	occurrences of For_Package in the body.
	(Requires_Cleanup_Actions
	(Node_Id; Boolean)): Add new formal parameter Lib_Level. Add
	local constant At_Lib_Level to keep monitor whether the path
	taken from the top-most context to the current construct involves
	package constructs. Update all calls to Requires_Cleanup_Actions.
	* exp_util.ads (Requires_Cleanup_Actions): Add new formal
	parameter Lib_Level and associated comment.

Patch

Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb	(revision 186860)
+++ exp_ch7.adb	(working copy)
@@ -3599,7 +3599,7 @@ 
                                  and then VM_Target = No_VM;
 
       Actions_Required     : constant Boolean :=
-                               Requires_Cleanup_Actions (N)
+                               Requires_Cleanup_Actions (N, True)
                                  or else Is_Asynchronous_Call
                                  or else Is_Master
                                  or else Is_Protected_Body
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 186860)
+++ exp_util.adb	(working copy)
@@ -150,16 +150,16 @@ 
 
    function Requires_Cleanup_Actions
      (L                 : List_Id;
-      For_Package       : Boolean;
+      Lib_Level         : Boolean;
       Nested_Constructs : Boolean) return Boolean;
    --  Given a list L, determine whether it contains one of the following:
    --
    --    1) controlled objects
    --    2) library-level tagged types
    --
-   --  Flag For_Package should be set when the list comes from a package spec
-   --  or body. Flag Nested_Constructs should be set when any nested packages
-   --  declared in L must be processed.
+   --  Flag Lib_Level should be set when the list comes from a construct at
+   --  the library level. Flag Nested_Constructs should be set when any nested
+   --  packages declared in L must be processed.
 
    -------------------------------------
    -- Activate_Atomic_Synchronization --
@@ -7038,9 +7038,14 @@ 
    -- Requires_Cleanup_Actions --
    ------------------------------
 
-   function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
-      For_Pkg : constant Boolean :=
-                  Nkind_In (N, N_Package_Body, N_Package_Specification);
+   function Requires_Cleanup_Actions
+     (N         : Node_Id;
+      Lib_Level : Boolean) return Boolean
+   is
+      At_Lib_Level : constant Boolean := Lib_Level and then
+                       Nkind_In (N, N_Package_Body, N_Package_Specification);
+      --  N is at the library level if the top-most context is a package and
+      --  the path taken to reach N does not inlcude non-package constructs.
 
    begin
       case Nkind (N) is
@@ -7052,20 +7057,20 @@ 
               N_Subprogram_Body       |
               N_Task_Body             =>
             return
-              Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
+              Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
                 or else
               (Present (Handled_Statement_Sequence (N))
                 and then
               Requires_Cleanup_Actions (Statements
-                (Handled_Statement_Sequence (N)), For_Pkg, True));
+                (Handled_Statement_Sequence (N)), At_Lib_Level, True));
 
          when N_Package_Specification =>
             return
               Requires_Cleanup_Actions
-                (Visible_Declarations (N), For_Pkg, True)
+                (Visible_Declarations (N), At_Lib_Level, True)
                   or else
               Requires_Cleanup_Actions
-                (Private_Declarations (N), For_Pkg, True);
+                (Private_Declarations (N), At_Lib_Level, True);
 
          when others                  =>
             return False;
@@ -7078,7 +7083,7 @@ 
 
    function Requires_Cleanup_Actions
      (L                 : List_Id;
-      For_Package       : Boolean;
+      Lib_Level         : Boolean;
       Nested_Constructs : Boolean) return Boolean
    is
       Decl    : Node_Id;
@@ -7125,9 +7130,7 @@ 
             --  finalization disabled. This applies only to objects at the
             --  library level.
 
-            if For_Package
-              and then Finalize_Storage_Only (Obj_Typ)
-            then
+            if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
                null;
 
             --  Transient variables are treated separately in order to minimize
@@ -7203,9 +7206,7 @@ 
             --  finalization disabled. This applies only to objects at the
             --  library level.
 
-            if For_Package
-              and then Finalize_Storage_Only (Obj_Typ)
-            then
+            if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
                null;
 
             --  Return object of a build-in-place function. This case is
@@ -7257,7 +7258,7 @@ 
                 (Is_Type (Typ)
                    and then Needs_Finalization (Typ)))
               and then Requires_Cleanup_Actions
-                         (Actions (Decl), For_Package, Nested_Constructs)
+                         (Actions (Decl), Lib_Level, Nested_Constructs)
             then
                return True;
             end if;
@@ -7274,7 +7275,8 @@ 
             end if;
 
             if Ekind (Pack_Id) /= E_Generic_Package
-              and then Requires_Cleanup_Actions (Specification (Decl))
+              and then Requires_Cleanup_Actions
+                         (Specification (Decl), Lib_Level)
             then
                return True;
             end if;
@@ -7287,7 +7289,7 @@ 
             Pack_Id := Corresponding_Spec (Decl);
 
             if Ekind (Pack_Id) /= E_Generic_Package
-              and then Requires_Cleanup_Actions (Decl)
+              and then Requires_Cleanup_Actions (Decl, Lib_Level)
             then
                return True;
             end if;
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 186860)
+++ exp_util.ads	(working copy)
@@ -744,14 +744,17 @@ 
    --  terms is scalar. This is true for scalars in the Ada sense, and for
    --  packed arrays which are represented by a scalar (modular) type.
 
-   function Requires_Cleanup_Actions (N : Node_Id) return Boolean;
+   function Requires_Cleanup_Actions
+     (N         : Node_Id;
+      Lib_Level : Boolean) return Boolean;
    --  Given a node N, determine whether its declarative and/or statement list
    --  contains one of the following:
    --
    --    1) controlled objects
    --    2) library-level tagged types
    --
-   --  The above cases require special actions on scope exit.
+   --  The above cases require special actions on scope exit. Flag Lib_Level
+   --  is used to track whether a construct is at the library level.
 
    function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean;
    --  Given the node for an N_Unchecked_Type_Conversion, return True if this