{ Created : 1993-04-25

Memory checker, checks for deallocating with a different size than the
allocated size and tracks not deallocated memory.




$Author$
$Date$
$Revision$


Last changes :
93-12-08  Adapted MemCheck to TDInfo
94-10-03  Extended width of error report
          Added caller of caller to allocation item to make finding the
          memory slip easier. The caller of th caller is shown in MEMCHECK.RPT
94-10-10  Installed exit handlers could cause other deallocations after MemCheck
          called Halt (because when an error has occured). You could get a 204
          in that case, so now MemCheck turns itself on, before calling Halt.
}



{$X+,O-,S-,R-,Q-,I-}
unit MemCheck;

interface

const
  MemCheckDescr:string = '';      { not used yet }

const
  ReportFileName = 'MEMCHECK.RPT';


procedure StoreAlloc(MemPtr : pointer; Size : word);
procedure FreeAlloc(MemPtr : pointer; Size : word);
procedure MemCheckReport;



implementation

uses Objects,
     BBError, BBGui, BBUtil,
     TDInfo;


type
  PAllocItem = ^TAllocItem;
  TAllocItem = record
    MemPtr : pointer;
    Caller,
    CallerItsCaller : pointer;
    Size : word;
  end;

  PAllocCollection = ^TAllocCollection;
  TAllocCollection = object(TSortedCollection)
    function  Compare(Key1, Key2 : pointer) : integer;  virtual;
    procedure FreeItem(Item : pointer);  virtual;
    procedure Insert(Item : pointer);  virtual;
    function  KeyOf(Item : pointer) : pointer;  virtual;
  end;

  PMemCheckRec = ^TMemCheckRec;
  TMemCheckRec = record
    CheckMem : WordBool;
    StoreAlloc : pointer;
    FreeAlloc : pointer;
  end;

var
  MemCheckRec : PMemCheckRec;
  AllocCol : PAllocCollection;


{****************************************************************************}
{* TAllocCollection                                                         *}
{****************************************************************************}

function TAllocCollection.Compare(Key1, Key2 : pointer) : integer;
begin
  if longint(Key1) < longint(Key2)
   then  Compare := -1
   else
     if longint(Key1) = longint(Key2)
      then  Compare := 0
      else  Compare := 1;
end;

procedure TAllocCollection.FreeItem(Item : pointer);
begin
  Dispose(PAllocItem(Item));
end;

procedure TAllocCollection.Insert(Item : pointer);
var
  Index : integer;
  l1,l2 : longint;
begin
  if Search(KeyOf(Item), Index)
   then  begin
     PrintError('Attempt to allocate memory at same address.', 0);
     Halt(1);
   end
   else  begin
     AtInsert(Index, Item);
   end;
end;

function TAllocCollection.KeyOf(Item : pointer) : pointer;
begin
  KeyOf := PAllocItem(Item)^.MemPtr;
end;


{****************************************************************************}
{* MemCheckOn and Off                                                       *}
{****************************************************************************}

procedure MemCheckOn;  assembler;
asm
  les  di,MemCheckRec
  mov  ax,1
  mov  es:[di].TMemCheckRec.CheckMem,ax
end;

procedure MemCheckOff;  assembler;
asm
  les  di,MemCheckRec
  xor  ax,ax
  mov  es:[di].TMemCheckRec.CheckMem,ax
end;



{****************************************************************************}
{* StoreAlloc and FreeAlloc                                                 *}
{****************************************************************************}

procedure StoreAlloc(MemPtr : pointer; Size : word);
var
  AllocItem : PAllocItem;
begin

{ turn MemChecking of to avoid recursive loops }
  asm
    les  di,MemCheckRec
    xor  ax,ax
    mov  es:[di].TMemCheckRec.CheckMem,ax
  end;

{ allocate memory tracking item }
  New(AllocItem);

{ store data about current allocation in it }
  asm
    les  di,AllocItem
    mov  bx,[bp]
    ror  bx,1
    rol  bx,1
    jnc  @@1
    dec  bx
  @@1:
    mov  ax,word ptr ss:[bx+02h]
    mov  word ptr es:[di].TAllocItem.Caller,ax
    mov  ax,word ptr ss:[bx+04h]
    mov  word ptr es:[di].TAllocItem.Caller+2,ax
    mov  bx,ss:[bx]
    ror  bx,1
    rol  bx,1
    jnc  @@2
    dec  bx
  @@2:
    cmp  word ptr ss:[bx],0
    je   @@end_of_stack
    mov  ax,word ptr ss:[bx+02h]
    mov  word ptr es:[di].TAllocItem.CallerItsCaller,ax
    mov  ax,word ptr ss:[bx+04h]
    mov  word ptr es:[di].TAllocItem.CallerItsCaller+2,ax
    jmp  @@3
  @@end_of_stack:
    xor  ax,ax
    mov  word ptr es:[di].TAllocItem.CallerItsCaller,ax
    mov  word ptr es:[di].TAllocItem.CallerItsCaller+2,ax
  @@3:
    push ds
    lds  si,MemPtr
    mov  word ptr es:[di].TAllocItem.MemPtr,si
    mov  word ptr es:[di].TAllocItem.MemPtr+2,ds
    pop  ds
    mov  ax,Size
    mov  word ptr es:[di].TAllocItem.Size,ax
  end;

{ insert allocation tracking item }
  AllocCol^.Insert(AllocItem);

  asm
{ turn MemChecking on }
    les  di,MemCheckRec
    mov  ax,1
    mov  es:[di].TMemCheckRec.CheckMem,ax

{ and restore ax and dx }
    mov  ax,word ptr &MemPtr
    mov  dx,word ptr &MemPtr+2
  end;
end;


procedure FreeAlloc(MemPtr : pointer; Size : word);

  function LowerMemoryCheck(Item : PAllocItem) : Boolean;
  {* checks only first four bytes... *}
  var
    p : pointer;
  begin
    LowerMemoryCheck := FALSE;
    with Item^ do  begin
      if Size <= 65536-8-16 then  begin
        if MemL[PtrRec(MemPtr).Seg:PtrRec(MemPtr).Ofs-4] <> $CCCCCCCC then
          Exit;
      end;
    end; { of with }
    LowerMemoryCheck := TRUE;
  end;

  function UpperMemoryCheck(Item : PAllocItem) : Boolean;
  {* checks only first four bytes... *}
  var
    p : pointer;
  begin
    UpperMemoryCheck := FALSE;
    with Item^ do  begin
      if Size <= 65536-8-8 then  begin
        if MemL[PtrRec(MemPtr).Seg:PtrRec(MemPtr).Ofs+Size] <> $CCCCCCCC then
          Exit;
      end;
    end; { of with }
    UpperMemoryCheck := TRUE;
  end;

var
  Index : integer;
begin

{ turn memory checking off }
  asm
    les  di,MemCheckRec
    xor  ax,ax
    mov  es:[di].TMemCheckRec.CheckMem,ax
  end;

  with AllocCol^ do  begin
    if not Search(MemPtr, Index) then  begin
      PrintError('Attempt to dispose a non-allocated block.', 0);
      MemCheckOn;  { installed exit handlers might dispose here after }
      Halt(1);
    end;
    if PAllocItem(At(Index))^.Size <> Size then  begin
      PrintError('Attempt to dispose a memory block with wrong block size. ' +
                 'Expected block size: ' + StrW(PAllocItem(At(Index))^.Size) +
                 '. Got: ' + StrW(Size), 0);
      MemCheckOn;  { installed exit handlers might dispose here after }
      Halt(1);
    end;
    if not LowerMemoryCheck(PAllocItem(At(Index))) then  begin
      PrintError('Memory before allocated area corrupt!', 0);
      MemCheckOn;  { installed exit handlers might dispose here after }
      Halt(1);
    end;
    if not UpperMemoryCheck(PAllocItem(At(Index))) then  begin
      PrintError('Memory after allocated area corrupt!', 0);
      MemCheckOn;  { installed exit handlers might dispose here after }
      Halt(1);
    end;
    AtFree(Index);
  end;

  asm
{ turn MemChecking on }
    les  di,MemCheckRec
    mov  ax,1
    mov  es:[di].TMemCheckRec.CheckMem,ax

{ and restore ax, bx and cx }
    mov  ax,Size
    mov  cx,word ptr &MemPtr
    mov  bx,word ptr &MemPtr+2
  end;
end;


procedure MemCheckReport;
const
  CallerWidth = 70;
var
  t : text;
  Amount : longint;

  procedure Print(Item : PAllocItem);  far;

    function GetAddress(Address : pointer) : string;
    var
      LogicalAddr : pointer;
      LineNumber : PLineNumber;
      Symbol : PSymbol;
      s : string;
    begin
      LogicalAddr := GetLogicalAddr(Address);
      if TDInfoPresent(nil)
       then  begin
         New(LineNumber, AtAddr(LogicalAddr));
         if LineNumber = nil
          then  begin
            s := HexStr(PtrRec(LogicalAddr).Seg) + ':' + HexStr(PtrRec(LogicalAddr).Ofs);
          end
          else  begin
            s := LineNumber^.ItsCorrelation^.ItsSourceFile^.ItsName + ' (' + StrW(LineNumber^.Value) + ') ';
            New(Symbol, AtAddr(LogicalAddr));
            if Symbol <> nil then  begin
              if Symbol^.ItsType^.ReturnType = 1
               then  s := s + 'procedure '
               else  s := s + 'function ';
              if Symbol^.ItsType^.ID = tid_SpecialFunc then  begin
                s := s + Symbol^.ItsType^.ItsClassType^.ItsName + '.';
              end;
              s := s + Symbol^.ItsName + ';';
              Dispose(Symbol, Done);
            end;
            Dispose(LineNumber, Done);
          end;
       end
       else
         s := HexStr(PtrRec(LogicalAddr).Seg) + ':' + HexStr(PtrRec(LogicalAddr).Ofs);
      GetAddress := s;
    end;

  begin
    with Item^ do  begin
      writeln(t, LeftJustify(GetAddress(Caller), CallerWidth), '  ', Size:5);
      writeln(t, '  ', LeftJustify(GetAddress(CallerItsCaller), CallerWidth-2));
      Inc(Amount, Size);
    end;
  end;

const
  BufSize = 1024;
var
  Buffer : array[1..BufSize] of char;
begin
  MemCheckOff;
  Assign(t, ReportFileName);
  Rewrite(t);
  SetTextBuf(t, Buffer, BufSize);
  writeln(t, 'Not disposed memory report. Date: ', GetDateStr, '  Time: ', GetTimeStr);
  writeln(t);
  writeln(t, LeftJustify('Caller', CallerWidth), '   Size');
  writeln(t);
  Amount := 0;
  AllocCol^.ForEach(@Print);
  writeln(t);
  writeln(t);
  writeln(t, 'Total not disposed memory: ', Amount, ' bytes');
  writeln(t, 'Total items: ', AllocCol^.Count);
  Close(t);
  MemCheckOn;
end;


begin
  MemCheckRec := ErrorAddr;
  if MemCheckRec <> nil then  begin
    AllocCol := New(PAllocCollection, Init(4096,4096));
    MemCheckRec^.StoreAlloc := @StoreAlloc;
    MemCheckRec^.FreeAlloc := @FreeAlloc;
    MemCheckOn;
  end;
end.  { of unit MemCheck }