fastmmusagetracker.pas.svn-base

Memory Manager for delphi 5-2007. Usefully to find the memory leaks and help for optimalize your mem

(*

Fast Memory Manager Usage Tracker 2.00

Description:

 - Shows FastMM4 allocation usage

 - Shows VM Memory in graphical map
    - Free
    - Commit
    - Reserved
    - EXE (Red)
    - DLLs (Blue)

 - VM Dump of the whole process
   (2GB standard, 3GB with the /3G switch set, and 4GB under WoW64)

 - General Information
    - System memory usage
    - Process memory usage
    - 5 Largest contiguous free VM memory spaces
    - FastMM4 summary information

Usage:
  - Add the FastMMUsageTracker unit
  - Add the ShowFastMMUsageTracker procedure to an event
  - FastMMUsageTracker form should not be autocreated

Notes:
  - Consider setting the base adress of your BPLs & DLLs or use Microsoft's
    ReBase.exe to set third party BPLs and DLLs. Libraries that do not have to
    be relocated can be shared across processes, thus conserving system
    resources.
  - The first of the "Largest contiguous free VM memory spaces" gives you an
    indication of the largest single memory block that can be allocated.

Change log:

  Version 2.00 (24 April 2008):
  - New usage tracker implemented by Hanspeter Widmer with many new features.
    (Thanks Hanspeter!);

*)

unit FastMMUsageTracker;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Grids, Buttons, ComCtrls, Menus, FastMM4;

type
  TChunkStatusEx = (
    {Items that correspond to the same entry in TChunkStatus}
    csExUnallocated,
    csExAllocated,
    csExReserved,
    csExSysAllocated,
    csExSysReserved,
    {TChunkStatusEx additional detail}
    csExSysExe,
    csExSysDLL);

  TMemoryMapEx = array[0..65535] of TChunkStatusEx;

  TfFastMMUsageTracker = class(TForm)
    tTimer: TTimer;
    bClose: TBitBtn;
    bUpdate: TBitBtn;
    ChkAutoUpdate: TCheckBox;
    smVMDump: TPopupMenu;
    smMM4Allocation: TPopupMenu;
    smGeneralInformation: TPopupMenu;
    miVMDumpCopyAlltoClipboard: TMenuItem;
    miGeneralInformationCopyAlltoClipboard: TMenuItem;
    siMM4AllocationCopyAlltoClipboard: TMenuItem;
    pcUsageTracker: TPageControl;
    tsAllocation: TTabSheet;
    tsVMGraph: TTabSheet;
    tsVMDump: TTabSheet;
    tsGeneralInformation: TTabSheet;
    mVMStatistics: TMemo;
    sgVMDump: TStringGrid;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    eAddress: TEdit;
    eState: TEdit;
    eDLLName: TEdit;
    ChkSmallGraph: TCheckBox;
    sgBlockStatistics: TStringGrid;
    dgMemoryMap: TDrawGrid;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure tTimerTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure bCloseClick(Sender: TObject);
    procedure dgMemoryMapDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure dgMemoryMapSelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure bUpdateClick(Sender: TObject);
    procedure ChkAutoUpdateClick(Sender: TObject);
    procedure ChkSmallGraphClick(Sender: TObject);
    procedure sgVMDumpMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure sgVMDumpMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure sgVMDumpDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure miVMDumpCopyAlltoClipboardClick(Sender: TObject);
    procedure miGeneralInformationCopyAlltoClipboardClick(Sender: TObject);
    procedure siMM4AllocationCopyAlltoClipboardClick(Sender: TObject);
  private
    {The current state}
    FMemoryManagerState: TMemoryManagerState;
    FMemoryMapEx: TMemoryMapEx;

    AddressSpacePageCount: Integer;

    OR_VMDumpDownCell: TGridCoord;

    procedure HeaderClicked(AGrid: TStringgrid; const ACell: TGridCoord);
    procedure SortGrid(grid: TStringgrid; PB_Nummeric: Boolean; byColumn: Integer; ascending: Boolean);

    procedure UpdateGraphMetrics;


  public
    {Refreshes the display}
    procedure RefreshSnapShot;
  end;

function ShowFastMMUsageTracker: TfFastMMUsageTracker;

implementation

uses
  Clipbrd, PsAPI;

{$R *.dfm}

const
  SystemBasicInformation = 0;
  SystemPerformanceInformation = 2;
  SystemTimeInformation = 3;


type
  {To get access to protected methods}
  TLocalStringGrid = class(TStringGrid);

  TMemoryStatusEx = packed record
    dwLength: DWORD;
    dwMemoryLoad: DWORD;
    ullTotalPhys: Int64;
    ullAvailPhys: Int64;
    ullTotalPageFile: Int64;
    ullAvailPageFile: Int64;
    ullTotalVirtual: Int64;
    ullAvailVirtual: Int64;
    ullAvailExtendedVirtual: Int64;
  end;
  PMemoryStatusEx = ^TMemoryStatusEx;
  LPMEMORYSTATUSEX = PMemoryStatusEx;

  TP_GlobalMemoryStatusEx = function(
    var PR_MemStatusEx: TMemoryStatusEx): LongBool; stdcall;

  TSystem_Basic_Information = packed record
    dwUnknown1: DWORD;
    uKeMaximumIncrement: ULONG;
    uPageSize: ULONG;
    uMmNumberOfPhysicalPages: ULONG;
    uMmLowestPhysicalPage: ULONG;
    uMmHighestPhysicalPage: ULONG;
    uAllocationGranularity: ULONG;
    pLowestUserAddress: Pointer;
    pMmHighestUserAddress: Pointer;
    uKeActiveProcessors: ULONG;
    bKeNumberProcessors: Byte;
    bUnknown2: Byte;
    wUnknown3: Word;
  end;

  TSystem_Performance_Information = packed record
    liIdleTime: LARGE_INTEGER;
    dwSpare: array[0..75] of DWORD;
  end;

  TSystem_Time_Information = packed record
    liKeBootTime: LARGE_INTEGER;
    liKeSystemTime: LARGE_INTEGER;
    liExpTimeZoneBias: LARGE_INTEGER;
    uCurrentTimeZoneId: ULONG;
    dwReserved: DWORD;
  end;

  TP_NtQuerySystemInformation = function(InfoClass: DWORD; Buffer: Pointer;
    BufSize: DWORD; ReturnSize: PCardinal): DWORD; stdcall;

var
  MP_GlobalMemoryStatusEx: TP_GlobalMemoryStatusEx = nil;
  MP_NtQuerySystemInformation: TP_NtQuerySystemInformation = nil;

//-----------------------------------------------------------------------------
// Various Global Procedures
//-----------------------------------------------------------------------------

function ShowFastMMUsageTracker: TfFastMMUsageTracker;
begin
  Application.CreateForm(TfFastMMUsageTracker, Result);
  if Assigned(Result) then
  begin
    Result.RefreshSnapShot;
    Result.Show;
  end;
end;

function CardinalToStringFormatted(const ACardinal: Cardinal): string;
begin
  Result := FormatFloat('#,##0', ACardinal);
end;

function Int64ToStringFormatted(const AInt64: Int64): string;
begin
  Result := FormatFloat('#,##0', AInt64);
end;

function CardinalToKStringFormatted(const ACardinal: Cardinal): string;
begin
  Result := FormatFloat('#,##0', ACardinal div 1024) + 'K';
end;

function Int64ToKStringFormatted(const AInt64: Int64): string;
begin
  Result := FormatFloat('#,##0', AInt64 div 1024) + 'K';
end;

procedure CopyGridContentsToClipBoard(AStringGrid: TStringGrid);
const
  TAB = Chr(VK_TAB);
  CRLF = #13#10;
var
  LI_r, LI_c: Integer;
  LS_S: string;
begin
  LS_S := '';
  for LI_r := 0 to AStringGrid.RowCount - 1 do
  begin
    for LI_c := 0 to AStringGrid.ColCount - 1 do
    begin
      LS_S := LS_S + AStringGrid.Cells[LI_c, LI_r];
      if LI_c < AStringGrid.ColCount - 1 then
        LS_S := LS_S + TAB;
    end;
    if LI_r < AStringGrid.RowCount - 1 then
      LS_S := LS_S + CRLF;
  end;
  ClipBoard.SetTextBuf(PChar(LS_S));
end;

//-----------------------------------------------------------------------------
// Form TfFastMMUsageTracker
//-----------------------------------------------------------------------------

procedure TfFastMMUsageTracker.FormCreate(Sender: TObject);
var
  LR_SystemInfo: TSystemInfo;
begin
  pcUsageTracker.ActivePage := tsAllocation;
  GetSystemInfo(LR_SystemInfo);
  {Get the number of address space pages}
  if (Cardinal(LR_SystemInfo.lpMaximumApplicationAddress) and $80000000) = 0 then
    AddressSpacePageCount := 32768
  else
    AddressSpacePageCount := 65536;
  {Update the graph metricx}
  UpdateGraphMetrics;
  {Set up the StringGrid columns}
  with sgBlockStatistics do
  begin
    Cells[0, 0] := 'Block Size';
    Cells[1, 0] := '# Live Pointers';
    Cells[2, 0] := 'Live Size';
    Cells[3, 0] := 'Used Space';
    Cells[4, 0] := 'Efficiency';
  end;
  with sgVMDump do
  begin
    Cells[0, 0] := 'VM Block';
    Cells[1, 0] := 'Size';
    Cells[2, 0] := 'Type';
    Cells[3, 0] := 'State';
    Cells[4, 0] := 'EXE/DLL';
  end;
end;

procedure TfFastMMUsageTracker.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

procedure TfFastMMUsageTracker.SortGrid(grid: TStringgrid; PB_Nummeric: Boolean; byColumn: Integer; ascending: Boolean);

  function CompareNumeric(const S1, S2: string): Integer;
  var
    LVal1, LVal2: Integer;
  begin
    begin
      LVal1 := StrToInt(S1);
      LVal2 := StrToInt(S2);
      if LVal1 = LVal2 then
      begin
        Result := 0;
      end
      else
      begin
        if LVal1 > LVal2 then
          Result := 1
        else
          Result := -1;
      end;
    end;
  end;

  procedure ExchangeGridRows(i, j: Integer);
  var
    k: Integer;
  begin
    for k := 0 to Grid.ColCount - 1 do
      Grid.Cols[k].Exchange(i, j);
  end;

  procedure QuickSortNummeric(L, R: Integer);
  var
    I, J: Integer;
    P: string;
  begin
    repeat
      I := L;
      J := R;
      P := Grid.Cells[byColumn, (L + R) shr 1];
      repeat
        while CompareNumeric(Grid.Cells[byColumn, I], P) < 0 do
          Inc(I);
        while CompareNumeric(Grid.Cells[byColumn, J], P) > 0 do
          Dec(J);
        if I <= J then
        begin
          if I <> J then
            ExchangeGridRows(I, J);
          Inc(I);
          Dec(J);
        end;
      until I > J;
      if L < J then
        QuickSortNummeric(L, J);
      L := I;
    until I >= R;
  end;

  procedure QuickSortString(L, R: Integer);
  var
    I, J: Integer;
    P: string;
  begin
    repeat
      I := L;
      J := R;
      P := Grid.Cells[byColumn, (L + R) shr 1];
      repeat
        while CompareText(Grid.Cells[byColumn, I], P) < 0 do
          Inc(I);
        while CompareText(Grid.Cells[byColumn, J], P) > 0 do
          Dec(J);
        if I <= J then