Yield в CodeGear RAD Studio (Delphi 2007 for Win32)

Привіт хабр!

Знадобилося раптово переносити програму з C# на Delphi. У програмі на C# активно використовувався yield. Погугливши простори інтернету в надії не займатися винаходом велосипеда, вдалося знайти реалізацію yield для Win32 на базі фиберов Embarcadero Delphi 2009 і вище, але от біда — потрібно зробити порт під CodeGear RAD Studio для версії Delphi 2007, в якій ще були відсутні узагальнені типи і анонімні методи. Міняти версію Delphi на більш пізню було не можна і тому довелося переписати знайдену реалізацію yield для більш ранньої версії.

Взявши ісходник юніта з реалізацій yield для Delphi 2009 і вище за авторством andriy Gerasika я його переробив для Delphi 2007.

Потрібно зробити підтримку yield тільки для Win32 і тільки для Delphi 2007, тому багато міняти не довелося, тільки прибрати узагальнення, яких ще не було необхідної версії Delphi і зробити емуляцію замикань.

В оригінальному коді узагальнені типи (узагальнення) були в стандартному вигляді:

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 потрібно якось обійтися без узагальнення, по можливості зберігши всю функціональність. Тому для зберігання повертається yield значення я вирішив використовувати запис типу TVarRec із стандартного юніта System:

/>
TVarRec = record
case of Byte
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).

І змінив оригінальні класи з узагальнення

/>
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;
Execute procedure; 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
Execute procedure; 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
Execute procedure; 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!


Оригінальна сторінка Andriy Gerasika з його реалізацією yield для Delphi, з якої все й почалося.

Джерело: Хабрахабр

0 коментарів

Тільки зареєстровані та авторизовані користувачі можуть залишати коментарі.