[Ada] Missing deallocation of subpool
Arnaud Charlet
charlet@adacore.com
Fri Oct 5 14:21:00 GMT 2012
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 <kirtchev@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.
-------------- next part --------------
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:
More information about the Gcc-patches
mailing list