{"id":810495,"url":"http://patchwork.ozlabs.org/api/patches/810495/?format=json","web_url":"http://patchwork.ozlabs.org/project/gcc/patch/20170906102736.GA116519@adacore.com/","project":{"id":17,"url":"http://patchwork.ozlabs.org/api/projects/17/?format=json","name":"GNU Compiler Collection","link_name":"gcc","list_id":"gcc-patches.gcc.gnu.org","list_email":"gcc-patches@gcc.gnu.org","web_url":null,"scm_url":null,"webscm_url":null,"list_archive_url":"","list_archive_url_format":"","commit_url_format":""},"msgid":"<20170906102736.GA116519@adacore.com>","list_archive_url":null,"date":"2017-09-06T10:27:36","name":"[Ada] Missing finalization of cursor in \"of\" iterator loop","commit_ref":null,"pull_url":null,"state":"new","archived":false,"hash":"dcfd190581e5faa79bd6c4e99c9b58ba8f5ac2b1","submitter":{"id":4418,"url":"http://patchwork.ozlabs.org/api/people/4418/?format=json","name":"Arnaud Charlet","email":"charlet@adacore.com"},"delegate":null,"mbox":"http://patchwork.ozlabs.org/project/gcc/patch/20170906102736.GA116519@adacore.com/mbox/","series":[{"id":1756,"url":"http://patchwork.ozlabs.org/api/series/1756/?format=json","web_url":"http://patchwork.ozlabs.org/project/gcc/list/?series=1756","date":"2017-09-06T10:27:36","name":"[Ada] Missing finalization of cursor in \"of\" iterator loop","version":1,"mbox":"http://patchwork.ozlabs.org/series/1756/mbox/"}],"comments":"http://patchwork.ozlabs.org/api/patches/810495/comments/","check":"pending","checks":"http://patchwork.ozlabs.org/api/patches/810495/checks/","tags":{},"related":[],"headers":{"Return-Path":"<gcc-patches-return-461581-incoming=patchwork.ozlabs.org@gcc.gnu.org>","X-Original-To":"incoming@patchwork.ozlabs.org","Delivered-To":["patchwork-incoming@bilbo.ozlabs.org","mailing list gcc-patches@gcc.gnu.org"],"Authentication-Results":["ozlabs.org;\n\tspf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org\n\t(client-ip=209.132.180.131; helo=sourceware.org;\n\tenvelope-from=gcc-patches-return-461581-incoming=patchwork.ozlabs.org@gcc.gnu.org;\n\treceiver=<UNKNOWN>)","ozlabs.org; dkim=pass (1024-bit key;\n\tunprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org\n\theader.b=\"nH1+Zoo2\"; dkim-atps=neutral","sourceware.org; auth=none"],"Received":["from sourceware.org (server1.sourceware.org [209.132.180.131])\n\t(using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256\n\tbits)) (No client certificate requested)\n\tby ozlabs.org (Postfix) with ESMTPS id 3xnKXt4Cpjz9sBd\n\tfor <incoming@patchwork.ozlabs.org>;\n\tWed,  6 Sep 2017 20:27:58 +1000 (AEST)","(qmail 31112 invoked by alias); 6 Sep 2017 10:27:41 -0000","(qmail 30981 invoked by uid 89); 6 Sep 2017 10:27:40 -0000","from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by\n\tsourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP;\n\tWed, 06 Sep 2017 10:27:38 +0000","from localhost (localhost.localdomain [127.0.0.1])\tby\n\tfiltered-rock.gnat.com (Postfix) with ESMTP id EEEA856146;\n\tWed,  6 Sep 2017 06:27:36 -0400 (EDT)","from rock.gnat.com ([127.0.0.1])\tby localhost (rock.gnat.com\n\t[127.0.0.1]) (amavisd-new, port 10024)\twith LMTP id\n\tFuh32VzC1sZy; Wed,  6 Sep 2017 06:27:36 -0400 (EDT)","from tron.gnat.com (tron.gnat.com [205.232.38.10])\tby\n\trock.gnat.com (Postfix) with ESMTP id DCA635606C;\n\tWed,  6 Sep 2017 06:27:36 -0400 (EDT)","by tron.gnat.com (Postfix, from userid 4192)\tid DB8F132B;\n\tWed,  6 Sep 2017 06:27:36 -0400 (EDT)"],"DomainKey-Signature":"a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id\n\t:list-unsubscribe:list-archive:list-post:list-help:sender:date\n\t:from:to:cc:subject:message-id:mime-version:content-type; q=dns;\n\ts=default; b=UUvy8XJ7f+DLu4+jgxs5X+wrzn7Ux1AAvN8UfY0JuvoENedzKs\n\t/g/P4vRWfYIswie8LcYjWwl1kU8zOLMClc0vF/jMkLCorPj7LgWwOI3aeYhmlmFU\n\tIBJ356retuSqh2XiA3w19hpb922lyyRtGP/SXMIePYB5mG3JLZqP424wU=","DKIM-Signature":"v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id\n\t:list-unsubscribe:list-archive:list-post:list-help:sender:date\n\t:from:to:cc:subject:message-id:mime-version:content-type; s=\n\tdefault; bh=2VB9MUXUaqF6Ch35DOYEhdoLUJM=; b=nH1+Zoo2jXK2iHKKsSdR\n\t1IQ5egqFL/HgjpssDnG+a0Boh8aDL2OzG0YH570NEhwysuE3DgRsmnUJO8y//X/s\n\tE+/M34AEgpa0MQ61BHad/HTuSAyqPiZPwbUHpkQHqsUb1nHe5flYE1ypSxUc6rfZ\n\tjmtw5o6Jl7TNC4Y1Pr5I05E=","Mailing-List":"contact gcc-patches-help@gcc.gnu.org; run by ezmlm","Precedence":"bulk","List-Id":"<gcc-patches.gcc.gnu.org>","List-Unsubscribe":"<mailto:gcc-patches-unsubscribe-incoming=patchwork.ozlabs.org@gcc.gnu.org>","List-Archive":"<http://gcc.gnu.org/ml/gcc-patches/>","List-Post":"<mailto:gcc-patches@gcc.gnu.org>","List-Help":"<mailto:gcc-patches-help@gcc.gnu.org>","Sender":"gcc-patches-owner@gcc.gnu.org","X-Virus-Found":"No","X-Spam-SWARE-Status":"No, score=-10.4 required=5.0 tests=AWL, BAYES_00,\n\tGIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS,\n\tRCVD_IN_DNSWL_NONE,\n\tSPF_PASS autolearn=ham version=3.3.2 spammy=","X-HELO":"rock.gnat.com","Date":"Wed, 6 Sep 2017 06:27:36 -0400","From":"Arnaud Charlet <charlet@adacore.com>","To":"gcc-patches@gcc.gnu.org","Cc":"Hristian Kirtchev <kirtchev@adacore.com>","Subject":"[Ada] Missing finalization of cursor in \"of\" iterator loop","Message-ID":"<20170906102736.GA116519@adacore.com>","MIME-Version":"1.0","Content-Type":"multipart/mixed; boundary=\"M9NhX3UHpAaciwkO\"","Content-Disposition":"inline","User-Agent":"Mutt/1.5.23 (2014-03-12)"},"content":"This patch modifies the finalization machinery to ensure that the cursor of an\n\"of\" iterator loop is properly finalized at the end of the loop. Previously it\nwas incorrectly assumed that such a cursor will never need finalization\nctions.\n\n------------\n-- Source --\n------------\n\n--  leak.adb\n\npragma Warnings (Off);\n\nwith Ada.Unchecked_Deallocation;\nwith Ada.Finalization;\nwith Ada.Iterator_Interfaces;\nwith Ada.Text_IO; use Ada.Text_IO;\n\nprocedure Leak is\n   type El is tagged null record;\n\n   type Integer_Access is access all Integer;\n\n   procedure Unchecked_Free is new Ada.Unchecked_Deallocation\n     (Integer, Integer_Access);\n\n   type Cursor is new Ada.Finalization.Controlled with record\n      Count : Integer_Access := new Integer'(1);\n   end record;\n\n   overriding procedure Adjust (C : in out Cursor);\n   overriding procedure Finalize (C : in out Cursor);\n\n   overriding procedure Adjust (C : in out Cursor) is\n   begin\n      C.Count.all := C.Count.all + 1;\n      Put_Line (\"Adjust   Cursor.   Count = \" & C.Count.all'Img);\n   end Adjust;\n\n   overriding procedure Finalize (C : in out Cursor) is\n   begin\n      C.Count.all := C.Count.all - 1;\n      Put_Line (\"Finalize Cursor.   Count = \" & C.Count.all'Img);\n      if C.Count.all = 0 then\n         Unchecked_Free (C.Count);\n      end if;\n   end Finalize;\n\n   function Has_Element (C : Cursor) return Boolean is (False);\n\n   package Child is\n      package Iterators is new Ada.Iterator_Interfaces\n        (Cursor       => Cursor,\n         Has_Element  => Has_Element);\n\n      type Iterator is\n        new Ada.Finalization.Controlled\n          and Iterators.Forward_Iterator\n      with record\n         Count : Integer_Access := new Integer'(1);\n      end record;\n\n      overriding function First (I : Iterator) return Cursor\n      is (Ada.Finalization.Controlled with others => <>);\n\n      overriding function Next (I : Iterator; C : Cursor) return Cursor\n      is (Ada.Finalization.Controlled with others => <>);\n\n      overriding procedure Adjust (I : in out Iterator);\n\n      end Child;\n\n   package body Child is\n      overriding procedure Adjust (I : in out Iterator) is\n      begin\n         I.Count.all := I.Count.all + 1;\n         Put_Line (\"Adjust   Iterator. Count = \" & I.Count.all'Img);\n      end Adjust;\n\n      overriding procedure Finalize (I : in out Iterator) is\n      begin\n         I.Count.all := I.Count.all - 1;\n         Put_Line (\"Finalize Iterator. Count = \" & I.Count.all'Img);\n         if I.Count.all = 0 then\n            Unchecked_Free (I.Count);\n         end if;\n      end Finalize;\n   end Child;\n\n   type Iterable is tagged null record\n     with Default_Iterator  => Iterate,\n          Iterator_Element  => El'Class,\n          Constant_Indexing => El_At;\n\n   function Iterate\n     (O : Iterable) return Child.Iterators.Forward_Iterator'Class\n   is (Child.Iterator'(Ada.Finalization.Controlled with others => <>));\n\n   function El_At (Self : Iterable; Pos : Cursor'Class) return El'Class\n   is (El'(others => <>));\n\n   Seq : Iterable;\n\nbegin\n   Put_Line (\"START\");\n   for V of Seq loop\n      null;\n   end loop;\n   Put_Line (\"END\");\nend Leak;\n\n----------------------------\n-- Compilation and output --\n----------------------------\n\n$ gnatmake -q leak.adb -largs -lgmem\n$ ./leak\n$ gnatmem ./leak > leaks.txt\n$ grep -c \"Number of non freed allocations\" leaks.txt\nSTART\nAdjust   Iterator. Count =  2\nFinalize Iterator. Count =  1\nAdjust   Cursor.   Count =  2\nFinalize Cursor.   Count =  1\nAdjust   Cursor.   Count =  2\nFinalize Cursor.   Count =  1\nFinalize Cursor.   Count =  0\nFinalize Iterator. Count =  0\nEND\n0\n\nTested on x86_64-pc-linux-gnu, committed on trunk\n\n2017-09-06  Hristian Kirtchev  <kirtchev@adacore.com>\n\n\t* einfo.adb (Status_Flag_Or_Transient_Decl): The attribute is now\n\tallowed on loop parameters.\n\t(Set_Status_Flag_Or_Transient_Decl): The attribute is now allowed\n\ton loop parameters.\n\t(Write_Field15_Name): Update the output for\n\tStatus_Flag_Or_Transient_Decl.\n\t* einfo.ads: Attribute Status_Flag_Or_Transient_Decl now applies\n\tto loop parameters. Update the documentation of the attribute\n\tand the E_Loop_Parameter entity.\n\t* exp_ch7.adb (Process_Declarations): Remove the bogus guard\n\twhich assumes that cursors can never be controlled.\n\t* exp_util.adb (Requires_Cleanup_Actions): Remove the bogus\n\tguard which assumes that cursors can never be controlled.","diff":"Index: exp_ch7.adb\n===================================================================\n--- exp_ch7.adb\t(revision 251753)\n+++ exp_ch7.adb\t(working copy)\n@@ -2100,15 +2100,6 @@\n                elsif Is_Ignored_Ghost_Entity (Obj_Id) then\n                   null;\n \n-               --  The expansion of iterator loops generates an object\n-               --  declaration where the Ekind is explicitly set to loop\n-               --  parameter. This is to ensure that the loop parameter behaves\n-               --  as a constant from user code point of view. Such object are\n-               --  never controlled and do not require finalization.\n-\n-               elsif Ekind (Obj_Id) = E_Loop_Parameter then\n-                  null;\n-\n                --  The object is of the form:\n                --    Obj : [constant] Typ [:= Expr];\n \nIndex: exp_util.adb\n===================================================================\n--- exp_util.adb\t(revision 251762)\n+++ exp_util.adb\t(working copy)\n@@ -11972,16 +11972,6 @@\n             elsif Is_Ignored_Ghost_Entity (Obj_Id) then\n                null;\n \n-            --  The expansion of iterator loops generates an object declaration\n-            --  where the Ekind is explicitly set to loop parameter. This is to\n-            --  ensure that the loop parameter behaves as a constant from user\n-            --  code point of view. Such object are never controlled and do not\n-            --  require cleanup actions. An iterator loop over a container of\n-            --  controlled objects does not produce such object declarations.\n-\n-            elsif Ekind (Obj_Id) = E_Loop_Parameter then\n-               return False;\n-\n             --  The object is of the form:\n             --    Obj : [constant] Typ [:= Expr];\n             --\nIndex: einfo.adb\n===================================================================\n--- einfo.adb\t(revision 251760)\n+++ einfo.adb\t(working copy)\n@@ -3371,7 +3371,9 @@\n \n    function Status_Flag_Or_Transient_Decl (Id : E) return N is\n    begin\n-      pragma Assert (Ekind_In (Id, E_Constant, E_Variable));\n+      pragma Assert (Ekind_In (Id, E_Constant,\n+                                   E_Loop_Parameter,\n+                                   E_Variable));\n       return Node15 (Id);\n    end Status_Flag_Or_Transient_Decl;\n \n@@ -6546,7 +6548,9 @@\n \n    procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is\n    begin\n-      pragma Assert (Ekind_In (Id, E_Constant, E_Variable));\n+      pragma Assert (Ekind_In (Id, E_Constant,\n+                                   E_Loop_Parameter,\n+                                   E_Variable));\n       Set_Node15 (Id, V);\n    end Set_Status_Flag_Or_Transient_Decl;\n \n@@ -10087,6 +10091,7 @@\n             Write_Str (\"Related_Instance\");\n \n          when E_Constant\n+            | E_Loop_Parameter\n             | E_Variable\n          =>\n             Write_Str (\"Status_Flag_Or_Transient_Decl\");\nIndex: einfo.ads\n===================================================================\n--- einfo.ads\t(revision 251760)\n+++ einfo.ads\t(working copy)\n@@ -4325,12 +4325,12 @@\n --       expression may consist of the above xxxPredicate call on its own.\n \n --    Status_Flag_Or_Transient_Decl (Node15)\n---       Defined in variables and constants. Applies to objects that require\n---       special treatment by the finalization machinery, such as extended\n---       return results, IF and CASE expression results, and objects inside\n---       N_Expression_With_Actions nodes. The attribute contains the entity\n---       of a flag which specifies particular behavior over a region of code\n---       or the declaration of a \"hook\" object.\n+--       Defined in constant, loop, and variable entities. Applies to objects\n+--       that require special treatment by the finalization machinery, such as\n+--       extended return results, IF and CASE expression results, and objects\n+--       inside N_Expression_With_Actions nodes. The attribute contains the\n+--       entity of a flag which specifies particular behavior over a region of\n+--       code or the declaration of a \"hook\" object.\n --       In which case is it a flag, or a hook object???\n \n --    Storage_Size_Variable (Node26) [implementation base type only]\n@@ -5846,7 +5846,7 @@\n    --    Esize                               (Uint12)\n    --    Extra_Accessibility                 (Node13)   (constants only)\n    --    Alignment                           (Uint14)\n-   --    Status_Flag_Or_Transient_Decl       (Node15)   (constants only)\n+   --    Status_Flag_Or_Transient_Decl       (Node15)\n    --    Actual_Subtype                      (Node17)\n    --    Renamed_Object                      (Node18)\n    --    Size_Check_Code                     (Node19)   (constants only)\n","prefixes":["Ada"]}