[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]