Yield в CodeGear RAD Studio (Delphi 2007 for Win32)

Привет!

Понадобилось внезапно портировать программу с C# на Delphi. В программе на C# активно использовался yield ^[1]. Погуглив просторы интернета в надежде не заниматься изобретением велосипеда, удалось найти реализацию yield для Win32 на базе фиберов ^[2] для Embarcadero Delphi 2009 ^[3] и выше, но вот беда — требовалось сделать порт под CodeGear RAD Studio для версии Delphi 2007, в которой ещё отсутствовали обобщённые типы ^[4] и анонимные методы ^[5]. Менять версию Delphi на более позднюю было нельзя и поэтому пришлось переписать найденную реализацию yield для более ранней версии.

Взяв исходник юнита ^[6] с реализаций yield для Delphi 2009 и выше за авторством Andriy Gerasika ^[7] я его переделал для Delphi 2007.

Требовалось сделать поддержку yield только для Win32 и только для Delphi 2007, поэтому много менять не пришлось, только убрать generics, которых ещё не было в требуемой версии Delphi и сделать эмуляцию замыканий ^[8].

В оригинальном коде обобщённые типы (generics) ^[4] были в стандартном виде:

type
  TYield<T> = procedure (Value: T) of object;
  TYieldProc<T> = reference to procedure(Yield: TYield<T>);

  TYieldEnumerator<T> = class
  {...}
  end;

  TYieldEnumerable<T> = record
  {...}
  end;

и посредством вывода типа через generic

TYieldEnumerator<T>

можно было задавать уже конкретные типы, как то

TYieldEnumerator<Integer>

TYieldEnumerator<Char>

и т.д., компилятор сам следил за корректным типом возвращаемого/возвращаемых значений, внутренних переменных и свойств. В Delphi 2007 требовалось как-то обойтись без generics, по возможности сохранив всю функциональность. Поэтому для хранения возвращаемого yield значения я решил использовать запись типа TVarRec из стандартного юнита System:

TVarRec = record
  case Byte of
    vtAnsiString: (VAnsiString: Pointer;);
    vtBoolean: (VBoolean: Boolean;);
    vtChar: (VChar: Char;);
    vtClass: (VClass: TClass;);
    vtCurrency: (VCurrency: PCurrency;);
    vtExtended: (VExtended: PExtended;);
    vtInt64: (VInt64: PInt64;);
    vtInteger: (VInteger: Integer;
                VType: Byte;);
    vtInterface: (VInterface: Pointer;);
    vtObject: (VObject: TObject;);
    vtPChar: (VPChar: PChar;);
    vtPointer: (VPointer: Pointer;);
    vtPWideChar: (VPWideChar: PWideChar;);
    vtString: (VString: PShortString;);
    vtVariant: (VVariant: PVariant;);
    vtWideChar: (VWideChar: WideChar;);
    vtWideString: (VWideString: Pointer;);
end;

которая в принципе может содержать любое значение. Для не POD типов (запией и классов) можно хранить указатель на них, TVarRec.VPointer, все остальные прекрасно хранятся и в записи TVarRec.

Так же пришлось изменить типы для

TYield<T> = procedure (Value: T) of object;
TYieldProc<T> = reference to procedure(Yield: TYield<T>);

убрав из обоих generic, а из второго reference to procedure за неимением анонимных методов в Delphi 2007:

TYield = procedure(aValue: TVarRec) of object;
TYieldProc = procedure(aYield: TYield; aYieldData: Pointer);

Переменная aYieldData типа Pointer в дальнейшем используется для эмуляции замыканий, которые тоже отсутствуют в Delphi 2007 (ведь надо же где-то хранить аргументы функции, из которой будет вызываться наш yield).

И изменил оригинальные классы с generics

TYieldEnumerator<T> = class
  private
    fYieldProc: TYieldProc<T>;
    fEOF: Boolean;
    fValue: T;
    property YieldProc: TYieldProc<T> read fYieldProc;
  private
    ThreadFiber: Cardinal;
    CallerFiber: Pointer;
    CalleeFiber: Pointer;
    FiberException: Pointer;
    procedure Execute; stdcall;
    procedure Yield(aValue: T);
  public
    constructor Create(const aYieldProc: TYieldProc<T>);
    destructor Destroy; override;
  public // enumerator
    function MoveNext: Boolean;
    property Current: T read fValue;
  end;

  TYieldEnumerable<T> = record
  private
    fYieldProc: TYieldProc<T>;
    property YieldProc: TYieldProc<T> read fYieldProc;
  public
    constructor Create(const aYieldProc: TYieldProc<T>);
    function GetEnumerator: TYieldEnumerator<T>;
  end;

сделав свои «generic» классы с учётом всех именений, наследованием от которых можно сэмулировать любые типы переменных:

TYieldEnumerator = class
  public
    constructor Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
    destructor Destroy; override;
  public
    function MoveNext: Boolean;
  private
    procedure Execute; stdcall;
    procedure Yield(aValue: TVarRec);
  protected
    m_yieldProc: TYieldProc;
    m_yieldData: Pointer;
    m_value: TVarRec;
  private
    m_threadFiber: Pointer;
    m_callerFiber: Pointer;
    m_calleeFiber: Pointer;
    m_fiberException: Pointer;
    m_done: Boolean;
  public
    property Current: TVarRec read m_value;
  end;

  TYieldEnumerable = record
  public
    constructor Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
    function GetEnumerator: TYieldEnumerator; inline;
  private
    m_yieldProc: TYieldProc;
    m_yieldData: Pointer;
  end;

Видно что они не так уж сильно отличаются от оригинальных, разве что прибавилось немного переменных и в конструкторах добавился параметр типа Pointer на данные для замыканий.

И в конструкторе TYieldEnumerator.Create слегка изменил получение «волокна» из текущего потока при самом первом вызове, добавил проверку на код ошибки $1e00 (актуально для Windows 7 и выше) и добавил бросание исключения при ошибке вызова ConvertThreadToFiber(nil):

 m_callerFiber := GetCurrentFiber;
  if (m_callerFiber = nil) or (Cardinal(m_callerFiber) = $1e00) then begin
    m_threadFiber := Pointer(ConvertThreadToFiber(nil));
    if m_threadFiber = nil then
      raise EAbort.CreateFmt('TYieldEnumerator.Create error: %d', [GetLastError]);
    m_callerFiber := GetCurrentFiber;
  end;

Вот в принципе и все модификации.

unit Yield_Win32;

interface

type
  TYield = procedure(aValue: TVarRec) of object;
  TYieldProc = procedure(aYield: TYield; aYieldData: Pointer);

  { TYieldEnumerator }
  TYieldEnumerator = class
  public
    constructor Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
    destructor Destroy; override;
  public
    function MoveNext: Boolean;
  private
    procedure Execute; stdcall;
    procedure Yield(aValue: TVarRec);
  protected
    m_yieldProc: TYieldProc;
    m_yieldData: Pointer;
    m_value: TVarRec;
  private
    m_threadFiber: Pointer;
    m_callerFiber: Pointer;
    m_calleeFiber: Pointer;
    m_fiberException: Pointer;
    m_done: Boolean;
  public
    property Current: TVarRec read m_value;
  end;

  { TYieldEnumerable }
  TYieldEnumerable = record
  public
    constructor Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
    function GetEnumerator: TYieldEnumerator; inline;
  private
    m_yieldProc: TYieldProc;
    m_yieldData: Pointer;
  end;

implementation

uses
  SysUtils,
  Windows;

procedure ConvertFiberToThread; external kernel32 name 'ConvertFiberToThread';

function GetCurrentFiber: Pointer;
asm
  mov eax, fs:[$10]
end;

{ TYieldEnumerator }
constructor TYieldEnumerator.Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
var
  _Execute: procedure of object; stdcall;
  __Execute: TMethod absolute _Execute;
begin
  inherited Create;
  m_callerFiber := GetCurrentFiber;
  if (m_callerFiber = nil) or (Cardinal(m_callerFiber) = $1e00) then begin
    m_threadFiber := Pointer(ConvertThreadToFiber(nil));
    if m_threadFiber = nil then
      raise EAbort.CreateFmt('TYieldEnumerator.Create error: %d', [GetLastError]);
    m_callerFiber := GetCurrentFiber;
  end;
  m_yieldProc := aYieldProc;
  m_yieldData := aYieldData;
  _Execute := Execute;
  m_calleeFiber := CreateFiber(0, __Execute.Code, __Execute.Data);
end;

destructor TYieldEnumerator.Destroy;
begin
  FreeMem(m_yieldData);
  DeleteFiber(m_calleeFiber);
  if m_threadFiber <> nil then
    ConvertFiberToThread;
  inherited;
end;

function TYieldEnumerator.MoveNext: Boolean;
begin
  if m_done then begin
    Result := False;
    Exit;
  end;
  m_done := True;
  SwitchToFiber(m_calleeFiber);
  if m_fiberException <> nil then
    raise TObject(m_fiberException);
  Result := not m_done;
end;

procedure TYieldEnumerator.Execute;
begin
  try
    m_yieldProc(Yield, m_yieldData);
  except
    m_fiberException := AcquireExceptionObject;
  end;
  SwitchToFiber(m_callerFiber);
end;

procedure TYieldEnumerator.Yield(aValue: TVarRec);
begin
  m_value := aValue;
  m_done := False;
  SwitchToFiber(m_callerFiber);
end;

{ TYieldEnumerable }
constructor TYieldEnumerable.Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
begin
  m_yieldProc := aYieldProc;
  m_yieldData := aYieldData;
end;

function TYieldEnumerable.GetEnumerator: TYieldEnumerator;
begin
  Result := TYieldEnumerator.Create(m_yieldProc, m_yieldData);
end;

end.

Пример PowersOf2.dpr из оригинального архива тоже изменил. В нём видно как дополнительный параметр конструктора aYieldData используется для эмуляции замыканий, как через вложенную функцию делаются замыкания и как методом наследования получать Yield классы для других переменных, в частности Integer. Остальные типы делаются по аналогии.

program PowersOf2;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Yield_Win32 in 'Yield_Win32.pas';

type
  {************************************}
  { create Yield enumerator of Integer }
  {************************************}

  { TYieldEnumeratorInteger }
  TYieldEnumeratorInteger = class(TYieldEnumerator)
  private
    function GetValue: Integer; inline;
  public
    property Current: Integer read GetValue;
  end;

  { TYieldEnumerableInteger }
  TYieldEnumerableInteger = record
  public
    constructor Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
    function GetEnumerator: TYieldEnumeratorInteger; inline;
  private
    m_yieldProc: TYieldProc;
    m_yieldData: Pointer;
  end;

{ TYieldEnumeratorInteger }
function TYieldEnumeratorInteger.GetValue;
begin
  Result := m_value.VInteger;
end;

{ TYieldEnumerableInteger }
constructor TYieldEnumerableInteger.Create(const aYieldProc: TYieldProc; aYieldData: Pointer);
begin
  m_yieldProc := aYieldProc;
  m_yieldData := aYieldData;
end;

function TYieldEnumerableInteger.GetEnumerator: TYieldEnumeratorInteger;
begin
  Result := TYieldEnumeratorInteger.Create(m_yieldProc, m_yieldData);
end;

function Power(Number: Integer; Exponent: Integer): TYieldEnumerableInteger;
  type
    PYieldData = ^TYieldData;
    TYieldData = record
      Number: Integer;
      Exponent: Integer;
    end;
  var
    p: PYieldData;

  procedure DoYield(Yield: TYield; pData: PYieldData);
  var
    i: Integer;
    v: TVarRec;
  begin
    v.VInteger := 1;
    for i := 1 to pData^.Exponent do begin
      v.VInteger := v.VInteger * pData^.Number;
      Yield(v);
    end;
  end;
begin
  GetMem(p, SizeOf(TYieldData));
  p^.number := Number;
  p^.exponent := Exponent;
  Result := TYieldEnumerableInteger.Create(@DoYield, p);
end;

var
  i: Integer;
begin
  try
    for i in Power(2, 9) do begin
      Writeln(i);
    end;
  Readln;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end.

Ну, вот вроде бы и всё. Как «говорил» перед завершением пример из Turbo Pascal 7.0 под названием bgidemo.pas:

Tha's all folks!

Оригинальная страница ^[9] Andriy Gerasika с его реализацией yield для Delphi, с которой всё и началось.

Автор: pfemidi

Источник ^[10]