[转载]Delphi中如何检测内存泄露
Writer:flier (flier)[quote]标 题:delphi中如何检测内存泄露(null)
试试偶这个内存使用监视器:)
用法非常简单，在你的project source里把
应用这个单元的那句放到最前，如
[code]...
uses
MemoryManager in '...pas',
Forms,
Main in 'Main.pas' {frmMain},
...
修改自Delphi Developer's Handbook……
代码如下……
unit MemoryManager;
interface
var
GetMemCount: Integer = 0;
FreeMemCount: Integer = 0;
ReallocMemCount: Integer = 0;
var
mmPopupMsgDlg: Boolean = True;
mmSaveToLogFile: Boolean = True;
mmErrLogFile: string = '';
procedure SnapToFile(Filename: string);
implementation
uses
Windows, SysUtils, TypInfo;
const
MaxCount = High(Word);
var
OldMemMgr: TMemoryManager;
ObjList: array[0..MaxCount] of Pointer;
FreeInList: Integer = 0;
procedure AddToList(P: Pointer);
begin
if FreeInList > High(ObjList) then
begin
MessageBox(0, '内存管理监视器指针列表溢出，请增大列表项数！', '内存管理监视器', mb_ok);
Exit;
end;
ObjList[FreeInList] := P;
Inc(FreeInList);
end;
procedure RemoveFromList(P: Pointer);
var
I: Integer;
begin
for I := 0 to FreeInList - 1 do
if ObjList[I] = P then
begin
Dec(FreeInList);
Move(ObjList[I + 1], ObjList[I], (FreeInList - I) * SizeOf(Pointer));
Exit;
end;
end;
procedure SnapToFile(Filename: string);
var
OutFile: TextFile;
I, CurrFree, BlockSize: Integer;
HeapStatus: THeapStatus;
Item: TObject;
ptd: PTypeData;
ppi: PPropInfo;
begin
AssignFile(OutFile, Filename);
try
if FileExists(Filename) then
Append(OutFile)
else
Rewrite(OutFile);
CurrFree := FreeInList;
HeapStatus := GetHeapStatus; { 局部堆状态 }
with HeapStatus do
begin
writeln(OutFile, '--');
writeln(OutFile, DateTimeToStr(Now));
writeln(OutFile);
write(OutFile, '可用地址空间 : ');
write(OutFile, TotalAddrSpace div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '未提交部分 : ');
write(OutFile, TotalUncommitted div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '已提交部分 : ');
write(OutFile, TotalCommitted div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '空闲部分 : ');
write(OutFile, TotalFree div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '已分配部分 : ');
write(OutFile, TotalAllocated div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '地址空间载入 : ');
write(OutFile, TotalAllocated div (TotalAddrSpace div 100));
writeln(OutFile, '%');
write(OutFile, '全部小空闲内存块 : ');
write(OutFile, FreeSmall div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '全部大空闲内存块 : ');
write(OutFile, FreeBig div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '其它未用内存块 : ');
write(OutFile, Unused div 1024);
writeln(OutFile, ' 千字节');
write(OutFile, '内存管理器消耗 : ');
write(OutFile, Overhead div 1024);
writeln(OutFile, ' 千字节');
end;
writeln(OutFile);
write(OutFile, '内存对象数目 : ');
writeln(OutFile, CurrFree);
for I := 0 to CurrFree - 1 do
begin
write(OutFile, I: 4);
write(OutFile, ') ');
write(OutFile, IntToHex(Cardinal(ObjList[I]), 16));
write(OutFile, ' - ');
BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^;
write(OutFile, BlockSize: 4);
write(OutFile, '($' + IntToHex(BlockSize, 4) + ')字节');
write(OutFile, ' - ');
try
Item := TObject(ObjList[I]);
// code not reliable
{ write (OutFile, Item.ClassName);
write (OutFile, ' (');
write (OutFile, IntToStr (Item.InstanceSize));
write (OutFile, ' bytes)');}
// type info technique
if PTypeInfo(Item.ClassInfo).Kind <> tkClass then
write(OutFile, '不是对象')
else
begin
ptd := GetTypeData(PTypeInfo(Item.ClassInfo));
// name, 如果是TComponent
ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'Name');
if ppi <> nil then
begin
write(OutFile, GetStrProp(Item, ppi));
write(OutFile, ' : ');
end
else
write(OutFile, '(未命名): ');
write(OutFile, PTypeInfo(Item.ClassInfo).Name);
write(OutFile, ' (');
write(OutFile, ptd.ClassType.InstanceSize);
write(OutFile, ' 字节) - In ');
write(OutFile, ptd.UnitName);
write(OutFile, '.pas');
end
except
on Exception do
write(OutFile, '不是对象');
end;
writeln(OutFile);
end;
finally
CloseFile(OutFile);
end;
end;
function NewGetMem(Size: Integer): Pointer;
begin
Inc(GetMemCount);
Result := OldMemMgr.GetMem(Size);
AddToList(Result);
end;
function NewFreeMem(P: Pointer): Integer;
begin
Inc(FreeMemCount);
Result := OldMemMgr.FreeMem(P);
RemoveFromList(P);
end;
function NewReallocMem(P: Pointer; Size: Integer): Pointer; begin
Inc(ReallocMemCount);
Result := OldMemMgr.ReallocMem(P, Size);
RemoveFromList(P);
AddToList(Result);
end;
const
NewMemMgr: TMemoryManager = (
GetMem: NewGetMem;
FreeMem: NewFreeMem;
ReallocMem: NewReallocMem);
initialization
GetMemoryManager(OldMemMgr);
SetMemoryManager(NewMemMgr);
finalization
SetMemoryManager(OldMemMgr);
if (GetMemCount - FreeMemCount) <> 0 then
begin
if mmPopupMsgDlg then
MessageBox(0, PChar(Format('出现%d处内存漏洞: ',
[GetMemCount - FreeMemCount])), '内存管理监视器', mb_ok);
if mmErrLogFile = '' then
mmErrLogFile := ExtractFileDir(ParamStr(0)) + '.Log';
if mmSaveToLogFile then
SnapToFile(mmErrLogFile);
end;
end.[/code]
[/quote] 据说是修正Delphi VCL内存泄漏用的
{ 需要修改Forms.pas单元或这是其他单元中相应的代码 }
[code]// While discussing one memory leak in Russian FidoNet Delphi conference, it
// seemed to turn out that Object Instancing is subject to be buggy.
// I tried to mend those problem. Thanx to anyone, who's posts i used in this patch
// These are changes for forms.pas (Delphi 5 and prior) or classes.pas (Delphi 6 or above)
// Made by [email]Arioch@nm.ru[/email]
// PS: I wonder if publishing bugfixes to Borland's RTL violates its licanse, since bugfix
// is certainly a 'derived software'
// Resume of trouble:
// Seems that MakeObjInstance been made in Delphi 1, where it tried to mimic MS-DOS styled
// chained lists (file handles, fcbs, mcbs, disk buffers, etc...)
// But the job was not finished and so there is an issues:
// 1) if one uses dll's with forms, Delphi leaks 4kb of RAM at each freeing of the last form,
// created in DLL.
// 2) more generic: RAM will leak at each subsequent call to MakeObjInstance having (mod 314 = 0)
// i hope it will fix it.
const
InstanceCount = 313;
{ Object instance management }
type
PObjectInstance = ^TObjectInstance;
TObjectInstance = packed record
Code: Byte;
Offset: Integer;
case Integer of
0: (Next: PObjectInstance);
1: (Method: TWndMethod);
end;
type
PInstanceBlock = ^TInstanceBlock;
TInstanceBlock = packed record
Next: PInstanceBlock;
Counter: word; //Arioch - aligning WndProcPtr to 32-bit boundary.
// We sure can add this after Instances to keep binary compatibility,
// but possibly loose in spead since no boundary for pointer and since
// counter would not be cached in CPU when reading record header
// after this addition record size is 4094 bytes. There are 2 bytes more for a i386 page
Code: array[1..2] of Byte;
WndProcPtr: Pointer;
Instances: array[0..InstanceCount] of TObjectInstance;
end;
var
InstBlockList: PInstanceBlock;
InstFreeList: PObjectInstance;
InstCritSect: TCriticalSection; //Arioch: multi-thread blocker
implementation
uses SyncObjs, //Arioch: add the rest of uses clause.... Need TCriticalSection from unit.
function CalcJmpOffset(Src, Dest: Pointer): Longint;
begin
Result := Longint(Dest) - (Longint(Src) + 5);
end;
function CalcJmpTarget(Src: Pointer, Offs: integer): Pointer; //Arioch
begin
Integer(Result) := Offs + (Longint(Src) + 5);
end;
function GetInstanceBlock(ObjectInstance: Pointer): PInstanceBlock; //Arioch
var oi: PObjectInstance absolute ObjectInstance; //i'mm to lazy to use with and typecast :-)
begin Result := nil; if ObjectInstance = nil then exit;
Pointer(Result) := CalcJmpTarget(ObjectInstance, oi^.Offset)
- sizeof(TInstanceBlock.Counter) - sizeof(TInstanceBlock.Next);
end;
function MakeObjectInstance(Method: TWndMethod): Pointer;
const
BlockCode: array[1..2] of Byte = (
$59, { POP ECX }
$E9); { JMP StdWndProc }
PageSize = 4096;
var
Block: PInstanceBlock;
Instance: PObjectInstance;
begin
try InstCritSect.Enter;
if InstFreeList = nil then
begin
Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
Block^.Next := InstBlockList; //Arioch: seems inherited from D1 -
// not finished MS-DOS styled array-chains model
// Move(BlockCode, Block^.Code, SizeOf(BlockCode));
//Arioch: since the procedure is not inline - it is CPU loss
Word(Block^.Code) := Word(BlockCode);
//Arioch: here we assume size of 2 bytes - but here is so lot of hacks, that one more will not hurt
Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
Block^.Counter := 0; // Arioch: here we will init counter
Instance := @Block^.Instances;
repeat
Instance^.Code := $E8; { CALL NEAR PTR Offset }
Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
Instance^.Next := InstFreeList; //Nil, then prev. Instance
InstFreeList := Instance;
//Inc(Longint(Instance), SizeOf(TObjectInstance));
//Arioch: LongInt? certainly D1 code, not even D3! Let's avoid misty code!
Instance := Succ(Instance);
until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
InstBlockList := Block;
end;
Result := InstFreeList;
Instance := InstFreeList;
InstFreeList := Instance^.Next;
Instance^.Method := Method;
Inc(GetInstanceBlock(Instance)^.Counter); //Arioch: need not check for overflow
// since last one will have NExt = nil, making RTL to allocate new block
finally InstCritSect.Leave; end;
end;
function FreeInstanceBlock(block: pointer): boolean;
var bi: PInstanceBlock absolute block;
oi, poi, noi: PObjectInstance; // needed to free block
begin
Result := false; if bi = nil then exit; if bi^.Counter <> 0 then exit;
oi := InstFreeList; poi := nil;
while oi <> nil do begin
noi := oi^.next;
// Here we must remove instances from the free-list before freeing block
// Othewise MakeObjectInstance will reuse it :-( leading to GPF
// I hope we do not need oi any more! We have bi instead.
if GetInstanceBlock(oi) = bi then // our victim! steal it away!
if poi <> nil then poi^.Next := noi;
if oi = InstFreeList then InstFreeList := noi;
// not effective, but simple, stupid, and solid (i hope)
end;
poi := oi; oi := noi;
end;
VirtualFree(block, 0, MEM_RELEASE); // no more memory leaks! at last! i hope!!!
Result := true;
end;
procedure FreeInstanceBlocks; //Garbage collection. Queerest of the queer.
var pbi, bi, nbi: PBlockInstance;
begin
pbi := nil; bi := InstBlockList;
while bi <> nil do begin
nbi := bi^.Next;
if FreeInstanceBlock(bi) then begin
if pbi <> nil then pbi^.Next := nbi;
if bi = InstBlockList then InstBlockList := nbi;
// not effective, but simple, stupid, and solid (i hope)
end;
pbi := bi; bi := nbi;
end;
end;
{ Free an object instance }
procedure FreeObjectInstance(ObjectInstance: Pointer);
var bi: PInstanceBlock; i: integer; //Arioch
oi: PObjectInstance absolute ObjectInstance; //i'm to lazy to use with and typecast :-)
begin
if ObjectInstance <> nil then
try InstCritSect.Enter;
bi := GetInstanceBlock(ObjectInstance); // what the block did we cleaned a bit?
if bi = nil then exit; // i cannot tell how may this be - but it is a crush!
if (bi^.Counter <= 0) or (bi^.Counter > InstanceCount + 1) then exit;
// crash! it was not TObjectInstance???
PObjectInstance(ObjectInstance)^.Next := InstFreeList;
InstFreeList := ObjectInstance;
//saving freed instance for the further re-use in never-sorting list.
//maybe it would be better to keep tracks in easc of blocks separately
//(for example checking if Instance^.Next=nil), but... To much to change.
Dec(bi^.Counter); if bi^.Counter <= 0 then FreeInstanceBlocks;
//full garbage collection - no one tells that we're freeing the top block!
finally InstCritSect.Leave; end;
end;
initialization
InstCritSect := TCriticalSection.Create();
//Arioch: here put the rest of original initialisation of unit
finalization
InstCritSect.Free();
//Arioch: here put the rest of original finalisation of unit
[/code]
页:
[1]