memcheck.pas

一个本地database引擎,支持中文T_Sql查询,兼容DELPHI标准数据库控件

	public
		Name: string;
		StartAddress: Cardinal;
		EndAddress: Cardinal;

		constructor Create(const AName: string; const AStartAddress: Cardinal; const ALength: Cardinal);
	end;

var
	Routines: array of TRoutineDebugInfos;
	RoutinesCount: integer;
	Units: array of TUnitDebugInfos;
	UnitsCount: integer;
	OutputFileHeader: string = 'MemCheck version 2.60'#13#10;

function BlockAllocationAddress(P: Pointer): Pointer;
var
	Block: PMemoryBlocHeader;
begin
	Block := PMemoryBlocHeader(PChar(P) - SizeOf(TMemoryBlocHeader));

	if Block.MagicNumber = Magic then
		Result := Block.CallerAddress[0]
	else
		Result := nil
end;

procedure UpdateLastHeapStatus;
begin
	LastHeapStatus := GetHeapStatus;
end;

function HeapStatusesDifferent(const Old, New: THeapStatus): boolean;
begin
	Result :=
		(Old.TotalAddrSpace <> New.TotalAddrSpace) or
		(Old.TotalUncommitted <> New.TotalUncommitted) or
		(Old.TotalCommitted <> New.TotalCommitted) or
		(Old.TotalAllocated <> New.TotalAllocated) or
		(Old.TotalFree <> New.TotalFree) or
		(Old.FreeSmall <> New.FreeSmall) or
		(Old.FreeBig <> New.FreeBig) or
		(Old.Unused <> New.Unused) or
		(Old.Overhead <> New.Overhead) or
		(Old.HeapErrorCode <> New.HeapErrorCode) or
		(New.TotalUncommitted + New.TotalCommitted <> New.TotalAddrSpace) or
		(New.Unused + New.FreeBig + New.FreeSmall <> New.TotalFree)
end;

class function TIntegerBinaryTree.StoredValue(const Address: Cardinal): Cardinal;
begin
	Result := Address shl 16;
	Result := Result or (Address shr 16);
	Result := Result xor $AAAAAAAA;
end;

constructor TIntegerBinaryTree._Create(const Address: Cardinal);
begin	//We do not call inherited Create for optimization
	fValue := Address
end;

function TIntegerBinaryTree.Has(const Address: Cardinal): Boolean;
begin
	Result := _Has(StoredValue(Address));
end;

procedure TIntegerBinaryTree.Add(const Address: Cardinal);
begin
	_Add(StoredValue(Address));
end;

procedure TIntegerBinaryTree.Remove(const Address: Cardinal);
begin
	_Remove(StoredValue(Address));
end;

function TIntegerBinaryTree._Has(const Address: Cardinal): Boolean;
begin
	if fValue = Address then
		Result := True
	else
		if (Address > fValue) and (fBigger <> nil) then
			Result := fBigger._Has(Address)
		else
			if (Address < fValue) and (fSmaller <> nil) then
				Result := fSmaller._Has(Address)
			else
				Result := False
end;

procedure TIntegerBinaryTree._Add(const Address: Cardinal);
begin
	Assert(Address <> fValue, 'TIntegerBinaryTree._Add: already in !');

	if (Address > fValue) then
		begin
			if fBigger <> nil then
				fBigger._Add(Address)
			else
				fBigger := TIntegerBinaryTree._Create(Address)
		end
	else
		begin
			if fSmaller <> nil then
				fSmaller._Add(Address)
			else
				fSmaller := TIntegerBinaryTree._Create(Address)
		end
end;

procedure TIntegerBinaryTree._Remove(const Address: Cardinal);
var
	Owner, Node: TIntegerBinaryTree;
	NodeIsOwnersBigger: Boolean;
	Middle, MiddleOwner: TIntegerBinaryTree;
begin
	Owner := nil;
	Node := CurrentlyAllocatedBlocksTree;

	while (Node <> nil) and (Node.fValue <> Address) do
		begin
			Owner := Node;

			if Address > Node.Value then
				Node := Node.fBigger
			else
				Node := Node.fSmaller
		end;

	Assert(Node <> nil, 'TIntegerBinaryTree._Remove: not in');

	NodeIsOwnersBigger := Node = Owner.fBigger;

	if Node.fBigger = nil then
		begin
			if NodeIsOwnersBigger then
				Owner.fBigger := Node.fSmaller
			else
				Owner.fSmaller := Node.fSmaller;
		end
	else
		if Node.fSmaller = nil then
			begin
				if NodeIsOwnersBigger then
					Owner.fBigger := Node.fBigger
				else
					Owner.fSmaller := Node.fBigger;
			end
		else
			begin
				Middle := Node.fSmaller;
				MiddleOwner := Node;

				while Middle.fBigger <> nil do
					begin
						MiddleOwner := Middle;
						Middle := Middle.fBigger;
					end;

				if Middle = Node.fSmaller then
					begin
						if NodeIsOwnersBigger then
							Owner.fBigger := Middle
						else
							Owner.fSmaller := Middle;

						Middle.fBigger := Node.fBigger
					end
				else
					begin
						MiddleOwner.fBigger := Middle.fSmaller;

						Middle.fSmaller := Node.fSmaller;
						Middle.fBigger := Node.fBigger;

						if NodeIsOwnersBigger then
							Owner.fBigger := Middle
						else
							Owner.fSmaller := Middle
					end;
			end;

	Node.Destroy;
end;

constructor TFieldInfo.Create(const TheOwnerClass: TClass; const TheFieldIndex: integer);
begin
	inherited Create;

	OwnerClass := TheOwnerClass;
	FieldIndex := TheFieldIndex;
end;

const
	TObjectVirtualMethodNames: array[1..8] of string = ('SafeCallException', 'AfterConstruction', 'BeforeDestruction', 'Dispatch', 'DefaultHandler', 'NewInstance', 'FreeInstance', 'Destroy');
	AddressOfNewInstance: pointer = @TObject.NewInstance;
	AddressOfTObjectCreate: pointer = @TObject.Create;

function CallerOfCaller: pointer;	//with stack frames !
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	mov eax, [EBP]
	cmp eax, ebp
	jb @@EndOfStack
	mov eax, [eax + 4]
	sub eax, 4
	ret
	@@EndOfStack:
	mov eax, $FFFF
end;

function Caller: pointer;	//with stack frame !
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	mov eax, [ebp + 4]
	sub eax, 4
	ret
	@@EndOfStack:
	mov eax, $FFFF
end;

function CallerOfGetMem: pointer;	//System._GetMem has no stack frame
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	{$IFDEF DELPHI7_OR_LATER}
	mov eax, [ebp + 12]
	{$ELSE}
	mov eax, [ebp + 8]
	{$ENDIF}
	ret
	@@EndOfStack:
	mov eax, $FFFF
end;

function CallerOfReallocMem: pointer;	//System._ReallocMem has no stack frame
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	mov eax, [EBP + 12]
	sub eax, 4
	ret
	@@EndOfStack:
	mov eax, $FFFF
end;

{$IFNDEF VER140}
function CallerIsNewAnsiString: boolean;	//NewAnsiString has no stack frame
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@no
	mov eax, [ebp + 8]
	sub eax, 13
	cmp eax, offset System.@NewAnsiString
	je @@yes
	@@no:
	mov eax, 0
	ret
	@@yes:
	mov eax, 1
end;
{$ENDIF}

function CallerIsNewInstance: boolean;	//TObject.NewInstance has no stack frame
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@no
	{$IFNDEF DELPHI6_OR_LATER}
	mov eax, [ebp + 8]
	sub eax, 9
	{$ELSE}
	mov eax, [EBP + 12]
	sub eax, 15
	{$ENDIF}
	cmp eax, AddressOfNewInstance
	je @@yes
	@@no:
	mov eax, 0
	ret
	@@yes:
	mov eax, 1
end;

{$IFDEF DELPHI6_OR_LATER}
function ltfm_CallerOfFreeInstance: pointer;
	//Tells the address of the caller of FreeInstance from LeakTrackingFreeMem
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	mov eax, [EBP + 28]
	sub eax, 4
	ret
	@@EndOfStack:
	mov eax, $FFFF
end;

function ltfm_CallerOf_FreeMem: pointer;
	//Tells the address of the caller of System._FreeMem from LeakTrackingFreeMem
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	mov eax, [EBP + 12]
	sub eax, 4
	ret
	@@EndOfStack:
	mov eax, $FFFF
end;

function ltgmCallerOfGetMemIsTObjectCreate: boolean;
	//Tells if the guy who called GetMem is TObject.Create
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	mov eax, [ebp + 36]
	sub eax, 12
	cmp eax, AddressOfTObjectCreate
	jne @@no
	mov eax, 1
	ret
	@@no:
	@@EndOfStack:
	mov eax, 0
end;

function ltgmCallerOfTObjectCreate: pointer;
	//Tells who called TObject.Create
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@EndOfStack
	mov eax, [EBP + 56]
	ret
	@@EndOfStack:
	mov eax, $FFFF
end;

function ltgmCallerIsNewAnsiString: boolean;
	//Tells if the guy who called GetMem is NewAnsiString
asm
	cmp ebp, 0	//this can happen when there are no stack frames
	je @@no
	mov eax, [ebp + 12]
	sub eax, 17
	cmp eax, offset System.@NewAnsiString
	je @@yes
	@@no:
	mov eax, 0
	ret
	@@yes:
	mov eax, 1
end;

{$ENDIF}

procedure ReleasedInstance.RaiseExcept;
var
	t: TMemoryBlocHeader;
	i: integer;
	FeedBackStr: string;
begin
	t := PMemoryBlocHeader((PChar(Self) - SizeOf(TMemoryBlocHeader)))^;
	try
		i := MaxNbSupportedVMTEntries - GIndex + 1;
		if i in [1..8] then
			FeedBackStr:= 'Call ' + TObjectVirtualMethodNames[i]
		else
			FeedBackStr:= 'Call ' + IntToStr(i) + '