fastmmusagetracker.pas.svn-base

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

        begin
          if I <> J then
            ExchangeGridRows(I, J);
          Inc(I);
          Dec(J);
        end;
      until I > J;
      if L < J then
        QuickSortString(L, J);
      L := I;
    until I >= R;
  end;

  procedure InvertGrid;
  var
    i, j: Integer;
  begin
    i := Grid.Fixedrows;
    j := Grid.Rowcount - 1;
    while i < j do
    begin
      ExchangeGridRows(I, J);
      Inc(i);
      Dec(j);
    end;
  end;

begin
  Screen.Cursor := crHourglass;
  Grid.Perform(WM_SETREDRAW, 0, 0);
  try
    if PB_Nummeric then
      QuickSortNummeric(Grid.FixedRows, Grid.Rowcount - 1)
    else
      QuickSortString(Grid.FixedRows, Grid.Rowcount - 1);
    if not Ascending then
      InvertGrid;
  finally
    Grid.Perform(WM_SETREDRAW, 1, 0);
    Grid.Refresh;
    Screen.Cursor := crDefault;
  end;
end;


procedure TfFastMMUsageTracker.HeaderClicked(AGrid: TStringgrid; const ACell: TGridCoord);
var
  i: Integer;
  LNumericSort: Boolean;
begin
  // The header cell stores a flag in the Objects property that signals the
  // current sort order of the grid column. A value of 0 shows no sort marker,
  // 1 means sorted ascending, -1 sorted descending
  // clear markers
  for i := AGrid.FixedCols to AGrid.ColCount - 1 do
  begin
    if Assigned(AGrid.Objects[i, 0]) and (i <> ACell.x) then
    begin
      AGrid.Objects[i, 0] := nil;
      TLocalStringGrid(AGrid).InvalidateCell(i, 0);
    end;
  end;
  // Sort grid on new column. If grid is currently sorted ascending on this
  // column we invert the sort direction, otherwise we sort it ascending.
  if ACell.X = 1 then
    LNumericSort := True
  else
    LNumericSort := False;
  if Integer(AGrid.Objects[ACell.x, ACell.y]) = 1 then
  begin
    SortGrid(AGrid, LNumericSort, ACell.x, False);
    AGrid.Objects[ACell.x, 0] := Pointer(-1);
  end
  else
  begin
    SortGrid(AGrid, LNumericSort, ACell.x, True);
    AGrid.Objects[ACell.x, 0] := Pointer(1);
  end;
  TLocalStringGrid(AGrid).InvalidateCell(ACell.x, ACell.y);
end;

procedure TfFastMMUsageTracker.UpdateGraphMetrics;
begin
  if ChkSmallGraph.Checked then
  begin
    dgMemoryMap.DefaultColWidth := 4;
    dgMemoryMap.ColCount := 128;
  end
  else
  begin
    dgMemoryMap.DefaultColWidth := 8;
    dgMemoryMap.ColCount := 64;
  end;
  dgMemoryMap.DefaultRowHeight := dgMemoryMap.DefaultColWidth;
  dgMemoryMap.RowCount := AddressSpacePageCount div dgMemoryMap.ColCount;
end;

procedure TfFastMMUsageTracker.RefreshSnapShot;
var
  LP_FreeVMList: TList;
  LU_MEM_FREE: DWord;
  LU_MEM_COMMIT: DWord;
  LU_MEM_RESERVE: DWord;
  LAllocatedSize, LTotalBlocks, LTotalAllocated, LTotalReserved: Cardinal;

  procedure UpdateVMGraph(var AMemoryMap: TMemoryMapEx);
  var
    LInd, LIndTop, I1: Integer;
    LChunkState: TChunkStatusEx;
    LMBI: TMemoryBasicInformation;
    LA_Char: array[0..MAX_PATH] of Char;
  begin
    LInd := 0;
    repeat
      {If the chunk is not allocated by this MM, what is its status?}
      if AMemoryMap[LInd] = csExSysAllocated then
      begin
        {Get all the reserved memory blocks and windows allocated memory blocks, etc.}
        VirtualQuery(Pointer(LInd * 65536), LMBI, SizeOf(LMBI));
        if LMBI.State = MEM_COMMIT then
        begin
          if (GetModuleFileName(DWord(LMBI.AllocationBase), LA_Char, MAX_PATH) <> 0) then
          begin
            if DWord(LMBI.AllocationBase) = SysInit.HInstance then
              LChunkState := csExSysExe
            else
              LChunkState := csExSysDLL;
          end
          else
          begin
            LChunkState := csExSysAllocated;
          end;
          if LMBI.RegionSize > 65536 then
          begin
            LIndTop := (Cardinal(LMBI.BaseAddress) + Cardinal(LMBI.RegionSize)) div 65536;
            // Fill up multiple tables
            for I1 := LInd to LIndTop do
              AMemoryMap[I1] := LChunkState;
            LInd := LIndTop;
          end
          else
          begin
            AMemoryMap[LInd] := LChunkState;
          end;
        end
      end;
      Inc(LInd);
    until LInd >= AddressSpacePageCount;
  end;

  procedure UpdateVMDump;
  var
    LP_Base: PByte;
    LR_Info: TMemoryBasicInformation;
    LU_rv: DWORD;
    LI_I: Integer;
    LA_Char: array[0..MAX_PATH] of Char;
  begin
    LP_Base := nil;
    LU_rv := VirtualQuery(LP_Base, LR_Info, sizeof(LR_Info));
    LI_I := 1;
    while LU_rv = sizeof(LR_Info) do
    begin
      with sgVMDump do
      begin
        Cells[0, LI_I] := IntToHex(Integer(LR_Info.BaseAddress), 8);
        Cells[1, LI_I] := IntToStr(LR_Info.RegionSize);
        Cells[3, LI_I] := IntToHex(Integer(LR_Info.Protect), 8);
        case LR_Info.State of

          MEM_Commit:
            begin
              LU_MEM_COMMIT := LU_MEM_COMMIT + LR_Info.RegionSize;
              if (GetModuleFileName(dword(LR_Info.AllocationBase), LA_Char, MAX_PATH) <> 0) then
              begin
                if DWord(LR_Info.AllocationBase) = SysInit.HInstance then
                  Cells[2, LI_I] := 'Exe'
                else
                  Cells[2, LI_I] := 'DLL';
                Cells[4, LI_I] := ExtractFileName(LA_Char);
              end
              else
              begin
                Cells[4, LI_I] := '';
                Cells[2, LI_I] := 'Commited';
              end;
            end;

          MEM_RESERVE:
            begin
              LU_MEM_RESERVE := LU_MEM_RESERVE + LR_Info.RegionSize;
              Cells[2, LI_I] := 'Reserved';
              Cells[4, LI_I] := '';
            end;

          MEM_FREE:
            begin
              LP_FreeVMList.Add(Pointer(LR_Info.RegionSize));
              LU_MEM_FREE := LU_MEM_FREE + Lr_Info.RegionSize;
              Cells[2, LI_I] := 'Free';
              Cells[4, LI_I] := '';
            end;
        end;

        Inc(LP_Base, LR_Info.RegionSize);
        LU_rv := VirtualQuery(LP_Base, LR_Info, sizeof(LR_Info));
        Inc(LI_I);
      end;
    end;

    sgVMDump.RowCount := LI_I;
  end;


  procedure UpdateFastMM4Data;
  var
    LInd: Integer;
    LU_StateLength: Cardinal;
  begin
    LU_StateLength := Length(FMemoryManagerState.SmallBlockTypeStates);
    {Set up the row count}
    sgBlockStatistics.RowCount := LU_StateLength + 4;
    sgBlockStatistics.Cells[0, LU_StateLength + 1] := 'Medium Blocks';
    sgBlockStatistics.Cells[0, LU_StateLength + 2] := 'Large Blocks';
    sgBlockStatistics.Cells[0, LU_StateLength + 3] := 'Overall';
    for LInd := 0 to High(FMemoryManagerState.SmallBlockTypeStates) do
    begin
      sgBlockStatistics.Cells[0, LInd + 1] :=
        IntToStr(FMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize)
        + '(' + IntToStr(FMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) + ')';
    end;
    {Set the texts inside the results string grid}
    for LInd := 0 to High(FMemoryManagerState.SmallBlockTypeStates) do
    begin
      with FMemoryManagerState.SmallBlockTypeStates[LInd] do
      begin
        sgBlockStatistics.Cells[1, LInd + 1] := IntToStr(AllocatedBlockCount);
        Inc(LTotalBlocks, AllocatedBlockCount);
        LAllocatedSize := AllocatedBlockCount * UseableBlockSize;
        sgBlockStatistics.Cells[2, LInd + 1] := IntToStr(LAllocatedSize);
        Inc(LTotalAllocated, LAllocatedSize);
        sgBlockStatistics.Cells[3, LInd + 1] := IntToStr(ReservedAddressSpace);
        Inc(LTotalReserved, ReservedAddressSpace);
        if ReservedAddressSpace > 0 then
          sgBlockStatistics.Cells[4, LInd + 1] := FormatFloat('0.##%', LAllocatedSize / ReservedAddressSpace * 100)
        else
          sgBlockStatistics.Cells[4, LInd + 1] := 'N/A';
      end;
    end;
    {Medium blocks}
    LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 1;
    sgBlockStatistics.Cells[1, LInd] := IntToStr(FMemoryManagerState.AllocatedMediumBlockCount);
    Inc(LTotalBlocks, FMemoryManagerState.AllocatedMediumBlockCount);
    sgBlockStatistics.Cells[2, LInd] := IntToStr(FMemoryManagerState.TotalAllocatedMediumBlockSize);
    Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedMediumBlockSize);
    sgBlockStatistics.Cells[3, LInd] := IntToStr(FMemoryManagerState.ReservedMediumBlockAddressSpace);
    Inc(LTotalReserved, FMemoryManagerState.ReservedMediumBlockAddressSpace);
    if FMemoryManagerState.ReservedMediumBlockAddressSpace > 0 then
      sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', FMemoryManagerState.TotalAllocatedMediumBlockSize / FMemoryManagerState.ReservedMediumBlockAddressSpace * 100)
    else
      sgBlockStatistics.Cells[4, LInd] := 'N/A';
    {Large blocks}
    LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 2;
    sgBlockStatistics.Cells[1, LInd] := IntToStr(FMemoryManagerState.AllocatedLargeBlockCount);
    Inc(LTotalBlocks, FMemoryManagerState.AllocatedLargeBlockCount);
    sgBlockStatistics.Cells[2, LInd] := IntToStr(FMemoryManagerState.TotalAllocatedLargeBlockSize);
    Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedLargeBlockSize);
    sgBlockStatistics.Cells[3, LInd] := IntToStr(FMemoryManagerState.ReservedLargeBlockAddressSpace);
    Inc(LTotalReserved, FMemoryManagerState.ReservedLargeBlockAddressSpace);
    if FMemoryManagerState.ReservedLargeBlockAddressSpace > 0 then
      sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', FMemoryManagerState.TotalAllocatedLargeBlockSize / FMemoryManagerState.ReservedLargeBlockAddressSpace * 100)
    else
      sgBlockStatistics.Cells[4, LInd] := 'N/A';
    {Overall}
    LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 3;
    sgBlockStatistics.Cells[1, LInd] := IntToStr(LTotalBlocks);
    sgBlockStatistics.Cells[2, LInd] := IntToStr(LTotalAllocated);
    sgBlockStatistics.Cells[3, LInd] := IntToStr(LTotalReserved);
    if LTotalReserved > 0 then
      sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', LTotalAllocated / LTotalReserved * 100)
    else
      sgBlockStatistics.Cells[4, LInd] := 'N/A';
  end;

  procedure UpdateStatisticsData;

    function LocSort(P1, P2: Pointer): Integer;
    begin
      if Cardinal(P1) = Cardinal(P2) then
        Result := 0
      else
      begin
        if Cardinal(P1) > Cardinal(P2) then
          Result := -1
        else
          Result := 1;
      end;
    end;

  const
    CI_MaxFreeBlocksList = 9;

  var
    LR_SystemInfo: TSystemInfo;
    LR_GlobalMemoryStatus: TMemoryStatus;
    LR_GlobalMemoryStatusEx: TMemoryStatusEx;
    LR_ProcessMemoryCounters: TProcessMemoryCounters;
    LR_SysBaseInfo: TSystem_Basic_Information;
    LU_MinQuota: Cardinal;
    LU_MaxQuota: Cardinal;
    LI_I: Integer;
    LI_Max: Integer;
  begin
    mVMStatistics.Lines.BeginUpdate;
    try
      mVMStatistics.Clear;

      LU_MinQuota := 0;
      LU_MaxQuota := 0;

      if Assigned(MP_GlobalMemoryStatusEx) then
      begin
        ZeroMemory(@LR_GlobalMemoryStatusEx, SizeOf(TMemoryStatusEx));
        LR_GlobalMemoryStatusEx.dwLength := SizeOf(TMemoryStatusEx);

        if not MP_GlobalMemoryStatusEx(LR_GlobalMemoryStatusEx) then
        begin
          mVMStatistics.Lines.Add('GlobalMemoryStatusEx err: ' + SysErrorMessage(GetLastError));
        end;
      end
      else
      begin
        LR_GlobalMemoryStatus.dwLength := SizeOf(TMemoryStatus);
        GlobalMemoryStatus(LR_GlobalMemoryStatus);
      end;

      LP_FreeVMList.Sort(@LocSort);

      GetProcessWorkingSetSize(GetCurrentProcess, LU_MinQuota, LU_MaxQuota);
      GetSystemInfo(LR_SystemInfo);

      with mVMStatistics.Lines do
      begin
        Add('System Info:');
        Add('------------');

        Add('Processor Count                   = ' + IntToStr(LR_SystemInfo.dwNumberOfProcessors));
        Add('Allocation Granularity            = ' + IntToStr(LR_SystemInfo.dwAllocationGranularity));

        if Assigned(MP_GlobalMemoryStatusEx) then
        begin
          with LR_GlobalMemoryStatusEx do
          begin
            Add('Available Physical Memory         = ' + Int64ToKStringFormatted(ullAvailPhys));
            Add('Total Physical Memory             = ' + Int64ToKStringFormatted(ullTotalPhys));
            Add('Available Virtual Memory          = ' + Int64ToKStringFormatted(ullAvailVirtual));
            Add('Total Virtual Memory              = ' + Int64ToKStringFormatted(ullTotalVirtual));
            Add('Total Virtual Extended Memory     = ' + Int64ToKStringFormatted(ullAvailExtendedVirtual));
          end;
        end

        else
        begin
          with LR_GlobalMemoryStatus do
          begin
            Add('Available Physical Memory         = ' + CardinalToKStringFormatted(dwAvailPhys));
            Add('Total Physical Memory             = ' + CardinalToKStringFormatted(dwTotalPhys));
            Add('Available Virtual Memory          = ' + CardinalToKStringFormatted(dwAvailVirtual));
            Add('Total Virtual Memory              = ' + CardinalToKStringFormatted(dwTotalVirtual));
          end;
        end;

        if Assigned(MP_NtQuerySystemInformation) then
        begin
          if MP_NtQuerySystemInformation(SystemBasicInformation, @LR_SysBaseInfo, SizeOf(LR_SysBaseInfo), nil) = 0 then
          begin
            with LR_SysBaseInfo do begin
              Add('Maximum Increment                 = ' + CardinalToKStringFormatted(uKeMaximumIncrement));