โปรแกรมจัดการหน่วยความจำ DELPHI

หน่วย MemoryManager;

อินเตอร์เฟซ

PROcedure SnapCurrMemStatToFile (ชื่อไฟล์: สตริง);

การดำเนินการ

การใช้งาน

Windows, SysUtils, TypInfo;

ค่าคงที่

MaxCount = สูง(คำ);

var

OldMemMgr: TMemoryManager;

ObjList: อาร์เรย์ [0..MaxCount] ของตัวชี้;

FreeInList: จำนวนเต็ม = 0;

GetMemCount: จำนวนเต็ม = 0;

FreeMemCount: จำนวนเต็ม = 0;

ReallocMemCount: จำนวนเต็ม = 0;

ขั้นตอน AddToList (P: ตัวชี้);

เริ่ม

ถ้า FreeInList > High(ObjList) แล้ว

เริ่ม

MessageBox(0, '内存管理监视器指针列表溢出，请增大列表项数！', '内存管理监视器', mb_ok);

ออก;

จบ;

ObjList [FreeInList] := P;

Inc(FreeInList);

จบ;

ขั้นตอน RemoveFromList (P: ตัวชี้);

var

ฉัน: จำนวนเต็ม;

เริ่ม

สำหรับฉัน := 0 ถึง FreeInList - 1 ทำ

ถ้า ObjList[I] = P แล้ว

เริ่ม

ธ.ค. (FreeInList);

ย้าย (ObjList [I + 1], ObjList [I], (FreeInList - I) * SizeOf (ตัวชี้));

ออก;

จบ;

จบ;

ขั้นตอน SnapCurrMemStatToFile (ชื่อไฟล์: string);

ค่าคงที่

FIELD_WIDTH = 20;

var

OutFile: ไฟล์ข้อความ;

ฉัน, CurrFree, BlockSize: จำนวนเต็ม;

ฮีปสถานะ: THEAPStatus;

รายการ: TObject;

ptd: PTypeData;

ppi: PPPropInfo;

ขั้นตอนการส่งออก (ข้อความ: string; ค่า: จำนวนเต็ม);

เริ่ม

Writeln(OutFile, ข้อความ: FIELD_WIDTH, ค่า div 1024, ' KB(', ค่า, ' ไบต์)');

จบ;

เริ่ม

AssignFile(OutFile, ชื่อไฟล์);

พยายาม

ถ้า FileExists(ชื่อไฟล์) แล้ว

เริ่ม

ผนวก(OutFile);

Writeln(OutFile);

จบ

อื่น

เขียนใหม่ (OutFile);

CurrFree := FreeInList;

HeapStatus := GetHeapStatus; { 局部堆状态 }

ด้วย HeapStatus ทำ

เริ่ม

Writeln(OutFile, '===== ', ExtractFileName(ParamStr(0)), ',', DateTimeToStr(ตอนนี้), ' =====');

Writeln(OutFile);

Output('可用地址空间 : ', TotalAddrSpace);

Output('未提交部分 : ', TotalUncomitting);

Output('已提交部分 : ', TotalCommission);

Output('空闲部分 : ', TotalFree);

Output('已分配部分 : ', TotalAllocated);

Output('全部小空闲内存块 : ', FreeSmall);

Output('全部大空闲内存块 : ', FreeBig);

Output('其它未用内存块 : ', ไม่ได้ใช้);

Output('内存管理器消耗 : ', โอเวอร์เฮด);

Writeln(OutFile, '地址空间载入 : ': FIELD_WIDTH, TotalAllocated div (TotalAddrSpace div 100), '%');

จบ;

Writeln(OutFile);

Writeln(OutFile, Format('当前出现 %d 处内存漏洞 :', [GetMemCount - FreeMemCount]));

สำหรับฉัน := 0 ถึง CurrFree - 1 ทำ

เริ่ม

เขียน (OutFile, I: 4, ') ', IntToHex (พระคาร์ดินัล (ObjList [I]), 16), ' - ');

BlockSize := PDWORD(DWORD(ObjList[I]) - 4)^;

เขียน(OutFile, BlockSize: 4, '($' + IntToHex(BlockSize, 4) + ')字节', ' - ');

พยายาม

รายการ := TObject(ObjList[I]);

ถ้า PTypeInfo(Item.ClassInfo).Kind <> tkClass แล้ว { พิมพ์เทคนิคข้อมูล }

write(OutFile, '不是对象')

อื่น

เริ่ม

ptd := GetTypeData(PTypeInfo(Item.ClassInfo));

ppi := GetPropInfo(PTypeInfo(Item.ClassInfo), 'ชื่อ'); { 如果是TComponent }

ถ้า ppi <> ไม่มีเลย

เริ่ม

เขียน (OutFile, GetStrProp (รายการ, ppi));

เขียน(OutFile, ' : ');

จบ

อื่น

เขียน(OutFile, '(未命名): ');

เขียน (OutFile, Item.ClassName, ' (', ptd.ClassType.InstanceSize,

' 字节) - ใน ', ptd.UnitName, '.pas');

จบ

ยกเว้น

ในข้อยกเว้นทำ

write(OutFile, '不是对象');

จบ;

writeln(OutFile);

จบ;

ในที่สุด

CloseFile(OutFile);

จบ;

จบ;

ฟังก์ชั่น NewGetMem (ขนาด: จำนวนเต็ม): ตัวชี้;

เริ่ม

Inc(GetMemCount);

ผลลัพธ์ := OldMemMgr.GetMem(ขนาด);

AddToList(ผลลัพธ์);

จบ;

ฟังก์ชั่น NewFreeMem (P: ตัวชี้): จำนวนเต็ม;

เริ่ม

Inc(FreeMemCount);

ผลลัพธ์ := OldMemMgr.FreeMem(P);

ลบจากรายการ(P);

จบ;

ฟังก์ชั่น NewReallocMem (P: ตัวชี้; ขนาด: จำนวนเต็ม): ตัวชี้;

เริ่ม

Inc(ReallocMemCount);

ผลลัพธ์ := OldMemMgr.ReallocMem(P, ขนาด);

ลบจากรายการ(P);

AddToList(ผลลัพธ์);

จบ;

ค่าคงที่

NewMemMgr: TMemoryManager = (

GetMem: ใหม่ GetMem;

FreeMem: ใหม่ฟรีเมม;

ReallocMem: ใหม่ ReallocMem);

การเริ่มต้น

GetMemoryManager (OldMemMgr);

SetMemoryManager (NewMemMgr);

การสรุป

SetMemoryManager (OldMemMgr);

ถ้า (GetMemCount - FreeMemCount) <> 0 แล้ว

SnapCurrMemStatToFile(ExtractFileDir(ParamStr(0)) + '/Memory.Log');

จบ.