fastmmusagetracker.pas.svn-base

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

              Add('Page Size                         = ' + CardinalToKStringFormatted(uPageSize));
              Add('Number of Physical Pages          = ' + CardinalToKStringFormatted(uMmNumberOfPhysicalPages));
              Add('Lowest Physical Page              = ' + CardinalToStringFormatted(uMmLowestPhysicalPage));
              Add('Highest Physical Page             = ' + CardinalToKStringFormatted(uMmHighestPhysicalPage));
            end;
          end;
        end;

        // same as GetProcessMemoryInfo & NtQuerySystemInformation (SystemBasicInformation

        // The working set is the amount of memory physically mapped to the process context at a given
        // time. Memory in the paged pool is system memory that can be transferred to the paging file
        // on disk (paged) when it is not being used. Memory in the nonpaged pool is system memory
        // that cannot be paged to disk as long as the corresponding objects are allocated. The pagefile
        // usage represents how much memory is set aside for the process in the system paging file.
        // When memory usage is too high, the virtual memory manager pages selected memory to disk.
        // When a thread needs a page that is not in memory, the memory manager reloads it from the
        // paging file.


        if GetProcessMemoryInfo(GetCurrentProcess, @LR_ProcessMemoryCounters, SizeOf(LR_ProcessMemoryCounters)) then
        begin
          with LR_ProcessMemoryCounters do
          begin
            Add('Page Fault Count                  = ' + CardinalToKStringFormatted(PageFaultCount));
            Add('Peak Working Set Size             = ' + CardinalToKStringFormatted(PeakWorkingSetSize));
            Add('Working Set Size                  = ' + CardinalToKStringFormatted(WorkingSetSize));
            Add('Quota Peak Paged Pool Usage       = ' + CardinalToKStringFormatted(QuotaPeakPagedPoolUsage));
            Add('Quota Paged Pool Usage            = ' + CardinalToStringFormatted(QuotaPagedPoolUsage));
            Add('Quota Peak Non-Paged Pool Usage  = ' + CardinalToStringFormatted(QuotaPeakNonPagedPoolUsage));
            Add('Quota Non-Paged Pool Usage       = ' + CardinalToStringFormatted(QuotaNonPagedPoolUsage));
            Add('Pagefile Usage                    = ' + CardinalToKStringFormatted(PagefileUsage));
            Add('Peak Pagefile Usage               = ' + CardinalToKStringFormatted(PeakPagefileUsage));
          end;
        end;

        Add('');
        Add('Process Info: PID (' + IntToStr(GetCurrentProcessId) + ')');
        Add('------------------------');
        Add('Minimum Address                   = ' + CardinalToStringFormatted(Cardinal(LR_SystemInfo.lpMinimumApplicationAddress)));
        Add('Maximum VM Address                = ' + CardinalToKStringFormatted(Cardinal(LR_SystemInfo.lpMaximumApplicationAddress)));
        Add('Page Protection & Commit Size     = ' + IntToStr(LR_SystemInfo.dWPageSize));
        Add('');
        Add('Quota info:');
        Add('-----------');
        Add('Minimum Quota                     = ' + CardinalToStringFormatted(LU_MinQuota));
        Add('Maximum Quota                     = ' + CardinalToStringFormatted(LU_MaxQuota));
        Add('');
        Add('VM Info:');
        Add('--------');
        Add('Total Free                        = ' + CardinalToKStringFormatted(LU_MEM_FREE));
        Add('Total Reserve                     = ' + CardinalToKStringFormatted(LU_MEM_RESERVE));
        Add('Total Commit                      = ' + CardinalToKStringFormatted(LU_MEM_COMMIT));

        if LP_FreeVMList.Count > CI_MaxFreeBlocksList then
          LI_Max := CI_MaxFreeBlocksList - 1
        else
          LI_Max := LP_FreeVMList.Count - 1;

        for LI_I := 0 to LI_Max do
        begin
          Add('Largest Free Block ' + IntToStr(LI_I + 1) + '.             = ' + CardinalToKStringFormatted(Cardinal(LP_FreeVMList.List[LI_I])));
        end;

        Add('');
        Add('FastMM4 Info:');
        Add('-------------');
        Add('Total Blocks                      = ' + CardinalToStringFormatted(LTotalBlocks));
        Add('Total Allocated                   = ' + CardinalToStringFormatted(LTotalAllocated));
        Add('Total Reserved                    = ' + CardinalToStringFormatted(LTotalReserved));
      end;

    finally
      mVMStatistics.Lines.EndUpdate;
    end;
  end;

var
  Save_Cursor: TCursor;
begin
  if SizeOf(TMemoryMap) <> SizeOf(TMemoryMapEx) then
  begin
    Showmessage('Internal implementation error');
    Exit;
  end;

  LU_MEM_FREE := 0;
  LU_MEM_COMMIT := 0;
  LU_MEM_RESERVE := 0;

  LTotalBlocks := 0;
  LTotalAllocated := 0;
  LTotalReserved := 0;

  // Set hourglass cursor
  Save_Cursor := Screen.Cursor;
  Screen.Cursor := crHourGlass;
  LP_FreeVMList := TList.Create;
  try
    // retrieve FastMM4 info

    GetMemoryManagerState(FMemoryManagerState);
    GetMemoryMap(TMemoryMap(FMemoryMapEx));

    // Update FastMM4 Graph with EXE & DLL locations
    UpdateVMGraph(FMemoryMapEx);

    // VM dump
    UpdateVMDump;

    // FastMM4 data
    UpdateFastMM4Data;

    // General Information
    UpdateStatisticsData;

    // Screen updates
    dgMemoryMap.Invalidate;

  finally
    FreeAndNil(LP_FreeVMList);
    Screen.Cursor := Save_Cursor;
  end;
end;

procedure TfFastMMUsageTracker.tTimerTimer(Sender: TObject);
begin
  tTimer.Enabled := False;
  try
    RefreshSnapShot;
  finally
    tTimer.Enabled := True;
  end;
end;

procedure TfFastMMUsageTracker.bCloseClick(Sender: TObject);
begin
  Close;
end;

procedure TfFastMMUsageTracker.dgMemoryMapDrawCell(Sender: TObject; ACol,
  ARow: Integer; Rect: TRect; State: TGridDrawState);
var
  LChunkIndex: integer;
  LChunkColour: TColor;
begin
  {Get the chunk index}
  LChunkIndex := ARow * dgMemoryMap.ColCount + ACol;

  {Get the correct colour}
  case FMemoryMapEx[LChunkIndex] of

    csExAllocated:
      begin
        LChunkColour := $9090FF;
      end;

    csExReserved:
      begin
        LChunkColour := $90F090;
      end;

    csExSysAllocated:
      begin
        LChunkColour := $707070;
      end;

    csExSysExe:
      begin
        LChunkColour := clRed;
      end;

    csExSysDLL:
      begin
        LChunkColour := clBlue;
      end;

    csExSysReserved:
      begin
        LChunkColour := $C0C0C0;
      end

  else
    begin
      {ExUnallocated}
      LChunkColour := $FFFFFF;
    end;
  end;

  {Draw the chunk background}
  dgMemoryMap.Canvas.Brush.Color := LChunkColour;

  if State = [] then
    dgMemoryMap.Canvas.FillRect(Rect)
  else
    dgMemoryMap.Canvas.Rectangle(Rect);
end;

procedure TfFastMMUsageTracker.dgMemoryMapSelectCell(Sender: TObject; ACol,
  ARow: Integer; var CanSelect: Boolean);
var
  LChunkIndex: Cardinal;
  LMBI: TMemoryBasicInformation;
  LA_Char: array[0..MAX_PATH] of char;
begin
  eDLLName.Text := '';
  LChunkIndex := ARow * dgMemoryMap.ColCount + ACol;
  eAddress.Text := Format('$%0.8x', [LChunkIndex shl 16]);

  case FMemoryMapEx[LChunkIndex] of

    csExAllocated:
      begin
        eState.Text := 'FastMM Allocated';
      end;

    csExReserved:
      begin
        eState.Text := 'FastMM Reserved';
      end;

    csExSysAllocated:
      begin
        eState.Text := 'System Allocated';
      end;

    csExSysExe:
      begin
        eState.Text := 'System Exe';
        VirtualQuery(Pointer(LChunkIndex shl 16), LMBI, SizeOf(LMBI));
        if (GetModuleFileName(dword(LMBI.AllocationBase), LA_Char, MAX_PATH) <> 0) then
        begin
          eDLLName.Text := LA_Char;
        end;
      end;

    csExSysDLL:
      begin
        eState.Text := 'System/User DLL';
        VirtualQuery(Pointer(LChunkIndex shl 16), LMBI, SizeOf(LMBI));
        if (GetModuleFileName(dword(LMBI.AllocationBase), LA_Char, MAX_PATH) <> 0) then
        begin
          eDLLName.Text := LA_Char;
        end;
      end;

    csExSysReserved:
      begin
        eState.Text := 'System Reserved';
      end

  else
    begin
      {ExUnallocated}
      eState.Text := 'Free';
    end;
  end;
end;

procedure TfFastMMUsageTracker.bUpdateClick(Sender: TObject);
begin
  RefreshSnapShot;
end;

procedure TfFastMMUsageTracker.ChkAutoUpdateClick(Sender: TObject);
begin
  tTimer.Enabled := ChkAutoUpdate.Checked;
end;

procedure TfFastMMUsageTracker.ChkSmallGraphClick(Sender: TObject);
begin
  UpdateGraphMetrics;
  dgMemoryMap.Invalidate;
  dgMemoryMap.SetFocus;
end;

procedure TfFastMMUsageTracker.sgVMDumpMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if (Button = mbLeft) and (Shift = [ssLeft]) then
  begin
    (Sender as TStringgrid).MouseToCell(X, Y, OR_VMDumpDownCell.X, OR_VMDumpDownCell.Y);
  end
  else
  begin
    OR_VMDumpDownCell.X := 0;
    OR_VMDumpDownCell.Y := 0;
  end;
end;

procedure TfFastMMUsageTracker.sgVMDumpMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  p: TGridCoord;
  LGrid: TStringgrid;
begin
  LGrid := Sender as TStringGrid;
  if (Button = mbLeft) and (Shift = []) then
  begin
    LGrid.MouseToCell(X, Y, p.X, p.Y);
    if CompareMem(@p, @OR_VMDumpDownCell, sizeof(p))
      and (p.Y < LGrid.FixedRows)
      and (p.X >= LGrid.FixedCols) then
    begin
      HeaderClicked(LGrid, p);
    end;
  end;
  OR_VMDumpDownCell.X := 0;
  OR_VMDumpDownCell.Y := 0;
end;

procedure TfFastMMUsageTracker.sgVMDumpDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
var
  LGrid: TStringgrid;
  LMarker: Char;
begin
  LGrid := Sender as TStringgrid;
  // paint the sort marker on header columns
  if (ACol >= LGrid.FixedCols) and (aRow = 0) then
  begin
    if Assigned(LGrid.Objects[aCol, aRow]) then
    begin
      if Integer(LGrid.Objects[aCol, aRow]) > 0 then
        LMarker := 't' // up wedge in Marlett font
      else
        LMarker := 'u'; // down wedge in Marlett font
      with LGrid.canvas do
      begin
        font.Name := 'Marlett';
        font.Charset := SYMBOL_CHARSET;
        font.Size := 12;
        textout(Rect.Right - TextWidth(LMarker), Rect.Top, LMarker);
        font := LGrid.font;
      end;
    end;
  end;
end;

procedure TfFastMMUsageTracker.siMM4AllocationCopyAlltoClipboardClick(Sender: TObject);
begin
  CopyGridContentsToClipBoard(sgBlockStatistics);
end;

procedure TfFastMMUsageTracker.miVMDumpCopyAlltoClipboardClick(Sender: TObject);
begin
  CopyGridContentsToClipBoard(sgVMDump);
end;

procedure TfFastMMUsageTracker.miGeneralInformationCopyAlltoClipboardClick(Sender: TObject);
begin
  with mVMStatistics do
  begin
    Lines.BeginUpdate;
    try
      SelectAll;
      CopyToClipboard;
      SelStart := 0;
    finally
      Lines.EndUpdate;
    end;
  end;
end;

procedure ModuleInit;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    MP_GlobalMemoryStatusEx := TP_GlobalMemoryStatusEx(
      GetProcAddress(GetModuleHandle(kernel32), 'GlobalMemoryStatusEx'));
    MP_NtQuerySystemInformation := TP_NtQuerySystemInformation(
      GetProcAddress(GetModuleHandle('ntdll.dll'), 'NtQuerySystemInformation'));
  end;
end;

initialization
  ModuleInit;

end.