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 <kirtc...@adacore.com> * 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: