{ +-------------------------------------------------------------+ }
{ |                                                             | }
{ |   GM-Software                                               | }
{ |   ===========                                               | }
{ |                                                             | }
{ |   Project: All Projects                                     | }
{ |                                                             | }
{ |   Description: Call stack and exception hook.               | }
{ |                                                             | }
{ |                                                             | }
{ |   Copyright (C) - 2006 - Gerrit Moeller.                    | }
{ |                                                             | }
{ |   Source code distributed under MIT license.                | }
{ |                                                             | }
{ |   See: https://www.gm-software.de                           | }
{ |                                                             | }
{ +-------------------------------------------------------------+ }

{$INCLUDE GMCompilerSettings.inc}

unit GMCallStack;

interface

uses {$IFDEF JEDIAPI}jwaWinType,{$ELSE}Windows,{$ENDIF} GMIntf, GMCollections;

type

  TGMThreadCallStack = class;

  IGMThreadCallStack = interface(IUnknown)
    ['{5A35A934-2828-49A9-A06C-55CF186C11E5}']
    function Obj: TGMThreadCallStack;
  end;

  TGMThreadCallStack = class(TGMRefCountedObj, IGMGetHandle, IGMCriticalSection, IGMThreadCallStack)
   protected
    FThreadId: LongWord;
    FCriticalSection: IGMCriticalSection;
   public
    CallStack: TGMPtrIntArray;
    constructor Create(const AThreadId: LongWord; const ARefLifeTime: Boolean = True); reintroduce;
    function Obj: TGMThreadCallStack;
    function GetHandle: THandle; stdcall;
    property CriticalSection: IGMCriticalSection read FCriticalSection implements IGMCriticalSection;
  end;


//function GMGetEBP: DWORD; assembler;

//function GMThreadExceptCallStackList: IGMObjArrayCollection;

function GMGetThreadCallStackData(const ThreadId: LongWord; const ADetach: Boolean = False): IGMThreadCallStack;

procedure GMCaptureCurrentThreadCallStack(var ADestStack: TGMPtrIntArray);
procedure GMCaptureThreadCallStackSnapshot;

//procedure GMFetchCallStackAddresses(var ADestStack: TGMPtrIntArray; const AEIP, AEBP, AESP: PtrUInt; const APContext: Pointer);


procedure GMGetCurrentThreadCallStack(var ADestStack: TGMPtrIntArray);
procedure GMSetCurrentThreadCallStack(const ASourceStack: TGMPtrIntArray; const AAppend: Boolean = True);
procedure GMJoinCurrentThreadCallStack(const AOtherCallStack: IGMThreadCallStack);

//procedure GMInstallExceptFilter;
procedure GMInstallExceptionVectorHandler;


implementation

uses GMCommon {$IFNDEF JEDIAPI},GMDbgHlp{$ELSE},jwaWinBase, jwaWinNT, jwaImageHlp, jwaWinError{$ENDIF};

const

  cStackMax = 300; // <- dont remember more than 300 Stack entries

  // Exception flags from system.pas
  cContinuable        = 0;
  cNonContinuable     = 1;
  cUnwinding          = 2;
  cUnwindingForExit   = 4;
  cUnwindInProgress   = cUnwinding or cUnwindingForExit;

  // Exception codes from system.pas
  cDelphiException    = $0EEDFADE;
  cDelphiReRaise      = $0EEDFADF;
  cDelphiExcept       = $0EEDFAE0;
  cDelphiFinally      = $0EEDFAE1;
  cDelphiTerminate    = $0EEDFAE2;
  cDelphiUnhandled    = $0EEDFAE3;
  cNonDelphiException = $0EEDFAE4;
  cDelphiExitFinally  = $0EEDFAE5;
  cCppException       = $0EEFFACE; { used by BCB }

  // windows exception codes
  cOSExceptionCodeLow   = STATUS_GUARD_PAGE_VIOLATION; // <- Show callstack of debug exceptions too!   // EXCEPTION_ACCESS_VIOLATION; // $C0000005;
  cOSExceptionCodeHigh  = CONTROL_C_EXIT;              // $C000013A;

  // Exception filter return values
  EXCEPTION_CONTINUE_SEARCH    = 0;
  EXCEPTION_EXECUTE_HANDLER    = 1;
  EXCEPTION_CONTINUE_EXECUTION = -1;


type

  {$IFNDEF JEDIAPI}
  PExceptionPointers = ^TExceptionPointers;
  {$ENDIF}

  PStackData = ^TStackData;
  TStackData = record
    CallersEBP: DWORD;
    CallerAddr: DWORD;
  end;

  TExcpetionFilterFunc = function (ExceptInfo: PExceptionPointers): LongInt; stdcall;


var

  vThreadCallStackList: IGMIntfArrayCollection = nil;
  //vOrgExceptionFilterFunc: TFNTopLevelExceptionFilter = nil;
  //vOrgExceptionFilterFunc: TExcpetionFilterFunc = nil;
  vExceptVectorFuncHandle: THandle = 0;

  vfAddVectoredExceptionHandler: function (FirstHandler: ULONG; VectorHandlerFunc: TExcpetionFilterFunc): THandle; stdcall = nil;
  vfRemoveVectoredExceptionHandler: function (HVectorHandler: THandle): ULONG; stdcall = nil;


{ --------------------------- }
{ ---- External Routines ---- }
{ --------------------------- }

// Only available on WinXP or higher!

//function AddVectoredExceptionHandler(FirstHandler: ULONG; VectorHandlerFunc: TExcpetionFilterFunc): THandle; stdcall; external 'Kernel32.dll';
//function RemoveVectoredExceptionHandler(HVectorHandler: THandle): ULONG; stdcall; external 'Kernel32.dll';

function AddVectoredExceptionHandler(FirstHandler: ULONG; VectorHandlerFunc: TExcpetionFilterFunc): THandle;
var HKernel32: THandle;
begin
  if not Assigned(vfAddVectoredExceptionHandler) then
   begin
    HKernel32 := GetModuleHandle('Kernel32.dll');
    if HKernel32 <> 0 then vfAddVectoredExceptionHandler := GetProcAddress(HKernel32, 'AddVectoredExceptionHandler');
   end;

  if Assigned(vfAddVectoredExceptionHandler) then Result := vfAddVectoredExceptionHandler(FirstHandler, VectorHandlerFunc) else Result := 0;
end;

function RemoveVectoredExceptionHandler(HVectorHandler: THandle): ULONG;
var HKernel32: THandle;
begin
  if not Assigned(vfRemoveVectoredExceptionHandler) then
   begin
    HKernel32 := GetModuleHandle('Kernel32.dll');
    if HKernel32 <> 0 then vfRemoveVectoredExceptionHandler := GetProcAddress(HKernel32, 'RemoveVectoredExceptionHandler');
   end;

  if Assigned(vfRemoveVectoredExceptionHandler) then Result := vfRemoveVectoredExceptionHandler(HVectorHandler) else Result := ERROR_INVALID_FUNCTION;
end;


{ ----------------------- }
{ ---- List Routines ---- }
{ ----------------------- }

//function GMThreadExceptCallStackList: IGMObjArrayCollection;
//begin
//Result := vThreadCallStackList;
//end;

function GMGetThreadCallStackData(const ThreadId: LongWord; const ADetach: Boolean): IGMThreadCallStack;
var syncLock: IUnknown; searchID: IUnknown; stackObj: IUnknown;
begin
  syncLock := TGMCriticalSectionLock.Create(vThreadCallStackList, True);
  searchID := TGMHandleObj.Create(GetCurrentThreadId, True);

  if vThreadCallStackList.Find(searchID, stackObj) then
   begin
    GMCheckQueryInterface(stackObj, IGMThreadCallStack, Result);
    if ADetach then vThreadCallStackList.RemoveByKey(stackObj);
   end
  else
   if not ADetach then // Result := nil else
    begin
     Result := TGMThreadCallStack.Create(GetCurrentThreadId);
     vThreadCallStackList.Add(Result);
    end;
end;


{ ------------------------- }
{ ---- Helper Routines ---- }
{ ------------------------- }

function ReadableMemSize(const StartAddr: Pointer; const Size: DWORD): DWORD;
const ReadAttributes = [PAGE_READONLY, PAGE_READWRITE, PAGE_WRITECOPY, PAGE_EXECUTE, PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE, PAGE_EXECUTE_WRITECOPY];
var memInfo: TMemoryBasicInformation; nextSize: DWORD;
begin
  Result := 0;
  if StartAddr = nil then Exit;
  if (VirtualQuery(StartAddr, memInfo, SizeOf(memInfo)) = SizeOf(memInfo)) and
     (memInfo.State = MEM_COMMIT) and (memInfo.Protect in ReadAttributes) then
   begin
    Result := (memInfo.RegionSize - (DWORD(StartAddr) - DWORD(memInfo.BaseAddress)));
    if (Result < Size) then
     begin
      repeat
       nextSize := ReadableMemSize(Pointer(DWORD(memInfo.BaseAddress) + memInfo.RegionSize), (Size - Result));
       if (nextSize > 0) then Inc(Result, nextSize) else Result := 0;
      until (Result >= Size) or (nextSize = 0);
     end;
   end;
end;

function IsReadableMemory(const StartAddr: Pointer; const Size: DWORD): Boolean;
begin
  Result := ReadableMemSize(StartAddr, Size) >= Size;                             
end;


{ ---------------------------- }
{ ---- TGMThreadCallStack ---- }
{ ---------------------------- }

constructor TGMThreadCallStack.Create(const AThreadId: LongWord; const ARefLifeTime: Boolean = True);
begin
  inherited Create(ARefLifeTime);
  FCriticalSection := TGMCriticalSection.Create(True);
  FThreadId := AThreadId;
end;

function TGMThreadCallStack.Obj: TGMThreadCallStack;
begin
  Result := Self;
end;

function TGMThreadCallStack.GetHandle: THandle;
begin
  Result := FThreadId;
end;


{ ----------------------------- }
{ ---- Callstack snapshots ---- }
{ ----------------------------- }

function GMGetEBP: PtrUInt;
asm
  {$IFDEF CPU32}
  MOV     EAX, EBP
  {$ENDIF CPU32}
  {$IFDEF CPU64}
  MOV     RAX, RBP
  {$ENDIF CPU64}
end;

function GMGetESP: PtrUInt;
asm
  {$IFDEF CPU32}
  MOV     EAX, ESP
  {$ENDIF CPU32}
  {$IFDEF CPU64}
  MOV     RAX, RSP
  {$ENDIF CPU64}
end;

//function GetExceptionPointer: Pointer;
//asm
//      {$IFDEF CPU32}
//      XOR     EAX, EAX
//      MOV     EAX, FS:[EAX]
//      {$ENDIF CPU32}
//      {$IFDEF CPU64}
//      XOR     RAX, RAX
//      MOV     RAX, FS:[RAX]
//      {$ENDIF CPU64}
//end;

// Reference: Matt Pietrek, MSJ, Under the hood, on TIBs:
// http://www.microsoft.com/MSJ/archive/S2CE.HTM

//function GetStackTop: PtrUInt;
//asm
//      {$IFDEF CPU32}
//      MOV     EAX, FS:[0].NT_TIB32.StackBase
//      {$ENDIF CPU32}
//      {$IFDEF CPU64}
//      {$IFDEF DELPHI64_TEMPORARY}
//      //TODO: check if the FS version doesn't work in general in 64-bit mode
//      MOV     RAX, GS:[ABS 8]
//      {$ELSE ~DELPHI64_TEMPORARY}
//      MOV     RAX, FS:[0].NT_TIB64.StackBase
//      {$ENDIF ~DELPHI64_TEMPORARY}
//      {$ENDIF CPU64}
//end;

//function GetStackLimit: PtrUInt;
//asm
//      {$IFDEF CPU32}
//      MOV     EAX, FS:[0].NT_TIB32.StackLimit
//      {$ENDIF CPU32}
//      {$IFDEF CPU64}
//      MOV     RAX, FS:[0].NT_TIB64.StackLimit
//      {$ENDIF CPU64}
//end;


{procedure GMFetchCallStackAddresses(var ADestStack: TGMPtrIntArray; AEIP, AEBP, AESP: PtrUInt; const APContext: Pointer);
//type
//PStackFrame = ^TStackFrame;
//TStackFrame = record
//  CallerFrame: PtrUInt;
//  CallerAddr: PtrUInt;
//end;

var TopOfStack, BaseOfStack: PtrUInt; StackFrame: PStackData; // i: Integer;
begin
//i:=0;

  SetLength(ADestStack, 0);

  BaseOfStack := AEBP - 1;
  TopOfStack := GetStackLimit;

  repeat
   SetLength(ADestStack, Length(ADestStack)+1);
   ADestStack[High(ADestStack)] := PStackData(AEBP).CallerAddr;
   AEBP := PStackData(AEBP).CallersEBP;

// Inc(i);
// while (BaseOfStack <= PtrUInt(StackFrame)) and (PtrUInt(StackFrame) <= TopOfStack) do
  until AEBP = 0; // (BaseOfStack > AEBP) or (AEBP > TopOfStack); // i = 4; // AEBP = 0;
end;}

procedure GMFetchCallStackAddresses(var ADestStack: TGMPtrIntArray; const AEIP, AEBP, AESP: PtrUInt; const APContext: Pointer);
var StackFrame: TStackFrame; count: Integer;
begin
//if Length(ADestStack) > 0 then Exit;
  SetLength(ADestStack, 0);

  FillByte(StackFrame, SizeOf(StackFrame), 0);

  StackFrame.AddrPC.Offset    := AEIP;
  StackFrame.AddrPC.Mode      := Ord(AddrModeFlat);
  StackFrame.AddrFrame.Offset := AEBP;
  StackFrame.AddrFrame.Mode   := Ord(AddrModeFlat);
  StackFrame.AddrStack.Offset := AESP;
  StackFrame.AddrStack.Mode   := Ord(AddrModeFlat);

  for count := 1 to cStackMax do // <- Loop will be left by break statements
   begin
//  if StackFrame.AddrFrame.Offset = 0 then Break;
    if not StackWalk(IMAGE_FILE_MACHINE_I386, GetCurrentProcess, GetCurrentThread,
                     @StackFrame, APContext, nil, SymFunctionTableAccess, SymGetModuleBase, nil) then Break;

    SetLength(ADestStack, Length(ADestStack)+1);
    ADestStack[High(ADestStack)] := LongInt(StackFrame.AddrPC.Offset);
   end;
end;

procedure GMFetchThreadCallStackAddresses(var ADestStack: TGMPtrIntArray; const AHThread: THandle);
var cntxt: TContext;
begin
  FillByte(cntxt, SizeOf(cntxt), 0);
  cntxt.ContextFlags := CONTEXT_FULL;
  if not GetThreadContext(AHThread, cntxt) then Exit;
  GMFetchCallStackAddresses(ADestStack, cntxt.EIP, cntxt.EBP, cntxt.Esp, @cntxt);
end;


procedure GMCaptureThreadCallStack(const AEIP, AEBP, AESP: PtrUInt; const APContext: Pointer);
var syncLock: IUnknown; threadEntry: IGMThreadCallStack;
begin
  threadEntry := GMGetThreadCallStackData(GetCurrentThreadId);
  if threadEntry = nil then Exit;
  syncLock := TGMCriticalSectionLock.Create(threadEntry);
  GMFetchCallStackAddresses(threadEntry.Obj.CallStack, AEIP, AEBP, AESP, APContext);
end;

procedure GMCaptureCurrentThreadCallStack(var ADestStack: TGMPtrIntArray);
//var EBP: PtrUInt;
begin
//EBP := GMGetEBP;
//GMFetchCallStackAddresses(ADestStack, PStackData(EBP).CallerAdr, PStackData(EBP).CallersEBP, 0, nil);
  GMFetchThreadCallStackAddresses(ADestStack, GetCurrentThread);
end;

procedure GMCaptureThreadCallStackSnapshot;
var syncLock: IUnknown; threadEntry: IGMThreadCallStack;
begin
  threadEntry := GMGetThreadCallStackData(GetCurrentThreadId);
  if threadEntry = nil then Exit;
  syncLock := TGMCriticalSectionLock.Create(threadEntry);
  GMFetchThreadCallStackAddresses(threadEntry.Obj.CallStack, GetCurrentThread);
end;


{ ------------------------------ }
{ ---- Managing Stack Lists ---- }
{ ------------------------------ }

procedure GMGetCurrentThreadCallStack(var ADestStack: TGMPtrIntArray);
var SyncLock: IUnknown; threadEntry: IGMThreadCallStack; i: Integer;
begin
  threadEntry := GMGetThreadCallStackData(GetCurrentThreadId);
  if threadEntry = nil then Exit;
  SyncLock := TGMCriticalSectionLock.Create(threadEntry);
  SetLength(ADestStack, Length(threadEntry.Obj.CallStack));
  for i:=Low(ADestStack) to High(ADestStack) do ADestStack[i] := threadEntry.Obj.CallStack[i];
  //vfGMMessageBox(GMFormat('Get Callstack thread %u copy: %d', [GetCurrentThreadId, Length(ADestStack)]));
end;

procedure GMSetCurrentThreadCallStack(const ASourceStack: TGMPtrIntArray; const AAppend: Boolean = True);
var SyncLock: IUnknown; threadEntry: IGMThreadCallStack; tmpStack: TGMPtrIntArray; // i: LongInt; Hi: LongInt;
begin
  threadEntry := GMGetThreadCallStackData(GetCurrentThreadId);
  if threadEntry = nil then Exit;
  SyncLock := TGMCriticalSectionLock.Create(threadEntry);

  if not AAppend then SetLength(threadEntry.Obj.CallStack, 0);

  GMAddIntegersToArray(tmpStack, ASourceStack);
  GMAddIntegersToArray(tmpStack, threadEntry.Obj.CallStack);

  SetLength(threadEntry.Obj.CallStack, 0);
  GMAddIntegersToArray(threadEntry.Obj.CallStack, tmpStack);
end;

procedure GMJoinCurrentThreadCallStack(const AOtherCallStack: IGMThreadCallStack);
begin
  GMCaptureThreadCallStackSnapshot;
  if AOtherCallStack <> nil then GMSetCurrentThreadCallStack(AOtherCallStack.Obj.CallStack, True);
end;


{ ------------------------------------- }
{ ---- Unhandeled exception filter ---- }
{ ------------------------------------- }

{function GMUnhandledExceptionFilter(ExceptInfo: PExceptionPointers): LongInt; stdcall;
var pCntxt: PContext;
//var Synclock: IUnknown;
begin
  //if Assigned(vOrgExceptionFilterFunc) then
   //Result := vOrgExceptionFilterFunc(ExceptInfo)
  //else

  //Synclock := TGMCriticalSectionLock.Create(GMThreadExceptCallStackList);

   Result := EXCEPTION_EXECUTE_HANDLER; // <- go on with standard handling in system unit
  //Result := EXCEPTION_CONTINUE_EXECUTION;

  //
  // Only take a snapshot of callstack addresses here. This can be done very fast.
  // Resolving the names of the addresses is done later in the exception handler using the adresses from the snapshot.
  // Exceptions inside this routine are not a good idea, a try except block isn't either.
  //

  //ExceptInfo.ExceptionRecord.ExceptionFlags and not cNonContinuable;
  //ExceptInfo.ExceptionRecord.ExceptionFlags := 0;

  //
  // Make sure parameters are ok ..
  //
  if not IsReadableMemory(ExceptInfo, SizeOf(ExceptInfo^)) or
     not IsReadableMemory(ExceptInfo.ExceptionRecord, SizeOf(ExceptInfo.ExceptionRecord^)) then Exit;

  // Dont overwrite old callstack when unwinding!
  if (ExceptInfo.ExceptionRecord.ExceptionFlags and cUnwindInProgress <> 0) then Exit;

  if IsReadableMemory(ExceptInfo.ContextRecord, SizeOf(ExceptInfo.ContextRecord^)) then
   pCntxt := ExceptInfo.ContextRecord else pCntxt := nil;

  //vfGMMessageBox(TObject(ExceptInfo.ExceptionRecord.ExceptionInformation[1]).ClassName);
  if (ExceptInfo.ExceptionRecord.ExceptionCode = cDelphiException) and
     (ExceptInfo.ExceptionRecord.NumberParameters >= 7) then
   begin
    if GMAskBoolean(TObject(ExceptInfo.ExceptionRecord.ExceptionInformation[1]), Ord(bevCaptureCallStack), True) then
     //begin
       GMCaptureThreadCallStack(ExceptInfo.ExceptionRecord.ExceptionInformation[0],
                                ExceptInfo.ExceptionRecord.ExceptionInformation[5],
                                ExceptInfo.ExceptionRecord.ExceptionInformation[6], pCntxt);
       //vfGMMessageBox('GMCaptureThreadCallStack');
     //end;
     //GMCaptureThreadCallStack(DWORD(ExceptInfo.ExceptionRecord.ExceptionAddress), GMGetEBP, 0, pCntxt);
   end else
  if (ExceptInfo.ExceptionRecord.ExceptionCode >= cOSExceptionCodeLow) and
     (ExceptInfo.ExceptionRecord.ExceptionCode < cOSExceptionCodeHigh) then
   if (pCntxt <> nil) and (pCntxt.ContextFlags and CONTEXT_CONTROL <> 0) then // (pCntxt.Ebp <> 0)
    GMCaptureThreadCallStack(pCntxt.Eip, pCntxt.Ebp, pCntxt.Esp, pCntxt)
   else
    GMCaptureThreadCallStack(DWORD(ExceptInfo.ExceptionRecord.ExceptionAddress), GMGetEBP, 0, pCntxt);

  //vfGMMessageBox('GMUnhandledExceptionFilter');
  if IsLibrary and Assigned(vOrgExceptionFilterFunc) then Result := vOrgExceptionFilterFunc(ExceptInfo);
end;}

function GMExceptionVectorHandler(ExceptInfo: PExceptionPointers): LongInt; stdcall;
var pCntxt: PContext;
begin
  Result := EXCEPTION_CONTINUE_SEARCH;

  if (ExceptInfo = nil) or (ExceptInfo.ContextRecord = nil) then Exit;

  pCntxt := ExceptInfo.ContextRecord;

  if (ExceptInfo.ExceptionRecord.ExceptionCode <> cDelphiException) or
      ((ExceptInfo.ExceptionRecord.NumberParameters >= 2) and
       GMAskBoolean(TObject(ExceptInfo.ExceptionRecord.ExceptionInformation[1]), Ord(bevCaptureCallStack), True)) then
   GMCaptureThreadCallStack(pCntxt.Eip, pCntxt.Ebp, pCntxt.Esp, pCntxt);


{
  if not IsReadableMemory(ExceptInfo, SizeOf(ExceptInfo^)) or
     not IsReadableMemory(ExceptInfo.ExceptionRecord, SizeOf(ExceptInfo.ExceptionRecord^)) then Exit;

  // Dont overwrite old callstack when unwinding!
  if (ExceptInfo.ExceptionRecord.ExceptionFlags and cUnwindInProgress <> 0) then Exit;

  if IsReadableMemory(ExceptInfo.ContextRecord, SizeOf(ExceptInfo.ContextRecord^)) then
     pCntxt := ExceptInfo.ContextRecord else pCntxt := nil;


  //vfGMMessageBox(TObject(ExceptInfo.ExceptionRecord.ExceptionInformation[1]).ClassName);
  if (ExceptInfo.ExceptionRecord.ExceptionCode = cDelphiException) and
     (ExceptInfo.ExceptionRecord.NumberParameters >= 7) then
   begin
    if GMAskBoolean(TObject(ExceptInfo.ExceptionRecord.ExceptionInformation[1]), Ord(bevCaptureCallStack), True) then
       GMCaptureThreadCallStack(ExceptInfo.ExceptionRecord.ExceptionInformation[0],   // <- EIP
                                ExceptInfo.ExceptionRecord.ExceptionInformation[5],   // <- EBP
                                ExceptInfo.ExceptionRecord.ExceptionInformation[6],   // <- ESP
                                pCntxt);
   end else
  if (ExceptInfo.ExceptionRecord.ExceptionCode >= cOSExceptionCodeLow) and
     (ExceptInfo.ExceptionRecord.ExceptionCode < cOSExceptionCodeHigh) then
   if (pCntxt <> nil) and (pCntxt.ContextFlags and CONTEXT_CONTROL <> 0) then // (pCntxt.Ebp <> 0)
    GMCaptureThreadCallStack(pCntxt.Eip, pCntxt.Ebp, pCntxt.Esp, pCntxt)
   else
    GMCaptureThreadCallStack(PtrUInt(ExceptInfo.ExceptionRecord.ExceptionAddress), GMGetEBP, GMGetESP, pCntxt);
    }
end;


{ ------------------------------------------------- }
{ ---- Install the unhandeled exception filter ---- }
{ ------------------------------------------------- }

{procedure GMInstallExceptFilter;
var OldExcpetionFilterFunc: TExcpetionFilterFunc;
begin
  //
  // NOTE: SetUnhandledExceptionFilter should be called only once per application (process).
  //       Calling it again inside a DLL will overwrite the setting of any previos call.
  //
  if Assigned(vOrgExceptionFilterFunc) then Exit;

  OldExcpetionFilterFunc := SetUnhandledExceptionFilter(@GMUnhandledExceptionFilter);
  if not Assigned(vOrgExceptionFilterFunc) then vOrgExceptionFilterFunc := OldExcpetionFilterFunc;

  //
  // Tell delphi system unit to call the windows UnhandledExceptionFilter function for all exceptions.
  // NOTE: UnhandledExceptionFilter will not be called by delphi system unit if the application
  //       is run from inside the IDE!
  //
  JITEnable := 2;
  //DebugHook := 1;
end;}

procedure GMInstallExceptionVectorHandler;
begin
  vExceptVectorFuncHandle := AddVectoredExceptionHandler(1, GMExceptionVectorHandler);
end;

initialization

  vThreadCallStackList := TGMIntfArrayCollection.Create(False, True, GMCompareByHandle, True);

finalization

  //if Assigned(vOrgExceptionFilterFunc) then SetUnhandledExceptionFilter(@vOrgExceptionFilterFunc);
  if vExceptVectorFuncHandle <> 0 then RemoveVectoredExceptionHandler
  (vExceptVectorFuncHandle);

end.