Adaのメモリ管理 ── アクセス型・Controlled型・ストレージプールの使い分け

with Ada.Text_IO; use Ada.Text_IO;

procedure Repeat_Demo is
   --  戻り値の長さは、呼び出すまで決まらない
   function Repeat (C : Character; N : Natural) return String is
      Result : constant String (1 .. N) := (others => C);
   begin
      return Result;
   end Repeat;

   N : Natural := 3;
begin
   for I in 1 .. 3 loop
      declare
         Line : constant String := Repeat ('*', N);
      begin
         Put_Line (Line & " length =" & Natural'Image (Line'Length));
      end;
      N := N * 2;
   end loop;
end Repeat_Demo;

with Ada.Text_IO; use Ada.Text_IO;

procedure SS_Loop is
   function Repeat (C : Character; N : Natural) return String is
      Result : constant String (1 .. N) := (others => C);
   begin
      return Result;
   end Repeat;

   Total : Long_Long_Integer := 0;
begin
   --  1 MB の文字列を 10,000 回返す。合計で約 10 GB になる
   for I in 1 .. 10_000 loop
      declare
         Line : constant String := Repeat ('*', 1_000_000);
      begin
         Total := Total + Long_Long_Integer (Line'Length);
      end;
   end loop;
   Put_Line ("total =" & Long_Long_Integer'Image (Total));
end SS_Loop;

pragma Restrictions (No_Secondary_Stack);

procedure Nosec is
   function Repeat (C : Character; N : Natural) return String is
      Result : constant String (1 .. N) := (others => C);
   begin
      return Result;
   end Repeat;

   Line : constant String := Repeat ('*', 3);
begin
   null;
end Nosec;

with Ada.Text_IO; use Ada.Text_IO;

procedure Access_Kinds is
   --  プール固有のアクセス型: new で確保したものだけを指せる
   type Int_Ptr is access Integer;

   --  汎用のアクセス型: aliased な変数も指せる
   type Int_Ref is access all Integer;

   P : constant Int_Ptr := new Integer'(10);

   Counter : aliased Integer := 20;
   R       : constant Int_Ref := Counter'Access;
begin
   R.all := R.all + 1;
   Put_Line ("P.all   =" & Integer'Image (P.all));
   Put_Line ("Counter =" & Integer'Image (Counter));
end Access_Kinds;

procedure Access_Errors is
   type Int_Ptr is access Integer;
   type Int_Ref is access all Integer;

   Plain   : Integer := 1;
   Counter : aliased Integer := 2;

   P1 : Int_Ptr := Counter'Access;  --  プール固有の型は変数を指せない
   R1 : Int_Ref := Plain'Access;    --  aliased でない変数は指せない
begin
   null;
end Access_Errors;

package Registry is
   type Int_Ref is access all Integer;

   Saved : Int_Ref;  --  ライブラリ水準の変数。プログラムの終わりまで残る

   procedure Remember_Static (X : aliased in out Integer);
end Registry;

package body Registry is
   procedure Remember_Static (X : aliased in out Integer) is
   begin
      Saved := X'Access;
   end Remember_Static;
end Registry;

package Registry is
   type Int_Ref is access all Integer;

   Saved : Int_Ref;  --  ライブラリ水準の変数。プログラムの終わりまで残る

   Global_Value : aliased Integer := 100;

   procedure Remember (X : access Integer);
end Registry;

package body Registry is
   procedure Remember (X : access Integer) is
   begin
      Saved := Int_Ref (X);  --  実引数の寿命を、実行時に確かめる
   end Remember;
end Registry;

with Ada.Text_IO; use Ada.Text_IO;
with Registry;    use Registry;

procedure Remember_Demo is
   procedure Try_Local is
      Local : aliased Integer := 1;
   begin
      Remember (Local'Access);
      Put_Line ("saved a local object");
   end Try_Local;
begin
   Remember (Global_Value'Access);
   Put_Line ("saved:" & Integer'Image (Saved.all));

   Try_Local;
end Remember_Demo;

with Ada.Text_IO; use Ada.Text_IO;

procedure Not_Null_Demo is
   type Int_Ptr is access Integer;

   --  引数に null が来ないことを、型の側で約束する
   procedure Show (P : not null Int_Ptr) is
   begin
      Put_Line ("value =" & Integer'Image (P.all));
   end Show;

   A : constant Int_Ptr := new Integer'(5);
   B : Int_Ptr;  --  初期値を書かないアクセス型の変数は null になる
begin
   Show (A);
   Show (B);
end Not_Null_Demo;

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;

procedure Dangling_Demo is
   type Int_Ptr is access Integer;
   procedure Free is new Ada.Unchecked_Deallocation (Integer, Int_Ptr);

   A : Int_Ptr := new Integer'(42);
   B : constant Int_Ptr := A;  --  同じオブジェクトを指す2本目のポインタ
begin
   Free (A);
   Put_Line ("A = null : " & Boolean'Image (A = null));
   Put_Line ("B = null : " & Boolean'Image (B = null));
   Put_Line ("B.all    =" & Integer'Image (B.all));  --  解放済みの領域を読む
end Dangling_Demo;

procedure Leak_Demo is
   type Int_Ptr is access Integer;
   P : Int_Ptr;
begin
   for I in 1 .. 1_000 loop
      P := new Integer'(I);  --  前の領域を指すポインタは、ここで失われる
   end loop;
end Leak_Demo;

with Ada.Unchecked_Deallocation;

procedure Dangling_Spark with SPARK_Mode is
   type Int_Ptr is access Integer;
   procedure Free is new Ada.Unchecked_Deallocation (Integer, Int_Ptr);

   A : Int_Ptr := new Integer'(42);
   B : Int_Ptr := A;  --  A の所有権は B に移る
   V : Integer;
begin
   Free (A);
   V := B.all;
   Free (B);
end Dangling_Spark;

with Ada.Finalization;

package Tracked is
   type Resource is new Ada.Finalization.Controlled with record
      Name : Character := '?';
   end record;

   overriding procedure Initialize (R : in out Resource);
   overriding procedure Adjust     (R : in out Resource);
   overriding procedure Finalize   (R : in out Resource);
end Tracked;

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO;             use Ada.Text_IO;

package body Tracked is
   overriding procedure Initialize (R : in out Resource) is
   begin
      Put_Line ("  Initialize " & R.Name);
   end Initialize;

   --  コピーされた側だと分かるように、名前を小文字にする
   overriding procedure Adjust (R : in out Resource) is
   begin
      Put_Line ("  Adjust     " & R.Name & " -> " & To_Lower (R.Name));
      R.Name := To_Lower (R.Name);
   end Adjust;

   overriding procedure Finalize (R : in out Resource) is
   begin
      Put_Line ("  Finalize   " & R.Name);
   end Finalize;
end Tracked;

with Ada.Finalization;
with Ada.Text_IO; use Ada.Text_IO;
with Tracked;     use Tracked;

procedure Raii_Demo is
begin
   Put_Line ("enter block");
   declare
      --  初期値を書かないので Initialize が呼ばれる
      A : Resource;
      --  集成体で初期化するので Initialize は呼ばれない
      B : Resource := (Ada.Finalization.Controlled with Name => 'B');
   begin
      A.Name := 'A';
      Put_Line ("assign B := A");
      B := A;
      Put_Line ("leave block");
   end;
   Put_Line ("after block");

   Put_Line ("enter block with exception");
   begin
      declare
         C : Resource;
      begin
         C.Name := 'C';
         raise Constraint_Error;
      end;
   exception
      when Constraint_Error =>
         Put_Line ("handled Constraint_Error");
   end;
end Raii_Demo;

with Ada.Text_IO; use Ada.Text_IO;

procedure Bounded_Demo is
   --  この型の new で使える領域を 64 バイトに限る
   type Int_Ptr is access Integer
     with Storage_Size => 64;

   P     : Int_Ptr;
   Count : Natural := 0;
begin
   loop
      P := new Integer'(Count);
      Count := Count + 1;
   end loop;
exception
   when Storage_Error =>
      Put_Line ("Storage_Error after" & Natural'Image (Count) & " allocations");
end Bounded_Demo;

with System;
with System.Storage_Elements; use System.Storage_Elements;
with System.Storage_Pools;    use System.Storage_Pools;

package Counting_Pools is
   --  確保と解放の回数、使用中のバイト数を数えるプール
   type Counting_Pool is new Root_Storage_Pool with record
      Allocations   : Natural       := 0;
      Deallocations : Natural       := 0;
      In_Use        : Storage_Count := 0;
   end record;

   overriding procedure Allocate
     (Pool                     : in out Counting_Pool;
      Storage_Address          : out System.Address;
      Size_In_Storage_Elements : Storage_Count;
      Alignment                : Storage_Count);

   overriding procedure Deallocate
     (Pool                     : in out Counting_Pool;
      Storage_Address          : System.Address;
      Size_In_Storage_Elements : Storage_Count;
      Alignment                : Storage_Count);

   overriding function Storage_Size
     (Pool : Counting_Pool) return Storage_Count;

   procedure Report (Pool : Counting_Pool; Label : String);
end Counting_Pools;

with Ada.Text_IO;      use Ada.Text_IO;
with System.Pool_Global;  --  GNAT の既定のプール(GNAT 固有のユニット)

package body Counting_Pools is
   Backing : System.Pool_Global.Unbounded_No_Reclaim_Pool
     renames System.Pool_Global.Global_Pool_Object;

   overriding procedure Allocate
     (Pool                     : in out Counting_Pool;
      Storage_Address          : out System.Address;
      Size_In_Storage_Elements : Storage_Count;
      Alignment                : Storage_Count) is
   begin
      Backing.Allocate (Storage_Address, Size_In_Storage_Elements, Alignment);
      Pool.Allocations := Pool.Allocations + 1;
      Pool.In_Use      := Pool.In_Use + Size_In_Storage_Elements;
   end Allocate;

   overriding procedure Deallocate
     (Pool                     : in out Counting_Pool;
      Storage_Address          : System.Address;
      Size_In_Storage_Elements : Storage_Count;
      Alignment                : Storage_Count) is
   begin
      Backing.Deallocate (Storage_Address, Size_In_Storage_Elements, Alignment);
      Pool.Deallocations := Pool.Deallocations + 1;
      Pool.In_Use        := Pool.In_Use - Size_In_Storage_Elements;
   end Deallocate;

   overriding function Storage_Size
     (Pool : Counting_Pool) return Storage_Count is
   begin
      return Storage_Count'Last;  --  上限は設けない
   end Storage_Size;

   procedure Report (Pool : Counting_Pool; Label : String) is
   begin
      Put_Line (Label & ": allocations =" & Natural'Image (Pool.Allocations)
                & ", deallocations =" & Natural'Image (Pool.Deallocations)
                & ", in use =" & Storage_Count'Image (Pool.In_Use) & " bytes");
   end Report;
end Counting_Pools;

with Ada.Finalization;
with Counting_Pools;

package Buffers is
   Pool : Counting_Pools.Counting_Pool;

   type Byte_Array is array (Positive range <>) of Character;
   type Byte_Array_Ptr is access Byte_Array
     with Storage_Pool => Pool;

   --  ヒープ上の配列を1つだけ持ち、スコープを出ると解放する型
   type Buffer is new Ada.Finalization.Limited_Controlled with record
      Data : Byte_Array_Ptr;
   end record;

   procedure Allocate (B : in out Buffer; Length : Positive);
   overriding procedure Finalize (B : in out Buffer);
end Buffers;

with Ada.Unchecked_Deallocation;

package body Buffers is
   procedure Free is new Ada.Unchecked_Deallocation (Byte_Array, Byte_Array_Ptr);

   procedure Allocate (B : in out Buffer; Length : Positive) is
   begin
      Free (B.Data);  --  既に持っていれば先に返す(null なら何もしない)
      B.Data := new Byte_Array (1 .. Length);
   end Allocate;

   overriding procedure Finalize (B : in out Buffer) is
   begin
      Free (B.Data);
   end Finalize;
end Buffers;

with Counting_Pools; use Counting_Pools;
with Buffers;        use Buffers;

procedure Pool_Demo is
begin
   Report (Pool, "start      ");

   declare
      X, Y : Buffer;
   begin
      Allocate (X, 100);
      Allocate (Y, 200);
      Allocate (X, 50);  --  X の100バイトを返してから50バイトを取り直す
      Report (Pool, "in block   ");
   end;  --  X と Y の Finalize が残りを解放する

   Report (Pool, "after block");
end Pool_Demo;

with Ada.Containers.Indefinite_Vectors;
with Ada.Text_IO; use Ada.Text_IO;

procedure Containers_Demo is
   --  長さの違う String をそのまま要素にできる
   package String_Vectors is new Ada.Containers.Indefinite_Vectors
     (Index_Type => Positive, Element_Type => String);

   Names : String_Vectors.Vector;
begin
   Names.Append ("Ada");
   Names.Append ("SPARK");
   Names.Append ("GNAT");

   for Name of Names loop
      Put_Line (Name & ":" & Natural'Image (Name'Length));
   end loop;

   Names.Delete (2);
   Put_Line ("length after delete:" & Ada.Containers.Count_Type'Image (Names.Length));
end Containers_Demo;