-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2009, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
--- This version contains allocation tracking capability.
+-- This version contains allocation tracking capability
-- The object file corresponding to this instrumented version is to be found
-- in libgmem.
-- gnatmem -i gmem.out program
--- See gnatmem section in the GNAT User's Guide for more details.
+-- See gnatmem section in the GNAT User's Guide for more details
-- NOTE: This capability is currently supported on the following targets:
-- Irix
-- Solaris
-- Tru64
+-- Alpha OpenVMS
+
+-- NOTE FOR FUTURE PLATFORMS SUPPORT: It is assumed that type Duration is
+-- 64 bit. If the need arises to support architectures where this assumption
+-- is incorrect, it will require changing the way timestamps of allocation
+-- events are recorded.
pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
with System.Traceback;
with System.Traceback_Entries;
with GNAT.IO;
+with System.OS_Primitives;
package body System.Memory is
pragma Import (C, fclose);
procedure Finalize;
- -- Replace the default __gnat_finalize to properly close the log file.
pragma Export (C, Finalize, "__gnat_finalize");
+ -- Replace the default __gnat_finalize to properly close the log file
- Address_Size : constant := System.Address'Max_Size_In_Storage_Elements;
+ Address_Size : constant := System.Address'Max_Size_In_Storage_Elements;
-- Size in bytes of a pointer
- Max_Call_Stack : constant := 200;
+ Max_Call_Stack : constant := 200;
-- Maximum number of frames supported
Tracebk : aliased array (0 .. Max_Call_Stack) of Traceback_Entry;
-- ??? What about Ada.Command_Line.Command_Name & ".out" instead of static
-- gmem.out
- Gmemfile : File_Ptr;
+ Gmemfile : File_Ptr;
-- Global C file pointer to the allocation log
+ Needs_Init : Boolean := True;
+ -- Reset after first call to Gmem_Initialize
+
procedure Gmem_Initialize;
-- Initialization routine; opens the file and writes a header string. This
-- header string is used as a magic-tag to know if the .out file is to be
function Alloc (Size : size_t) return System.Address is
Result : aliased System.Address;
Actual_Size : aliased size_t := Size;
+ Timestamp : aliased Duration;
begin
if Size = size_t'Last then
First_Call := False;
- Gmem_Initialize;
+ if Needs_Init then
+ Gmem_Initialize;
+ end if;
+
+ Timestamp := System.OS_Primitives.Clock;
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 (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
-- Finalize --
--------------
- Needs_Init : Boolean := True;
- -- Reset after first call to Gmem_Initialize
-
procedure Finalize is
begin
if not Needs_Init then
----------
procedure Free (Ptr : System.Address) is
- Addr : aliased constant System.Address := Ptr;
+ Addr : aliased constant System.Address := Ptr;
+ Timestamp : aliased Duration;
begin
Lock_Task.all;
First_Call := False;
- Gmem_Initialize;
+ if Needs_Init then
+ Gmem_Initialize;
+ end if;
+
Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
Skip_Frames => 2);
+ Timestamp := System.OS_Primitives.Clock;
fputc (Character'Pos ('D'), Gmemfile);
fwrite (Addr'Address, Address_Size, 1, Gmemfile);
+ fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
---------------------
procedure Gmem_Initialize is
+ Timestamp : aliased Duration;
+
begin
if Needs_Init then
Needs_Init := False;
+ System.OS_Primitives.Initialize;
+ Timestamp := System.OS_Primitives.Clock;
Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL);
if Gmemfile = System.Null_Address then
end if;
fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile);
+ fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
end if;
end Gmem_Initialize;
-------------
function Realloc
- (Ptr : System.Address; Size : size_t) return System.Address
+ (Ptr : System.Address;
+ Size : size_t) return System.Address
is
- Addr : aliased constant System.Address := Ptr;
- Result : aliased System.Address;
+ Addr : aliased constant System.Address := Ptr;
+ Result : aliased System.Address;
+ Timestamp : aliased Duration;
begin
-- For the purposes of allocations logging, we treat realloc as a free
Lock_Task.all;
if First_Call then
-
First_Call := False;
-- We first log deallocation call
- Gmem_Initialize;
+ if Needs_Init then
+ Gmem_Initialize;
+ end if;
Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
Skip_Frames => 2);
+ Timestamp := System.OS_Primitives.Clock;
fputc (Character'Pos ('D'), Gmemfile);
fwrite (Addr'Address, Address_Size, 1, Gmemfile);
+ fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
fwrite (Result'Address, Address_Size, 1, Gmemfile);
fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
Gmemfile);
+ fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
Gmemfile);
OSDN Git Service
