home *** CD-ROM | disk | FTP | other *** search
/ The Pier Shareware 6 / The_Pier_Shareware_Number_6_(The_Pier_Exchange)_(1995).iso / 038 / pmd110.zip / MEMCHECK.PAS < prev    next >
Pascal/Delphi Source File  |  1994-11-14  |  10KB  |  383 lines
  1. { Created : 1993-04-25
  2.  
  3. Memory checker, checks for deallocating with a different size than the
  4. allocated size and tracks not deallocated memory.
  5.  
  6.  
  7.  
  8.  
  9. $Author$
  10. $Date$
  11. $Revision$
  12.  
  13.  
  14. Last changes :
  15. 93-12-08  Adapted MemCheck to TDInfo
  16. 94-10-03  Extended width of error report
  17.           Added caller of caller to allocation item to make finding the
  18.           memory slip easier. The caller of th caller is shown in MEMCHECK.RPT
  19. 94-10-10  Installed exit handlers could cause other deallocations after MemCheck
  20.           called Halt (because when an error has occured). You could get a 204
  21.           in that case, so now MemCheck turns itself on, before calling Halt.
  22. }
  23.  
  24.  
  25.  
  26. {$X+,O-,S-,R-,Q-,I-}
  27. unit MemCheck;
  28.  
  29. interface
  30.  
  31. const
  32.   MemCheckDescr:string = '';      { not used yet }
  33.  
  34. const
  35.   ReportFileName = 'MEMCHECK.RPT';
  36.  
  37.  
  38. procedure StoreAlloc(MemPtr : pointer; Size : word);
  39. procedure FreeAlloc(MemPtr : pointer; Size : word);
  40. procedure MemCheckReport;
  41.  
  42.  
  43.  
  44. implementation
  45.  
  46. uses Objects,
  47.      BBError, BBGui, BBUtil,
  48.      TDInfo;
  49.  
  50.  
  51. type
  52.   PAllocItem = ^TAllocItem;
  53.   TAllocItem = record
  54.     MemPtr : pointer;
  55.     Caller,
  56.     CallerItsCaller : pointer;
  57.     Size : word;
  58.   end;
  59.  
  60.   PAllocCollection = ^TAllocCollection;
  61.   TAllocCollection = object(TSortedCollection)
  62.     function  Compare(Key1, Key2 : pointer) : integer;  virtual;
  63.     procedure FreeItem(Item : pointer);  virtual;
  64.     procedure Insert(Item : pointer);  virtual;
  65.     function  KeyOf(Item : pointer) : pointer;  virtual;
  66.   end;
  67.  
  68.   PMemCheckRec = ^TMemCheckRec;
  69.   TMemCheckRec = record
  70.     CheckMem : WordBool;
  71.     StoreAlloc : pointer;
  72.     FreeAlloc : pointer;
  73.   end;
  74.  
  75. var
  76.   MemCheckRec : PMemCheckRec;
  77.   AllocCol : PAllocCollection;
  78.  
  79.  
  80. {****************************************************************************}
  81. {* TAllocCollection                                                         *}
  82. {****************************************************************************}
  83.  
  84. function TAllocCollection.Compare(Key1, Key2 : pointer) : integer;
  85. begin
  86.   if longint(Key1) < longint(Key2)
  87.    then  Compare := -1
  88.    else
  89.      if longint(Key1) = longint(Key2)
  90.       then  Compare := 0
  91.       else  Compare := 1;
  92. end;
  93.  
  94. procedure TAllocCollection.FreeItem(Item : pointer);
  95. begin
  96.   Dispose(PAllocItem(Item));
  97. end;
  98.  
  99. procedure TAllocCollection.Insert(Item : pointer);
  100. var
  101.   Index : integer;
  102.   l1,l2 : longint;
  103. begin
  104.   if Search(KeyOf(Item), Index)
  105.    then  begin
  106.      PrintError('Attempt to allocate memory at same address.', 0);
  107.      Halt(1);
  108.    end
  109.    else  begin
  110.      AtInsert(Index, Item);
  111.    end;
  112. end;
  113.  
  114. function TAllocCollection.KeyOf(Item : pointer) : pointer;
  115. begin
  116.   KeyOf := PAllocItem(Item)^.MemPtr;
  117. end;
  118.  
  119.  
  120. {****************************************************************************}
  121. {* MemCheckOn and Off                                                       *}
  122. {****************************************************************************}
  123.  
  124. procedure MemCheckOn;  assembler;
  125. asm
  126.   les  di,MemCheckRec
  127.   mov  ax,1
  128.   mov  es:[di].TMemCheckRec.CheckMem,ax
  129. end;
  130.  
  131. procedure MemCheckOff;  assembler;
  132. asm
  133.   les  di,MemCheckRec
  134.   xor  ax,ax
  135.   mov  es:[di].TMemCheckRec.CheckMem,ax
  136. end;
  137.  
  138.  
  139.  
  140. {****************************************************************************}
  141. {* StoreAlloc and FreeAlloc                                                 *}
  142. {****************************************************************************}
  143.  
  144. procedure StoreAlloc(MemPtr : pointer; Size : word);
  145. var
  146.   AllocItem : PAllocItem;
  147. begin
  148.  
  149. { turn MemChecking of to avoid recursive loops }
  150.   asm
  151.     les  di,MemCheckRec
  152.     xor  ax,ax
  153.     mov  es:[di].TMemCheckRec.CheckMem,ax
  154.   end;
  155.  
  156. { allocate memory tracking item }
  157.   New(AllocItem);
  158.  
  159. { store data about current allocation in it }
  160.   asm
  161.     les  di,AllocItem
  162.     mov  bx,[bp]
  163.     ror  bx,1
  164.     rol  bx,1
  165.     jnc  @@1
  166.     dec  bx
  167.   @@1:
  168.     mov  ax,word ptr ss:[bx+02h]
  169.     mov  word ptr es:[di].TAllocItem.Caller,ax
  170.     mov  ax,word ptr ss:[bx+04h]
  171.     mov  word ptr es:[di].TAllocItem.Caller+2,ax
  172.     mov  bx,ss:[bx]
  173.     ror  bx,1
  174.     rol  bx,1
  175.     jnc  @@2
  176.     dec  bx
  177.   @@2:
  178.     cmp  word ptr ss:[bx],0
  179.     je   @@end_of_stack
  180.     mov  ax,word ptr ss:[bx+02h]
  181.     mov  word ptr es:[di].TAllocItem.CallerItsCaller,ax
  182.     mov  ax,word ptr ss:[bx+04h]
  183.     mov  word ptr es:[di].TAllocItem.CallerItsCaller+2,ax
  184.     jmp  @@3
  185.   @@end_of_stack:
  186.     xor  ax,ax
  187.     mov  word ptr es:[di].TAllocItem.CallerItsCaller,ax
  188.     mov  word ptr es:[di].TAllocItem.CallerItsCaller+2,ax
  189.   @@3:
  190.     push ds
  191.     lds  si,MemPtr
  192.     mov  word ptr es:[di].TAllocItem.MemPtr,si
  193.     mov  word ptr es:[di].TAllocItem.MemPtr+2,ds
  194.     pop  ds
  195.     mov  ax,Size
  196.     mov  word ptr es:[di].TAllocItem.Size,ax
  197.   end;
  198.  
  199. { insert allocation tracking item }
  200.   AllocCol^.Insert(AllocItem);
  201.  
  202.   asm
  203. { turn MemChecking on }
  204.     les  di,MemCheckRec
  205.     mov  ax,1
  206.     mov  es:[di].TMemCheckRec.CheckMem,ax
  207.  
  208. { and restore ax and dx }
  209.     mov  ax,word ptr &MemPtr
  210.     mov  dx,word ptr &MemPtr+2
  211.   end;
  212. end;
  213.  
  214.  
  215. procedure FreeAlloc(MemPtr : pointer; Size : word);
  216.  
  217.   function LowerMemoryCheck(Item : PAllocItem) : Boolean;
  218.   {* checks only first four bytes... *}
  219.   var
  220.     p : pointer;
  221.   begin
  222.     LowerMemoryCheck := FALSE;
  223.     with Item^ do  begin
  224.       if Size <= 65536-8-16 then  begin
  225.         if MemL[PtrRec(MemPtr).Seg:PtrRec(MemPtr).Ofs-4] <> $CCCCCCCC then
  226.           Exit;
  227.       end;
  228.     end; { of with }
  229.     LowerMemoryCheck := TRUE;
  230.   end;
  231.  
  232.   function UpperMemoryCheck(Item : PAllocItem) : Boolean;
  233.   {* checks only first four bytes... *}
  234.   var
  235.     p : pointer;
  236.   begin
  237.     UpperMemoryCheck := FALSE;
  238.     with Item^ do  begin
  239.       if Size <= 65536-8-8 then  begin
  240.         if MemL[PtrRec(MemPtr).Seg:PtrRec(MemPtr).Ofs+Size] <> $CCCCCCCC then
  241.           Exit;
  242.       end;
  243.     end; { of with }
  244.     UpperMemoryCheck := TRUE;
  245.   end;
  246.  
  247. var
  248.   Index : integer;
  249. begin
  250.  
  251. { turn memory checking off }
  252.   asm
  253.     les  di,MemCheckRec
  254.     xor  ax,ax
  255.     mov  es:[di].TMemCheckRec.CheckMem,ax
  256.   end;
  257.  
  258.   with AllocCol^ do  begin
  259.     if not Search(MemPtr, Index) then  begin
  260.       PrintError('Attempt to dispose a non-allocated block.', 0);
  261.       MemCheckOn;  { installed exit handlers might dispose here after }
  262.       Halt(1);
  263.     end;
  264.     if PAllocItem(At(Index))^.Size <> Size then  begin
  265.       PrintError('Attempt to dispose a memory block with wrong block size. ' +
  266.                  'Expected block size: ' + StrW(PAllocItem(At(Index))^.Size) +
  267.                  '. Got: ' + StrW(Size), 0);
  268.       MemCheckOn;  { installed exit handlers might dispose here after }
  269.       Halt(1);
  270.     end;
  271.     if not LowerMemoryCheck(PAllocItem(At(Index))) then  begin
  272.       PrintError('Memory before allocated area corrupt!', 0);
  273.       MemCheckOn;  { installed exit handlers might dispose here after }
  274.       Halt(1);
  275.     end;
  276.     if not UpperMemoryCheck(PAllocItem(At(Index))) then  begin
  277.       PrintError('Memory after allocated area corrupt!', 0);
  278.       MemCheckOn;  { installed exit handlers might dispose here after }
  279.       Halt(1);
  280.     end;
  281.     AtFree(Index);
  282.   end;
  283.  
  284.   asm
  285. { turn MemChecking on }
  286.     les  di,MemCheckRec
  287.     mov  ax,1
  288.     mov  es:[di].TMemCheckRec.CheckMem,ax
  289.  
  290. { and restore ax, bx and cx }
  291.     mov  ax,Size
  292.     mov  cx,word ptr &MemPtr
  293.     mov  bx,word ptr &MemPtr+2
  294.   end;
  295. end;
  296.  
  297.  
  298. procedure MemCheckReport;
  299. const
  300.   CallerWidth = 70;
  301. var
  302.   t : text;
  303.   Amount : longint;
  304.  
  305.   procedure Print(Item : PAllocItem);  far;
  306.  
  307.     function GetAddress(Address : pointer) : string;
  308.     var
  309.       LogicalAddr : pointer;
  310.       LineNumber : PLineNumber;
  311.       Symbol : PSymbol;
  312.       s : string;
  313.     begin
  314.       LogicalAddr := GetLogicalAddr(Address);
  315.       if TDInfoPresent(nil)
  316.        then  begin
  317.          New(LineNumber, AtAddr(LogicalAddr));
  318.          if LineNumber = nil
  319.           then  begin
  320.             s := HexStr(PtrRec(LogicalAddr).Seg) + ':' + HexStr(PtrRec(LogicalAddr).Ofs);
  321.           end
  322.           else  begin
  323.             s := LineNumber^.ItsCorrelation^.ItsSourceFile^.ItsName + ' (' + StrW(LineNumber^.Value) + ') ';
  324.             New(Symbol, AtAddr(LogicalAddr));
  325.             if Symbol <> nil then  begin
  326.               if Symbol^.ItsType^.ReturnType = 1
  327.                then  s := s + 'procedure '
  328.                else  s := s + 'function ';
  329.               if Symbol^.ItsType^.ID = tid_SpecialFunc then  begin
  330.                 s := s + Symbol^.ItsType^.ItsClassType^.ItsName + '.';
  331.               end;
  332.               s := s + Symbol^.ItsName + ';';
  333.               Dispose(Symbol, Done);
  334.             end;
  335.             Dispose(LineNumber, Done);
  336.           end;
  337.        end
  338.        else
  339.          s := HexStr(PtrRec(LogicalAddr).Seg) + ':' + HexStr(PtrRec(LogicalAddr).Ofs);
  340.       GetAddress := s;
  341.     end;
  342.  
  343.   begin
  344.     with Item^ do  begin
  345.       writeln(t, LeftJustify(GetAddress(Caller), CallerWidth), '  ', Size:5);
  346.       writeln(t, '  ', LeftJustify(GetAddress(CallerItsCaller), CallerWidth-2));
  347.       Inc(Amount, Size);
  348.     end;
  349.   end;
  350.  
  351. const
  352.   BufSize = 1024;
  353. var
  354.   Buffer : array[1..BufSize] of char;
  355. begin
  356.   MemCheckOff;
  357.   Assign(t, ReportFileName);
  358.   Rewrite(t);
  359.   SetTextBuf(t, Buffer, BufSize);
  360.   writeln(t, 'Not disposed memory report. Date: ', GetDateStr, '  Time: ', GetTimeStr);
  361.   writeln(t);
  362.   writeln(t, LeftJustify('Caller', CallerWidth), '   Size');
  363.   writeln(t);
  364.   Amount := 0;
  365.   AllocCol^.ForEach(@Print);
  366.   writeln(t);
  367.   writeln(t);
  368.   writeln(t, 'Total not disposed memory: ', Amount, ' bytes');
  369.   writeln(t, 'Total items: ', AllocCol^.Count);
  370.   Close(t);
  371.   MemCheckOn;
  372. end;
  373.  
  374.  
  375. begin
  376.   MemCheckRec := ErrorAddr;
  377.   if MemCheckRec <> nil then  begin
  378.     AllocCol := New(PAllocCollection, Init(4096,4096));
  379.     MemCheckRec^.StoreAlloc := @StoreAlloc;
  380.     MemCheckRec^.FreeAlloc := @FreeAlloc;
  381.     MemCheckOn;
  382.   end;
  383. end.  { of unit MemCheck }