Custom exception handler for use with FPC

SystemExceptionHandling.pas

unit SystemExceptionHandling;

// Inspired by what is described at FPC's forums:
// http://bugs.freepascal.org/view.php?id=12974 [^]
//
// especially in comment 0040683 by Bernd Kreuss

{$mode objfpc}{$H+}
{$AsmMode intel}

{$IF not (defined(MSWINDOWS) and (defined(WIN32) OR defined(WIN64)))}
{$Error SystemExceptionHandling.pas applies to Windows NT 5.00+ only!}
{$EndIf}

interface

implementation

uses
  Windows, SysUtils, SysConst;

resourcestring
  SAccessViolationExtra = 'Access violation %s';
  SArrayOutOfBounds = 'Array element out of bounds';
  SInPageExtra  = 'Cannot access page %s';
  SFloatDenormal = 'Denormal Floating point operand';
  SFloatStackError = 'Floating point stack corrupted';
  SIllegalInstruction = 'Illegal instruction';
  SGenericExternalException = 'External Exception %8x';
  SAtAddress = ' at address ';


procedure UnwindFloatingPointException; assembler;
{$IFDEF WIN32}
asm
  fnclex
  emms
end;
{$ENDIF WIN32}
{$IFDEF WIN64}
var
  ControlWord: DWORD;
asm
  stmxcsr ControlWord
  and ControlWord, $FFE0
  ldmxcsr ControlWord
end;
{$ENDIF WIN64}

threadvar
  // Keep last Exception data.
  // Just last is enough because this is called immediately after returning from our
  // handler, no exception nesting could happen (except in corner cases where the OS is currently dying)
  // Also keep local variables for the handler in here, to make sure we don't allocate anything there.
  lastInfo: record
          ExceptionRecord : EXCEPTION_RECORD;
          ContextRecord : CONTEXT;
          ExcObject: EExternal;
          tmpStr: ShortString;
       end;

function ExceptionHandler(Info: PEXCEPTION_POINTERS): LongInt; stdcall;

  function GetModuleBaseByAddr(Addr: Pointer): Pointer;
  var
    Tmm: TMemoryBasicInformation;
  begin
    if VirtualQuery(addr, @Tmm, SizeOf(Tmm)) <> SizeOf(Tmm) then
      Result := nil
    else
      Result := Tmm.AllocationBase;
  end;

  procedure SetContinueAddress(Addr: Pointer);
  begin
    // clear the windows exception and point it to a place that
    // will raise a pascal exception instead.
    Info^.ContextRecord^.{$IFDEF WIN32}Eip{$ELSE}Rip{$ENDIF} := {%H-}PtrUInt(Addr);
  end;

  function FormatDetails(er: PEXCEPTION_RECORD): String;
  begin
    Result:= '';
    if (Er^.ExceptionCode = EXCEPTION_ACCESS_VIOLATION) or
       (Er^.ExceptionCode = EXCEPTION_IN_PAGE_ERROR) then begin
      case er^.ExceptionInformation[0] of
        0: Result:= 'reading from';
        1: Result:= 'writing to';
        8: Result:= 'causing DEP violation at';
      end;
      Result:= Result + ' $'+ hexStr(Pointer(er^.ExceptionInformation[1]));
    end;
    if Er^.ExceptionCode = EXCEPTION_IN_PAGE_ERROR then
      Result:= Result + ' NTSTATUS: $'+ hexStr(er^.ExceptionInformation[2], sizeof(er^.ExceptionInformation[2])*2);
  end;

label
  lblRaiseException;
var
  EO: EExternal;
begin
  // did it happen in the same module where this function resides?
  if GetModuleBaseByAddr(Info^.ExceptionRecord^.ExceptionAddress) = GetModuleBaseByAddr(@lblRaiseException) then
  begin
    UnwindFloatingPointException;
    // we only care about some exceptions
    case Info^.ExceptionRecord^.ExceptionCode of
      EXCEPTION_ACCESS_VIOLATION       : EO:= EAccessViolation.CreateResFmt(@SAccessViolationExtra, [FormatDetails(Info^.ExceptionRecord)]);
      EXCEPTION_ARRAY_BOUNDS_EXCEEDED  : EO:= EAccessViolation.CreateRes(@SArrayOutOfBounds);
      EXCEPTION_IN_PAGE_ERROR          : EO:= EAccessViolation.CreateResFmt(@SInPageExtra, [FormatDetails(Info^.ExceptionRecord)]);
      //EXCEPTION_SINGLE_STEP            : EO:= EExternalException.Create('It''s a trap'); // only for some debuggers
      //EXCEPTION_INVALID_HANDLE         : EO:= EAccessViolation.Create('Invalid Handle'); // not in MSDN, maybe not used?

      EXCEPTION_FLT_DENORMAL_OPERAND   : EO:= EInvalidOp.CreateRes(@SFloatDenormal);
      EXCEPTION_FLT_DIVIDE_BY_ZERO     : EO:= EZeroDivide.CreateRes(@SZeroDivide);
      EXCEPTION_FLT_INVALID_OPERATION  : EO:= EInvalidOp.CreateRes(@SInvalidOp);
      EXCEPTION_FLT_OVERFLOW           : EO:= EOverflow.CreateRes(@SOverflow);
      EXCEPTION_FLT_STACK_CHECK        : EO:= EInvalidOp.CreateRes(@SFloatStackError);
      EXCEPTION_FLT_UNDERFLOW          : EO:= EUnderflow.CreateRes(@SUnderflow);

      EXCEPTION_INT_DIVIDE_BY_ZERO     : EO:= EDivByZero.CreateRes(@SDivByZero);
      EXCEPTION_INT_OVERFLOW           : EO:= EOverflow.CreateRes(@SIntOverflow);

      EXCEPTION_STACK_OVERFLOW         : EO:= EStackOverflow.CreateRes(@SStackOverflow);
      EXCEPTION_ILLEGAL_INSTRUCTION    : EO:= EPrivilege.CreateRes(@SIllegalInstruction);
      EXCEPTION_PRIV_INSTRUCTION       : EO:= EPrivilege.CreateRes(@SPrivilege);
    else
//      ExcObject:= EExternalException.CreateResFmt(@SGenericExternalException,[ExceptionRecord.ExceptionCode]);
      Exit(EXCEPTION_CONTINUE_SEARCH);
    end;
    EO.Message:= EO.Message + SAtAddress + '$' + hexStr(Info^.ExceptionRecord^.ExceptionAddress);
    EO.ExceptionRecord^:= Info^.ExceptionRecord^;

    SetContinueAddress(@lblRaiseException);
    lastInfo.ContextRecord:= Info^.ContextRecord^;
    lastInfo.ExceptionRecord:= Info^.ExceptionRecord^;
    lastInfo.ExcObject:= EO;
    Exit(EXCEPTION_CONTINUE_EXECUTION);
  end;
  Exit(EXCEPTION_CONTINUE_SEARCH);

  // the following will never be reached during this function call,
  // instead it will be jumped to and executed *after* this function has
  // returned and windows restarts execution at the new position of eip/rip.
lblRaiseException:
  // throw exception at the address the original error occured on, with that stack (so stacktraces show correct data)
  With lastInfo do begin
    raise ExcObject
      at ExceptionRecord.ExceptionAddress, {%H-}Pointer(ContextRecord.{$IFDEF WIN32}Esp{$ELSE}Rsp{$ENDIF});
  end;
end;

function AddVectoredExceptionHandler(FirstHandler: DWORD; VectoredHandler: pointer): pointer; stdcall; external 'kernel32.dll' name 'AddVectoredExceptionHandler';
function RemoveVectoredExceptionHandler(VectoredHandlerHandle: pointer): ULONG; stdcall; external 'kernel32.dll' name 'RemoveVectoredExceptionHandler';

const
  CALL_FIRST = 1;

var
  ExceptionHandle: Pointer;

initialization
  ExceptionHandle := AddVectoredExceptionHandler(CALL_FIRST, @ExceptionHandler);

finalization
  RemoveVectoredExceptionHandler(ExceptionHandle);
end.