From patchwork Wed Sep 6 10:27:36 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 810495 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461581-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="nH1+Zoo2"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3xnKXt4Cpjz9sBd for ; Wed, 6 Sep 2017 20:27:58 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=UUvy8XJ7f+DLu4+jgxs5X+wrzn7Ux1AAvN8UfY0JuvoENedzKs /g/P4vRWfYIswie8LcYjWwl1kU8zOLMClc0vF/jMkLCorPj7LgWwOI3aeYhmlmFU IBJ356retuSqh2XiA3w19hpb922lyyRtGP/SXMIePYB5mG3JLZqP424wU= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=2VB9MUXUaqF6Ch35DOYEhdoLUJM=; b=nH1+Zoo2jXK2iHKKsSdR 1IQ5egqFL/HgjpssDnG+a0Boh8aDL2OzG0YH570NEhwysuE3DgRsmnUJO8y//X/s E+/M34AEgpa0MQ61BHad/HTuSAyqPiZPwbUHpkQHqsUb1nHe5flYE1ypSxUc6rfZ jmtw5o6Jl7TNC4Y1Pr5I05E= Received: (qmail 31112 invoked by alias); 6 Sep 2017 10:27:41 -0000 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 Received: (qmail 30981 invoked by uid 89); 6 Sep 2017 10:27:40 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-10.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy= X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 06 Sep 2017 10:27:38 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id EEEA856146; Wed, 6 Sep 2017 06:27:36 -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 Fuh32VzC1sZy; Wed, 6 Sep 2017 06:27:36 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id DCA635606C; Wed, 6 Sep 2017 06:27:36 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id DB8F132B; Wed, 6 Sep 2017 06:27:36 -0400 (EDT) Date: Wed, 6 Sep 2017 06:27:36 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Missing finalization of cursor in "of" iterator loop Message-ID: <20170906102736.GA116519@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch modifies the finalization machinery to ensure that the cursor of an "of" iterator loop is properly finalized at the end of the loop. Previously it was incorrectly assumed that such a cursor will never need finalization ctions. ------------ -- Source -- ------------ -- leak.adb pragma Warnings (Off); with Ada.Unchecked_Deallocation; with Ada.Finalization; with Ada.Iterator_Interfaces; with Ada.Text_IO; use Ada.Text_IO; procedure Leak is type El is tagged null record; type Integer_Access is access all Integer; procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Integer, Integer_Access); type Cursor is new Ada.Finalization.Controlled with record Count : Integer_Access := new Integer'(1); end record; overriding procedure Adjust (C : in out Cursor); overriding procedure Finalize (C : in out Cursor); overriding procedure Adjust (C : in out Cursor) is begin C.Count.all := C.Count.all + 1; Put_Line ("Adjust Cursor. Count = " & C.Count.all'Img); end Adjust; overriding procedure Finalize (C : in out Cursor) is begin C.Count.all := C.Count.all - 1; Put_Line ("Finalize Cursor. Count = " & C.Count.all'Img); if C.Count.all = 0 then Unchecked_Free (C.Count); end if; end Finalize; function Has_Element (C : Cursor) return Boolean is (False); package Child is package Iterators is new Ada.Iterator_Interfaces (Cursor => Cursor, Has_Element => Has_Element); type Iterator is new Ada.Finalization.Controlled and Iterators.Forward_Iterator with record Count : Integer_Access := new Integer'(1); end record; overriding function First (I : Iterator) return Cursor is (Ada.Finalization.Controlled with others => <>); overriding function Next (I : Iterator; C : Cursor) return Cursor is (Ada.Finalization.Controlled with others => <>); overriding procedure Adjust (I : in out Iterator); end Child; package body Child is overriding procedure Adjust (I : in out Iterator) is begin I.Count.all := I.Count.all + 1; Put_Line ("Adjust Iterator. Count = " & I.Count.all'Img); end Adjust; overriding procedure Finalize (I : in out Iterator) is begin I.Count.all := I.Count.all - 1; Put_Line ("Finalize Iterator. Count = " & I.Count.all'Img); if I.Count.all = 0 then Unchecked_Free (I.Count); end if; end Finalize; end Child; type Iterable is tagged null record with Default_Iterator => Iterate, Iterator_Element => El'Class, Constant_Indexing => El_At; function Iterate (O : Iterable) return Child.Iterators.Forward_Iterator'Class is (Child.Iterator'(Ada.Finalization.Controlled with others => <>)); function El_At (Self : Iterable; Pos : Cursor'Class) return El'Class is (El'(others => <>)); Seq : Iterable; begin Put_Line ("START"); for V of Seq loop null; end loop; Put_Line ("END"); end Leak; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q leak.adb -largs -lgmem $ ./leak $ gnatmem ./leak > leaks.txt $ grep -c "Number of non freed allocations" leaks.txt START Adjust Iterator. Count = 2 Finalize Iterator. Count = 1 Adjust Cursor. Count = 2 Finalize Cursor. Count = 1 Adjust Cursor. Count = 2 Finalize Cursor. Count = 1 Finalize Cursor. Count = 0 Finalize Iterator. Count = 0 END 0 Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Hristian Kirtchev * einfo.adb (Status_Flag_Or_Transient_Decl): The attribute is now allowed on loop parameters. (Set_Status_Flag_Or_Transient_Decl): The attribute is now allowed on loop parameters. (Write_Field15_Name): Update the output for Status_Flag_Or_Transient_Decl. * einfo.ads: Attribute Status_Flag_Or_Transient_Decl now applies to loop parameters. Update the documentation of the attribute and the E_Loop_Parameter entity. * exp_ch7.adb (Process_Declarations): Remove the bogus guard which assumes that cursors can never be controlled. * exp_util.adb (Requires_Cleanup_Actions): Remove the bogus guard which assumes that cursors can never be controlled. Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 251753) +++ exp_ch7.adb (working copy) @@ -2100,15 +2100,6 @@ elsif Is_Ignored_Ghost_Entity (Obj_Id) then null; - -- The expansion of iterator loops generates an object - -- declaration where the Ekind is explicitly set to loop - -- parameter. This is to ensure that the loop parameter behaves - -- as a constant from user code point of view. Such object are - -- never controlled and do not require finalization. - - elsif Ekind (Obj_Id) = E_Loop_Parameter then - null; - -- The object is of the form: -- Obj : [constant] Typ [:= Expr]; Index: exp_util.adb =================================================================== --- exp_util.adb (revision 251762) +++ exp_util.adb (working copy) @@ -11972,16 +11972,6 @@ elsif Is_Ignored_Ghost_Entity (Obj_Id) then null; - -- The expansion of iterator loops generates an object declaration - -- where the Ekind is explicitly set to loop parameter. This is to - -- ensure that the loop parameter behaves as a constant from user - -- code point of view. Such object are never controlled and do not - -- require cleanup actions. An iterator loop over a container of - -- controlled objects does not produce such object declarations. - - elsif Ekind (Obj_Id) = E_Loop_Parameter then - return False; - -- The object is of the form: -- Obj : [constant] Typ [:= Expr]; -- Index: einfo.adb =================================================================== --- einfo.adb (revision 251760) +++ einfo.adb (working copy) @@ -3371,7 +3371,9 @@ function Status_Flag_Or_Transient_Decl (Id : E) return N is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind_In (Id, E_Constant, + E_Loop_Parameter, + E_Variable)); return Node15 (Id); end Status_Flag_Or_Transient_Decl; @@ -6546,7 +6548,9 @@ procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind_In (Id, E_Constant, + E_Loop_Parameter, + E_Variable)); Set_Node15 (Id, V); end Set_Status_Flag_Or_Transient_Decl; @@ -10087,6 +10091,7 @@ Write_Str ("Related_Instance"); when E_Constant + | E_Loop_Parameter | E_Variable => Write_Str ("Status_Flag_Or_Transient_Decl"); Index: einfo.ads =================================================================== --- einfo.ads (revision 251760) +++ einfo.ads (working copy) @@ -4325,12 +4325,12 @@ -- expression may consist of the above xxxPredicate call on its own. -- Status_Flag_Or_Transient_Decl (Node15) --- Defined in variables and constants. Applies to objects that require --- special treatment by the finalization machinery, such as extended --- return results, IF and CASE expression results, and objects inside --- N_Expression_With_Actions nodes. The attribute contains the entity --- of a flag which specifies particular behavior over a region of code --- or the declaration of a "hook" object. +-- Defined in constant, loop, and variable entities. Applies to objects +-- that require special treatment by the finalization machinery, such as +-- extended return results, IF and CASE expression results, and objects +-- inside N_Expression_With_Actions nodes. The attribute contains the +-- entity of a flag which specifies particular behavior over a region of +-- code or the declaration of a "hook" object. -- In which case is it a flag, or a hook object??? -- Storage_Size_Variable (Node26) [implementation base type only] @@ -5846,7 +5846,7 @@ -- Esize (Uint12) -- Extra_Accessibility (Node13) (constants only) -- Alignment (Uint14) - -- Status_Flag_Or_Transient_Decl (Node15) (constants only) + -- Status_Flag_Or_Transient_Decl (Node15) -- Actual_Subtype (Node17) -- Renamed_Object (Node18) -- Size_Check_Code (Node19) (constants only)