From patchwork Thu Apr 26 09:49:48 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 155214 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id B28FFB6FA5 for ; Thu, 26 Apr 2012 19:50:16 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1336038617; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=pX4h63JdZCmUg/KD+40w gtJrR9g=; b=kQWqw7C+U9rL1OnLV0H9alV4JbzZVG6OPN9iXQwUUFnkCjgWe4Zo EpuYCHnuMDvDQnv3LuxcY06KMUP5zQNS3XWjPbRnWGdFRs1Z+Dc9MhOhlm4ZFhmM pt0LP18L12UI+dKIi00Sg8Irw36zAr/A6iNMxNg1YfxOvWuFn6riELk= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=KPLFQIV+hp9ReBr8/sECAUjwXnxdAypWeqUzCr6nFSF1Fv0/oj4H1zpcg6UDBa fq5zSvK7BA8ggUHz+htofbIODgkUT0lUsnVUlXezF0vCaV4wK5eErJ+BMEX5jU5N vyHBNX1F2yuZu48dRZ7gm8kWJuKs6uX1hBAGozuomaPnQ=; Received: (qmail 18949 invoked by alias); 26 Apr 2012 09:50:04 -0000 Received: (qmail 18787 invoked by uid 22791); 26 Apr 2012 09:50:03 -0000 X-SWARE-Spam-Status: No, hits=-3.5 required=5.0 tests=AWL, BAYES_00, KHOP_RCVD_UNTRUST, RCVD_IN_HOSTKARMA_NO, RCVD_IN_HOSTKARMA_W, RCVD_IN_HOSTKARMA_WL X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 26 Apr 2012 09:49:49 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id D49CB1C6E35; Thu, 26 Apr 2012 05:49:48 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 9H7Vr27Mqkoq; Thu, 26 Apr 2012 05:49:48 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id BB0431C674C; Thu, 26 Apr 2012 05:49:48 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id BA5F03FEE8; Thu, 26 Apr 2012 05:49:48 -0400 (EDT) Date: Thu, 26 Apr 2012 05:49:48 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Finalization of controlled object in instance Message-ID: <20120426094948.GA17159@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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. 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