Power-Programmierung/CD1.mdf/pascal/library/dos/packer/arc/arctool/heapchek.pas

Pascal/Delphi Source File | 1988-09-28 | 12.5 KB | 440 lines

{

* DESCRIPTION
Unit that contains procedures developed to help debug a program that uses
the heap extensively, and other routines to return more information about
the free list and to influence the behaviour of the heap manager. Requires
the use of units from the commercial product Turbo Professional 4.0, by
TurboPower Software.

* ASSOCIATED FILES
HEAPCHEK.PAS
DEMO.EXE
DEMO.PAS
HEAPCHEK.TPU

}
Unit HeapChek;

{ This unit contains some procedures which I developed to help debug a program
  that uses the heap extensively, and some other routines to return more info
  about the free list and to influence the behaviour of the heap manager.

  Note: the procedures and functions which return information about the heap
  are safe -- they use information published by Borland and only read from
  the free list.  FirstFitHeap, BestFitHeap and WorstFitHeap operate by
  directly manipulating the heap, and as such cannot be guaranteed to work
  in Turbo 4.0, and may not work at all if Borland "improves" the heap manager
  in future releases of Turbo Pascal.

  For those who are interested, the free list behaves as follows:  When
  a block of memory is allocted, the Heap Manager first checks the free
  list, starting with the first item.  If there are no items on the free
  list, or no blocks big enough, memory is allocated starting at HeapPtr
  and HeapPtr is raised.

  If there is a suitable block, the Heap Manager removes the block from
  the free list, creates a pointer to a suitable block on the heap, and
  places the remaining block (if any) at the front of the free list.

  When a block is disposed, the free list is checked for any adjacent
  blocks (i.e. a block just before or after in memory which has already
  been disposed), adds these to the block being released, and places the
  new entry at the front of the free list.

  If the new free block appears at the end of the heap, HeapPtr is
  adjusted and no new entry appears on the free list.

  As a consequence, the free list is arranged from most recently used to
  least recently used.

  Because NEW always takes the first block, FirstFitHeap, BestFitHeap
  and WorstFitHeap operate by finding a block which meets the desired
  criteria, and swaps the first entry and the desired entry on the free
  list.

  For more info, see Chapter 26 of the Turbo Pascal manual

  Placed in the public domain by Lynn W. Taylor  (CIS 74176,52) }

Interface

uses TpString;  { Write your own HexW and HexPtr routines and you can
                  eliminate this, or get Turbo Professional 4.0 from
                  TurboPower Software }


const AlwaysShowHeapStatus: boolean = false;

{ if you set AlwaysShowHeapStatus to true, the heap status will be shown
  automatically on exit.  If false (default), it will be displayed only
  if an appropriate error occurs }

Function FreeCount: integer;

{ returns the number of free blocks on the free list }

Function MinAvail: longint;

{ returns the size of the smallest available block (in bytes) -- useful for
  checking to see if the heap is fragmented.  If FreeCount is zero, MinAvail
  returns MaxAvail. }

Function MaxFreeListBlock: longint;

{ returns the size of largest block on the free list -- which may be smaller
  than MaxAvail.  Function returns 0 if the free list is empty }

Procedure ShowFreeList;

{ Displays the free list using WRITEs to StdOut }

Procedure HeapCheck;

{ Displays a number of useful heap parameters -- useful for debugging.  Also
  called by the exit procedure if the appropriate error ocurs, or if
  AlwaysShowHeapStatus is true }

Procedure WorstFitHeap;

{ Finds largest block on the Free List, and swaps it with the first block
  so the next allocation will use part of the largest free block.  It works
  fine for me but use at your own risk }

Procedure BestFitHeap(Size: word);

{ Finds smallest block which is "Size" or bigger on the Free List, and swaps
  it with the first block so the next allocation will use part of this block.
  It works fine for me but use at your own risk }

Procedure FirstFitHeap(Size: word);

{ Finds lowest block which is "Size" or bigger on the Free List, and swaps
  it with the first block so the next allocation will use part of this block.
  It works fine for me but use at your own risk

  Lowest means the one closest to HeapOrg }

Procedure LastFitHeap(Size: word);

{ Finds highest block which is "Size" or bigger on the Free List, and swaps
  it with the first block so the next allocation will use part of this block.
  It works fine for me but use at your own risk

  Highest means the one farthest from HeapOrg }

Procedure ExactFitHeap(Size: word);

{ A cross between BestFitHeap and FirstFitHeap.  If a block that exactly
  matches Size exists, it is used, otherwise the first block is used. }

Procedure SwapFreeHeap;

{ Exchanges first and last free list entries.  Since the heap manager always
  puts it's result on the front of the free list, this makes sure that the
  block just disposed is the LAST block to be used.  This usually means that
  the block will hang around long enough that it is most likely to get merged
  into another block }

Implementation

type FreeRec=record
               OrgOfs, OrgSeg, EndOfs, EndSeg: word;
             end;
     FreeList=array[0..8190] of FreeRec;
     FreeListP=^FreeList;

var SaveExit: pointer;

Function FreeAddr(P: FreeRec): LongInt;

Begin
  FreeAddr:=(16*P.OrgSeg)+P.OrgOfs;
End;

Function FreeSize(P: FreeRec): LongInt;

Begin
  FreeSize:=((16*P.EndSeg)+P.EndOfs)-((16*P.OrgSeg)+P.OrgOfs)
End;

Function FreeCount: integer;

Begin
  If Ofs(FreePtr^)=0
    then FreeCount:=0
    else FreeCount:=(8192-Ofs(FreePtr^) div 8) mod 8192;
End;  {FreeCount}

Function MinAvail: longint;

var Ctr: integer;
    SmallestSize, BlockSize: longint;
    TheFreeList: FreeListP;

Begin
  SmallestSize:=MemAvail;
  If FreeCount=0 then Exit;
  TheFreeList:=FreePtr;
  For Ctr:=0 to FreeCount-1 do
    Begin
      BlockSize:=FreeSize(TheFreeList^[Ctr]);
      If BlockSize<SmallestSize then SmallestSize:=BlockSize
    End;
  MinAvail:=SmallestSize
End;  {MinAvail}

Function MaxFreeListBlock: longint;

var Ctr: integer;
    BiggestSize, BlockSize: longint;
    TheFreeList: FreeListP;

Begin
  BiggestSize:=0;
  TheFreeList:=FreePtr;
  For Ctr:=0 to FreeCount-1 do
    Begin
      BlockSize:=FreeSize(TheFreeList^[Ctr]);
      If BlockSize>BiggestSize then BiggestSize:=BlockSize
    End;
  MaxFreeListBlock:=BiggestSize
End;  {MaxFreeListBlock}

Procedure ShowFreeList;

var Ctr: integer;
    TheFreeList: FreeListP;

Begin
  WriteLn('Free list:');
  WriteLn;
  TheFreeList:=FreePtr;
  For Ctr:=0 to FreeCount-1 do
    WriteLn('$', HexW(TheFreeList^[Ctr].OrgSeg), ':',
                 HexW(TheFreeList^[Ctr].OrgOfs), ' - ',
            '$', HexW(TheFreeList^[Ctr].EndSeg), ':',
                 HexW(TheFreeList^[Ctr].EndOfs));
End;  {ShowFreeList}

Procedure WorstFitHeap;

var Ctr: integer;
    BiggestSize, BiggestBlock, BlockSize: longint;
    TheFreeList: FreeListP;
    Temp: FreeRec;

Begin
  If FreeCount<2 then Exit;
  TheFreeList:=FreePtr;
  BiggestSize:=0;
  BiggestBlock:=0;
  For Ctr:=0 to FreeCount-1 do
    Begin
      BlockSize:=FreeSize(TheFreeList^[Ctr]);
      If BlockSize>BiggestSize then
        Begin
          BiggestSize:=BlockSize;
          BiggestBlock:=Ctr
        End
    End;
  If BiggestBlock=0 then Exit;
  Temp:=TheFreeList^[0];
  TheFreeList^[0]:=TheFreeList^[BiggestBlock];
  TheFreeList^[BiggestBlock]:=Temp
End;  {WorstFitHeap}

Procedure BestFitHeap(Size: word);

var Ctr: integer;
    SmallestSize, SmallestBlock, BlockSize: longint;
    TheFreeList: FreeListP;
    Temp: FreeRec;

Begin
  If FreeCount<2 then Exit;
  TheFreeList:=FreePtr;
  SmallestSize:=FreeSize(TheFreeList^[0]);
  SmallestBlock:=0;
  Ctr:=FreeCount-1;
  Repeat
    BlockSize:=FreeSize(TheFreeList^[Ctr]);
    If (BlockSize>=Size) and (BlockSize<=SmallestSize) then
      Begin
        SmallestSize:=BlockSize;
        SmallestBlock:=Ctr
      End;
    Ctr:=Ctr-1
  Until (SmallestSize=Size) or (Ctr=0);
  If SmallestBlock=0 then Exit;
  Temp:=TheFreeList^[0];
  TheFreeList^[0]:=TheFreeList^[SmallestBlock];
  TheFreeList^[SmallestBlock]:=Temp
End;  {BestFitHeap}

Procedure ExactFitHeap(Size: word);

var Ctr: integer;
    LowestBlock, LowestAddr, BlockSize: longint;
    TheFreeList: FreeListP;
    Temp: FreeRec;

Begin
  If FreeCount<2 then Exit;
  TheFreeList:=FreePtr;
  LowestAddr:=FreeAddr(TheFreeList^[0]);
  LowestBlock:=0;
  Ctr:=FreeCount-1;
  Repeat
    BlockSize:=FreeSize(TheFreeList^[Ctr]);
    If (BlockSize=Size)
      then LowestBlock:=Ctr
      else
        If LowestAddr>FreeAddr(TheFreeList^[Ctr]) then
          Begin
            LowestAddr:=FreeAddr(TheFreeList^[Ctr]);
            LowestBlock:=Ctr
          End;
    Ctr:=Ctr-1
  Until (BlockSize=Size) or (Ctr=0);
  If LowestBlock=0 then Exit;
  Temp:=TheFreeList^[0];
  TheFreeList^[0]:=TheFreeList^[LowestBlock];
  TheFreeList^[LowestBlock]:=Temp
End;  {ExactFitHeap}

Procedure FirstFitHeap(Size: word);

var Ctr: integer;
    FirstAddress, FirstAddressBlock, BlockSize: longint;
    TheFreeList: FreeListP;
    Temp: FreeRec;

Begin
  If FreeCount<2 then Exit;
  TheFreeList:=FreePtr;
  FirstAddress:=FreeAddr(TheFreeList^[0]);
  FirstAddressBlock:=0;
  For Ctr:=1 to FreeCount-1 do
    Begin
      BlockSize:=FreeSize(TheFreeList^[Ctr]);
      If (BlockSize>=Size) and
         (FreeAddr(TheFreeList^[Ctr])<FirstAddress) then
        Begin
          FirstAddress:=FreeAddr(TheFreeList^[Ctr]);
          FirstAddressBlock:=Ctr
        End
    End;
  If FirstAddressBlock=0 then Exit;
  Temp:=TheFreeList^[0];
  TheFreeList^[0]:=TheFreeList^[FirstAddressBlock];
  TheFreeList^[FirstAddressBlock]:=Temp
End;  {FirstFitHeap}

Procedure LastFitHeap(Size: word);

var Ctr: integer;
    LastAddress, LastAddressBlock, BlockSize: longint;
    TheFreeList: FreeListP;
    Temp: FreeRec;

Begin
  If FreeCount<2 then Exit;
  TheFreeList:=FreePtr;
  LastAddress:=FreeAddr(TheFreeList^[0]);
  LastAddressBlock:=0;
  For Ctr:=1 to FreeCount-1 do
    Begin
      BlockSize:=FreeSize(TheFreeList^[Ctr]);
      If (BlockSize>=Size) and
         (FreeAddr(TheFreeList^[Ctr])<LastAddress) then
        Begin
          LastAddress:=FreeAddr(TheFreeList^[Ctr]);
          LastAddressBlock:=Ctr
        End
    End;
  If LastAddressBlock=0 then Exit;
  Temp:=TheFreeList^[0];
  TheFreeList^[0]:=TheFreeList^[LastAddressBlock];
  TheFreeList^[LastAddressBlock]:=Temp
End;  {LastFitHeap}

Procedure SwapFreeHeap;

var Top: integer;
    TheFreeList: FreeListP;
    Temp: FreeRec;

Begin
  If FreeCount<2 then Exit;
  TheFreeList:=FreePtr;
  Top:=FreeCount-1;
  Temp:=TheFreeList^[0];
  TheFreeList^[0]:=TheFreeList^[Top];
  TheFreeList^[Top]:=Temp
End;  {SwapFreeHeap}

Procedure HeapCheck;

var TheFreeList: FreeListP;
    Ctr: integer;
    BlockSize: LongInt;
    SmallestSize, SmallestCount: LongInt;

Begin
  WriteLn('HeapOrg:    $',HexPtr(HeapOrg));
  WriteLn('HeapPtr:    $',HexPtr(HeapPtr));
  WriteLn('FreePtr:    $',HexPtr(FreePtr));
  WriteLn('FreeMin:    ',FreeMin);
  WriteLn('MemAvail:   ',MemAvail);
  WriteLn('MaxAvail:   ',MaxAvail);
  WriteLn;
  SmallestSize:=MemAvail;
  SmallestCount:=0;
  TheFreeList:=FreePtr;
  For Ctr:=0 to FreeCount-1 do
    Begin
      BlockSize:=FreeSize(TheFreeList^[Ctr]);
      If BlockSize=SmallestSize then SmallestCount:=SmallestCount+1;
      If BlockSize<SmallestSize then
        Begin
          SmallestSize:=BlockSize;
          SmallestCount:=1
        End
    End;
  WriteLn('Free Block Count: ', FreeCount);
  If FreeCount<>0
    then
      Begin
    WriteLn('Largest Block:    ', MaxFreeListBlock);
        WriteLn('Smallest Block:   ', SmallestSize);
        WriteLn('Blocks this size: ', SmallestCount)
      End
    else
      Begin
    WriteLn('Largest Block:    - ');
        WriteLn('Smallest Block:   - ');
        WriteLn('Blocks this size: - ')
      End;
  WriteLn;
End;  {HeapCheck}

{$F+}
Procedure HeapExit;

Begin
  ExitProc:=SaveExit;
{ If ExitCode<>0 then Write(#7, #7, #7, #7, #7); }
  If (ExitCode=203) or (ExitCode=204) or AlwaysShowHeapStatus
    then HeapCheck;
  { Don't show heap information unless error is Heap Overflow or
    Invalid pointer operation, or if AlwaysShowHeapStatus is true }
End;  {HeapExit}
{$F-}

Begin
  SaveExit:=ExitProc;
  ExitProc:=@HeapExit;
End.