OS/2 Shareware BBS: 10 Tools/10-Tools.zip/memmon.zip/MEMMON.PAS

Pascal/Delphi Source File | 1997-05-10 | 10KB | 437 lines

{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█                                                   █}
{█  Virtual Pascal Hack v1.10                        █}
{█  Memory usage monitor routines for VP/2 v1.10     █}
{█  ─────────────────────────────────────────────────█}
{█  Copyright (C) 1997 fPrint UK Ltd                 █}
{█  Written April-May 1997 by Allan Mertner          █}
{█                                                   █}
{█  NOTE: USE THIS UNIT AT YOUR OWN RISK.            █}
{█                                                   █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}

unit MemMon;

interface

{$X+,Delphi+}

uses
  Os2Base;

{---[ Reporting ]---}

procedure DisplayStandardData;
  // Displays standard debugging information based on
  // data collected in this unit

procedure DisplayUnFreedMemory;
  // Displays a list of heap memory allocated but not
  // freed, including allocation size and line number
  // of allocating call


{---[ Heap routines ]---}

function GetMaxMemoryUsed: Longint;
  // Returns the maximum number of bytes allocated on the
  // heap at any one time

function GetCurrentMemoryUsed: Longint;
  // Returns the number of bytes current allocated on the
  // heap


{---[ Stack routines ]---}

function GetMaxStackUsed: Longint;
  // Returns the maximum number of stack bytes allocated
  // by the current thread

function GetMaxStackUsageLocation: String;
  // Returns the file name and line number where the stack
  // usage was at maximum for current thread

function GetMaxThreadStackUsed(TID: Longint): Longint;
  // Returns the maximum number of stack bytes allocated
  // by a specific thread

function GetMaxThreadStackUsageLocation(TID: Longint): String;
  // Returns the file name and line number where the stack
  // usage was at maximum for a specific thread

const
  // Maximum number of threads supported for stack checking
  MaxThreads = 200;

implementation

uses
  VPUtils;

{---[ Heap routines ]---}

type
  PAllocRec = ^TAllocRec;
  TAllocRec = record
    Size   : Longint;
    Caller : Longint;
    Addr   : Pointer;
    Unused : Longint;
  end;

const
  InitialAllocs = 64;

var
  Allocations : PAllocRec;
  AllocCount  : Longint;
  AllocIndex  : Longint;
  AllocTotal  : Longint;
  AllocMax    : Longint;

function GetCurrentMemoryUsed: Longint;
begin
  Result := AllocTotal;
end;

function GetMaxMemoryUsed: Longint;
begin
  Result := AllocMax;
end;


{---[ Reporting ]---}

procedure DisplayStandardData;
var
  i: Longint;
begin
  { Output maximum stack usage for each thread: }
  for i := 1 to MaxThreads do
    if GetMaxThreadStackUsed(i) > 0 then
      begin
        Write('Stack usage, ');
        if i = 1 then
          writeln('main thread')
        else
          Writeln('thread #',i);
        Writeln('  Stack used : ',GetMaxThreadStackUsed(i));
        Writeln('  Location   : ',GetMaxThreadStackUsageLocation(i));
      end;

  Writeln;
  DisplayUnfreedMemory;

  Writeln;
  Writeln('Current heap memory allocated: ',GetCurrentMemoryUsed,' bytes');
  Writeln('Maximum heap memory allocated: ',GetMaxMemoryUsed,' bytes');
end;

procedure DisplayUnFreedMemory;
var
  FileName : String;
  LineNo   : Longint;
  i        : Longint;
  S        : String;
  P        : PAllocRec;
begin
  if AllocIndex = 0 then
    Writeln('All heap memory was freed')
  else
    begin
      Writeln('The following memory blocks were not freed:');
      Writeln('  Heap Address    Bytes   Allocation code');
    end;
  P := Allocations;
  for i := 1 to AllocIndex do
    begin
      if GetLocationInfo(Ptr(P^.Caller-1), FileName, LineNo) <> nil then
        begin
          Str(LineNo, S);
          S := FileName + ', Line ' + S;
        end
      else
        S := '(return address is '+Int2Hex(P^.Caller, 8)+')';

      Writeln( '    @',Ptr2Hex(P^.Addr),'   ',P^.Size:7, '   '+S);
      inc(P);
    end;
end;


{---[ Stack routines ]---}

// Disable stack checking
{$S-}

var
  MinStack: Array[1..MaxThreads] of Cardinal;
  MaxStack: Array[1..MaxThreads] of Cardinal;
  Caller  : Array[1..MaxThreads] of Pointer;

function GetMaxThreadStackUsed(TID: Longint): Longint;
begin
  If not (TID in [1..MaxThreads]) or (MaxStack[TID] = 0) then
    Result := 0
  else
    Result := MaxStack[TID]-MinStack[TID];
end;

function GetMaxThreadStackUsageLocation(TID: Longint): String;
var
  FileName: String;
  LineNo: Longint;
begin
  Result := '';
  if TID in [1..MaxThreads] then
    if GetLocationInfo(Caller[TID], FileName, LineNo) <> nil then
      begin
        Str(LineNo, Result);
        Result := FileName + ', Line ' + Result;
      end;
end;

function GetMaxStackUsed: Longint;
begin
  Result := GetMaxThreadStackUsed(GetThreadID);
end;

function GetMaxStackUsageLocation: String;
begin
  Result := GetMaxThreadStackUsageLocation(GetThreadID);
end;

procedure Failed;
begin
  Writeln('Stack/Heap Usage Checking failed to install');
  Writeln;
  Writeln('This unit only works with Virtual Pascal for OS/2 v1.10,');
  Writeln('and must be compiled with the compiler options found in');
  Writeln('the original source files in order to work.');
  Writeln;
  Writeln('Program terminated.');
  Halt(1);
end;

{ -----  Below this line, the code must be left unchanged to work }

{$S-,W-,Optimize+,T-,X+}
procedure MyStackCheck;
assembler; {$Frame-} {$Uses None} {$Alters None}
asm
    push   eax
    push   ecx

    call   GetThreadID
    dec    eax
    mov    ecx,esp
    cmp    ecx,[eax*4+offset MaxStack]
    jle    @@NotBigger
    mov    [eax*4+offset MaxStack],ecx
  @@NotBigger:
    cmp    ecx,[eax*4+offset MinStack]
    jge    @@NotSmaller
    mov    [eax*4+offset MinStack],ecx
    mov    ecx,[esp+12]
    mov    [eax*4+offset Caller],ecx
  @@NotSmaller:

    pop    ecx
    pop    eax

    xchg   [esp+8],eax
    add    eax,1000h
end;

var
  MemGetOriginal : Longint;
  MemFreeOriginal: Longint;
  SaveEAX        : Longint;
  SaveECX        : Longint;
  SaveEDX        : Longint;
  HeapSem        : Longint;

procedure IncreaseAllocation;
var
  P: Pointer;
begin
  GetMem(P, (AllocCount+InitialAllocs)*Sizeof(TAllocRec));
  move(Allocations^, P^, AllocCount*Sizeof(TAllocRec));
  FreeMem(Allocations, AllocCount*Sizeof(TAllocRec));
  inc(AllocCount, InitialAllocs);
  Allocations := P;
end;

procedure MyMemGet;
assembler; {$Frame-} {$Uses None} {$Alters None}
asm
    bt     HeapSem, 0
    jnc    @@RetrySem

    call   MemGetOriginal
    ret

  @@RetrySem:
    bts    HeapSem, 1
    jnc    @@Go
    push   31
    call   DosSleep
    jmp    @@RetrySem

  @@Go:
    mov    [SaveEAX],eax
    mov    [SaveECX],ecx
    mov    [SaveEDX],edx

    mov    ecx,AllocIndex
    cmp    ecx,AllocCount
    jl     @@EnoughMemory

    bts    HeapSem,0

    call   IncreaseAllocation
    mov    ecx,AllocIndex

    btr    HeapSem,0

  @@EnoughMemory:
    mov    edx,[Allocations]
    shl    ecx,4
    mov    [edx+ecx],eax
    add    AllocTotal,eax
    mov    eax,AllocTotal
    cmp    eax,AllocMax
    jle    @@NotBiggest
    mov    AllocMax,eax

  @@NotBiggest:
    mov    eax,[esp+4]
    mov    [edx+ecx+4],eax

    mov    eax,[SaveEAX]

    call   MemGetOriginal

    mov    [edx+ecx+8],eax
    inc    AllocIndex

    mov    edx,[SaveEDX]
    mov    ecx,[SaveECX]

    and    HeapSem,$FD
end;

procedure MyMemFree;
assembler; {$Frame-} {$Uses None} {$Alters None}
asm
  @@RetrySem:
    bts    HeapSem, 1
    jnc    @@Go
    push   31
    call   DosSleep
    jmp    @@RetrySem

  @@Go:
    push   eax
    push   esi
    push   ecx
    push   edx

    mov    edx,[Allocations]
    mov    ecx,AllocIndex
    dec    ecx
    mov    esi,ecx
    shl    esi,4

  @@Next:
    cmp    ebx,[edx+esi+8]
    je     @@found
    sub    esi,16
    loopne @@Next
    jmp    @@NotFound

  @@Found:
    sub    AllocTotal,eax
    push   edi
    add    esi,[Allocations]
    mov    edi,esi
    add    esi,16
    mov    eax,ecx
    mov    ecx,AllocCount
    sub    ecx,eax
    rep    movsd

    pop    edi
    dec    AllocIndex

  @@NotFound:

    pop    edx
    pop    ecx
    pop    esi
    pop    eax

    btr    HeapSem,1

    call   MemFreeOriginal
end;

{$S+}
procedure HackStackCheck;
var
  i: Longint;
  StackCheck: Longint;
begin
  fillchar(MaxStack, Sizeof(MaxStack), 0);
  for i := Low(MinStack) to High(MinStack) do
    MinStack[i] := $7FFFFFFF;

  StackCheck := Ofs(HackStackCheck)+3;
  inc(StackCheck, MemL[StackCheck]+4);

  if DosSetMem(Ptr(StackCheck), 10, pag_Write) <> 0 then Failed;
  Mem [StackCheck]   := $E8;
  MemL[StackCheck+1] := Longint(@MyStackCheck)-StackCheck-5;
  MemL[StackCheck+5] := $90909090;
  DosSetMem(Ptr(StackCheck), 10, pag_Default);
end;

{$S-}
procedure HackMemoryManager;
var
  p       : Pointer;
  MemGet  : Longint;
  MemFree : Longint;
begin
  GetMem(Allocations, InitialAllocs*Sizeof(TAllocRec));
  FreeMem(P, 0);
  AllocCount := InitialAllocs;
  AllocIndex := 0;

  MemGet := Ofs(HackMemoryManager)+10;
  inc(MemGet, MemL[MemGet]+4+4);
  MemGetOriginal := MemL[MemGet+1]+MemGet+5;

  if DosSetMem(Ptr(MemGet), 5, pag_Write) <> 0 then Failed;
  MemL[MemGet+1] := Longint(@MyMemGet)-MemGet-5;
  DosSetMem(Ptr(MemGet), 5, pag_Default);

  MemFree := Ofs(HackMemoryManager)+23;
  inc(MemFree, MemL[MemFree]+4);
  MemFreeOriginal := MemL[MemFree+11]+MemFree+15;

  if DosSetMem(Ptr(MemFree), 5, pag_Write) <> 0 then Failed;
  MemL[MemFree+11] := Longint(@MyMemFree)-MemFree-15;
  DosSetMem(Ptr(MemFree), 5, pag_Default);

  AllocMax   := 0;
  AllocTotal := 0;
end;

begin
  HackStackCheck;
  HackMemoryManager;
end.