fastmm_fulldebugmode.dpr

高效的内存管理开源项目,完全取代BorladMM的内存管理

{

Fast Memory Manager: FullDebugMode Support DLL 1.42

Description:
 Support DLL for FastMM. With this DLL available, FastMM will report debug info
 (unit name, line numbers, etc.) for stack traces.

Usage:
 1) To compile you will need the JCL library (http://sourceforge.net/projects/jcl/)
 2) Place in the same location as the replacement borlndmm.dll or your
 application's executable module.

Change log:
 Version 1.00 (9 July 2005):
  - Initial release.
 Version 1.01 (13 July 2005):
  - Added the option to use madExcept instead of the JCL Debug library. (Thanks
    to Martin Aignesberger.)
 Version 1.02 (30 September 2005):
  - Changed options to display detail for addresses inside libraries as well.
 Version 1.03 (13 October 2005):
  - Added a raw stack trace procedure that implements raw stack traces.
 Version 1.10 (14 October 2005):
  - Improved the program logic behind the skipping of stack levels to cause
    less incorrect entries in raw stack traces. (Thanks to Craig Peterson.)
 Version 1.20 (17 October 2005):
  - Improved support for madExcept stack traces. (Thanks to Mathias Rauen.)
 Version 1.30 (26 October 2005):
  - Changed name to FastMM_FullDebugMode to reflect the fact that there is now
    a static dependency on this DLL for FullDebugMode. The static dependency
    solves a DLL unload order issue. (Thanks to Bart van der Werf.)
 Version 1.40 (31 October 2005):
  - Added support for EurekaLog. (Thanks to Fabio Dell'Aria.)
 Version 1.42 (23 June 2006):
  - Fixed a bug in the RawStackTraces code that may have caused an A/V in some
    rare circumstances. (Thanks to Primoz Gabrijelcic.)
 Version 1.44 (16 November 2006):
  - Changed the RawStackTraces code to prevent it from modifying the Windows
    "GetLastError" error code. (Thanks to Primoz Gabrijelcic.)

}

{--------------------Start of options block-------------------------}

{Select the stack tracing library to use. The JCL, madExcept and EurekaLog are
 supported. Only one can be used at a time.}
{$define JCLDebug}
{.$define madExcept}
{.$define EurekaLog}

{--------------------End of options block-------------------------}

library FastMM_FullDebugMode;

uses
  {$ifdef JCLDebug}JCLDebug{$endif}
  {$ifdef madExcept}madStackTrace{$endif}
  {$ifdef EurekaLog}ExceptionLog{$endif},
  SysUtils, Windows;

{$R *.res}

{$STACKFRAMES ON}

{--------------------------Frame Based Stack Tracing--------------------------}

{Dumps the call stack trace to the given address. Fills the list with the
 addresses where the called addresses can be found. This is the fast stack
 frame based tracing routine.}
procedure GetFrameBasedStackTrace(AReturnAddresses: PCardinal; AMaxDepth, ASkipFrames: Cardinal);
var
  LStackTop, LStackBottom, LCurrentFrame: Cardinal;
begin
  {Get the call stack top and current bottom}
  asm
    mov eax, FS:[4]
    sub eax, 3
    mov LStackTop, eax
    mov LStackBottom, ebp
  end;
  {Get the current frame start}
  LCurrentFrame := LStackBottom;
  {Fill the call stack}
  while (AMaxDepth > 0)
    and (LCurrentFrame >= LStackBottom)
    and (LCurrentFrame < LStackTop) do
  begin
    {Ignore the requested number of levels}
    if ASkipFrames = 0 then
    begin
      AReturnAddresses^ := PCardinal(LCurrentFrame + 4)^;
      Inc(AReturnAddresses);
      Dec(AMaxDepth);
    end
    else
      Dec(ASkipFrames);
    {Get the next frame}
    LCurrentFrame := PCardinal(LCurrentFrame)^;
  end;
  {Clear the remaining dwords}
  while (AMaxDepth > 0) do
  begin
    AReturnAddresses^ := 0;
    Inc(AReturnAddresses);
    Dec(AMaxDepth);
  end;
end;

{-----------------------------Raw Stack Tracing-----------------------------}

const
  {Hexadecimal characters}
  HexTable: array[0..15] of char = '0123456789ABCDEF';

type
  {The state of a memory page. Used by the raw stack tracing mechanism to
   determine whether an address is a valid call site or not.}
  TMemoryPageAccess = (mpaUnknown, mpaNotExecutable, mpaExecutable);

var
  {There are a total of 1M x 4K pages in the 4GB address space}
  MemoryPageAccessMap: array[0..1024 * 1024 - 1] of TMemoryPageAccess;

{Updates the memory page}
procedure UpdateMemoryPageAccessMap(AAddress: Cardinal);
var
  LMemInfo: TMemoryBasicInformation;
  LAccess: TMemoryPageAccess;
  LStartPage, LPageCount: Cardinal;
begin
  {Query the page}
  if VirtualQuery(Pointer(AAddress), LMemInfo, SizeOf(LMemInfo)) <> 0 then
  begin
    {Get access type}
    if (LMemInfo.State = MEM_COMMIT)
      and (LMemInfo.Protect and (PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE
        or PAGE_EXECUTE_WRITECOPY or PAGE_EXECUTE) <> 0)
      and (LMemInfo.Protect and PAGE_GUARD = 0) then
    begin
      LAccess := mpaExecutable
    end
    else
      LAccess := mpaNotExecutable;
    {Update the map}
    LStartPage := Cardinal(LMemInfo.BaseAddress) div 4096;
    LPageCount := LMemInfo.RegionSize div 4096;
    if (LStartPage + LPageCount) < Cardinal(length(MemoryPageAccessMap)) then
      FillChar(MemoryPageAccessMap[LStartPage], LPageCount, ord(LAccess));
  end
  else
  begin
    {Invalid address}
    MemoryPageAccessMap[AAddress div 4096] := mpaNotExecutable;
  end;
end;

{Returns true if the return address is a valid call site. This function is only
 safe to call while exceptions are being handled.}
function IsValidCallSite(AReturnAddress: Cardinal): boolean;
var
  LCallAddress, LCode8Back, LCode4Back: Cardinal;
begin
  if (AReturnAddress and $ffff0000 <> 0) then
  begin
    {The call address is up to 8 bytes before the return address}
    LCallAddress := AReturnAddress - 8;
    {Update the page map}
    if MemoryPageAccessMap[LCallAddress div 4096] = mpaUnknown then
      UpdateMemoryPageAccessMap(LCallAddress);
    {Check the page access}
    if (MemoryPageAccessMap[LCallAddress div 4096] = mpaExecutable)
      and (MemoryPageAccessMap[(LCallAddress + 8) div 4096] = mpaExecutable) then
    begin
      {Read the previous 8 bytes}
      try
        LCode8Back := PCardinal(LCallAddress)^;
        LCode4Back := PCardinal(LCallAddress + 4)^;
        {Is it a valid "call" instruction?}
        Result :=
          {5-byte, CALL [-$1234567]}
          ((LCode8Back and $FF000000) = $E8000000)
          {2 byte, CALL EAX}
          or ((LCode4Back and $38FF0000) = $10FF0000)
          {3 byte, CALL [EBP+0x8]}
          or ((LCode4Back and $0038FF00) = $0010FF00)
          {4 byte, CALL ??}
          or ((LCode4Back and $000038FF) = $000010FF)
          {6-byte, CALL ??}
          or ((LCode8Back and $38FF0000) = $10FF0000)
          {7-byte, CALL [ESP-0x1234567]}
          or ((LCode8Back and $0038FF00) = $0010FF00);
      except
        {The access has changed}
        UpdateMemoryPageAccessMap(LCallAddress);
        {Not executable}
        Result := False;
      end;
    end
    else
      Result := False;
  end
  else
    Result := False;
end;

{Dumps the call stack trace to the given address. Fills the list with the
 addresses where the called addresses can be found. This is the "raw" stack
 tracing routine.}
procedure GetRawStackTrace(AReturnAddresses: PCardinal; AMaxDepth, ASkipFrames: Cardinal);
var
  LStackTop, LStackBottom, LCurrentFrame, LNextFrame, LReturnAddress,
    LStackAddress, LLastOSError: Cardinal;
begin
  {Are exceptions being handled? Can only do a raw stack trace if the possible
   access violations are going to be handled.}
  if Assigned(ExceptObjProc) then
  begin
    {Save the last Windows error code}
    LLastOSError := GetLastError;
    {Get the call stack top and current bottom}
    asm
      mov eax, FS:[4]
      sub eax, 3
      mov LStackTop, eax
      mov LStackBottom, ebp
    end;
    {Get the current frame start}
    LCurrentFrame := LStackBottom;
    {Fill the call stack}
    while (AMaxDepth > 0)
      and (LCurrentFrame < LStackTop) do
    begin
      {Get the next frame}
      LNextFrame := PCardinal(LCurrentFrame)^;
      {Is it a valid stack frame address?}
      if (LNextFrame < LStackTop)
        and (LNextFrame > LCurrentFrame) then
      begin
        {The pointer to the next stack frame appears valid: Get the return
         address of the current frame}
        LReturnAddress := PCardinal(LCurrentFrame + 4)^;
        {Does this appear to be a valid return address}
        if (LReturnAddress and $ffff0000) <> 0 then
        begin
          {Is the map for this return address incorrect? If may be unknown or marked
           as unexecutable because a library was previously not yet loaded, or
           perhaps this is not a valid stack frame.}
          if MemoryPageAccessMap[(LReturnAddress - 8) div 4096] <> mpaExecutable then
            UpdateMemoryPageAccessMap(LReturnAddress - 8);
          {Is this return address actually valid?}
          if IsValidCallSite(LReturnAddress) then
          begin
            {Ignore the requested number of levels}
            if ASkipFrames = 0 then
            begin
              AReturnAddresses^ := LReturnAddress;
              Inc(AReturnAddresses);
              Dec(AMaxDepth);