[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]

    Unit HeapChk;
    {$R-,S-}

    (************************************************************************
     *                                                                      *
     *                             HeapChk.pas                              *
     *                                                                      *
     *                     Copyright (c) Andy Cooper 1991                   *
     *                                                                      *
     *     May be used and distributed for non commercial use without       *
     *     restriction.  All commercial rights reserved.                    *
     *                                                                      *
     *                                                                      *
     *   WARNING:  This code may be version specific and has been tested    *
     *             with Turbo Pascal version 6.0 only.  Must be compiled    *
     *             with range and stack checking off.                       *
     *                                                                      *
     *                                                                      *
     *   The unit HeapChk MUST be the first unit in the uses statement of   *
     *   the primary file.  It does not (and in fact should not) have to be *
     *   included in any other units.                                       *
     *                                                                      *
     *   On exit from the program the file HEAPCHK.TXT will contain         *
     *   information about the run.                                         *
     *                                                                      *
     *   HeapChk error triggers                                             *
     *                                                                      *
     *      If an attempt is made to return a heap area that does not       *
     *      match the original allocation an error is flagged and the       *
     *      contents of the heap structure is written to the file.          *
     *                                                                      *
     *      If an attempt is made to return a non existing heap area the    *
     *      contents of the heap structure is written to the file.          *
     *                                                                      *
     *      If RELEASE is called with free heap areas below the MARK,       *
     *      turbo pascal discards the memory instead of returning it.       *
     *      HeapChk flags this condition, sums the areas lost and           *
     *      optionally lists the areas to be discarded                      *
     *                                                                      *
     *      If HeapChk determines that the freelist is corrupted an error   *
     *      is flagged.                                                     *
     *                                                                      *
     *   Content of HEAPCHK.TXT                                             *
     *                                                                      *
     *      Heapchk.txt contains an entry for every error condition         *
     *      encountered.  If level is > 2 then the program will be          *
     *      terminated otherwise a warning is recorded.                     *
     *                                                                      *
     *      The error or warning printout will contain one line for each    *
     *      active heap area consisting of the pointer value returned,      *
     *      requested length, address of instruction AFTER the call to      *
     *      NEW / GETMEM and a best guess at the caller to the procedure    *
     *      that issued the getmem.  This is useful for turbovision etc     *
     *      as you can find where you were in your code, ie where were      *
     *      you when you called the tv procedure.  To use these addresses   *
     *      run the program under turbo debugger, obtain the printout, then *
     *      use the GO <ctrl-g> function to find the calling code.  NOTE    *
     *      the IDE find error function does not work.                      *
     *                                                                      *
     *      There will be an entry for each call to MARK and if the free    *
     *      list is corrupted it will be dumped.                            *
     *                                                                      *
     *                                                                      *
     ************************************************************************)

    interface
      procedure displaystats;

    const
      level           = 2;              {> 2 causes error halt, <= 2 warning}
      prtreleaseon    = false;          {if true dumps heap areas discarded }
                                        {when release is called             }

      hex : array[0..15] of char = '0123456789abcdef';

      precsize        = 500;            {maximum number of pointer entries}
      Heaprec         = 1;
      Markrec         = 2;

      ptrofl          = 1;
      ptrnotfound     = 2;
      ptrbadlength    = 3;
      getmembusyerr   = 4;
      freemembusyerr  = 5;
      BadFreeList     = 6;
      markrecnotfound = 7;
      CannotMark      = 8;
      CannotRelease   = 9;

      errorcodes : array[1..9] of string[60] =
        ('Internal Error - Heap structure overflow',
         'Program Error - Attempting to return non-allocated memory',
         'Program Error - FreeMem length does not match area allocated',
         'Internal Error - Recursive call to getmem',
         'Internal Error - Recursive call to freemem',
         'Heap Failure - Free List Corrupted',
         'Release failed - No matching mark pointer',
         'Mark Failed - Free list not empty',
         'Release Failed - Free list not empty'
         );

    type
      prec = record
               p           : pointer;
               l,
               f           : word;
               caller,                   {address of next instruction after }
                                         {the code that called getmem       }
               pcaller     : pointer;    {"best guess" at the previous caller}
             end;

      freelst = record
                  next  : pointer;
                  bytes,
                  paras : word;
                end;

      fake = record
               case boolean of
                 true  : (ptr : pointer);
                 false : (pofs,
                          pseg  : word)
               end;

    var
      getmembusyflag,
      freemembusyflag : word;
      pprev,
      pretto,
      pgetmem,
      pfreemem        : pointer;
      orphaned,
      lostheap,
      lg,lf,lm,lr     : longint;
      precarray       : array[1..precsize] of prec;
      pindx           : integer;
      savexit         : pointer;
      lfile           : text;
      progname        : string[80];

    implementation
    uses
      crt,printer;

    procedure displaystats;
      begin
        writeln('There were ',lg,' calls to new/getmem');
        writeln('There were ',lf,' calls to dispose/freemem');
        writeln('There were ',lm,' calls to mark');
        writeln('There were ',lr,' calls to release');
        writeln('There were ',lostheap,' Bytes lost');
      end;

    function hexptr(p:pointer):string;
      var
        f : fake;
        s : string;
      begin
        f.ptr := p;
        s[1] := hex[(hi(f.pseg) shr 4)];
        s[2] := hex[hi(f.pseg) and $f];
        s[3] := hex[(lo(f.pseg) shr 4)];
        s[4] := hex[lo(f.pseg) and $f];
        s[5] := ':';
        s[6] := hex[(hi(f.pofs) shr 4)];
        s[7] := hex[hi(f.pofs) and $f];
        s[8] := hex[(lo(f.pofs) shr 4)];
        s[9] := hex[lo(f.pofs) and $f];
        s[0] := chr(9);
        hexptr := s
      end;

    procedure prtrec(i:integer);
      begin
        write(lfile,i:4,' Ptr = ',hexptr(precarray[i].p),
                                ' Len = ',precarray[i].l:5,
                                '  Caller = ',hexptr(precarray[i].caller),
                                '  PCaller = ',hexptr(precarray[i].pcaller));
        if precarray[i].f = markrec then
          writeln(lfile,' Mark Record')
        else
          writeln(lfile);
      end;

    procedure error(errno:word;p:pointer;l:word);
      {called on error if level > 2}
      var
        i : integer;
      begin
        writeln(lfile,errorcodes[errno]);
        writeln(lfile,'Ptr = ',hexptr(p),' Len = ',l);
        if errno = cannotrelease then
          writeln(lfile,'Freelist = ',hexptr(freelist));
        writeln(lfile,'******* Dump of heap structure *******');
        for i := 1 to pindx do
          prtrec(i);
        writeln(lfile,'******* End of heap structure *******'#13#10);
        window(1,1,80,25);
        normvideo;
        clrscr;
        halt;
      end;

    procedure warning(errno:word;p:pointer;l:word);
      {called on error if level <= 2}
      var
        i : integer;
      begin
        writeln(lfile,errorcodes[errno]);
        writeln(lfile,'Ptr = ',hexptr(p),' Len = ',l);
        if errno = cannotrelease then
          writeln(lfile,'Freelist = ',hexptr(freelist));
        writeln(lfile,'******* Dump of heap structure *******');
        for i := 1 to pindx do
          prtrec(i);
        writeln(lfile,'******* End of heap structure *******'#13#10);
      end;

    function NormPtr(p:pointer):longint;
      {normalize pointer}
      var
        sp : fake;
        l  : longint;
      begin
        sp.ptr := p;
        l := sp.pseg;
        l := l*16;
        l := l + sp.pofs;
        NormPtr := l;
      end;

    procedure CheckFreeList;
      var
        p    : pointer;
        lhp,
        lho,
        lhf  : longint;

      begin
        p := freelist;
        lhp := NormPtr(HeapPtr);
        lho := NormPtr(HeapOrg);
        while p <> heapptr do
          begin
            lhf := NormPtr(p);
            if (lhf > lhp) or (lhf < lho) then
              error(BadFreelist,p,0)
            else
              p := freelst(p^).next
          end;
      end;

    procedure PrintFreeList;
      var
        p    : pointer;
        lhf,
        lhp,
        lho  : longint;

      begin
        p := freelist;
        lhp := NormPtr(HeapPtr);
        lho := NormPtr(HeapOrg);
        writeln(lfile,'********** Dump of Free List *********');
        while p <> heapptr do
          begin
            lhf := NormPtr(p);
            if (lhf > lhp) or (lhf < lho) then
              error(BadFreelist,p,0)
            else
              begin
                writeln(lfile,' Ptr = ',hexptr(p),' Len = ',freelst(p^).bytes+freelst(p^).paras shl 2);
                p := freelst(p^).next
              end;
          end;
        writeln(lfile,'********** End of Free List *********'#13#10);
      end;

    procedure delrec(indx:integer);
      {delete record from array}
      begin
        if indx <> pindx then
          move(precarray[indx+1],precarray[indx],(pindx-indx) shl 4);
        dec(pindx)
      end;

    procedure MyMark(var p:pointer);far;
      {Duplicate tp mark instead of hooking entry point}
      begin
        inc(lm);
        checkfreelist;
        if heapptr <> freelist then
          if level > 2 then
            error(CannotMark,p,0)
          else
            warning(CannotMark,p,0);
        p := heapptr;
        if pindx+1 > precsize then
          error(ptrofl,nil,pindx);
        inc(pindx);
        precarray[pindx].p := heapptr;
        precarray[pindx].f := Markrec;
        precarray[pindx].l := 0;
        precarray[pindx].caller := nil;
        precarray[pindx].pcaller := nil;
      end;

    procedure MyRelease(var p:pointer);far;
      {duplicate tp release instead of hooking entry point}
      var
        i : integer;
        l,
        lhp,
        lhf  : longint;
      begin
        inc(lr);
        checkfreelist;
        if normptr(freelist) < normptr(p) then
          if level > 2 then
            error(CannotRelease,p,0)
          else
            warning(CannotRelease,p,0);
        i := pindx;
        while (i>0) and not ((precarray[i].p=p) and (precarray[i].f=MarkRec)) do
          dec(i);
        if i = 0 then
          error(MarkRecNotFound,p,0);
        if normptr(freelist) < normptr(p) then
          printfreelist;

        lhp := normptr(p);
        while freelist <> heapptr do
          begin
            lhf := NormPtr(freelist);
            if lhf < lhp then
              lostheap := lostheap + freelst(freelist^).bytes+freelst(freelist^).paras shl 2;
            freelist := freelst(freelist^).next
          end;

        delrec(i);                          {delete mark record}
        {******************************}
        {   This is waht tp does!!!    }
        heapptr := p;
        freelist := p;
        {******************************}
        i := 1;
        l := NormPtr(p);
        if prtreleaseon then
          writeln(lfile,'****** Discarding Pointers above ',hexptr(p),' ******');
        while i <= pindx do
          if l > NormPtr(Precarray[i].p) then
            inc(i)
          else
            begin
              if prtreleaseon then
                prtrec(i);
              DelRec(i);
            end;
        if prtreleaseon then
          writeln(lfile,'**************** End of Discard ****************');
      end;

    procedure Getmem_Return;assembler;
        { this code intercepts the return from tp's heap allocation
          stuff and stores the actual pointer value into the array}
        asm
            add  [word ptr lg],1
            jnc  @@1
            inc  [word ptr lg+2]
            @@1:
            dec  getmembusyflag
            mov  bx,pindx
            inc  pindx
            shl  bx,1                   {pindx * 16}
            shl  bx,1
            shl  bx,1
            shl  bx,1
            add  bx,offset precarray    {heap record base}
            mov  [bx],ax                {store returned pointer}
            mov  [bx+2],dx
            mov  bx,offset pretto       {retrieve return to address}
            jmp  dword ptr [bx]         { and jump }
        end;

    procedure Intercept_Getmem;assembler;
        asm
            mov  ax,[bp+2]                  {take a guess at the previous}
            mov  [word ptr pprev],ax        {procedure call return address}
            mov  ax,[bp+4]
            mov  [word ptr pprev+2],ax
            push bp                          {duplicate original code}
            mov  bp,sp
            cmp  getmembusyflag,0
            je   @@1
            mov  ax,getmembusyerr
            push ax
            xor  ax,ax
            push ax
            push ax
            push ax
            call error
            @@1:
            call CheckFreelist
            inc  getmembusyflag
            mov  ax,[bp+2]                   {intercept return address}
            mov  [word ptr pretto],ax        {from getmem and...}
            mov  ax,[bp+4]
            mov  [word ptr pretto+2],ax
            mov  ax,offset Getmem_Return     {replace it with ours}
            mov  [bp+2],ax
            mov  ax,seg Getmem_Return
            mov  [bp+4],ax

            mov  bx,pindx                    {get heap buffer indx}
            inc  bx
            cmp  bx,precsize                 {check it for overflow}
            jle  @@2
            mov  ax,ptrofl
            push ax
            xor  ax,ax
            push ax
            push ax
            push ax
            call error                      {display error and halt}

          @@2:
            dec  bx
            shl  bx,1                       {pindx * 16}
            shl  bx,1
            shl  bx,1
            shl  bx,1
            add  bx,offset precarray        {base of array}
            mov  ax,HeapRec
            mov  [bx+6],ax                  {flag Heaprec}
            mov  ax,[word ptr pretto]       {Callers address}
            mov  [bx+8],ax
            mov  ax,[word ptr pretto+2]
            mov  [bx+10],ax
            mov  ax,[word ptr pprev]       {Callers address}
            mov  [bx+12],ax
            mov  ax,[word ptr pprev+2]
            mov  [bx+14],ax
            {**********  This must be last as ax must contain length *********}
            mov  ax,[bp+6]                  {length of heap request}
            mov  [bx+4],ax                  {  to heap structure}
            mov  bx,offset pgetmem
            jmp  dword ptr [bx]             {jump back to execute getmem}
        end;

    procedure Intercept_Freemem;assembler;
      { on entry the stack contains a pointer to the memory to be freed and
        it's length.  The operation is verified and then the heap freemem
        procedure is called.  Note that the ax register must be conditioned}

        asm push bp                          {duplicate existing code}
            mov  bp,sp
            cmp  FreememBusyFlag,0           {check for recursive call}
            je   @@1
            mov  ax,FreememBusyErr
            push ax
            xor  ax,ax
            push ax
            push ax
            push ax
            call error
          @@1:
            add  word ptr lf,1
            jnc  @@99
            inc  word ptr lf+2
          @@99:
            call CheckFreelist
            inc  FreememBusyFlag
            mov  bx,pindx
            mov  cx,bx
            shl  bx,1                       {pindx * 16}
            shl  bx,1
            shl  bx,1
            shl  bx,1
            add  bx,offset precarray        {base of array}
          @@2:
            jcxz @@3
            dec  cx
            sub  bx,16
            mov  ax,[bp+10]                 {check pointer segment}
            cmp  ax,[bx+2]                  { to stored values}
            jne  @@2
            mov  ax,[bp+8]                  {check pointer offset}
            cmp  ax,[bx]
            jne  @@2
            mov  ax,heaprec
            cmp  ax,[bx+6]
            jne  @@2                        {heap record}
            mov  ax,[bp+6]                  {check length of area}
            cmp  ax,[bx+4]
            je   @@4
            dec  freemembusyflag
            mov  ax,ptrbadlength            {pointer found but bad length}
            push ax
            mov  ax,[bp+10]
            push ax
            mov  ax,[bp+8]
            push ax
            mov  ax,[bp+6]
            push ax
            call error
          @@3:                              {attempting to return a non}
            dec  freemembusyflag
            mov  ax,ptrnotfound             { allocated area}
            push ax
            mov  ax,[bp+10]
            push ax
            mov  ax,[bp+8]
            push ax
            mov  ax,[bp+6]
            push ax
            call error
          @@4:                              {found a good area}
            inc  cx
            cmp  cx,pindx                   {if not last allocated then}
            je   @@5
            mov  ax,ds                      {  close up the hole}
            mov  es,ax
            mov  di,bx                      {addr of record to delete}
            mov  si,di
            add  si,16                      {addr of next record}
            mov  ax,pindx
            sub  ax,cx                      {number of records to move}
            mov  cx,ax
            shl  cx,1                       {  multiplied by 16}
            shl  cx,1
            shl  cx,1
            shl  cx,1
            cld
            rep  movsb
          @@5:
            dec  pindx                     {decrement heaparray ptr}
            dec  freemembusyflag
            mov  ax,[bp+6]
            mov  bx,offset pfreemem
            jmp  dword ptr [bx]
        end;

    procedure Find_Procs;far;
      label
        lmark,
        lgetmem,
        lfreemem,
        lrelease;
      var
        tmp : pointer;
      begin
        asm
          {*********************************************
           retrieve the address of the getmem procedure
           and patch in the intercept code
           *********************************************}
            mov  bx,offset lgetmem
            add  bx,5
            mov  ax,word ptr [cs:bx]
            mov  [word ptr pgetmem],ax
            add  [word ptr pgetmem],6
            inc  bx
            inc  bx
            mov  dx,word ptr [cs:bx]
            mov  [word ptr pgetmem+2],dx
            mov  es,dx
            mov  bx,ax
            mov  byte ptr [es:bx],$EA  {jmp far}
            mov  ax,offset Intercept_Getmem
            inc  bx
            mov  word ptr [es:bx],ax
            mov  ax,seg Intercept_Getmem
            inc  bx
            inc  bx
            mov  word ptr [es:bx],ax
            mov  al,$90
            inc  bx
            inc  bx
            mov  byte ptr [es:bx],al

          {********************************************
           Now get the address of the freemem procedure
           and patch in the intercept code
           ********************************************}
            mov  bx,offset lfreemem
            add  bx,11
            mov  ax,word ptr [cs:bx]
            mov  [word ptr pfreemem],ax
            add  [word ptr pfreemem],6
            inc  bx
            inc  bx
            mov  dx,word ptr [cs:bx]
            mov  [word ptr pfreemem+2],dx
            mov  es,dx
            mov  bx,ax
            mov  byte ptr [es:bx],$EA  {jmp far}
            mov  ax,offset Intercept_Freemem
            inc  bx
            mov  word ptr [es:bx],ax
            mov  ax,seg Intercept_Freemem
            inc  bx
            inc  bx
            mov  word ptr [es:bx],ax
            mov  al,$90
            inc  bx
            inc  bx
            mov  byte ptr [es:bx],al
          {********************************************
           Now get the address of the Mark procedure
           and patch in the intercept code
           ********************************************}
            mov  bx,offset lmark
            add  bx,6
            mov  bx,word ptr [cs:bx]
            mov  byte ptr [es:bx],$EA  {jmp far}
            mov  ax,offset MyMark
            inc  bx
            mov  word ptr [es:bx],ax
            mov  ax,seg MyMark
            inc  bx
            inc  bx
            mov  word ptr [es:bx],ax
            mov  al,$90
            inc  bx
            inc  bx
            mov  byte ptr [es:bx],al
          {********************************************
           Now get the address of the Release procedure
           and patch in the intercept code
           ********************************************}
            mov  bx,offset lRelease
            add  bx,6
            mov  bx,word ptr [cs:bx]
            mov  byte ptr [es:bx],$EA  {jmp far}
            mov  ax,offset MyRelease
            inc  bx
            mov  word ptr [es:bx],ax
            mov  ax,seg MyRelease
            inc  bx
            inc  bx
            mov  word ptr [es:bx],ax
            mov  al,$90
            inc  bx
            inc  bx
            mov  byte ptr [es:bx],al
            mov  sp,bp
            pop  bp
            retf
        end;
        lgetmem:
        getmem(tmp,1);
        lfreemem:
        freemem(tmp,1);
        lmark:
        mark(tmp);
        lrelease:
        release(tmp);
      end;

    procedure cleanup;far;
      var
        i        : integer;

      begin
        if pindx > 0 then
          begin
            orphaned := 0;
            writeln(lfile,'******* Unreleased Heap On Exit *******');
            for i := 1 to pindx do
              begin
                orphaned := orphaned+precarray[i].l;
                prtrec(i);
              end;
            writeln(lfile,'******* End of Unreleased Heap ********'#13#10);
          end;
        writeln(lfile,#13#10'        ******* Total heap operations *******');
        writeln(lfile,'   Gets      Frees      Marks     Releases  Lost Heap  Orphaned Heap');
        writeln(lfile,'---------- ---------- ---------- ---------- ---------- -------------');
        writeln(lfile,lg:10,' ',lf:10,' ',lm:10,' ',lr:10,' ',lostheap:10,' ',Orphaned:13);
        close(lfile);
        exitproc := savexit;
      end;

    begin
      progname := paramstr(0);
      lg := 0;
      lf := 0;
      lm := 0;
      lr := 0;
      lostheap := 0;
      orphaned := 0;
      getmembusyflag := 0;
      freemembusyflag := 0;
      pindx := 0;
      assign(lfile,'heapchk.txt');
      rewrite(lfile);
      Writeln(lfile,'Heap Data for program ',progname,#13#10);
      savexit := exitproc;
      exitproc := @cleanup;
      Find_Procs;
    end.

[Back to MEMORY SWAG index] [Back to Main SWAG index] [Original]