Delphi exception stack backup and restore class

uWin64ExceptionStack.pas

unit uWin64ExceptionStack;

interface

{$IFDEF WIN64}

const
  MAX_NESTED_EXCEPTIONS = 16;

type
  TSavedRaiseFrame = record
    NextRaiseOffset: Integer;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
  end;
  TSavedRaiseFrames = array[0..MAX_NESTED_EXCEPTIONS - 1] of TSavedRaiseFrame;

  TWin64ExceptionStack = record
    ExceptionObjectCount : Integer;
    SavedRaiseFrames : TSavedRaiseFrames;
    RaiseListPtrOffset : Integer;
    procedure LoadFromThreadExceptionStack;
    procedure SaveToThreadExceptionStack;
  end;

{$ENDIF}

implementation

{$IFDEF WIN64}

uses
  Windows;

type
  PPRaiseFrame = ^PRaiseFrame;
  PRaiseFrame = ^TRaiseFrame;
  TRaiseFrame = record
    NextRaise: PRaiseFrame;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
  end;
  PRaiseFrames = ^TRaiseFrames;
  TRaiseFrames = array[0..MAX_NESTED_EXCEPTIONS - 1] of TRaiseFrame;

const
  RAISEFRAMES_TLS_OFFSET = $0;
  EXCEPTIONOBJECTCOUNT_TLS_OFFSET = sizeof(TRaiseFrames);
  RAISELISTPTR_TLS_OFFSET = EXCEPTIONOBJECTCOUNT_TLS_OFFSET + sizeof(NativeUInt);
  NULL_RAISE_FRAME = -1;

// GetTLS function extracted and simplified from SysInit.pas unit
function GetTLS : Pointer;
const
  tlsArray = $58; { offset of tls array from FS: }
type
  PPPointerArray = ^PPointerArray;
var
  P: PPointerArray;
begin
  if ModuleIsLib then
    Result := TlsGetValue(TlsIndex)
  else
  begin
    //P := PPPointerArray(ReadGSQWord(tlsArray));
    P := PPPointerArray(PByte(@GSSegBase) + tlsArray)^;
    Result := P^[TlsIndex];
  end;
end;

procedure TWin64ExceptionStack.LoadFromThreadExceptionStack;
var
  ATLS : Pointer;
  RaiseFrame : PRaiseFrame;
  i : integer;
begin
  ATLS := GetTLS;
  ExceptionObjectCount := PInteger(NativeUInt(ATLS) + EXCEPTIONOBJECTCOUNT_TLS_OFFSET)^;
  for i := 0 to ExceptionObjectCount - 1 do
    begin
      RaiseFrame := @PRaiseFrames(NativeUInt(ATLS) + RAISEFRAMES_TLS_OFFSET)[i];
      SavedRaiseFrames[i].ExceptAddr := RaiseFrame.ExceptAddr;
      SavedRaiseFrames[i].ExceptObject := RaiseFrame.ExceptObject;
      if RaiseFrame.NextRaise <> nil then
        SavedRaiseFrames[i].NextRaiseOffset := NativeUInt(RaiseFrame.NextRaise) - NativeUInt(ATLS) - RAISEFRAMES_TLS_OFFSET
      else SavedRaiseFrames[i].NextRaiseOffset := NULL_RAISE_FRAME;
    end;
  if PPRaiseFrame(NativeUInt(ATLS) + RAISELISTPTR_TLS_OFFSET)^ <> nil then
    RaiseListPtrOffset := NativeUInt(PPRaiseFrame(NativeUInt(ATLS) + RAISELISTPTR_TLS_OFFSET)^) - NativeUInt(ATLS) - RAISEFRAMES_TLS_OFFSET
  else RaiseListPtrOffset := NULL_RAISE_FRAME;
end;

procedure TWin64ExceptionStack.SaveToThreadExceptionStack;
var
  ATLS : Pointer;
  RaiseFrame : PRaiseFrame;
  i : integer;
begin
  ATLS := GetTLS;
  PInteger(NativeUInt(ATLS) + EXCEPTIONOBJECTCOUNT_TLS_OFFSET)^ := ExceptionObjectCount;
  for i := 0 to ExceptionObjectCount - 1 do
    begin
      RaiseFrame := @PRaiseFrames(NativeUInt(ATLS) + RAISEFRAMES_TLS_OFFSET)[i];
      RaiseFrame.ExceptAddr := SavedRaiseFrames[i].ExceptAddr;
      RaiseFrame.ExceptObject := SavedRaiseFrames[i].ExceptObject;
      if SavedRaiseFrames[i].NextRaiseOffset <> NULL_RAISE_FRAME then
        RaiseFrame.NextRaise := PRaiseFrame(NativeUInt(PRaiseFrames(NativeUInt(ATLS) + RAISEFRAMES_TLS_OFFSET)) + SavedRaiseFrames[i].NextRaiseOffset)
      else RaiseFrame.NextRaise := nil;
    end;
  if RaiseListPtrOffset <> NULL_RAISE_FRAME then
    PPRaiseFrame(NativeUInt(ATLS) + RAISELISTPTR_TLS_OFFSET)^ := PRaiseFrame(NativeUInt(PRaiseFrames(NativeUInt(ATLS) + RAISEFRAMES_TLS_OFFSET)) + RaiseListPtrOffset)
  else PPRaiseFrame(NativeUInt(ATLS) + RAISELISTPTR_TLS_OFFSET)^ := nil;
end;

{$ENDIF}

end.