How to properly support Windows Fibers in Delphi without breaking exception handling

If you are giving a shot to Windows Fibers under Delphi, you probably faced the issue of how to properly handle Delphi's structured exception handling AND switching between fibers transparently.

Assuming you already know what Fibers are, how to use them and when to use them, I will cut to the chase. If you don't know, or don't know enough, I recommend you the following reads to get started:


https://msdn.microsoft.com/en-us/library/windows/desktop/ms682661%28v=vs.85%29.aspx
http://blogs.technet.com/b/markrussinovich/archive/2009/07/08/3261309.aspx


When exceptions happen in a Delphi program, the compiler generates code to store nested exceptions on an exception stack. This stack is stored in a TLS allocated by the program upon startup.

When using Delphi compiled in 32 bits, the issue of persisting and restoring this stack is trivial. Up to the latest versions of Delphi the RTL exposes a couple of functions in the system unit that allow you to do the trick in two lines of code (literally).
The challenge with Delphi programs compiled in 64 bits is that Delphi doesn't expose anymore an API to persist and restore the Exception stack. It's not hard overcome this, but it requires a bit of reverse engineering and watching what the compiler does by enabling the CPU debugger.
I'll spare you from the pain, and below you will find a unit that does the trick:

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.

view raw uWin64ExceptionStack.pas hosted with ❤ by GitHub

Here's the full code that I use for switching between fibers:

	{
	The idea of DelphiSwitchToFiber() function is to backup on a local variable in stack the
	state of the Exception stack right before calling SwitchToFiber() and then restoring its state
	right atfer returns from call to SwitchToFiber().
	If SwitchToFiber() is used directly from within an Except or Finally block, and if there's an exception
	raised after switching to another fiber, upon coming back the results will be unpredictable because
	the exception stack will be completely unwinded and all raise exceptions destroyed.
	In order to prevent this issue we must backup the Exception stack before the call to SwitchToFiber()
	and restore it right after the call.
	Details of 64 bits exception stack persistance in unit uWin64ExceptionStack.pas
	It's important to notice that when getting back from SwitchToFiber() we can't even assume that
	the call was done within the context of Thread where the call was initiated. That's why on
	64 bits implementation of this function, we need to obtain TLS pointer to ThreadVar storage
	area right after the call to SwitchToThread().
	Notice also that 32 bits implementation is dramatically simpler. On 32 bits versions of Delphi
	when compiling under Windows, the system unit simply kept a linked list of stacked exceptions
	so backing up our Exception stack was as simple as storing a pointer to this list on a local
	variable and then restoring this pointer with the provided system API calls.
	Win64 is an entirely different story, system unit hides completely all of the exception management
	details, so we have to essently do a hack by accessing the area of the TLS where threadvars are stored
	to persist the three key elements that participate on Exception management stack. These are:
	RaiseFrames : TRaiseFrames;
	ExceptionObjectCount : Integer;
	RaiseListPtr : PRaiseFrame;
	Notice that when calculating offset into TLS area to backup and restore RaiseListPtr we consider
	ExceptionObjectCount size as NativeUInt (64 bits) rather than a regular integer (32 bits). This is
	because Delphi compiler aligns to 64 bits the elements stored in the ThreadVar storage area.
	}
	{$IFDEF WIN64}
	// Details to implement this function pulled from System.pas unit
	procedure DelphiSwitchToFiber(AFiber : Pointer);
	var
	Win64ExceptionStack : TWin64ExceptionStack;
	begin
	Win64ExceptionStack.LoadFromThreadExceptionStack;
	SwitchToFiber(AFiber);
	Win64ExceptionStack.SaveToThreadExceptionStack;
	end;
	{$ELSE}
	{$IFDEF VER130}
	// SetRaiseList is totally broken in Delphi 5. Needs to be replaced by this function
	function SetRaiseList(NewPtr: Pointer): Pointer;
	asm
	PUSH EAX
	CALL SysInit.@GetTLS
	MOV EDX, [EAX].$0 // Offset of threadvar RaiseListPtr in TLS memory block
	POP ECX
	MOV [EAX], ECX
	MOV EAX, EDX
	end;
	{$ENDIF}
	procedure DelphiSwitchToFiber(AFiber : Pointer);
	var
	SavedRaiseList : Pointer;
	begin
	SavedRaiseList := RaiseList;
	SwitchToFiber(AFiber);
	SetRaiseList(SavedRaiseList);
	end;
	{$ENDIF}

view raw DelphiSwitchToFiber.pas hosted with ❤ by GitHub

Before I forget!!!

Here's a sample test that performs a SwitchToFiber() inside an exception handler block. In fact, it's a triple nested exception handler block to test the mechanism of persisting and restored more than just one element of the exception stack.

	procedure TestTJobQueue.JobMethodRaiseAndSwitchToFiber(const AJob: IJob; const AParams: array of Variant);
	begin
	try
	Check(True);
	raise ETestJobQueue.Create('Hello');
	except
	on E : Exception do
	begin
	try
	raise ETestJobQueue.Create('Hello Nested');
	except
	on E : Exception do
	begin
	try
	raise ETestJobQueue.Create('Hello More Nested');
	except
	on E : Exception do
	begin
	AJob.Sleep(400); // <-- This call will perform a SwitchToFiber() to emulate a blocking wait
	CheckEqualsString('Hello More Nested', E.Message);
	end;
	end;
	CheckEqualsString('Hello Nested', E.Message);
	end;
	end;
	CheckEqualsString('Hello', E.Message);
	end;
	end;
	Check(True);
	end;

view raw BreakSwitchToFiber.pas hosted with ❤ by GitHub

I hope this helps you on your adventure trying to implement fibers using Delphi.

A note on testing the approach:

Code was verified to work properly on:
Delphi 2007
DelphiXE4 running in WIN32 and WIN64

Special note about Delphi 5. SetRaiseList was totally broken. When used, it will send the application into a tailspin of access violations. See the fixed code, mainly borrowed from Delphi 2007 implementation.