Patchwork [Ada] Missing deallocation of subpool

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 5, 2012, 2:21 p.m.
Message ID <20121005142144.GA5829@adacore.com>
Download mbox | patch
Permalink /patch/189488/
State New
Headers show

Comments

Arnaud Charlet - Oct. 5, 2012, 2:21 p.m.
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.

Patch

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: