Leak Watcher Tool - Overloading the memory allocation - delphi

Question

I'm developing a Tool to help me find memory leak on my application.
The feature runs well while I'm working with object (TOBJECT), but I'm getting some problems while I'm working with buffer.
In SOME cases, that I could not identify I got some errors in my application, this errors seems to be some bad access to memory. I could not find any possible error on my logic or my code. If some one with more experience with Delphi can help me. Maybe some memory manager particular behavior is causing the problem.
A little more explanations:
Memory Allocation Control
Objective: Count how much memory buffer with determined size is all allocated by the system, exemple:
Buffer Size | Amount of Allocs | Total Memory Used
325 | 35265 | 11461125
23 | 32 | 736
... | ... | ...
How I control the memory allocation and deallocation:
I created an array of integer that goes from 0 to 65365. This array will be used to keep the amount of allocs of the corresponding size.
For example, If I call GetMem for a buffer of 523, the Array[523] will increase + 1.
The GetMem, ReallocMem, AllocMem, the problem is easy to resolve 'cause one of it's parameters is the size of the buffer. So I can use this to increase the position of the array.
The problem cames with the FreeMem, 'cause the only parameter is the pointer of the buffer. I don't know it's size.
- I can't create a list to keep the Pointer and it's size. 'Cause there is SO much allocations, it will be so much expensive to the application keep searching/adding/removing items from this list. And this list must to be protected with critical section etc etc. So no way.
How I'm trying to solve this problem:
Just to remeber I created the array to keep the number off allocations.
Items: 0 65365
|................................|
Addess: $X $(65365x SizeOf(Integer))
When allocators methos are called, for example: GetMem(52);
I changed the behavior of it, I will alloc the requested size (52), but I'll add here a size of an integer;
So I will have:
0 4 56
|.....|...........................|
$x
In the plus space (0..3) I'll set the address of the corresponding space of the array. In this case the address position $array(52). And I add + (SizeOf(Integer)) to the address result of the GetMem, so it will have access just the 52 bytes that were asked for.
When the FreeMem are called. What I do is:
- Get the pointer asked for deallocation.
- Decrease the pointer by the size of the integer
- Check if the address of the current pointer is relative to the Array of control address.
- If it is, I use the the address and decrease 1 from the Array position
- And ask for the FreeMem
In the biggest part of time and systems it's working very well. BUT, In some moments that I really don't know how and were I get some strange errors in system. Erros that I NEVER get if I deactive this implementation.
I'm commenting the code to get easier to be understood, but It's not a hard code so, here it's:
Other thread in: https://forums.embarcadero.com/thread.jspa?threadID=77787
unit uInstancesAnalyser;
{
Functionality: The feature developed in this unit try to watch how the memory are being allocated by your system. The main focus of it is help to find memory leak in the most non intrusive way.
How to Install: Put this unit as the first unit of yout project. If use use a third memory manager put this unit just after the unit of your memory manager.
How to get it's report: It's not the final version of this unit, so the viewer was not developed. By the momento you can call the
method SaveInstancesToFile. It'll create a text file called MemReport in the executable path.
WARNING: If you use the pointer of the VMT destinated to vmtAutoTable, you should not use the directive TRACEINSTANCES.
How it works:
The feature work in two different approaches:
1) Map the memory usage by objects
2) Map the memory usage by buffers (Records, strings and so on)
How are Objects tracked:
The TObject.NewInstance was replaced by a new method (TObjectHack.NNewInstanceTrace).
So when the creation of an object is called it's redirect to the new method. In this new method is increased the counter of the relative class and change the method in the VMT that is responsible to free the object to a new destructor method (vmtFreeInstance). This new destructor call the decrease of the counter and the old destructor.
This way I can know how much of objects of each class are alive in the system.
(More details about how it deep work can be found in the comments on the code)
How are Memory Buffer Traced:
The GetMem, FreeMem, ReallocMem, AllocMem were replaced by new method that have an special behavior to help track the buffers.
As the memory allocation use the same method to every kind of memory request, I'm not able to create a single counter to each count of buffer. So, I calculate them base on it size. First I create a array of integer that start on 0 and goes to 65365.
When the system ask me to give it a buffer of 65 bytes, I increase the position 65 of the array and the buffer is deallocated I call the decrease of the position of the array corresponding to buffer size. If the size requested to the buffer is bigger or equal to 65365, I'll use the position 65365 of the array.
(More details about how it deep work can be found in the comments on the code)
--------------------------------------------------------------------------------------
Develop by Rodrigo Farias Rezino
E-mail: rodrigofrezino#gmail.com
Stackoverflow: http://stackoverflow.com/users/225010/saci
Please, any bug let me know
}
interface
{$DEFINE TRACEBUFFER} {Directive used to track buffer} //Comment to inactive
{$DEFINE TRACEINSTANCES} {Directive used to track objects} //Comment to inactive
//{$DEFINE WATCHTHREADS} // It's not finished
uses
Classes, SyncObjs, uIntegerList;
{You can register possibles names for some Buffers Sizes, it can be useful when you are working with record. Example
TRecordTest = record
Field1: Integer
Field2: string[50]
So, you can call RegisterNamedBuffer(TRecordTest, SizeOf(TRecordTest));
This way, in on the report of buffer/objects will be explicit what possibles named buffer can be that memory in use.}
procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
{This function return the possible named buffers registered with that size}
function GetBufferName(ASize: integer): string;
{It's a simple output to save the report of memory usage on the disk. It'll create a file called test.txt in the executable directory}
procedure SaveInstancesToFile;
var
{Flag to say if the memory watcher is on or off}
SIsMemoryWatcherActive: Boolean;
implementation
uses
Windows, SysUtils, TypInfo;
const
SIZE_OF_INT = SizeOf(Integer);
SIZE_OF_MAP = 65365;
{$IFDEF WATCHTHREADS}
GAP_SIZE = SIZE_OF_INT * 2;
{$ELSE}
GAP_SIZE = SIZE_OF_INT;
{$ENDIF}
type
TArrayOfMap = array [0..SIZE_OF_MAP] of Integer;
TThreadMemory = array [0..SIZE_OF_MAP] of Integer;
{This class is used to Register}
TNamedBufferList = class(TIntegerList)
public
constructor Create;
function GetBufferName(ASize: integer): string;
procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
end;
PClassVars = ^TClassVars;
TClassVars = class(TObject)
private
class var ListClassVars: TList;
public
BaseInstanceCount: Integer;
BaseClassName: string;
BaseParentClassName: string;
BaseInstanceSize: Integer;
OldVMTFreeInstance: Pointer;
constructor Create;
class procedure SaveToDisk;
end;
TNamedBuffer = class(TObject)
Names: string;
end;
PJump = ^TJump;
TJump = packed record
OpCode: Byte;
Distance: Pointer;
end;
TObjectHack = class(TObject)
private
FCriticalSection: TCriticalSection;
class procedure SetClassVars(AClassVars: TClassVars); //inline;
class function GetClassVars: TClassVars; inline;
procedure IncCounter; inline;
procedure DecCounter; inline;
procedure CallOldFunction;
public
constructor Create;
destructor Destroy; override;
class function NNewInstance: TObject;
class function NNewInstanceTrace: TObject;
procedure NFreeInstance;
end;
var
SDefaultGetMem: function(Size: Integer): Pointer;
SDefaultFreeMem: function(P: Pointer): Integer;
SDefaultReallocMem: function(P: Pointer; Size: Integer): Pointer;
SDefaultAllocMem: function(Size: Cardinal): Pointer;
SThreadMemory: TThreadMemory;
SMap: TArrayOfMap;
SNamedBufferList: TNamedBufferList;
{$IFDEF WATCHTHREADS}
SMissedMemoryFlow: Integer;
{$ENDIF}
{$REGION 'Util'}
type
TWinVersion = (wvUnknown, wv95, wv98, wv98SE, wvNT, wvME, wv2000, wvXP, wvVista, wv2003, wv7);
function GetWinVersion: TWinVersion;
var
osVerInfo: TOSVersionInfo;
majorVersion, minorVersion: Integer;
begin
Result := wvUnknown;
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
minorVersion := osVerInfo.dwMinorVersion;
majorVersion := osVerInfo.dwMajorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT:
begin
if majorVersion <= 4 then
Result := wvNT
else if (majorVersion = 5) and (minorVersion = 0) then
Result := wv2000
else if (majorVersion = 5) and (minorVersion = 1) then
Result := wvXP
else if (majorVersion = 5) and (minorVersion = 2) then
Result := wv2003
else if (majorVersion = 6) then
Result := wvVista
else if (majorVersion = 7) then
Result := wv7;
end;
VER_PLATFORM_WIN32_WINDOWS:
begin
if (majorVersion = 4) and (minorVersion = 0) then
Result := wv95
else if (majorVersion = 4) and (minorVersion = 10) then
begin
if osVerInfo.szCSDVersion[1] = 'A' then
Result := wv98SE
else
Result := wv98;
end
else if (majorVersion = 4) and (minorVersion = 90) then
Result := wvME
else
Result := wvUnknown;
end;
end;
end;
end;
function GetMethodAddress(AStub: Pointer): Pointer;
const
CALL_OPCODE = $E8;
begin
if PBYTE(AStub)^ = CALL_OPCODE then
begin
Inc(Integer(AStub));
Result := Pointer(Integer(AStub) + SizeOf(Pointer) + PInteger(AStub)^);
end
else
Result := nil;
end;
procedure AddressPatch(const ASource, ADestination: Pointer);
const
JMP_OPCODE = $E9;
SIZE = SizeOf(TJump);
var
NewJump: PJump;
OldProtect: Cardinal;
begin
if VirtualProtect(ASource, SIZE, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
NewJump := PJump(ASource);
NewJump.OpCode := JMP_OPCODE;
NewJump.Distance := Pointer(Integer(ADestination) - Integer(ASource) - 5);
FlushInstructionCache(GetCurrentProcess, ASource, SizeOf(TJump));
VirtualProtect(ASource, SIZE, OldProtect, #OldProtect);
end;
end;
function PatchCodeDWORD(ACode: PDWORD; AValue: DWORD): Boolean;
var
LRestoreProtection, LIgnore: DWORD;
begin
Result := False;
if VirtualProtect(ACode, SizeOf(ACode^), PAGE_EXECUTE_READWRITE, LRestoreProtection) then
begin
Result := True;
ACode^ := AValue;
Result := VirtualProtect(ACode, SizeOf(ACode^), LRestoreProtection, LIgnore);
if not Result then
Exit;
Result := FlushInstructionCache(GetCurrentProcess, ACode, SizeOf(ACode^));
end;
end;
{$ENDREGION}
function GetInstanceList: TList;
begin
Result := TClassVars.ListClassVars;
end;
procedure SaveInstancesToFile;
begin
TClassVars.SaveToDisk;
end;
procedure OldNewInstance;
asm
call TObject.NewInstance;
end;
procedure OldAfterConstruction;
asm
call TObject.InitInstance;
end;
{ TObjectHack }
type
TExecute = procedure of object;
procedure TObjectHack.CallOldFunction;
var
Routine: TMethod;
Execute: TExecute;
begin
Routine.Data := Pointer(Self);
Routine.Code := GetClassVars.OldVMTFreeInstance;
Execute := TExecute(Routine);
Execute;
end;
constructor TObjectHack.Create;
begin
end;
procedure TObjectHack.DecCounter;
var
ThreadId: Cardinal;
begin
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - Self.InstanceSize;
ThreadId := 0;
if (Self.ClassType.InheritsFrom(TThread)) then
ThreadId := TThread(Self).ThreadID;
{$ENDIF}
GetClassVars.BaseInstanceCount := GetClassVars.BaseInstanceCount -1;
CallOldFunction;
{$IFDEF WATCHTHREADS}
if ThreadId <> 0 then
begin
if SThreadMemory[ThreadId] < 0 then
SMissedMemoryFlow := SMissedMemoryFlow + SThreadMemory[ThreadId];
SThreadMemory[ThreadId] := 0;
end;
{$ENDIF}
end;
destructor TObjectHack.Destroy;
begin
inherited;
end;
class function TObjectHack.GetClassVars: TClassVars;
begin
Result := PClassVars(Integer(Self) + vmtAutoTable)^;
end;
function _InitializeHook(AClass: TClass; AOffset: Integer; HookAddress: Pointer): Boolean;
var
lAddress: Pointer;
lProtect: DWord;
begin
lAddress := Pointer(Integer(AClass) + AOffset);
Result := VirtualProtect(lAddress, 4, PAGE_READWRITE, #lProtect);
if not Result then
Exit;
CopyMemory(lAddress, #HookAddress, 4);
Result := VirtualProtect(lAddress, 4, lProtect, #lProtect);
end;
class procedure TObjectHack.SetClassVars(AClassVars: TClassVars);
begin
AClassVars.BaseClassName := Self.ClassName;
AClassVars.BaseInstanceSize := Self.InstanceSize;
AClassVars.OldVMTFreeInstance := PPointer(Integer(TClass(Self)) + vmtFreeInstance)^;
if Self.ClassParent <> nil then
AClassVars.BaseParentClassName := Self.ClassParent.ClassName;
PatchCodeDWORD(PDWORD(Integer(Self) + vmtAutoTable), DWORD(AClassVars));
_InitializeHook(Self, vmtFreeInstance, #TObjectHack.DecCounter);
end;
procedure RegisterClassVarsSupport(const Classes: array of TObjectHack);
var
LClass: TObjectHack;
begin
for LClass in Classes do
if LClass.GetClassVars = nil then
LClass.SetClassVars(TClassVars.Create)
else
raise Exception.CreateFmt('Class %s has automated section or duplicated registration.', [LClass.ClassName]);
end;
procedure TObjectHack.IncCounter;
begin
if GetClassVars = nil then
RegisterClassVarsSupport(Self);
GetClassVars.BaseInstanceCount := GetClassVars.BaseInstanceCount + 1;
end;
{ TClassVars }
constructor TClassVars.Create;
begin
ListClassVars.Add(Self);
end;
class procedure TClassVars.SaveToDisk;
var
LStringList: TStringList;
i: Integer;
begin
LStringList := TStringList.Create;
try
LStringList.Add('CLASS | NUMBER OF INSTANCES');
{$IFDEF TRACEINSTANCES}
for i := 0 to ListClassVars.Count -1 do
if TClassVars(ListClassVars.Items[I]).BaseInstanceCount > 0 then
LStringList.Add(TClassVars(ListClassVars.Items[I]).BaseClassName + '|' + IntToStr(TClassVars(ListClassVars.Items[I]).BaseInstanceCount));
{$ENDIF}
{$IFDEF TRACEBUFFER}
for I := 0 to SIZE_OF_MAP do
if SMap[I] > 0 then
LStringList.Add(Format('Mem. Size: %d | Amount: %d', [I, SMap[I]]));
{$ENDIF}
LStringList.SaveToFile(ExtractFilePath(ParamStr(0)) + 'MemReport.txt');
finally
FreeAndNil(LStringList);
end;
end;
//////////////////////////////////////////////////////////////////////////////////////
/// Memory manager controller
function IsInMap(AValue: Integer): Boolean; inline;
begin
try
Result := (AValue > Integer(#SMap)) and (AValue <= Integer(#SMap[SIZE_OF_MAP]));
except
Result := False;
end;
end;
function MemorySizeOfPos(APos: Integer): Integer; inline;
begin
Result := (APos - Integer(#SMap)) div SIZE_OF_INT;
end;
function NAllocMem(Size: Cardinal): Pointer;
var
pIntValue: ^Integer;
MapSize: Integer;
ThreadId: Cardinal;
begin
if Size > SIZE_OF_MAP then
MapSize := SIZE_OF_MAP
else
MapSize := Size;
Result := SDefaultAllocMem(Size + GAP_SIZE);
pIntValue := Result;
SMap[MapSize] := SMap[MapSize] + 1;
pIntValue^ := Integer(#SMap[MapSize]);
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Size;
pIntValue := Pointer(Integer(Result) + SIZE_OF_INT);
pIntValue^ := ThreadId;
{$ENDIF}
Result := Pointer(Integer(Result) + GAP_SIZE);
end;
function NGetMem(Size: Integer): Pointer;
var
LPointer: Pointer;
pIntValue: ^Integer;
MapSize: Integer;
ThreadId: Cardinal;
begin
if Size > SIZE_OF_MAP then
MapSize := SIZE_OF_MAP
else
MapSize := Size;
LPointer := SDefaultGetMem(Size + GAP_SIZE);
pIntValue := LPointer;
SMap[MapSize] := SMap[MapSize] + 1;
pIntValue^ := Integer(#SMap[MapSize]);
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Size;
pIntValue := Pointer(Integer(LPointer) + SIZE_OF_INT);
pIntValue^ := ThreadId;
{$ENDIF}
Result := Pointer(Integer(LPointer) + GAP_SIZE);
end;
function NFreeMem(P: Pointer): Integer;
var
pIntValue: ^Integer;
LPointer: Pointer;
ThreadId: Cardinal;
LFreed: Boolean;
begin
LPointer := Pointer(Integer(P) - GAP_SIZE);
pIntValue := LPointer;
if IsInMap(pIntValue^) then
begin
{$IFDEF WATCHTHREADS}
ThreadId := Integer(Pointer(Integer(pIntValue) + SIZE_OF_INT)^);
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - MemorySizeOfPos(pIntValue^);
{$ENDIF}
Integer(Pointer(pIntValue^)^) := Integer(Pointer(pIntValue^)^) - 1;
Result := SDefaultFreeMem(LPointer);
end
else
Result := SDefaultFreeMem(P);
end;
function NReallocMem(P: Pointer; Size: Integer): Pointer;
var
pIntValue: ^Integer;
LPointer: Pointer;
LSizeMap: Integer;
ThreadId: Cardinal;
begin
LPointer := Pointer(Integer(P) - GAP_SIZE);
pIntValue := LPointer;
if not IsInMap(pIntValue^) then
begin
Result := SDefaultReallocMem(P, Size);
Exit;
end;
if Size > SIZE_OF_MAP then
LSizeMap := SIZE_OF_MAP
else
LSizeMap := Size;
//Uma vez com o valor setado, não pode remover o setor
Integer(Pointer(pIntValue^)^) := Integer(Pointer(pIntValue^)^) - 1;
{$IFDEF WATCHTHREADS}
ThreadId := Integer(Pointer(Integer(pIntValue) + SIZE_OF_INT)^);
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - MemorySizeOfPos(pIntValue^) + Size;
{$ENDIF}
Result := SDefaultReallocMem(LPointer, Size + GAP_SIZE);
SMap[LSizeMap] := SMap[LSizeMap] + 1;
pIntValue := Result;
pIntValue^ := Integer(#SMap[LSizeMap]);
Result := Pointer(Integer(Result) + GAP_SIZE);
end;
procedure TObjectHack.NFreeInstance;
var
ThreadId: Cardinal;
begin
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] - Self.InstanceSize;
{$ENDIF}
CleanupInstance;
SDefaultFreeMem(Self);
end;
class function TObjectHack.NNewInstance: TObject;
var
ThreadId: Cardinal;
begin
Result := InitInstance(SDefaultGetMem(Self.InstanceSize));
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Self.InstanceSize;
{$ENDIF}
end;
class function TObjectHack.NNewInstanceTrace: TObject;
var
ThreadId: Cardinal;
begin
try
Result := InitInstance(SDefaultGetMem(Self.InstanceSize));
if (Result.ClassType = TClassVars) or (Result is EExternal) then
Exit;
TObjectHack(Result).IncCounter;
{$IFDEF WATCHTHREADS}
ThreadId := GetCurrentThreadId;
SThreadMemory[ThreadId] := SThreadMemory[ThreadId] + Self.InstanceSize;
{$ENDIF}
except
raise Exception.Create(Result.ClassName);
end;
end;
procedure InitializeArray;
var
I: Integer;
begin
for I := 0 to SIZE_OF_MAP do
SMap[I] := 0;
end;
type
PLocalTest = ^LocalTest;
LocalTest = record
Size: integer;
Size2: string;
end;
procedure ApplyMemoryManager;
var
LMemoryManager: TMemoryManagerEx;
begin
GetMemoryManager(LMemoryManager);
SDefaultGetMem := LMemoryManager.GetMem;
{$IFNDEF TRACEBUFFER}
Exit;
{$ENDIF}
LMemoryManager.GetMem := NGetMem;
SDefaultFreeMem := LMemoryManager.FreeMem;
LMemoryManager.FreeMem := NFreeMem;
SDefaultReallocMem := LMemoryManager.ReallocMem;
LMemoryManager.ReallocMem := NReallocMem;
SDefaultAllocMem := LMemoryManager.AllocMem;
LMemoryManager.AllocMem := NAllocMem;
SetMemoryManager(LMemoryManager);
end;
procedure TestRecord;
var
LTest: PLocalTest;
begin
LTest := AllocMem(1);
Dispose(LTest);
LTest := AllocMem(SIZE_OF_MAP + 1);
Dispose(LTest);
New(LTest);
ReallocMem(LTest, SIZE_OF_MAP +1);
Dispose(LTest);
end;
procedure TesteObject;
var
LTestObject: TObject;
begin
LTestObject := TObject.Create;
LTestObject.Free;
end;
{ TNamedBuffer }
constructor TNamedBufferList.Create;
begin
inherited Create;
Sorted := True;
end;
function GetBufferName(ASize: integer): string;
begin
Result := SNamedBufferList.GetBufferName(ASize);
end;
procedure RegisterNamedBuffer(ABufferName: string; ASize: integer);
begin
SNamedBufferList.RegisterNamedBuffer(ABufferName, ASize);
end;
function TNamedBufferList.GetBufferName(ASize: integer): string;
var
LIndex: Integer;
begin
Result := 'Unknow';
LIndex := IndexOf(ASize);
if LIndex = -1 then
Exit;
Result := TNamedBuffer(Objects[LIndex]).Names;
end;
procedure TNamedBufferList.RegisterNamedBuffer(ABufferName: string; ASize: integer);
var
LIndex: Integer;
LNamedBuffer: TNamedBuffer;
begin
LIndex := IndexOf(ASize);
if LIndex = -1 then
begin
LNamedBuffer := TNamedBuffer.Create;
LNamedBuffer.Names := 'Possible types: ' + ABufferName;
Self.AddObject(ASize, LNamedBuffer);
end
else
TNamedBuffer(Objects[LIndex]).Names := TNamedBuffer(Objects[LIndex]).Names + ' | ' + ABufferName;
end;
procedure InitializeAnalyser;
var
LCan: Boolean;
begin
SIsMemoryWatcherActive := False;
SNamedBufferList := TNamedBufferList.Create;
case GetWinVersion of
wv98, wvXP, wvVista, wv7: LCan := True;
else LCan := False;
end;
if not LCan then
Exit;
{$IFDEF TRACEINSTANCES}
TClassVars.ListClassVars := TList.Create;
{$ENDIF}
{$IFDEF TRACEBUFFER}
InitializeArray;
{$ENDIF}
ApplyMemoryManager;
/// Buffer wrapper
{$IFDEF TRACEBUFFER}
TestRecord;
{$IFNDEF TRACEINSTANCES}
AddressPatch(GetMethodAddress(#OldNewInstance), #TObjectHack.NNewInstance);
{$ENDIF}
{$ENDIF}
///Class wrapper
{$IFDEF TRACEINSTANCES}
AddressPatch(GetMethodAddress(#OldNewInstance), #TObjectHack.NNewInstanceTrace);
TesteObject;
{$ENDIF}
SIsMemoryWatcherActive := True;
end;
{ TThreadDestroy }
initialization
InitializeAnalyser
end.

Answer 1

I was not cleaning the parity byte on FreeMem.
I continue working on this, if someone would like to take a look or help: http://rfrezinos.wordpress.com/delphi-memory-profiler/
Att.