LCL потоки win32

[Kitayets]

Написал простую программу по книге для Delphi (немного модифицировал без потери основного смысла).

Программа проста:
создана форма, на ней менюха. По команде меню создаётся поток (либо 10 потоков) который рисует на канве формы линии с случайными координатам выбранным цветом (случайным цветом при создании сразу 10-и потоков). Также есть команды удаления одного потока / всех потоков. Перед отрисовкой линии поток лочит канву формы. Координаты канвы для расчёта координат отрисовываемых линий читаются в синхронизированном методе потока.

проблема: при запуске в windows xp 32 - программа ведёт себя нестабильно. через небольшое время запущенные потоки прекращают отображаться. если добавлять сразу 10 потоков - то со 100% вероятностью не отображаются. при этом само окно нормально отрисовывается - изменяется размер, менюха и диалог выбора цвета отрабатывают. При запуске из под отладчика показывает extrnal:SIGFPE.

При этом, при запуске на linux fedora 64 из под wine (тот же самый бинарник) - отрабатывает точно как я и ожидаю. потоки создаются/удаляются и не перестают отображаться.

При сборке под linux x64 /GTK2 - после запуска первого потока ИКСы подвисли - пришлось убивать lazarus из консоли...

В чём косяк?
прикладываю исходники программы

[Maxizar]

Очень приятно, что вы читаете на сколько я понял Двухтомник по Delphi 5. Этот пример был именно от туда. Так вот именно для Delphi. авторы говорят что лучше делать так:

Код: Выделить всё

 FreeOnTerminate:=True;

 while not (Terminated or Application.Terminated) do
  begin
//не посильная работа потока. 
end;

Так вот в Lazarus лучше делать вот так:

Код: Выделить всё

//FreeOnTerminate:=True;  <---- вот это не надо делать
 while not (Terminated or Application.Terminated) do
  begin
//не посильная работа потока. 
end;
  Free;             //<- лучше так в конце работы потока
  Self:=Nil;       //<- где Self указатель на сам поток.  

Вот привожу исправленный вариант вашей программы, после исправления у меня все работает (У меня Win SP3 от 10.02.2010 г своей сборки).

Код: Выделить всё

unit Main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  Menus;

type

  { TMainForm }

  TMainForm = class(TForm)
    ColorDialog1: TColorDialog;
    MainMenu1: TMainMenu;
    AddThread: TMenuItem;
    Add10: TMenuItem;
    RemoveAll: TMenuItem;
    RemoveThread: TMenuItem;
    Options1: TMenuItem;
    procedure Add10Click(Sender: TObject);
    procedure AddThreadClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure RemoveAllClick(Sender: TObject);
    procedure RemoveThreadClick(Sender: TObject);
  private
    { private declarations }
    ThreadList: TList;
  public
    { public declarations }
  end;

  { TDrawThread }

  TDrawThread = class(TThread)
  private
    P1, P2: TPoint;
    FColor: TColor;
    FForm:  TForm;
    procedure GetRandCoords;
  public
    constructor Create(AForm: TForm; AColor: TColor);
    procedure Execute; override;
  end;

var
  MainForm: TMainForm;

implementation

{ TMainForm }

procedure TMainForm.FormCreate(Sender: TObject);
begin
    ThreadList:= TList.Create;
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.AddThreadClick(Sender: TObject);
begin
    if ColorDialog1.Execute then
        ThreadList.Add(TDrawThread.Create(Self, ColorDialog1.Color));
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.Add10Click(Sender: TObject);
var
    i: integer;
begin
    for i:= 1 to 10 do
        ThreadList.Add(TDrawThread.Create(Self, Random(MaxInt)));
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
    RemoveAllClick(nil);
    ThreadList.Free;
end;

procedure TMainForm.RemoveAllClick(Sender: TObject);
var
    i: integer;
begin
    Cursor:= crHourGlass;
    try
        for i:= ThreadList.Count - 1 downto 0 do
        begin
            TDrawThread(ThreadList[i]).Terminate;
//            TDrawThread(ThreadList[i]).WaitFor;
        end;
        ThreadList.Clear;
    finally
        Cursor:= crDefault;
    end;
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.RemoveThreadClick(Sender: TObject);
begin
    if ThreadList.Count < 1 then exit;
    TDrawThread(ThreadList[ThreadList.Count - 1]).Terminate;
    ThreadList.Delete(ThreadList.Count - 1);
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

{ TDrawThread }

constructor TDrawThread.Create(AForm: TForm; AColor: TColor);
begin
  FColor:= AColor;
  FForm := AForm;
  inherited Create(False);
end;

procedure TDrawThread.GetRandCoords;
var
  MaxX, MaxY: Integer;
begin

    MaxX:= FForm.ClientWidth;
    MaxY:= FForm.ClientHeight;
    P1.x:= Random(MaxX);
    P2.x:= Random(MaxX);
    P1.y:= Random(MaxY);
    P2.y:= Random(MaxY);
end;

procedure TDrawThread.Execute;

begin
    //FreeOnTerminate:= True;
    while not (self.Terminated or Application.Terminated) do
    begin
        Synchronize(@GetRandCoords);

        with FForm.Canvas do
        begin
            Lock;
            Pen.Color:= FColor;
            MoveTo(P1);
            LineTo(P2);
            Unlock;
            Sleep(100);
        end;
    end;
    Free;
    Self:=Nil;
end;

initialization
  {$I main.lrs}
  Randomize;

end.

[Kitayets]

Спасибо за участие!

Очень приятно, что вы читаете на сколько я понял Двухтомник по Delphi 5. Этот пример был именно от туда.

Да-да вроде неплохая книга. Вообще же хороших книг по delphi и objectpascal очень мало IMHO.

Так вот именно для Delphi. авторы говорят что лучше делать так:

Код: Выделить всё

 FreeOnTerminate:=True;

 while not (Terminated or Application.Terminated) do
  begin
//не посильная работа потока. 
end;

Так вот в Lazarus лучше делать вот так:

Код: Выделить всё

//FreeOnTerminate:=True;  <---- вот это не надо делать
 while not (Terminated or Application.Terminated) do
  begin
//не посильная работа потока. 
end;
  Free;             //<- лучше так в конце работы потока
  Self:=Nil;       //<- где Self указатель на сам поток.  

В общем не вижу разницы т.к. вроде это эквивалентные варианты?
В общем с Вашими правками - у меня также сбоит программа в win32 XP.

Вот прикладываю пару картинок:
1. Вот сообщение появляющиеся при запуске программы из лазаруса. (после добавление потока/потоков)


2. момент ошибки при запуске из под gdb.


3. backtarce в gdb


Судя по gdb (рис.2) SIGFPE происходит при переключении на поток. Причём SIGFPE - аппаратное исключение мат. сопроцессора? откуда там это может происходить? и почему из под wine тотже бинарник работает суперстабильно?

[Maxizar]

В общем с Вашими правками - у меня также сбоит программа в win32 XP.

Могу назвать лишь одну причину, (судя по аналагичному сценарию), данная ситуация у меня произошла, когда я баловался с ОллиДебагером. из за чего произошел сбой внутреннего отладчика винды (мне так кажеться). Помогло лишь переустановка Windows.

В общем не вижу разницы т.к. вроде это эквивалентные варианты?

Знаете это действительно иногда решает не понятки с FreeOnTerminate:=True;.
Проблем нету когда поток один, а вот когда потоков данного класса много, то поверте мне делать:
Free;
Self:=Nil;
Просто необходимо.

[Kitayets]

Короче повозился с отладчиком, прошёлся по тексту и понял, что метод Canvas.Lock(), видимо, не отрабатывает до конца, т.е. не блокирует обращение к свойствам Canvas (конкретно к объекту Canvas.Pen) из других потоков.
Ошибка возникает при установке цвета пера в потоке:

Код: Выделить всё

        with FForm.Canvas do
          begin
              Lock;
              Pen.Color:= FColor; // <-- вызов приводящий к исключению
              MoveTo(P1);
              LineTo(P2);
              Unlock;
              Sleep(1);
          end; 

дальше вызов переходит к методу Pen.SetColor:

Код: Выделить всё

procedure TPen.SetColor(const NewColor: TColor; const NewFPColor: TFPColor);
begin
  if (NewColor = Color) and (NewFPColor = FPColor) then Exit; // если цвет не изменился то выходим процедуры
  FreeReference; // <-- а если изменился, то удаляем ссылку на существующее перо из кэша ресурсов?
  FColor := NewColor;
  inherited SetFPColor(NewFPColor);
  Changed;
end;   

дальше вызывается Pen.FreeReference:

Код: Выделить всё

procedure TPen.FreeReference;
begin
  if not FReference.Allocated then Exit;

  Changing;
  if FPenHandleCached then
  begin
    PenResourceCache.FindPen(FReference.Handle).DecreaseRefCount; //<-- здесь вызывается исключение т.к. "кто-то" уже удалил из кэша ресурсов предыдущие перо и RefCount = 0.
    FPenHandleCached := False;
  end else
    DeleteObject(HGDIOBJ(FReference.Handle));
  FReference._lclHandle := 0;
end; 

Думаю, что "кто-то" - это основной поток выполнения (GUI). После того как Pen "закэшировался", происходит переключение между потоками в момент после вызова TPen.FreeReference, но до вызова PenResourceCache.FindPen(FReference.Handle).DecreaseRefCount; и следующий поток несмотря на canvas.lock() получает доступ к canvas.pen и выполняет DecreaseRefCount раньше прерванного потока.

Добавлено спустя 8 минут 16 секунд:
В связи с этим сделал вызов отрисовки на Canvas в синхронизированном методе (т.е. в основном потоке выполнения приложения) - и теперь проблема исчезла! Таким образом это косвенно подтверждает что именно главный поток управления не обращал внимание на Canvas.lock().
Вот изменённый код TDrawThread из main.pas (всё остальное осталось без изменений):

Код: Выделить всё

TDrawThread = class(TThread)
  private
    P1, P2: TPoint;
    FColor: TColor;
    FForm:  TForm;
    procedure DrawLine; 
    procedure GetRandCoords;
  public
    constructor Create(AForm: TForm; AColor: TColor);
    procedure Execute; override;
end;

procedure TDrawThread.DrawLine;
begin
  with FForm.Canvas do
          begin
              Pen.Color:= FColor;
              MoveTo(P1);
              LineTo(P2);
          end;
end;
procedure TDrawThread.Execute; 
begin
    //FreeOnTerminate:= True;
    while not (self.Terminated or Application.Terminated) do
    begin
        Synchronize(@GetRandCoords);
        Synchronize(@DrawLine);
        Sleep(1);
    end;
    self.Free;
    self:=  nil;
end;   

Добавлено спустя 1 час 37 минут 49 секунд:
ещё немного подумал и понял, что в таком варианте - приложение по факту однопоточное, т.к. параллельно потоки только "спят"

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

Код: Выделить всё

unit Main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  Menus;

type

  { TMainForm }

  TMainForm = class(TForm)
    ColorDialog1: TColorDialog;
    MainMenu1: TMainMenu;
    AddThread: TMenuItem;
    Add10: TMenuItem;
    RemoveAll: TMenuItem;
    RemoveThread: TMenuItem;
    Options1: TMenuItem;
    procedure Add10Click(Sender: TObject);
    procedure AddThreadClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure RemoveAllClick(Sender: TObject);
    procedure RemoveThreadClick(Sender: TObject);
  private
    { private declarations }
    ThreadList: TList;
  public
    { public declarations }
  end;

  { TDrawThread }

  TDrawThread = class(TThread)
  private
    P1, P2: TPoint;
    FColor: TColor;
    FForm:  TForm;
    MaxX, MaxY: Integer;
    procedure DrawLine;
    procedure GetFormCoords;
  public
    constructor Create(AForm: TForm; AColor: TColor);
    procedure Execute; override;
  end;

var
  MainForm: TMainForm;

implementation

{ TMainForm }

procedure TMainForm.FormCreate(Sender: TObject);
begin
    ThreadList:= TList.Create;
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.AddThreadClick(Sender: TObject);
begin
    if ColorDialog1.Execute then
        ThreadList.Add(TDrawThread.Create(Self, ColorDialog1.Color));
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.Add10Click(Sender: TObject);
var
    i: integer;
begin
    for i:= 1 to 10 do
        ThreadList.Add(TDrawThread.Create(Self, Random(MaxInt)));
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
    RemoveAllClick(nil);
    ThreadList.Free;
end;

procedure TMainForm.RemoveAllClick(Sender: TObject);
var
    i: integer;
begin
    Cursor:= crHourGlass;
    try
        for i:= ThreadList.Count - 1 downto 0 do
        begin
            TDrawThread(ThreadList[i]).Terminate;
//            TDrawThread(ThreadList[i]).WaitFor;
        end;
        ThreadList.Clear;
    finally
        Cursor:= crDefault;
    end;
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

procedure TMainForm.RemoveThreadClick(Sender: TObject);
begin
    if ThreadList.Count < 1 then exit;
    TDrawThread(ThreadList[ThreadList.Count - 1]).Terminate;
    ThreadList.Delete(ThreadList.Count - 1);
    self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;

{ TDrawThread }

constructor TDrawThread.Create(AForm: TForm; AColor: TColor);
begin
  FColor:= AColor;
  FForm := AForm;
  inherited Create(False);
end;

procedure TDrawThread.GetFormCoords;

begin

    self.MaxX:= FForm.ClientWidth;
    self.MaxY:= FForm.ClientHeight;

end;

procedure TDrawThread.DrawLine;
begin
  with FForm.Canvas do
          begin
              Pen.Color:= FColor;
              MoveTo(P1);
              LineTo(P2);
          end;
end;

procedure TDrawThread.Execute;

begin
    FreeOnTerminate:= True;
    while not (self.Terminated or Application.Terminated) do
    begin
        Synchronize(@GetFormCoords);

        P1.x:= Random(self.MaxX);
        P2.x:= Random(self.MaxX);
        P1.y:= Random(self.MaxY);
        P2.y:= Random(self.MaxY);

        Synchronize(@DrawLine);
        Sleep(1);
    end;
end;

initialization
  {$I main.lrs}
  Randomize;

end. 

и на счёт что лучше для лазаруса:

Код: Выделить всё

FreeOnTerminate:=True;

или

Код: Выделить всё

Free;             
Self:=Nil;

при втором варианте в windows XP 32b при удалении потоков в приложении - в диспетчере задач количество потоков в процессе не уменьшается! в первом же случае всё корректно.

Чтобы посмотреть количество потоков в приложении нужно в диспетчере задач win xp зайти и выбрать View->Select Coluns -> Thread Count. после этого на вкладке Processes появится дополнительный столбец Threads.

Так что чтобы не допускать утечек ресурсов системы я думаю лучше использовать вариант с FreeOnTerminate:=True;

[Max Rusov]

Для изучения потоков гораздо более красивый пример - сортировка в потоках из Demos'ов Delphi.

Кстати - функция Random как раз не thread-safe, и обращение к ней желательно защищать крит. секцией

[Sergei I. Gorelkin]

Код: Выделить всё

Free;
Self:=Nil;

при втором варианте в windows XP 32b при удалении потоков в приложении - в диспетчере задач количество потоков в процессе не уменьшается! в первом же случае всё корректно.

Логично. В деструкторе TThread вызывается сначала Terminate, потом WaitFor. И если поток вызовет Free самому себе, то он просто будет вечно ждать сам себя и никогда не завершится.
По этой же причине с потоками можно обращаться точно так же, как с любыми другими объектами: создали (Create) - уничтожили (Free), не устанавливая FreeOnTerminate в True. Просто, если поток еще работает, то вызов Free дождется его завершения. И никаких невалидных ссылок.