memcheck.pas

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

problem because they just rely on putting the unit first in the DPR; but this is not safe without a build all.
In MemCheck we absolutely need to use two units: SysUtils and Windows.
Then, I decided in MemCheck 2.54 to use the unit Classes because I think it will lead to much simpler code.
We also use two units which we can use without risk since they dont have a finalization: Math and SyncObjs.
An analysis of the uses clauses of these five units shows that in fact MemCheck uses indirectly the following units:
Math, Classes, Typinfo, Consts, Variants, VaRUtils, SysUtils, ActiveX, Messages, SysConst, Windows, SyncObjs, System, SysInit and Types.
Of these, only Classes, Variants, System and SysUtils have a finalization section. I checked and it is not possible to have a leak
reported by MemCheck which is not correct because the memory would have been freed by one of these finalizations.
In the procedure ChangeFinalizationsOrder I make sure that only these four units are finalized after MemCheck (I could have decided for
the fifteen, but this would be more work, and I know it is useless).
*)
unit MemCheck;
{$A+}
{$H+}
{$IFDEF VER150}
	{$DEFINE DELPHI6_OR_LATER}
	{$DEFINE DELPHI7_OR_LATER}
	{$WARNINGS OFF}	//We probably don't want to hear about warnings - Not sure about that
{$ENDIF}
{$IFDEF VER140}
	{$DEFINE DELPHI6_OR_LATER}
{$ENDIF}
{$IFDEF DELPHI6_OR_LATER}
	{$WARN UNIT_PLATFORM OFF}	//NOT certified for Kylix
	{$WARN SYMBOL_PLATFORM OFF}
	{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}

interface

procedure MemChk;
{Activates MemCheck and resets the allocated blocks stack.
Warning: the old stack is lost ! - It is the client's duty to commit the
releasable blocks by calling CommitReleases(AllocatedBlocks)}

procedure UnMemChk;
{sets back the memory manager that was installed before MemChk was called
If MemCheck is not active, this does not matter. The default delphi memory manager is set.
You should be very careful about calling this routine and know exactly what it does (see the FAQ on the web site)}

procedure CommitReleases;
{really releases the blocks}

procedure AddTimeStampInformation(const I: string);
{Logs the given information as associated with the current time stamp
Requires that MemCheck is active}

procedure LogSevereExceptions(const WithVersionInfo: string);
{Activates the exception logger}

function MemoryBlockCorrupted(P: Pointer): Boolean;
{Is the given block bad ?
P is a block you may for example have created with GetMem, or P can be an object.
Bad means you have written beyond the block's allocated space or the memory for this object was freed.
If P was allocated before MemCheck was launched, we return False}

function BlockAllocationAddress(P: Pointer): Pointer;
{The address at which P was allocated
If MemCheck was not running when P was allocated (ie we do not find our magic number), we return $00000000}

function IsMemCheckActive: boolean;
{Is MemCheck currently running ?
ie, is the current memory manager memcheck's ?}

function TextualDebugInfoForAddress(const TheAddress: Cardinal): string;

var
	MemCheckLogFileName: string = 's:\MemCheck.log';	//The file memcheck will log information to
	DeallocateFreedMemoryWhenBlockBiggerThan: Integer = 0;
	{should blocks be really deallocated when FreeMem is called ? If you want all blocks to be deallocated, set this
	constant to 0. If you want blocks to be never deallocated, set the cstte to MaxInt. When blocks are not deallocated,
	MemCheck can give information about when the second deallocation occured}

	ShowLogFileWhenUseful: Boolean = True;

const
	StoredCallStackDepth = 26;
	{Size of the call stack we store when GetMem is called, must be an EVEN number}

type
	TCallStack = array[0..StoredCallStackDepth] of Pointer;

procedure FillCallStack(var St: TCallStack; const NbLevelsToExclude: integer);
//Fills St with the call stack

function CallStackTextualRepresentation(const S: TCallStack; const LineHeader: string): string;
//Will contain CR/LFs

implementation

uses
	Windows,							{Windows has no finalization, so is OK to use with no care}
	Classes,
	Math,
	SyncObjs,
	{$IFDEF DELPHI6_OR_LATER}Variants,{$ENDIF}
	SysUtils;						   {Because of this uses, SysUtils must be finalized after MemCheck - Which is necessary anyway because SysUtils calls DoneExceptions in its finalization}

type
	TKindOfMemory = (MClass, MUser, MReallocedUser);
	{MClass means the block carries an object
	MUser means the block is a buffer of unknown type (in fact we just know this is not an object)
	MReallocedUser means this block was reallocated}

const
	(**************** MEMCHECK OPTIONS ********************)
	DanglingInterfacesVerified = False;
	{When an object is destroyed, should we fill the interface VMT with a special value which
	will allow tracking of calls to this interface after the object was destroyed - This incompatible with CheckWipedBlocksOnTermination, so you have to choose}

	WipeOutMemoryOnFreeMem = True;
	{This is about what is done on memory freeing:
	- for objects, this option replaces the VMT with a special one which will raise exceptions if a virtual method is called
	- for other memory kinds, this will fill the memory space with the char below}
	CharToUseToWipeOut: char = #0;
	//I choose #0 because this makes objet fields Nil, which is easier to debug. Tell me if you have a better idea !

	CheckWipedBlocksOnTermination = True and WipeOutMemoryOnFreeMem and not (DanglingInterfacesVerified);
	{When iterating on the blocks (in OutputAllocatedBlocks), we check for every block which has been deallocated that it is still
	filled with CharToUseToWipeOut.
	Warning: this is VERY time-consuming
	This is meaningful only when the blocks are wiped out on free mem
	This is incompatible with dangling interfaces checking}
	DoNotCheckWipedBlocksBiggerThan = 4000;

	CollectStatsAboutObjectAllocation = False;
	{Every time FreeMem is called for allocationg an object, this will register information about the class instanciated:
	class name, number of instances, allocated space for one instance
	Note: this has to be done on FreeMem because when GetMem is called, the VMT is not installed yet and we can not know
	this is an object}

	KeepMaxMemoryUsage = CollectStatsAboutObjectAllocation;
	{Will report the biggest memory usage during the execution}

	ComputeMemoryUsageStats = False;
	{Outputs the memory usage along the life of the execution. This output can be easily graphed, in excel for example}
	MemoryUsageStatsStep = 5;
	{Meaningful only when ComputeMemoryUsageStats
	When this is set to 5, we collect information for the stats every 5 call to GetMem, unless size is bigger than StatCollectionForce}
	StatCollectionForce = 1000;

	BlocksToShow: array[TKindOfMemory] of Boolean = (true, true, true);
	{eg if BlocksToShow[MClass] is True, the blocks allocated for class instances will be shown}

	CheckHeapStatus = False;
	// Checks that the heap has not been corrupted since last call to the memory manager
	// Warning: VERY time-consuming

	IdentifyObjectFields = False;
	IdentifyFieldsOfObjectsConformantTo: TClass = Tobject;

	MaxLeak = 1000;
	{This option tells to MemCheck not to display more than a certain quantity of leaks, so that the finalization
	phase does not take too long}

	UseDebugInfos = True;
	//Should use the debug informations which are in the executable ?

   (**************** END OF MEMCHECK OPTIONS ********************)

var
	ShowCallStack: Boolean;
	{When we show an allocated block, should we show the call stack that went to the allocation ? Set to false
	before each block. The usual way to use this is calling Evaluate/Modify just after an EMemoryLeak was raised}

const
	MaxListSize = MaxInt div 16 - 1;

type
	PObjectsArray = ^TObjectsArray;
	TObjectsArray = array[0..MaxListSize] of TObject;

	PStringsArray = ^TStringsArray;
	TStringsArray = array[0..99999999] of string;
	{Used to simulate string lists}

	PIntegersArray = ^TIntegersArray;
	TIntegersArray = array[0..99999999] of integer;
	{Used to simulate lists of integer}

var
	TimeStamps: PStringsArray = nil;
	{Allows associating a string of information with a time stamp}
	TimeStampsCount: integer = 0;
	{Number of time stamps in the array}
	TimeStampsAllocated: integer = 0;
	{Number of positions available in the array}

const
	DeallocateInstancesConformingTo = False;
	InstancesConformingToForDeallocation: TClass = TObject;
	{used only when BlocksToShow[MClass] is True - eg If InstancesConformingTo = TList, only blocks allocated for instances
	of TList and its heirs will be shown}

	InstancesConformingToForReporting: TClass = TObject;
	{used only when BlocksToShow[MClass] is True - eg If InstancesConformingTo = TList, only blocks allocated for instances
	of TList and its heirs will be shown}

	MaxNbSupportedVMTEntries = 200;
	{Don't change this number, its a Hack! jm}

type
	PMemoryBlocHeader = ^TMemoryBlocHeader;
	TMemoryBlocHeader = record
		{
		This is the header we put in front of a memory block
		For each memory allocation, we allocate "size requested + header size + footer size" because we keep information inside the memory zone.
		Therefore, the address returned by GetMem is: [the address we get from OldMemoryManager.GetMem] + HeaderSize.

		. DestructionAdress: an identifier telling if the bloc is active or not (when FreeMem is called we do not really free the mem).
		  Nil when the block has not been freed yet; otherwise, contains the address of the caller of the destruction. This will be useful
		  for reporting errors such as "this memory has already been freed, at address XXX".
		. PreceedingBlock: link of the linked list of allocated blocs
		. NextBlock: link of the linked list of allocated blocs
		. KindOfBlock: is the data an object or unknown kind of data (such as a buffer)
		. VMT: the classtype of the object
		. CallerAddress: an array containing the call stack at allocation time
		. AllocatedSize: the size allocated for the user (size requested by the user)
		. MagicNumber: an integer we use to recognize a block which was allocated using our own allocator
		}
		DestructionAdress: Pointer;
		PreceedingBlock: Pointer;
		NextBlock: Pointer;
		KindOfBlock: TKindOfMemory;
		VMT: TClass;
		CallerAddress: TCallStack;
		AllocatedSize: integer;		 //this is an integer because the parameter of GetMem is an integer
		LastTimeStamp: integer;		 //-1 means no time stamp
		NotUsed: Cardinal;			  //Because Size of the header must be a multiple 8
		MagicNumber: Cardinal;
	end;

	PMemoryBlockFooter = ^TMemoryBlockFooter;
	TMemoryBlockFooter = Cardinal;
	{This is the end-of-bloc marker we use to check that the user did not write beyond the allowed space}

	EMemoryLeak = class(Exception);
	EStackUnwinding = class(EMemoryLeak);
	EBadInstance = class(Exception);
	{This exception is raised when a virtual method is called on an object which has been freed}
	EFreedBlockDamaged = class(Exception);
	EInterfaceFreedInstance = class(Exception);
	{This exception is raised when a method is called on an interface whom object has been freed}

	VMTTable = array[0..MaxNbSupportedVMTEntries] of pointer;
	pVMTTable = ^VMTTable;
	TMyVMT = record
		A: array[0..19] of byte;
		B: VMTTable;
	end;

	ReleasedInstance = class
		procedure RaiseExcept;
		procedure InterfaceError; stdcall;
		procedure Error; virtual;
	end;

	TFieldInfo = class
		OwnerClass: TClass;
		FieldIndex: integer;

		constructor Create(const TheOwnerClass: TClass; const TheFieldIndex: integer);
	end;

const
	EndOfBlock: Cardinal = $FFFFFFFA;
	Magic: Cardinal = $FFFFFFFF;

var
	FreedInstance: PChar;
	BadObjectVMT: TMyVMT;
	BadInterfaceVMT: VMTTable;
	GIndex: Integer;

	LastBlock: PMemoryBlocHeader;

	MemCheckActive: boolean = False;
	{Is MemCheck currently running ?
	ie, is the current memory manager memcheck's ?}
	MemCheckInitialized: Boolean = False;
	{Has InitializeOnce been called ?
	This variable should ONLY be used by InitializeOnce and the finalization}

   {*** arrays for stats ***}
	AllocatedObjectsClasses: array of TClass;
	NbClasses: integer = 0;

	AllocatedInstances: PIntegersArray = nil; {instances counter}
	AllocStatsCount: integer = 0;
	StatsArraysAllocatedPos: integer = 0;
	{This is used to display some statistics about objects allocated. Each time an object is allocated, we look if its
	class name appears in this list. If it does, we increment the counter of class' instances for this class;
	if it does not appear, we had it with a counter set to one.}

	MemoryUsageStats: PIntegersArray = nil; {instances counter}
	MemoryUsageStatsCount: integer = 0;
	MemoryUsageStatsAllocatedPos: integer = 0;
	MemoryUsageStatsLoop: integer = -1;

	SevereExceptionsLogFile: Text;
	{This is the log file for exceptions}

	OutOfMemory: EOutOfMemory;
	// Because when we have to raise this, we do not want to have to instanciate it (as there is no memory available)

	HeapCorrupted: Exception;

	NotDestroyedFields: PIntegersArray = nil;
	NotDestroyedFieldsInfos: PObjectsArray = nil;
	NotDestroyedFieldsCount: integer = 0;
	NotDestroyedFieldsAllocatedSpace: integer = 0;

	LastHeapStatus: THeapStatus;

	MaxMemoryUsage: Integer = 0;
	// see KeepMaxMemoryUsage

	OldMemoryManager: TMemoryManager;
	//Set by the MemChk routine

type
	TIntegerBinaryTree = class
	protected
		fValue: Cardinal;
		fBigger: TIntegerBinaryTree;
		fSmaller: TIntegerBinaryTree;

		class function StoredValue(const Address: Cardinal): Cardinal;
		constructor _Create(const Address: Cardinal);
		function _Has(const Address: Cardinal): Boolean;
		procedure _Add(const Address: Cardinal);
		procedure _Remove(const Address: Cardinal);

	public
		function Has(const Address: Cardinal): Boolean;
		procedure Add(const Address: Cardinal);
		procedure Remove(const Address: Cardinal);

		property Value: Cardinal read fValue;
	end;

	PCardinal = ^Cardinal;

var
	CurrentlyAllocatedBlocksTree: TIntegerBinaryTree;

type
	TAddressToLine = class
	public
		Address: Cardinal;
		Line: Cardinal;

		constructor Create(const AAddress, ALine: Cardinal);
	end;

	PAddressesArray = ^TAddressesArray;
	TAddressesArray = array[0..MaxInt div 16 - 1] of TAddressToLine;

	TUnitDebugInfos = class
	public
		Name: string;
		Addresses: array of TAddressToLine;

		constructor Create(const AName: string; const NbLines: Cardinal);

		function LineWhichContainsAddress(const Address: Cardinal): string;
	end;

	TRoutineDebugInfos = class