pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
with Ada.Exceptions;
with System.Soft_Links;
with System.Traceback;
with System.Traceback_Entries;
with GNAT.IO;
package body System.Memory is
use Ada.Exceptions;
use System.Soft_Links;
use System.Traceback;
use System.Traceback_Entries;
use GNAT.IO;
function c_malloc (Size : size_t) return System.Address;
pragma Import (C, c_malloc, "malloc");
procedure c_free (Ptr : System.Address);
pragma Import (C, c_free, "free");
function c_realloc
(Ptr : System.Address; Size : size_t) return System.Address;
pragma Import (C, c_realloc, "realloc");
subtype File_Ptr is System.Address;
function fopen (Path : String; Mode : String) return File_Ptr;
pragma Import (C, fopen);
procedure OS_Exit (Status : Integer);
pragma Import (C, OS_Exit, "__gnat_os_exit");
pragma No_Return (OS_Exit);
procedure fwrite
(Ptr : System.Address;
Size : size_t;
Nmemb : size_t;
Stream : File_Ptr);
procedure fwrite
(Str : String;
Size : size_t;
Nmemb : size_t;
Stream : File_Ptr);
pragma Import (C, fwrite);
procedure fputc (C : Integer; Stream : File_Ptr);
pragma Import (C, fputc);
procedure fclose (Stream : File_Ptr);
pragma Import (C, fclose);
procedure Finalize;
pragma Export (C, Finalize, "__gnat_finalize");
Address_Size : constant := System.Address'Max_Size_In_Storage_Elements;
Max_Call_Stack : constant := 200;
Tracebk : aliased array (0 .. Max_Call_Stack) of Traceback_Entry;
Num_Calls : aliased Integer := 0;
Gmemfname : constant String := "gmem.out" & ASCII.NUL;
Gmemfile : File_Ptr;
procedure Gmem_Initialize;
First_Call : Boolean := True;
function Alloc (Size : size_t) return System.Address is
Result : aliased System.Address;
Actual_Size : aliased size_t := Size;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
if Size = 0 then
Actual_Size := 1;
end if;
Lock_Task.all;
Result := c_malloc (Actual_Size);
if First_Call then
First_Call := False;
Gmem_Initialize;
Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
Skip_Frames => 2);
fputc (Character'Pos ('A'), Gmemfile);
fwrite (Result'Address, Address_Size, 1, Gmemfile);
fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
declare
Ptr : System.Address := PC_For (Tracebk (J));
begin
fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
end;
end loop;
First_Call := True;
end if;
Unlock_Task.all;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Alloc;
Needs_Init : Boolean := True;
procedure Finalize is
begin
if not Needs_Init then
fclose (Gmemfile);
end if;
end Finalize;
procedure Free (Ptr : System.Address) is
Addr : aliased constant System.Address := Ptr;
begin
Lock_Task.all;
if First_Call then
First_Call := False;
Gmem_Initialize;
Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
Skip_Frames => 2);
fputc (Character'Pos ('D'), Gmemfile);
fwrite (Addr'Address, Address_Size, 1, Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
declare
Ptr : System.Address := PC_For (Tracebk (J));
begin
fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
end;
end loop;
c_free (Ptr);
First_Call := True;
end if;
Unlock_Task.all;
end Free;
procedure Gmem_Initialize is
begin
if Needs_Init then
Needs_Init := False;
Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
if Gmemfile = System.Null_Address then
Put_Line ("Couldn't open gnatmem log file for writing");
OS_Exit (255);
end if;
fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
end if;
end Gmem_Initialize;
function Realloc
(Ptr : System.Address; Size : size_t) return System.Address
is
Addr : aliased constant System.Address := Ptr;
Result : aliased System.Address;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
Abort_Defer.all;
Lock_Task.all;
if First_Call then
First_Call := False;
Gmem_Initialize;
Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
Skip_Frames => 2);
fputc (Character'Pos ('D'), Gmemfile);
fwrite (Addr'Address, Address_Size, 1, Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
declare
Ptr : System.Address := PC_For (Tracebk (J));
begin
fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
end;
end loop;
Result := c_realloc (Ptr, Size);
fputc (Character'Pos ('A'), Gmemfile);
fwrite (Result'Address, Address_Size, 1, Gmemfile);
fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
declare
Ptr : System.Address := PC_For (Tracebk (J));
begin
fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
end;
end loop;
First_Call := True;
end if;
Unlock_Task.all;
Abort_Undefer.all;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Realloc;
end System.Memory;