Delphi 柏林 PPL TFuture 在第二次等待中挂起
Delphi Berlin PPL TFuture hangs on WAIT in second instance
这几天我一直在想这个问题。我有一段相当复杂的代码，其中挂有 TFuture。我确信我在导致它的复杂代码中做了一些险恶的事情。我很惊讶我能够创建一个以相同方式挂起的相当简单的示例。我认为我对 Delphi 的并行编程库有很好的理解，所以我几乎确信这是某种错误；但我真的可以使用多双眼睛来指出我错过了什么。
我希望这看起来相当直截了当：它是一个后台工作处理对象。它创建一个 TTask 来完成它的主要工作。在设置过程中有一个相当耗时的过程，它使用 TFuture 来帮助并行进行应用程序初始化。创建 TGadget 的 second 实例时会出现问题：第二个实例中的 TFuture 将挂起对 TFuture.Value 的调用（"FAvailable := IsAvailableFutureTask.Value"，第 145 行） .如果没有其他实例，它 不会 挂起，也就是说，如果我在创建新实例之前先将所有 "Gadget" 实例设置为 nil，它将始终有效。它只有在已经有一个实例 运行 时才会挂起。
如果您先单击任一按钮然后再次单击任一按钮（哪个按钮是第一个或第二个都无关紧要），我会得到这种行为。
这是一个 VCL 表单应用；这是主要的表单代码：
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
System.Threading
;
type
IGadget = interface
['{E426DCA3-D817-4231-8D19-9B839F89A8E3}']
function GetAvailable : boolean;
property Available : boolean read GetAvailable;
procedure SetDial(const Value : string);
property Dial : string write SetDial;
procedure SetSwitches(const Value : string);
property Switches : string write SetSwitches;
end;
TGadget = class(TInterfacedObject, IGadget)
protected
DialValue : string;
SwitchesValue : string;
HaveConfiguration : boolean;
FAvailable : boolean;
IsAvailableFutureTask : IFuture<boolean>;
ProcessWorkTask : ITask;
procedure CheckIfAvailable;
procedure ConfigurationChanged;
procedure ProcessWork(Sender : TObject);
(* IGadget *)
function GetAvailable : boolean;
procedure SetDial(const Value : string);
procedure SetSwitches(const Value : string);
public
constructor Create;
destructor Destroy; override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
protected
function PrepareGadget : IGadget;
public
Gadget1 : IGadget;
Gadget2 : IGadget;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TGadget.Create;
begin
inherited Create;
ProcessWorkTask := TTask.Run(self,ProcessWork);
end;
destructor TGadget.Destroy;
begin
ProcessWorkTask.Cancel;
inherited Destroy;
end;
procedure TGadget.ProcessWork(Sender : TObject);
begin
repeat
//
// process the Gadget's work
//
TThread.Yield;
until TTask.CurrentTask.Status = TTaskStatus.Canceled;
end;
procedure TGadget.CheckIfAvailable;
begin
FAvailable := false;
IsAvailableFutureTask := nil;
if not HaveConfiguration then exit;
IsAvailableFutureTask := TTask.Future<boolean>(
function : boolean
var
GadgetAvailable : boolean;
begin
try
//
// Perform some time consuming task to determine if
// the Gadget is available
//
sleep(2000);
GadgetAvailable := true;
except
on E:Exception do
begin
GadgetAvailable := false;
end
end;
Result := GadgetAvailable;
end);
end;
function TGadget.GetAvailable : boolean;
begin
if assigned(IsAvailableFutureTask) then
FAvailable := IsAvailableFutureTask.Value;
Result := FAvailable
end;
procedure TGadget.ConfigurationChanged;
begin
HaveConfiguration := false;
if (DialValue = '') or (SwitchesValue = '') then exit;
HaveConfiguration := true;
CheckIfAvailable;
end;
procedure TGadget.SetDial(const Value : string);
begin
DialValue := Value;
ConfigurationChanged
end;
procedure TGadget.SetSwitches(const Value : string);
begin
SwitchesValue := Value;
ConfigurationChanged
end;
///////////////////////////////////////////////////////////
function TForm1.PrepareGadget : IGadget;
begin
label1.Caption := 'seting up...';
Application.ProcessMessages;
Result := TGadget.Create;
Result.Dial := 'Do something or other';
Result.Switches := 'Toggled or whatever';
if Result.Available then
label1.Caption := 'is available'
else
label1.Caption := 'not available';
Application.ProcessMessages;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Gadget1 := PrepareGadget;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Gadget2 := PrepareGadget;
end;
end.
...和 DFM：
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 119
ClientWidth = 359
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 216
Top = 25
Width = 61
Height = 13
Caption = 'not available'
end
object Button1: TButton
Left = 40
Top = 20
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 40
Top = 56
Width = 75
Height = 25
Caption = 'Button2'
TabOrder = 1
OnClick = Button2Click
end
end
TTask 只会创建与处理器数量相等的线程数。因此，如果您只有一个处理器，无论您将创建多少 ttask 并且 运行，一次只会 运行（它们是检测 ttask 何时休眠到 运行 的算法] 另一个 ttask，但它设计得很糟糕，可以等待大约 30 秒 - 1 分钟来检测，而不是一个 ttask 在 运行 另一个实例之前什么都不做）。 Tparalell 也一样，我想 tfutur 也一样。
所以你必须只对非常密集的 CPU 算法（使用 100% 的 CPU）使用 TTask/tparalell/tfutur，否则你必须使用 TThread。我所说的非常密集的 CPU 程序是指像计算素数这样的程序，而不是像做 http 请求或类似的那样思考
根据 Ikol 的一些提示，我已经确定了问题所在。是的，加一个"sleep(1);"就可以解决问题：
constructor TGadget.Create;
begin
inherited Create;
ProcessWorkTask := TTask.Run(self,ProcessWork);
Sleep(1);
end;
但这并不能很好地解释这里发生的事情。
"TFuture.Value" 检查定义的任务函数是否已经完成，如果是，它 returns 该函数的结果；如果任务尚未完成，它会在任务上调用 WAIT，然后 returns 任务函数的结果值。
这是我认为正在发生的事情：
在我的示例中，这是事件序列（这是 没有 Sleep(1) 解决方法）：
1) 第一次按下按钮；
2) 创建一个 "TGadget"，它创建一个 "ProcessWorkTask"。 （注意：由于 ThreadPool 中没有其他任务，因此该任务启动得非常快。）
3) 在"PrepareGadget"中设置了新的Gadget实例的"Dials"和"Switches"最终导致...
4) "IsAvailableFutureTask" TFuture 任务启动。 （这也及时开始工作。）
5) "configuring" 新 Gadget 之后，"Available" 方法立即调用 "IsAvailableFutureTask" 未来的值。
线程池中现在有 2 个任务。
6) 第二次按下按钮
7) 创建一个 "TGadget"，它创建一个 "ProcessWorkTask"。 （注意：由于现在 ThreadPool 中有 个其他任务，因此此任务不会像第一次那样快速启动。）
8) "PrepareGadget" 再次触发另一个 "IsAvailableFutureTask" 开始。 ThreadPool 中现在有 4 个任务，这个 TFuture 任务需要更长的时间才能开始。事实上，它处于 "WaitingToStart" 状态时...
9) ..."Available" 方法调用 "IsAvailableFutureTask" #2 TFuture 的值。
由于线程池正在等待尚未启动的任务，因此挂起所有内容。
添加 "Sleep(1)" 使 ThreadPool 有足够的时间来获取任务 运行，以便（第二个）TFuture 在对其值的调用执行时处于 运行 状态。而不是 "sleep" 我认为更好的选择是：
constructor TGadget.Create;
begin
inherited Create;
ProcessWorkTask := TTask.Run(self,ProcessWork);
while ProcessWorkTask.Status = TTaskStatus.WaitingToRun do
TThread.Yield;
end;
此外，使用单独的 ThreadPool 也可以使其正常工作：
constructor TGadget.Create;
begin
inherited Create;
GadgetPool := TThreadPool.Create;
ProcessWorkTask := TTask.Run(self,ProcessWork,GadgetPool);
end;
我的结论是这是一个遗漏的错误，无法确保您的 TFuture 在另一个线程调用它的值之前进入 运行 状态。
这几天我一直在想这个问题。我有一段相当复杂的代码，其中挂有 TFuture。我确信我在导致它的复杂代码中做了一些险恶的事情。我很惊讶我能够创建一个以相同方式挂起的相当简单的示例。我认为我对 Delphi 的并行编程库有很好的理解，所以我几乎确信这是某种错误；但我真的可以使用多双眼睛来指出我错过了什么。
我希望这看起来相当直截了当：它是一个后台工作处理对象。它创建一个 TTask 来完成它的主要工作。在设置过程中有一个相当耗时的过程，它使用 TFuture 来帮助并行进行应用程序初始化。创建 TGadget 的 second 实例时会出现问题：第二个实例中的 TFuture 将挂起对 TFuture.Value 的调用（"FAvailable := IsAvailableFutureTask.Value"，第 145 行） .如果没有其他实例，它 不会 挂起，也就是说，如果我在创建新实例之前先将所有 "Gadget" 实例设置为 nil，它将始终有效。它只有在已经有一个实例 运行 时才会挂起。
如果您先单击任一按钮然后再次单击任一按钮（哪个按钮是第一个或第二个都无关紧要），我会得到这种行为。
这是一个 VCL 表单应用；这是主要的表单代码：
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
System.Threading
;
type
IGadget = interface
['{E426DCA3-D817-4231-8D19-9B839F89A8E3}']
function GetAvailable : boolean;
property Available : boolean read GetAvailable;
procedure SetDial(const Value : string);
property Dial : string write SetDial;
procedure SetSwitches(const Value : string);
property Switches : string write SetSwitches;
end;
TGadget = class(TInterfacedObject, IGadget)
protected
DialValue : string;
SwitchesValue : string;
HaveConfiguration : boolean;
FAvailable : boolean;
IsAvailableFutureTask : IFuture<boolean>;
ProcessWorkTask : ITask;
procedure CheckIfAvailable;
procedure ConfigurationChanged;
procedure ProcessWork(Sender : TObject);
(* IGadget *)
function GetAvailable : boolean;
procedure SetDial(const Value : string);
procedure SetSwitches(const Value : string);
public
constructor Create;
destructor Destroy; override;
end;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
protected
function PrepareGadget : IGadget;
public
Gadget1 : IGadget;
Gadget2 : IGadget;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//////////////////////////////////////////////////////////////////////////////////////////////////////
constructor TGadget.Create;
begin
inherited Create;
ProcessWorkTask := TTask.Run(self,ProcessWork);
end;
destructor TGadget.Destroy;
begin
ProcessWorkTask.Cancel;
inherited Destroy;
end;
procedure TGadget.ProcessWork(Sender : TObject);
begin
repeat
//
// process the Gadget's work
//
TThread.Yield;
until TTask.CurrentTask.Status = TTaskStatus.Canceled;
end;
procedure TGadget.CheckIfAvailable;
begin
FAvailable := false;
IsAvailableFutureTask := nil;
if not HaveConfiguration then exit;
IsAvailableFutureTask := TTask.Future<boolean>(
function : boolean
var
GadgetAvailable : boolean;
begin
try
//
// Perform some time consuming task to determine if
// the Gadget is available
//
sleep(2000);
GadgetAvailable := true;
except
on E:Exception do
begin
GadgetAvailable := false;
end
end;
Result := GadgetAvailable;
end);
end;
function TGadget.GetAvailable : boolean;
begin
if assigned(IsAvailableFutureTask) then
FAvailable := IsAvailableFutureTask.Value;
Result := FAvailable
end;
procedure TGadget.ConfigurationChanged;
begin
HaveConfiguration := false;
if (DialValue = '') or (SwitchesValue = '') then exit;
HaveConfiguration := true;
CheckIfAvailable;
end;
procedure TGadget.SetDial(const Value : string);
begin
DialValue := Value;
ConfigurationChanged
end;
procedure TGadget.SetSwitches(const Value : string);
begin
SwitchesValue := Value;
ConfigurationChanged
end;
///////////////////////////////////////////////////////////
function TForm1.PrepareGadget : IGadget;
begin
label1.Caption := 'seting up...';
Application.ProcessMessages;
Result := TGadget.Create;
Result.Dial := 'Do something or other';
Result.Switches := 'Toggled or whatever';
if Result.Available then
label1.Caption := 'is available'
else
label1.Caption := 'not available';
Application.ProcessMessages;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Gadget1 := PrepareGadget;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Gadget2 := PrepareGadget;
end;
end.
...和 DFM：
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 119
ClientWidth = 359
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 216
Top = 25
Width = 61
Height = 13
Caption = 'not available'
end
object Button1: TButton
Left = 40
Top = 20
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 40
Top = 56
Width = 75
Height = 25
Caption = 'Button2'
TabOrder = 1
OnClick = Button2Click
end
end
TTask 只会创建与处理器数量相等的线程数。因此，如果您只有一个处理器，无论您将创建多少 ttask 并且 运行，一次只会 运行（它们是检测 ttask 何时休眠到 运行 的算法] 另一个 ttask，但它设计得很糟糕，可以等待大约 30 秒 - 1 分钟来检测，而不是一个 ttask 在 运行 另一个实例之前什么都不做）。 Tparalell 也一样，我想 tfutur 也一样。
所以你必须只对非常密集的 CPU 算法（使用 100% 的 CPU）使用 TTask/tparalell/tfutur，否则你必须使用 TThread。我所说的非常密集的 CPU 程序是指像计算素数这样的程序，而不是像做 http 请求或类似的那样思考
根据 Ikol 的一些提示，我已经确定了问题所在。是的，加一个"sleep(1);"就可以解决问题：
constructor TGadget.Create;
begin
inherited Create;
ProcessWorkTask := TTask.Run(self,ProcessWork);
Sleep(1);
end;
但这并不能很好地解释这里发生的事情。
"TFuture.Value" 检查定义的任务函数是否已经完成，如果是，它 returns 该函数的结果；如果任务尚未完成，它会在任务上调用 WAIT，然后 returns 任务函数的结果值。
这是我认为正在发生的事情：
在我的示例中，这是事件序列（这是 没有 Sleep(1) 解决方法）：
1) 第一次按下按钮；
2) 创建一个 "TGadget"，它创建一个 "ProcessWorkTask"。 （注意：由于 ThreadPool 中没有其他任务，因此该任务启动得非常快。）
3) 在"PrepareGadget"中设置了新的Gadget实例的"Dials"和"Switches"最终导致...
4) "IsAvailableFutureTask" TFuture 任务启动。 （这也及时开始工作。）
5) "configuring" 新 Gadget 之后，"Available" 方法立即调用 "IsAvailableFutureTask" 未来的值。
线程池中现在有 2 个任务。
6) 第二次按下按钮
7) 创建一个 "TGadget"，它创建一个 "ProcessWorkTask"。 （注意：由于现在 ThreadPool 中有 个其他任务，因此此任务不会像第一次那样快速启动。）
8) "PrepareGadget" 再次触发另一个 "IsAvailableFutureTask" 开始。 ThreadPool 中现在有 4 个任务，这个 TFuture 任务需要更长的时间才能开始。事实上，它处于 "WaitingToStart" 状态时...
9) ..."Available" 方法调用 "IsAvailableFutureTask" #2 TFuture 的值。
由于线程池正在等待尚未启动的任务，因此挂起所有内容。
添加 "Sleep(1)" 使 ThreadPool 有足够的时间来获取任务 运行，以便（第二个）TFuture 在对其值的调用执行时处于 运行 状态。而不是 "sleep" 我认为更好的选择是：
constructor TGadget.Create;
begin
inherited Create;
ProcessWorkTask := TTask.Run(self,ProcessWork);
while ProcessWorkTask.Status = TTaskStatus.WaitingToRun do
TThread.Yield;
end;
此外，使用单独的 ThreadPool 也可以使其正常工作：
constructor TGadget.Create;
begin
inherited Create;
GadgetPool := TThreadPool.Create;
ProcessWorkTask := TTask.Run(self,ProcessWork,GadgetPool);
end;
我的结论是这是一个遗漏的错误，无法确保您的 TFuture 在另一个线程调用它的值之前进入 运行 状态。