Re: User Defined Storage Pool : Example

[anon@att.net]

-- referance delete for spacing


-- Found on www.adapower.com
--
-- http://www.adapower.com/index.php?Command=Class&ClassID=Advanced&CID=222
--
-- Files:
--        memory_management-test.adb
--        memory_management-support.ads
--        memory_management-support.adb
--        memory_management.ads
--        memory_management.adb
--
-- To compile and run:
-- 
--   >gnat make memory_management-test.adb
--   >memory_management-test

--
--  Memory Management with Storage Pools (Anh Vo)
--
--  Memory management can cause real headache due to memory leakage over 
--  time. That is, memory allocation is not properly deallocated after the 
--  call. When the memory runs out, the result could be catastrophic for 
--  some applications. This problem can be recued by garbage collector 
--  built-in the compiler such as Java. However, the cost of run-time 
--  overhead is high.
     
--  Here comes Ada 95 to the recue. How is it possible you may ask? Ah! 
--  Ada 95 provides a feature called Storage Pool. It allows the users 
--  have total control over the memory management. Best of all, it does 
--  not involve run-time overhead as garbage collector. When it is 
--  combined with controlled type, the memory leakage problem is history.
    
--  As shown in the test case, 100 storage elements were allocated 
--  initially. Then, these storage elements are reused again and again. It 
--  is pretty cool isn't it? Enjoy.
     

--------------------------------------------
-- File => memory_management-test.adb
--
with Ada.Finalization ;
with Ada.Text_Io ;
with Memory_Management.Support ;
     
procedure Memory_Management.Test is
    use Ada ;
    use Text_Io ;
     
begin
     
  Put_Line ("********* Memory Control Testing Starts **********") ;
   
  for Index in 1 .. 10 loop
    declare
      David_Botton : Support.General_Data ;
      Nick_Roberts : Support.General_Data ;
      Anh_Vo       : Support.General_Data ;
     
    begin
      David_Botton := ( Finalization.Controlled with
                         Id   => new Integer' ( 111 ), 
                         Name => new String' ( "David Botton" ) ) ;

      Nick_Roberts := ( Finalization.Controlled with
                          Id   => new Integer' ( 222 ), 
                          Name => new String' ( "Nick Roberts" ) ) ;

      Anh_Vo := ( Finalization.Controlled with
                    Id   => new Integer' ( 333 ),
                    Name => new String' ( "Anh Vo" ) ) ;
    end ;
  end loop ;
     
  Put_Line ( "Memory Management Test Passes" ) ;
     
exception
  when others =>
    Put_Line ( "Memory Management Test Fails" ) ;
     
end Memory_Management.Test ;


--------------------------------------------
-- File => memory_management-support.ads
--
with Ada.Finalization ;
     
package Memory_Management.Support is
     
  use Ada ;
     
  -- Adjust the storage size according to the application
  Big_Pool : User_Pool ( Size => 100 )  ;
     
  type Int_Acc is access Integer ;
    for Int_Acc'Storage_Pool use Big_Pool ;
     
  type Str_Acc is access all String ;
    for Str_Acc'Storage_Pool use Int_Acc'Storage_Pool ;
     
  type General_Data is new Finalization.Controlled 
         with record
                Id : Int_Acc ;
                Name : Str_Acc ;
              end record ;
     
  procedure Initialize ( Object : in out General_Data )  ;
     
  procedure Finalize ( Object : in out General_Data )  ;
     
end Memory_Management.Support ;
     

--------------------------------------------
-- File => memory_management-support.adb
--
with Ada.Unchecked_Deallocation ;
     
package body Memory_Management.Support is
     
  procedure Free is new Ada.Unchecked_Deallocation 
                                                 ( Integer, Int_Acc ) ;
  procedure Free is new Ada.Unchecked_Deallocation
                                                  ( String, Str_Acc ) ;
     
   procedure Initialize ( Object : in out General_Data ) is
     begin
       null ;
     end Initialize ;
     
  procedure Finalize ( Object : in out General_Data ) is
    begin
      Free ( Object.Id ) ;
      Free ( Object.Name ) ;
    end Finalize ;
     
end Memory_Management.Support ;
     
--------------------------------------------     
-- File => memory_management.ads
--
with System.Storage_Pools ;
with System.Storage_Elements ;
     
package Memory_Management is
     
    use System ;
    use Storage_Elements ;
    use Storage_Pools ;
     
  type User_Pool ( Size : Storage_Count ) is new
                                       Root_Storage_Pool with private ;
     
  procedure Allocate ( Pool                     : in out User_Pool ;
                       Storage_Address          :    out Address   ;
                       Size_In_Storage_Elements : in Storage_Count ;
                       Alignment                : in Storage_Count ) ;
     
  procedure Deallocate 
                      ( Pool                     : in out User_Pool ;
                        Storage_Address          : in     Address   ;
                        Size_In_Storage_Elements : in Storage_Count ;
                        Alignment                : in Storage_Count ) ;
     
  function Storage_Size ( Pool : in User_Pool ) 
               return Storage_Count ;
     
  -- Exeption declaration

  Memory_Exhausted : exception ;
     
  Item_Too_Big : exception ;
     
private
  type User_Pool ( Size : Storage_Count ) is new Root_Storage_Pool
           with record
                  Data       : Storage_Array ( 1 .. Size ) ;
                  Addr_Index : Storage_Count := 1 ;
                end record ;
     
end Memory_Management ;
     

--------------------------------------------     
-- File => memory_management.adb
--
with Ada.Exceptions ;
with Ada.Text_Io ;
with System ;
with System.Storage_Elements ;
with System.Address_To_Access_Conversions ;
     
package body Memory_Management is
     
    use Ada ;
    use Text_Io ;
    use System ;
    use Storage_Elements ;
    use type Storage_Count ;
     
  Package_Name : constant String := "Memory_Management." ;
     
    -- Used to turn on/off the debug information
  Debug_On : Boolean := True ; -- False ;
     
  type Holder is record
         Next_Address : Address := System.Null_Address ;
  end record ;
     
  package Addr_To_Acc is new Address_To_Access_Conversions ( Holder ) ;
     
  -- Keep track of the size of memory block for reuse
  Free_Storage_Keeper : array ( Storage_Count range 1 .. 100 )
          of Address := ( others => Null_Address ) ;
     
  procedure Display_Info ( Message       : string ; 
                           With_New_Line : Boolean := True ) is
    begin
      if Debug_On then
        if With_New_Line then
          Put_Line ( Message ) ;
        else
          Put ( Message ) ;
        end if ;
      end if ;
    end Display_Info ;
     

  procedure Allocate ( Pool                     : in out User_Pool ;
                       Storage_Address          :    out Address   ;
                       Size_In_Storage_Elements : in Storage_Count ;
                       Alignment                : in Storage_Count ) is
          
      Procedure_Name : constant String := "Allocate" ;
      Temp_Address   : Address  := Null_Address ;
      Marker         : Storage_Count ;
    begin
     
      Marker := ( Size_In_Storage_Elements + Alignment - 1 )
              / Alignment ;
     
      if Free_Storage_Keeper ( Marker ) /= Null_Address then
        Storage_Address := Free_Storage_Keeper ( Marker ) ;
        Free_Storage_Keeper (Marker) :=
        Addr_To_Acc.To_Pointer 
                ( Free_Storage_Keeper ( Marker ) ).Next_Address ;
      else
        Temp_Address := Pool.Data (Pool.Addr_Index)'Address ;
              
        Pool.Addr_Index := Pool.Addr_Index 
                         + Alignment 
                         * ( ( Size_In_Storage_Elements 
                               + Alignment - 1 ) 
                         / Alignment ) ;
     
        -- make sure memory is available as requested
        if Pool.Addr_Index > Pool.Size then
          Exceptions.Raise_Exception ( Storage_Error'Identity,
                                       "Storage exhausted in " 
                                       & Package_Name 
                                       & Procedure_Name ) ;
        else
          Storage_Address := Temp_Address ;
        end if ;
      end if ;
     
      Display_Info  ( "Address allocated from pool: "
                      & Integer_Address'Image 
                          ( To_Integer ( Storage_Address ) ) ) ;
   
      Display_Info ( "storage elements allocated from pool: "
                     & Storage_Count'Image 
                          ( Size_In_Storage_Elements ) ) ;
     
      Display_Info ( "Alignment in allocation operation: "
                     & Storage_Count'Image ( Alignment ) ) ;
   
    exception
      when Error : others => -- Object too big or memory exhausted
        Display_Info ( Exceptions.Exception_Information ( Error ) ) ;
        raise ;
     
    end Allocate ;


  procedure Deallocate 
                     ( Pool                     : in out User_Pool ;
                       Storage_Address          : in     Address   ;
                       Size_In_Storage_Elements : in Storage_Count ;
                       Alignment                : in Storage_Count ) is
          
      Marker : Storage_Count ;
     
    begin
     
      Marker := ( Size_In_Storage_Elements + Alignment - 1) 
              / Alignment ;
      Addr_To_Acc.To_Pointer ( Storage_Address ).Next_Address :=
                                     Free_Storage_Keeper ( Marker ) ;
      Free_Storage_Keeper ( Marker ) := Storage_Address ;
     
      Display_Info  ( "Address returned to pool: " 
                      & Integer_Address'Image 
                          ( To_Integer ( Storage_Address ) ) ) ;
     
      Display_Info ( "storage elements returned to pool: "
                     & Storage_Count'Image 
                         ( Size_In_Storage_Elements ) ) ;
     
      Display_Info ( "Alignment used in deallocation: "
                     & Storage_Count'Image ( Alignment ) ) ;
     
  end Deallocate ;
     
  function Storage_Size ( Pool : in User_Pool ) 
             return Storage_Count is
    begin
      return Pool.Size ;
    end Storage_Size ;
     
end Memory_Management ;