我的Delphi程序似乎存在内存泄漏问题

Question

好的，我对Delphi相当新（从我的代码中你会看出来 - 尽量不要笑得太厉害以至于受伤），但是我已经成功制作了一个小型桌面画布颜色选择器。它能够工作，但有点漏水，这就是我来到这里的原因 :D

它似乎有泄漏现象。开始时，它使用约2 MB的内存，并且每秒钟增加约2 kB，直到在大约10分钟后达到约10 MB。在我的双核2.7 GHz CPU上，它使用5%到20%的CPU功率，波动不定。在持续运行大约10分钟后，我的电脑变得无响应。

从下面的源代码中可以看到，我正在释放TBitmap（或者说我试图这样做，不确定是否成功，似乎不起作用）。

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  GetCursorPos(MousePos);

  try
    Canvas1 := TCanvas.Create;
    Canvas1.Handle := GetDC(0);
    Pxl  := TBitmap.Create;
    Pxl.Width  := 106;
    Pxl.Height := 106;
    W := Pxl.Width;
    H := Pxl.Height;
    T := (W div 2);
    L := (H div 2);
    Zoom := 10;
    Rect1 := Rect(MousePos.X - (W div Zoom), MousePos.Y - (H div Zoom), MousePos.X + (W div Zoom), MousePos.Y + (H div Zoom));
    Rect2 := Rect(0, 0, H, W);
    Pxl.Canvas.CopyRect(Rect2, Canvas1, Rect1);
    Pxl.Canvas.Pen.Color := clRed;
    Pxl.Canvas.MoveTo(T, 0);
    Pxl.Canvas.LineTo(L, H);
    Pxl.Canvas.MoveTo(0, T);
    Pxl.Canvas.LineTo(W, L);
    Image1.Picture.Bitmap := Pxl;
  finally
    Pxl.Free;
  end;

  try
    Pxl2 := TBitmap.Create;
    Pxl2.Width  := 1;
    Pxl2.Height := 1;
    Box1 := MousePos.X;
    Box2 := MousePos.Y;

    BitBlt(Pxl2.Canvas.Handle, 0, 0, 1, 1, GetDC(0), Box1, Box2, SRCCOPY);
    C := Pxl2.Canvas.Pixels[0, 0];
    Coord.Text := IntToStr(Box1) + ', ' + IntToStr(Box2);
    DelColor.Text := ColorToString(C);
    HexColor.Text := IntToHex(GetRValue(C), 2) + IntToHex(GetGValue(C), 2) + IntToHex(GetBValue(C), 2);
    RGB.Text := IntToStr(GetRValue(C)) + ', ' + IntToStr(GetGValue(C)) + ', ' + IntToStr(GetBValue(C));
    Panel1.Color := C;
  finally
    Pxl2.Free;
  end;
end;

procedure TForm1.OnKeyDown(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
  begin
    if Timer1.Enabled then
      begin
        Timer1.Enabled := false;
        Panel2.Caption := 'Got it! Press Enter to reset.';
      end
    else
      begin
        Timer1.Enabled := true;
        Panel2.Caption := 'Press Enter to lock color.';
      end;
  end;
end;

注意：如果这有任何影响，定时器设置为每10毫秒运行一次。

非常感谢任何和所有帮助找出为什么会出现内存泄漏并且使用了如此多的资源！

如果需要，您可以在此处获取项目（Delphi 2010）：http://www.mediafire.com/file/cgltcy9c2s80f74/Color%20Picker.rar 谢谢！

- Clowerweb

---

谢谢，我会尝试将它们移除。它们实际上会造成问题吗，还是只是不需要？ - Clowerweb

为什么要使用计时器？不应该使用OnMouseMove吗？空闲时没有运行计时器的意义。 - David Heffernan

真的，但如果您将鼠标保持静止在可能更改颜色的动画或其他内容上，则无法更新颜色。计时器是所有CPU使用率的原因吗，还是它不断使用更多内存，或者两者都有？ - Clowerweb

此外，您应该在try...finally之前创建要释放的对象。不要在try finally中创建。Canvas1和Pxl。那么Pxl2是什么？ - Lars Truijens

嗨，Lars，假设你指的是内存和CPU使用情况，读数来自于观察Windows任务管理器中的应用程序。我将尝试将创建对象移至外部 - 这会有什么影响吗？将它们放在那里的缺点是什么，或者这只是一般最佳实践？ - Clowerweb

Answer 1

您从未释放Canvas1对象，导致进程堆和GDI对象的句柄泄漏。

- OnTheFly

---

谢谢！乍一看，似乎将CPU使用率减少了约一半，但由于某些原因，内存使用仍在增加。 - Clowerweb

看起来这是正确的答案。另外值得注意的是，你可以让Delphi告诉你内存泄漏发生在哪里和什么地方。 "什么"很容易。只需设置 ReportMemoryLeaksAtShutdown：= true。 "哪里"有点棘手。为此，您需要从SourceForge下载FastMM4的完整版本，并使用FullDebugMode获取内存泄漏的堆栈跟踪。它提供了如何在项目中执行此操作的说明。 - Mason Wheeler

谢谢Mason，我实际上尝试了FastMM，即使我按照它的指示将其作为第一个“uses”，它仍然说内存已经分配，这让我感到奇怪。可能是我的Delphi版本的问题吗？ - Clowerweb

@Clowerweb：这是您的表格的第一次使用还是DPR的第一次使用？它必须放在DPR的第一次使用中才能起作用，而不仅仅是表格。 - Mason Wheeler

啊，谢谢你，梅森！一个朋友指出我在这种情况下可能误用了“内存泄漏”这个术语。他说这不是内存泄漏，只是继续使用更多的内存，而内存泄漏通常被定义为应用程序在关闭后没有释放它正在使用的内存。不确定这是否正确，但这很有道理。无论我的程序在做什么，在运行时它每秒钟会使用大约2 kB的内存（不确定它关闭后会发生什么）。 - Clowerweb

Answer 2

正如用户在上面所说的那样，拥有桌面窗口DC的TCanvas实例从未被释放，也没有释放DC。我在这里发现了另一个DC泄漏问题：

BitBlt(Pxl2.Canvas.Handle, 0, 0, 1, 1, GetDC(0), Box1, Box2, SRCCOPY);
                                       ^^^^^^^^

这并不能解决内存泄漏问题，但可以解释为什么Windows在20分钟后变得无响应（假设之前的问题已经修复）。

---

每个 GetDC 调用都需要与之对应的 ReleaseDC。事实上，GDI 对象比内存更加珍贵。

- Premature Optimization

---

是的，之前的漏洞已经被修补了，但并没有太大的改变。内存使用仍然快速上升，CPU使用率在前两分钟之间从2％到10％开始，然后在接下来的7分钟左右上升到15％-20％，直到电脑再次无响应。 - Clowerweb

那你建议怎么清除呢？它是一个函数，所以不能真正被清除。如果我听起来像个新手，对不起，但是我确实是。 - Clowerweb

谢谢！CPU使用率降到了2%至5%之间，大约是我们起始点的四分之一。不幸的是，内存使用率仍在上升，但这至少解决了一个问题！ - Clowerweb

ReleaseDC对于类或私有DC不是必需的。（但屏幕DC是一个常见的DC，而不是类或私有DC。）DC与内存一样珍贵。 - Rob Kennedy

看起来我又错了。虽然似乎有所改善，但在大约五分钟后，CPU 使用率开始再次慢慢攀升至约 20％ 左右，但这次我并没有注意到相同的性能下降。我仍然希望它保持非常低的 CPU 使用率。 - Clowerweb

Answer 3

好的，我在尝试一番并参考了这里的一些指针后，终于找到了解决方案。虽然没有人完全正确地解决了问题，但每个人都走在了正确的轨道上。问题在于我在函数内（以及早期版本中的计时器过程）调用了GetDC()。将其移动到“try ... finally”之外，同时保持在函数中（如建议所述），仍未产生结果，但已经接近，并给了我一个实际有效的想法。所以我将它移得更远-进入表单的OnCreate事件。

以下是最终代码：

function DesktopColor(const X, Y: Integer): TColor;
begin
  Color1 := TCanvas.Create;
  Color1.Handle := DC;
  Result := GetPixel(Color1.Handle, X, Y);
  Color1.Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  GetCursorPos(Pos);
  Rect1 := Rect(Pos.X - (W div Zoom), Pos.Y - (H div Zoom), Pos.X + (W div Zoom), Pos.Y + (H div Zoom));
  Rect2 := Rect(0, 0, H, W);
  Pxl.Canvas.CopyRect(Rect2, Canvas1, Rect1);
  Pxl.Canvas.Pen.Color := clRed;
  Pxl.Canvas.MoveTo(T, 0);
  Pxl.Canvas.LineTo(L, H);
  Pxl.Canvas.MoveTo(0, T);
  Pxl.Canvas.LineTo(W, L);
  Image1.Picture.Bitmap := Pxl;
  Coord.Text := IntToStr(Pos.X) + ', ' + IntToStr(Pos.Y);
  C := DesktopColor(Pos.X, Pos.Y);
  DelColor.Text := ColorToString(C);
  HexColor.Text := IntToHex(GetRValue(C), 2) + IntToHex(GetGValue(C), 2) + IntToHex(GetBValue(C), 2);
  RGB.Text := IntToStr(GetRValue(C)) + ', ' + IntToStr(GetGValue(C)) + ', ' + IntToStr(GetBValue(C));
  Panel1.Color := C;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Pxl := TBitmap.Create;
  Canvas1 := TCanvas.Create;
  DC := GetDC(0);
  Pxl.Width  := 106;
  Pxl.Height := 106;
  Canvas1.Handle := DC;
  W := Pxl.Width;
  H := Pxl.Height;
  T := (W div 2);
  L := (H div 2);
  Zoom := 10;
  Timer1.Enabled := True;
end;

procedure TForm1.OnKeyDown(Sender: TObject; var Key: Char);
begin
  if Key = #13 then
  begin
    if Timer1.Enabled then
      begin
        Timer1.Enabled := false;
        Panel2.Caption := 'Got it! Press Enter to reset.';
      end
    else
      begin
        Timer1.Enabled := true;
        Panel2.Caption := 'Press Enter to lock color.';
      end;
  end;
end;

procedure TForm1.OnDestroy(Sender: TObject);
begin
  ReleaseDC(0, Canvas1.Handle);
  ReleaseDC(0, Color1.Handle);
end;

最终结果如下：CPU使用率：00％空闲，如果您移动鼠标足够快，则为01％峰值；内存使用率：~3,500 kB solid，保持不变。我甚至将计时器从10毫秒提高到5毫秒，仍然得到相同的数字。

以下是所有上述修复的最终项目：http://www.mediafire.com/file/ebc8b4hzre7q6r5/Color%20Picker.rar 感谢所有帮助过我的人，我非常感激！我打算开源该项目，供所有发现此帖子并发现它有用的人使用。没有许可证，请随意使用。无需给予信用，但如果您想在其中留下我的名字，那就很酷:D

- Clowerweb

Answer 4

关于你的 DesktopColor 代码的一些评论：

如果创建或获取 DC 失败，将不会锁定任何资源，解锁或释放将会生成错误，因为你试图释放不存在的资源。

规则是初始化应该总是在 try 前完成，否则你将不知道是否安全地析构入口。
在这种情况下，这并不是一个很大的问题，因为 GetxDC/ReleaseDC 不会生成异常，如果不成功只会返回 0。

其次，我建议添加测试以确保使用 DC 的调用成功。当使用 Delphi 对象时，你不需要这样做，因为异常会处理这个问题，但 Windows DC 不使用异常，所以你需要自己进行测试。我建议使用断言，因为你可以在调试时启用它们，在程序调试完成后禁用它们。

但由于 GetxDC 从不生成异常，并且为了保持一致，我建议将代码更改为：

{$C+} //enable assertions for debug purposes.
//or {$C-} //Disable assertions in production code

function DesktopColor(const X, Y: Integer): TColor;
var 
  Color: TCanvas; 
  Handle: THandle;   
begin     
  Color := TCanvas.Create;
  //If the create fails GetWindowsDC will not get stored anywhere 
  //and we cannot free it. 
  Handle:= GetWindowDC(GetDesktopWindow); 
  try
    Assert(Handle <> 0);
    Color.Handle := Handle; //Will generate an exception if create failed. 
    Handle := 0;       
    Result := GetPixel(Color.Handle, X, Y);   
  finally   
    //Free the handle if it wasn't transfered to the canvas.
    if Handle <> 0 then ReleaseDC(0, Handle); 
    Color.Free;  //TCanvas.Destroy will call releaseDC on Color.handle.
                 //If the transfer was succesful 
  end; {tryf}   
end;

对于Timer1Timer，同样的参数适用。

警告
当你禁用断言时，Delphi将从你的项目中删除整个assert语句，因此不要在assert中放置任何具有副作用的代码！

链接：
断言：http://beensoft.blogspot.com/2008/02/using-assert.html

- Johan

---

谢谢！我实际上找到了解决方案，但是它让我等待2个小时才能发布答案。实际上，问题在于我必须将其完全移出函数（仅将其移动到try...finally之外不起作用）。我将GetDC调用移动到窗体的OnCreate事件中，就解决了！ - Clowerweb

@Clowerweb，缓存那些DC的想法不错。我建议看一下TCanvas的源代码，如果你处理句柄的方式像TCanvas处理它们一样，那么你就知道你已经正确地处理了这些句柄。 - Johan

谢谢Johan，提供了许多有用的技巧。最终我编辑了原始帖子，如果你想看结果的话。我很高兴这个问题终于解决了，它困扰了我很长时间，而答案却是如此简单。 - Clowerweb

顺便提一下，你可以使用Win32Check代替Assert来获得更具体的错误消息。 - Premature Optimization