Delphi Berlin PPL TFuture hangs on WAIT in second instance

Question

I've been puzzling over this for several days now. I've have a fairly complex bit of code where a TFuture is hanging. I was sure that I was doing something sinister in my complex code that was causing it. I am amazed that I was able to create a fairly simple example that hangs in the same way. I thought I had a good understanding of Delphi's Parallel Programming Library so I'm almost convinced that this is some kind of bug; but I could really use several extra pairs of eyes that can hopefully point out what I've missed.

I hope this appears fairly straight forward: It is a background work processing Object. It creates an TTask to do it's main work. And there is a fairly time-consuming process during setup that uses a TFuture to help allow App initialization to be in parallel. The problem occurs when a second instance of the TGadget is created: The TFuture in the second instance will hang on the call to TFuture.Value ("FAvailable := IsAvailableFutureTask.Value", line 145). It will not hang if there are no other instances, that is, if I first set all "Gadget" instances to nil before creating a new one, it will always work. It only hangs if there is already an instance running.

I get the behavior if you first click either button and the click again on either button (it doesn't matter which button is first or second).

This is a VCL forms app; here is the main form code:

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.

...and the 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

Answer 1

TTask will create only the number of thread who is equal to the number of processor. so if you have only one processor no matter how many ttask you will create and run, only one will run at a time (their is some algo to detect when a ttask is sleeping to run another ttask but it's badly designed and can wait around 30s - 1min to detect than one ttask is doing nothing before to run another instance). it's the same for Tparalell and i guess it's the same for tfutur.

so you must use TTask/tparalell/tfutur only for very intensive CPU algo (who use 100% of the CPU) else you must use TThread. By very intensive CPU procedure i mean for example procedure like calculating prime number, and not think like doing http request or similar

Answer 2

With some hints from Ikol, I've isolated the problem. Yes, adding a "sleep(1);" will solve the problem:

constructor TGadget.Create;

begin
   inherited Create;

   ProcessWorkTask := TTask.Run(self,ProcessWork);

   Sleep(1);
end;

but this doesn't really explain whats going on here very well.

"TFuture.Value" checks if the defined task function has completed, it returns the result of that function if so; if the task has not yet completed it calls WAIT on the task and then returns the task function's result value.

Here's what I think is happening:

In my example, this is the sequence of events (this is without the Sleep(1) work-around):

1) Press a button the first time;

2) Creates a "TGadget" which creates a "ProcessWorkTask". (Note: since there are no other Tasks in the ThreadPool, this task gets started pretty quickly.)

3) In "PrepareGadget", the new Gadget instance's "Dials" and "Switches" are set which ultimately causes...

4) A "IsAvailableFutureTask" TFuture task is kicked off. (This too gets started in time for things to work.)

5) Immediately after "configuring" the new Gadget, the "Available" method calls for the value of the "IsAvailableFutureTask" future.

There are now 2 Tasks in the ThreadPool.

6) Press a button for the second time

7) Creates a "TGadget" which creates a "ProcessWorkTask". (Note: since there are other Tasks in the ThreadPool now, this task does not get started as quickly as the first time around.)

8) "PrepareGadget" again triggers another "IsAvailableFutureTask" to be started. With 4 tasks now in the ThreadPool this TFuture task takes longer to get started. In fact, it is sitting in the "WaitingToStart" state when...

9) ...the "Available" method calls for the value of "IsAvailableFutureTask" #2 TFuture.

Which hangs everything since the ThreadPool is waiting on a task that has not started.

Adding the "Sleep(1)" gives the ThreadPool enough time to get the Tasks running so that the (second) TFuture is in the running state when the call for it's value executes. Instead of "sleep" I think a better choice would be:

constructor TGadget.Create;

begin
   inherited Create;

   ProcessWorkTask := TTask.Run(self,ProcessWork);

   while ProcessWorkTask.Status = TTaskStatus.WaitingToRun do
      TThread.Yield;
end;

Also, using a seperate ThreadPool makes it work as well:

constructor TGadget.Create;

begin
   inherited Create;

   GadgetPool := TThreadPool.Create;
   ProcessWorkTask := TTask.Run(self,ProcessWork,GadgetPool);
end;

My conclusion is that this is a bug of omission, there is no way to insure that your TFuture gets into the running state before another thread calls for it's value.