| Subject: | Having fun: coroutines in Delphi |
| Posted by: | Bart van der Werf (blueli…@xs4all.nl) |
| Date: | Mon, 19 Jun 2006 |
unit Coroutine;{
Author: Bart van der Werf
Date: 19 Feb 2006
Delphi: Delphi7 (not tested on other versions)
Summary: Quick and dirty coroutine for delphi.
Limitations:
Does not support continuation invoke chains that include the same instance
twice.
}
interfaceuses SysUtils, SyncObjs, Classes, Windows;type
TProcThread = class(TThread)
private
FProc: TThreadMethod;
protected
procedure Execute; override;
public
constructor Create(Proc: TThreadMethod);
end;{ Coroutine support class
Note: recursive calling the same instance of the coroutine not supported
Note: not threadsafe
Note: no thread affinity
}
TCoroutine = class
private
{We are abusing a thread here for several reasons.
a. To have windows create a stack with a default size, and guardpages and
all that
b. To have windows create a SEH base
c. To have delphi create a delphi exception handler base
The thread itself will do nothing, we steal its stack and let it block on a
mutex till the Coroutine is released. Setting up these parameters ourself is
possible but this is much simpler. Letting the thread block on a mutex
should cost no measurable amount of overhead.
}
FContext: TProcThread; FInCoroutine: Boolean;
FActive: Boolean;
FTerminating: Boolean;
FStackBase: Pointer;
FStackLimit: Pointer;
FSEH: Pointer;
FStack: Pointer;
FCurrentSEH: Pointer;
FCurrentStack: Pointer;
FCurrentInstruction: Pointer; FCallerSEH: Pointer;
FCallerStackBase: Pointer;
FCallerStackLimit: Pointer;
FCallerStack: Pointer;
FCallerInstruction: Pointer; FThreadLock: TEvent;
FThreadInitFlag: TEvent; FExceptionRaised: Exception; procedure
StealThread;
procedure Setup;
procedure Reset;
procedure BackToCaller;
procedure Enter;
protected
procedure Yield; // call me from the Execute method to return the thread
to
// the call of Invoke, unless IsTerminating is true then an
exception
// is raised
function IsTerminating: Boolean; // signal to Execute that it should not
call
// Yield and that it should cleanup its resources and return
// from the method
procedure Execute; virtual; abstract; // override me, either return
// from this method or call yield
public
constructor Create;
{
Destruction:
If the Coroutine is currently active then:
IsTerminating is set to true
Then Invoke is called and we want the Execute method to return
Yield throws an exception to enforce this.
}
destructor Destroy; override;
procedure Invoke; //call me to run/continue the Execute method
end;implementation{ TCoroutine }function GetCurrentAddress: Pointer;
asm
mov eax, [esp]
ret
end;procedure FpuInit;
const Default8087CW: Word = $1332 { $133F};
asm
FNINIT
FWAIT
FLDCW Default8087CW
end;procedure TCoroutine.Enter;
var
Me: TCoroutine;
begin
Me := Self;
asm
pushad
cld
call FpuInit
mov eax, Me
mov ecx, 0
mov edx, fs:[ecx]
mov [EAX].TCoroutine.FCallerSEH, edx
mov ecx, 4
mov edx, fs:[ecx]
mov [EAX].TCoroutine.FCallerStackBase, edx
mov ecx, 8
mov edx, fs:[ecx]
mov [EAX].TCoroutine.FCallerStackLimit, edx
mov edx, esp
mov [EAX].TCoroutine.FCallerStack, edx
mov edx, offset @A
mov [EAX].TCoroutine.FCallerInstruction, edx
mov ecx, 0
mov edx, [EAX].TCoroutine.FCurrentSEH
mov fs:[ecx], edx
mov ecx, 4
mov edx, [EAX].TCoroutine.FStackBase
mov fs:[ecx], edx
mov ecx, 8
mov edx, [EAX].TCoroutine.FStackLimit
mov fs:[ecx], edx
mov edx, [EAX].TCoroutine.FCurrentStack
mov esp, edx
mov edx, [EAX].TCoroutine.FCurrentInstruction
push edx
ret
@A:
popad
end;
end;procedure TCoroutine.Setup;
begin
try
Execute;
except
on e: Exception do begin
FExceptionRaised := e;
end;
end;
Reset;
BackToCaller;
end;constructor TCoroutine.Create;
begin
FInCoroutine := False;
FThreadLock := TEvent.Create(nil, True, False, '');
FThreadLock.ResetEvent;
FThreadInitFlag := TEvent.Create(nil, True, False, '');
FThreadInitFlag.ResetEvent;
FContext := TProcThread.Create(StealThread);
FThreadInitFlag.WaitFor(INFINITE);
FThreadInitFlag.Free;
Reset;
end;destructor TCoroutine.Destroy;
begin
Assert(not FInCoroutine);
if FActive then begin
FTerminating := True;
FInCoroutine := True;
Enter;
FInCoroutine := False;
Assert(not FActive);
end;
if Assigned(FThreadLock) then
FThreadLock.SetEvent;
FContext.Free;
FThreadLock.Free;
end;procedure TCoroutine.Invoke;
var
E: Exception;
begin
Assert(not FInCoroutine);
FActive := True;
FInCoroutine := True;
Enter;
FInCoroutine := False;
if Assigned(FExceptionRaised) then begin
E := FExceptionRaised;
FExceptionRaised := nil;
raise E;
end;
end;type
TBlip = record
case Blap: Boolean of
True: (A: TThreadMethod;);
False: (B, C: Pointer;);
end;procedure TCoroutine.Reset;
var
FProc: TBlip;
begin
FProc.A := Setup;
FCurrentInstruction := FProc.B;
FCurrentSEH := FSEH;
FCurrentStack := FStack;
FActive := False;
end;procedure TCoroutine.StealThread;
var
Me: TCoroutine;
begin
Me := Self;
asm
mov eax, Me
mov ecx, 0
mov edx, fs:[ecx]
mov [EAX].TCoroutine.FSEH, edx
mov ecx, 4
mov edx, fs:[ecx]
mov [EAX].TCoroutine.FStackBase, edx
mov ecx, 8
mov edx, fs:[ecx]
mov [EAX].TCoroutine.FStackLimit, edx
mov edx, esp
sub edx, 1024; // reserve some stack for the call to the mutex
mov [EAX].TCoroutine.FStack, edx
end; FThreadInitFlag.SetEvent;
FThreadLock.WaitFor(INFINITE);
end;procedure TCoroutine.BackToCaller;
var
Me: TCoroutine;
begin
Me := Self;
asm
mov eax, Me
cld
call FpuInit
mov ecx, 0
mov edx, [EAX].TCoroutine.FCallerSEH
mov fs:[ecx], edx
mov ecx, 4
mov edx, [EAX].TCoroutine.FCallerStackBase
mov fs:[ecx], edx
mov ecx, 8
mov edx, [EAX].TCoroutine.FCallerStackLimit
mov fs:[ecx], edx
mov edx, [EAX].TCoroutine.FCallerStack
mov esp, edx
mov edx, [EAX].TCoroutine.FCallerInstruction
push edx
ret
end;
end;procedure TCoroutine.Yield;
var
Me: TCoroutine;
begin
Assert(FInCoroutine);
if FTerminating then
raise Exception.Create('Cannot yield, terminating'); Me := Self;
asm
pushad
cld
call FpuInit
mov eax, Me
mov ecx, 0
mov edx, fs:[ecx]
mov [EAX].TCoroutine.FCurrentSEH, edx
mov edx, esp
mov [EAX].TCoroutine.FCurrentStack, edx
mov edx, offset @A
mov [EAX].TCoroutine.FCurrentInstruction, edx
mov ecx, 0
mov edx, [EAX].TCoroutine.FCallerSEH
mov fs:[ecx], edx
mov ecx, 4
mov edx, [EAX].TCoroutine.FCallerStackBase
mov fs:[ecx], edx
mov ecx, 8
mov edx, [EAX].TCoroutine.FCallerStackLimit
mov fs:[ecx], edx
mov edx, [EAX].TCoroutine.FCallerStack
mov esp, edx
mov edx, [EAX].TCoroutine.FCallerInstruction
push edx
ret
@A:
popad
end;
end;function TCoroutine.IsTerminating: Boolean;
begin
Result := FTerminating;
end;{ TProcThread }constructor TProcThread.Create(Proc: TThreadMethod);
begin
FProc := Proc;
inherited Create(False);
end;procedure TProcThread.Execute;
begin
FProc();
end;end.