Cool little Coroutines function

Posted by Bart van der Werf on February 19, 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.
}

interface

uses 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.