From patchwork Fri Oct 5 14:21:45 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 189488 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 D17582C032E for ; Sat, 6 Oct 2012 00:22:00 +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=1350051721; 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=HoZPUe8yhzehDNH9hVmO OfAVQhA=; b=V2Ec1YbGzuaRyfxdhoOIWfGKIQTe8Imjb0ImCgxvhINyC3QP/nf0 FQtSzpVkdvESq2V7Spr4yF/7rghSyx5Rldg8ctKUVQCoR+zwu89iQDCQA0NMA4w1 J9kzwe8+6TKssZFnJ2UOb47j2plIk7LDxBEiU6zMFtSywbxacsXaEWM= 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=NK/w94kvecjXjq1zMCIA/VNUXHZ/CI16P4swGwWVD/sjQ5rp/njYy+N0WDIS/x YdcbAtDUzafmEGZWyP4JdqC/iXGyK8DXdC0kF9xGWZulznNeiI2x/jR7BYAz1lPM vq29Z0irczcPkEKSqbydCchZ24XqAp+79u4C4ISSdW6hU=; Received: (qmail 915 invoked by alias); 5 Oct 2012 14:21:53 -0000 Received: (qmail 905 invoked by uid 22791); 5 Oct 2012 14:21:52 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO 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; Fri, 05 Oct 2012 14:21:45 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 317341C79D9; Fri, 5 Oct 2012 10:21:45 -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 un4LmBEcKB7v; Fri, 5 Oct 2012 10:21:45 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 050081C7994; Fri, 5 Oct 2012 10:21:45 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 03562919E3; Fri, 5 Oct 2012 10:21:45 -0400 (EDT) Date: Fri, 5 Oct 2012 10:21:45 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Missing deallocation of subpool Message-ID: <20121005142144.GA5829@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 ensures that Deallocate_Subpool is invoked on each subpool when the owner pool_with_subpools is finalized. ------------ -- Source -- ------------ -- gc_spool.ads with System.Storage_Pools.Subpools; private with System.Storage_Elements; package GC_SPool is use System; use System.Storage_Pools.Subpools; type Store is new Root_Storage_Pool_With_Subpools with private; subtype Substore_Handle is System.Storage_Pools.Subpools.Subpool_Handle; overriding function Create_Subpool (Pool : in out Store) return not null Substore_Handle; overriding procedure Deallocate_Subpool (Pool : in out Store; Subpool : in out Substore_Handle); private use System.Storage_Elements; type Substore is new Root_Subpool with null record; type Substore_Access is access all Substore; type Store is new Root_Storage_Pool_With_Subpools with record Default, S : Substore_Access; end record; overriding procedure Initialize (Pool : in out Store); overriding procedure Allocate_From_Subpool (Pool : in out Store; Storage_Address : out System.Address; Size : Storage_Count; Alignment : Storage_Count; Subpool : not null Substore_Handle); overriding function Default_Subpool_For_Pool (Pool : Store) return not null Substore_Handle; end GC_SPool; -- gc_spool.adb with Ada.Text_IO; package body GC_SPool is use Ada; type Handle is access all Storage_Array; overriding procedure Initialize (Pool : in out Store) is begin Text_IO.Put_Line ("Initialize"); Pool.Default := new Substore; Storage_Pools.Subpools.Set_Pool_Of_Subpool (Subpool_Handle (Pool.Default), Pool); Pool.S := new Substore; end Initialize; overriding procedure Allocate_From_Subpool (Pool : in out Store; Storage_Address : out System.Address; Size : Storage_Count; Alignment : Storage_Count; Subpool : not null Substore_Handle) is H : Handle := new Storage_Array (1 .. Size); begin Text_IO.Put_Line ("Allocate from subpool : " & Size'Img); Storage_Address := H (1)'Address; end Allocate_From_Subpool; overriding function Create_Subpool (Pool : in out Store) return not null Substore_Handle is S : Substore_Handle := Pool.S.all'Unchecked_Access; begin Text_IO.Put_Line ("Create subpool"); Storage_Pools.Subpools.Set_Pool_Of_Subpool (S, Pool); return S; end Create_Subpool; overriding procedure Deallocate_Subpool (Pool : in out Store; Subpool : in out Substore_Handle) is begin Text_IO.Put_Line ("Deallocate subpool"); end Deallocate_Subpool; overriding function Default_Subpool_For_Pool (Pool : Store) return not null Substore_Handle is begin Text_IO.Put_Line ("Default subpool for pool"); return Pool.Default.all'Unchecked_Access; end Default_Subpool_For_Pool; end GC_SPool; -- tpool.adb with Ada.Text_IO; with GC_SPool; procedure Tpool is use Ada; pragma Default_Storage_Pool (null); package Pool renames GC_SPool; GCP : Pool.Store; type R is record A, B, C : Integer; end record; type AR is access all R; for AR'Storage_Pool use GCP; GCSP : Pool.Substore_Handle := Pool.Create_Subpool (GCP); O1 : AR := new (GCSP) R'(8, 7, 8); begin Text_IO.Put_Line ("Start Tpool"); end Tpool; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnat12 tpool.adb $ ./tpool Initialize Create subpool Allocate from subpool : 12 Start Tpool Deallocate subpool Deallocate subpool Tested on x86_64-pc-linux-gnu, committed on trunk 2012-10-05 Hristian Kirtchev * s-spsufi.adb: Add with clause for Ada.Unchecked_Deallocation. Add with and use clauses for System.Finalization_Masters. (Finalize_And_Deallocate): Add an instance of Ada.Unchecked_Deallocation. Merge the code from the now obsolete Finalize_Subpool into this routine. * s-spsufi.ads: Add pragma Preelaborate. * s-stposu.adb: Remove with clause for Ada.Unchecked_Deallocation; Add with and use clauses for System.Storage_Pools.Subpools.Finalization; (Finalize_Pool): Update the comment on all actions takes with respect to a subpool finalization. Finalize and deallocate each individual subpool. (Finalize_Subpool): Removed. (Free): Removed; (Detach): Move from package body to spec. * s-stposu.ads (Detach): Move from package body to spec. (Finalize_Subpool): Removed. Index: s-stposu.adb =================================================================== --- s-stposu.adb (revision 192066) +++ s-stposu.adb (working copy) @@ -31,12 +31,13 @@ with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; with System.Address_Image; with System.Finalization_Masters; use System.Finalization_Masters; with System.IO; use System.IO; with System.Soft_Links; use System.Soft_Links; with System.Storage_Elements; use System.Storage_Elements; +with System.Storage_Pools.Subpools.Finalization; +use System.Storage_Pools.Subpools.Finalization; package body System.Storage_Pools.Subpools is @@ -51,11 +52,6 @@ procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr); -- Attach a subpool node to a pool - procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr); - - procedure Detach (N : not null SP_Node_Ptr); - -- Unhook a subpool node from an arbitrary subpool list - ----------------------------------- -- Adjust_Controlled_Dereference -- ----------------------------------- @@ -544,9 +540,10 @@ -- 2) Remove the the subpool from the owner's list of subpools -- 3) Deallocate the doubly linked list node associated with the -- subpool. + -- 4) Call Deallocate_Subpool begin - Finalize_Subpool (Curr_Ptr.Subpool); + Finalize_And_Deallocate (Curr_Ptr.Subpool); exception when Fin_Occur : others => @@ -565,32 +562,6 @@ end if; end Finalize_Pool; - ---------------------- - -- Finalize_Subpool -- - ---------------------- - - procedure Finalize_Subpool (Subpool : not null Subpool_Handle) is - begin - -- Do nothing if the subpool was never used - - if Subpool.Owner = null or else Subpool.Node = null then - return; - end if; - - -- Clean up all controlled objects chained on the subpool's master - - Finalize (Subpool.Master); - - -- Remove the subpool from its owner's list of subpools - - Detach (Subpool.Node); - - -- Destroy the associated doubly linked list node which was created in - -- Set_Pool_Of_Subpool. - - Free (Subpool.Node); - end Finalize_Subpool; - ------------------------------ -- Header_Size_With_Padding -- ------------------------------ Index: s-stposu.ads =================================================================== --- s-stposu.ads (revision 192066) +++ s-stposu.ads (working copy) @@ -325,6 +325,9 @@ -- is controlled. When set to True, the machinery generates additional -- data. + procedure Detach (N : not null SP_Node_Ptr); + -- Unhook a subpool node from an arbitrary subpool list + overriding procedure Finalize (Controller : in out Pool_Controller); -- Buffer routine, calls Finalize_Pool @@ -333,11 +336,6 @@ -- their masters. This action first detaches a controlled object from a -- particular master, then invokes its Finalize_Address primitive. - procedure Finalize_Subpool (Subpool : not null Subpool_Handle); - -- Finalize all controlled objects chained on Subpool's master. Remove the - -- subpool from its owner's list. Deallocate the associated doubly linked - -- list node. - function Header_Size_With_Padding (Alignment : System.Storage_Elements.Storage_Count) return System.Storage_Elements.Storage_Count; Index: s-spsufi.adb =================================================================== --- s-spsufi.adb (revision 192066) +++ s-spsufi.adb (working copy) @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -30,6 +30,9 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Unchecked_Deallocation; +with System.Finalization_Masters; use System.Finalization_Masters; + package body System.Storage_Pools.Subpools.Finalization is ----------------------------- @@ -37,6 +40,8 @@ ----------------------------- procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is + procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr); + begin -- Do nothing if the subpool was never created or never used. The latter -- case may arise with an array of subpool implementations. @@ -48,10 +53,19 @@ return; end if; - -- Clean up all controlled objects allocated through the subpool + -- Clean up all controlled objects chained on the subpool's master - Finalize_Subpool (Subpool); + Finalize (Subpool.Master); + -- Remove the subpool from its owner's list of subpools + + Detach (Subpool.Node); + + -- Destroy the associated doubly linked list node which was created in + -- Set_Pool_Of_Subpools. + + Free (Subpool.Node); + -- Dispatch to the user-defined implementation of Deallocate_Subpool Deallocate_Subpool (Pool_Of_Subpool (Subpool).all, Subpool); Index: s-spsufi.ads =================================================================== --- s-spsufi.ads (revision 192066) +++ s-spsufi.ads (working copy) @@ -7,7 +7,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,6 +33,7 @@ pragma Compiler_Unit; package System.Storage_Pools.Subpools.Finalization is + pragma Preelaborate; procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle); -- This routine performs the following actions: