Help me fix a small unit?

From: Raptor (bogus_at_none.com)
Date: 02/26/05 

Date: Fri, 25 Feb 2005 17:37:32 -0800

I've tried a few memory leak detectors, and two of them show some promise.
The most compact (which, as a fan of Small Code, naturally drew my
attention) was written for "virtual Pascal and Delphi." With a few TEMPORARY
KLUGE changes it compiles on D4, but raises a memory write error when it
hits some assembly code.

It would be great if we could get this working. I'll list the unit here,
with most comments abbreviated, and note the spots about which I have
questions. My notes are in CAPS WITH ARROWS --->

// Memory leak detector for Virtual Pascal and Delphi
// (c) 1998 Joerg Pleumann

unit MemLeaks;

{$H-}

{$X+} // ORIG --> {$X+, Delphi+}

interface

uses
  SysUtils;

implementation

{$IFNDEF VIRTUALPASCAL}
uses
  Windows;
{$ENDIF}

{$IFDEF VIRTUALPASCAL}
uses
  VpSysLow;
{$ENDIF VIRTUALPASCAL}

function NewGetMem(Size: LongInt): Pointer; forward;
function NewFreeMem(P: Pointer): LongInt; forward;
function NewReallocMem(P: Pointer; Size: LongInt): Pointer; forward;

const

  MemBlockDelta = 1024;

  NewMemoryManager: TMemoryManager =
  ( GetMem: NewGetMem;
    FreeMem: NewFreeMem;
    ReAllocMem: NewReAllocMem );

type
  PMemBlock = ^TMemBlock;
  TMemBlock = record
    FAddress: Pointer;
    FSize: LongInt;
    FCaller: Pointer; (* ATC -- Stores the caller's address *)
    FThread: LongInt; (* ATC -- Stores the caller's thread *)
  end;

  PMemBlockList = ^TMemBlockList;
  TMemBlockList = array[0..MaxInt div SizeOf(TMemBlock) - 1] of TMemBlock;

var
  MemBlockList: PMemBlockList = nil; // Currently allocated blocks
  MemBlockCount: LongInt = 0;
  MemBlockLimit: LongInt = 0;
  MemBlockTotal: LongInt = 0; // Total memory allocated minus heap heap.
  OldMemoryManager: TMemoryManager;

// Finds address of the caller by walking stack.

function CallerAddr2org:Pointer;
// {$FRAME-} <-- DELPHI COMPILE ERROR
assembler;
asm
  mov eax, [ebp]
  mov eax, [eax+4]
  sub eax, 5
end;

function CallerAddr2:Pointer;
  asm
    mov eax,[ebp+4] <-- MEMORY WRITE ERROR HERE ON UNIT LOAD
    sub eax,5
    mov edx,offset _MemNew
    cmp eax,edx
    jb @not_MemNew
    add edx,$20
    cmp eax,edx
    jnb @not_MemNew

    // Who has called "New" or "GetMem" ?
    mov eax,[ebp+$14]
    sub eax,5
    jmp @ret

  @not_MemNew:

    // inside "_MemRealloc" (Realloc) ?
    mov edx,offset _MemRealloc
    cmp eax,edx
    jb @not_MemRealloc
    add edx,$20
    cmp eax,edx
    jnb @not_MemRealloc_0
    add edx,$56-$20
    cmp eax,edx
    jnb @not_MemRealloc

    // Who has called "ReallocMem" ?
    mov eax,[ebp+$1c]
    sub eax,5
    jmp @ret

  @not_MemRealloc_0:
    mov eax,[ebp+$18]
    sub eax,5
    jmp @ret

  @not_MemRealloc:

    // more detection ..
  @ret:
  end;

// Adds a block to list of currrently allocated memory blocks.
procedure AddBlock(Address: Pointer; Size: LongInt; Caller: Pointer);
begin
  if Address <> nil then
  begin
    if MemBlockCount = MemBlockLimit then
    begin
      MemBlockList := OldMemoryManager.ReAllocMem(MemBlockList,
        (MemBlockLimit + MemBlockDelta) * SizeOf(TMemBlock));

      Inc(MemBlockLimit, MemBlockDelta);
    end;

    with MemBlockList^[MemBlockCount] do
    begin
      FAddress := Address;
      FSize := Size;
      FCaller := Caller;
// --> WAS FThread := GetThreadID;
      FThread := GetCurrentThreadID;
// IS THIS THE RIGHT SUBSTITUTE?
    end;

    Inc(MemBlockCount);
    Inc(MemBlockTotal, Size);
  end;
end;

// Deletes block from list of currently allocated memory.

procedure DeleteBlock(Address: Pointer);
var
  I: LongInt;
begin
  if Address <> nil then
  begin
    I := MemBlockCount - 1;

    while (I <> -1) and (MemBlockList^[I].FAddress <> Address) do
      Dec(I);

    if I <> - 1 then
    begin
      Dec(MemBlockCount);
      Dec(MemBlockTotal, MemBlockList^[I].FSize);

      Move(MemBlockList^[I + 1], MemBlockList^[I],
        (MemBlockCount - I) * SizeOf(TMemBlock));
    end;
  end;
end;

(**
 * Tries to classify the memory block. This is more or
 * less a guess, but works most of the time. :-) The
 * function is able to detect AnsiStrings and object
 * instances (new object model only). Everything else
 * is returned as 'Unknown'.
 *)

function MemClassify(Address: Pointer; Size: LongInt): string;
type
  TStrRec = record
    RefCnt: LongInt;
    Length: LongInt;
   Data: array[0..2000000000] of Char; <-- KLUGE PATCH
// ORIG --> Data: array[0..MaxLongInt] of Char;
// DELPHI 4 GIVES "EXCEEDS 2 GB1 ERROR. I THOUGHT
// MaxLongInt *WAS* 2 GB.

end;
var
  AString: ^TStrRec absolute Address;
  AObject: TObject absolute Address;
begin
  if Size > 8 then
    with AString^ do
    begin
      if (Length + 9 = Size) and (Data[Length] = #0) then
      begin
        Result := 'AnsiString (Length=' + IntToStr(Length)
                + ', RefCnt=' + IntToStr(RefCnt) + ')';
        Exit;
      end;
    end;

  try
    if AObject.InstanceSize = Size then
    begin
      Result := TObject(Address).ClassName;
      Exit;
    end;
  except
  end;

  Result := 'Unknown';
end;

// Dumps a given block of memory to a string.

function MemToHexAsc(Address: PChar; Length: Integer): string;
var
  I: Integer;
begin
  Result := '';

  for I := 0 to Length - 1 do
    Result := Result + IntToHex(Byte(Address[I]), 2) + ' ';

  for I := Length to 15 do
    Result := Result + ' ';

  Result := Result + ' ';

  for I := 0 to Length - 1 do
  begin
    if Address[I] >= ' ' then
      Result := Result + Address[I]
    else
      Result := Result + '.';
  end;
end;

function CallerInfo(Caller: Pointer; Thread:LongInt): string;
var
  LineNum : Integer;
begin
// I THINK THIS LINE MUST BE VIRTUAL PASCAL SPECIFIC AND DON'T
// KNOW THE DELPHI EQUUIVALENT.
// ---> if GetLocationInfo(Caller,Result,LineNum) <> nil then
    Result := Format('%s line %d (thread %d)',[Result,LineNum,Thread])
// TEMP else
// TEMP Result := Format('unknown: %p (thread %d)',[Caller,Thread])
 end;

procedure DumpHeap;
var
  F: Text;
  I, L: LongInt;
  P: PChar;
begin
  Assign(F, 'MemLeaks.dmp');
  Rewrite(F);

  WriteLn(F, '; Dump of memory leak detector.');
  WriteLn(F, ';');
  WriteLn(F, '; Executable file : ', ParamStr(0));
  WriteLn(F, '; Date and time : ', FormatDateTime('yyyy"/"mm"/"dd
hh":"nn":"ss', Now));
  WriteLn(F, '; Number of leaks : ', MemBlockCount);
  WriteLn(F, '; Total memory loss: ', MemBlockTotal, ' bytes (without
overhead)');
  WriteLn(F, ';');
  WriteLn(F, '; Leaks are listed in order of allocation.');
  WriteLn(F);

  for I := 0 to MemBlockCount - 1 do
  begin
    with MemBlockList^[I] do
    begin
      P := FAddress;
      L := FSize;

      WriteLn(F, 'Address : ', IntToHex(LongInt(P), 8));
      WriteLn(F, 'Size : ', IntToHex(L, 8), ' (', L, ' bytes)');
      WriteLn(F, 'Caller : ', CallerInfo(FCaller, FThread));
      WriteLn(F, 'Type : ', MemClassify(FAddress, FSize));
      Write (F, 'Contents: ');

      while L > 16 do
      begin
        WriteLn(F, MemToHexAsc(P, 16));
        Write (F, ' ');
        Inc(P, 16);
        Dec(L, 16);
      end;

      WriteLn(F, MemToHexAsc(P, L));
      WriteLn(F);
    end;
  end;

  WriteLn(F, '; End of file.');

  Close(F);
end;

function NewGetMem(Size: LongInt): Pointer;
begin
  Result := OldMemoryManager.GetMem(Size);
  AddBlock(Result, Size, CallerAddr2);
end;

function NewFreeMem(P: Pointer): Longint;
begin
  DeleteBlock(P);
  Result := OldMemoryManager.FreeMem(P);
end;

function NewReallocMem(P: Pointer; Size: LongInt): Pointer;
begin
  DeleteBlock(P);
  Result := OldMemoryManager.ReAllocMem(P, Size);
  AddBlock(Result, Size, CallerAddr2);
end;

initialization
  GetMem(MemBlockList, MemBlockDelta * SizeOf(TMemBlock));

  GetMemoryManager(OldMemoryManager);
  SetMemoryManager(NewMemoryManager);

finalization
  SetMemoryManager(OldMemoryManager);

  if (ExitCode = 0) and (MemBlockCount <> 0) then
  begin
    {$IFNDEF VIRTUALPASCAL} (* DELPHI ? *)
    MessageBeep($FFFFFFFF);
    MessageBeep($FFFFFFFF);
    MessageBeep($FFFFFFFF);
    {$ENDIF}

    {$IFDEF VIRTUALPASCAL} (* VP 2.0 OS/2,Win32,DPMI32 *)
    SysBeepEx(440, 100);
    SysCtrlSleep(500);
    SysBeepEx(440, 100);
    SysCtrlSleep(500);
    SysBeepEx(440, 100);
    {$ENDIF VIRTUALPASCAL}

    DumpHeap;
  end;

  FreeMem(MemBlockList);
end.

Relevant Pages

  • How to free memory in Javascript?
    ... How do i free memory in Javascript? ... saleDate = new Date; ... references to it are released) the memory is freed by the garbage collector. ...
    (microsoft.public.scripting.jscript)
  • Re: Creating my on variable
    ... var = new Roby(); ... simply reinitializes the memory of var, it doesn't perform a new allocation. ... And declared two structes as that struct. ...
    (microsoft.public.dotnet.framework)
  • Re: Pointer to record
    ... You are trying to create a persistent block of memory which stores ... // memory used by PNewRec pointers ... so it may not compile or there may be some syntax errors etc. ...
    (borland.public.delphi.language.objectpascal)
  • Re: [PHP] Storing values in arrays
    ... PHP has not application var, and not multi thread ... the only way is database, share memory. ...
    (php.general)
  • Re: How to use lock prefix to make instruction atomic (in a multi-threaded program)
    ... cmp $0, global_counter ... Is it always going to be atomic read (I mean, reading the value of ... two fetches from memory) would leave room for a race condition, ... The fact that a believer is happier than a sceptic is no more to the ...
    (comp.lang.asm.x86)