INT 21h

Select language

Lazarus: многопоточность в Linux и Windows

№ 4467 В разделе Programming от August 19th, 2012,
В подшивках: ,

Наверняка вы делаете не бесполезные программы и частенько они выполняют долгие операции. На столько долгие, что интерфейс замирает пока программу не “отпустит”. На помощь приходит многопоточность! Смысл в том, чтобы отделить долгоиграющую подпрограмму от основной программы и иногда синхронизировать потоки для обновления переменных или интерфейса. Именно это мне и пришлось сделать при доработке программы отправки команд на контроллер освещения через Bluetooth.

Демонстрация незамирающего окна:

Update (19.08.2012): В конце этой статьи есть дополнение о создании очередей и ожидании конца выполнения смежной задачи, а также видео для демонстрации.

У Windows и Linux разные способы работы с потоками, поэтому сначала придется наложить небольшой патч на файл проекта (например, myproject.lpr). По умолчанию uses выглядит так:

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Interfaces, // this includes the LCL widgetset

Нужно его изменить на такой вариант:

uses
  {$IFNDEF WIN32}
  {$DEFINE UseCThreads}
  {$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Interfaces, // this includes the LCL widgetset

Теперь можно создать класс нужного нам потока. В вашем любимом модуле сразу после uses добавьте описание нового класса:

Type
  TSerialThread = class(TThread)
  private
    fStatusText, fDataOut, fDataIn, fPortName, fStatus : String;
    fErrorCode : Integer;
    fStatusGet : Boolean;
    procedure Draw;
    procedure UpdateStatus;
  protected
    procedure Execute; override;
  public
    Constructor Create(CreateSuspended : boolean);
  end;

Чуть ниже идет определение глобальных переменных var. Добавьте в него SerThread : TSerialThread;.

Теперь нужно описать как работает новый класс. Согласно документации при создании класса можно определить некоторые параметры. Поскольку определять особо и нечего, то сделаем самый простой конструктор:

constructor TSerialThread.Create(CreateSuspended : boolean);
  begin
    FreeOnTerminate := True;
    inherited Create(CreateSuspended);
  end;

Одного конструктора мало. Должны быть функции обновления интерфейса программы:

procedure TSerialThread.Draw;
// Показать состояние устройства на форме
var
  state: integer;
begin
  //нарисовать ответ устройства на форме
  state := Hex2Dec(fStatus);
  if (odd(state shr 0)) then Form1.ToggleBox16.Checked := true else 
     Form1.ToggleBox16.Checked := false;
  if (odd(state shr 1)) then Form1.ToggleBox15.Checked := true else
     Form1.ToggleBox15.Checked := false;
  ...
  if (odd(state shr 14)) then Form1.ToggleBox2.Checked := true else 
     Form1.ToggleBox2.Checked := false;
  if (odd(state shr 15)) then Form1.ToggleBox1.Checked := true else 
     Form1.ToggleBox1.Checked := false;
  Form1.Timer1.Enabled:=True; //разрешить автоматическое получение 
     //состояния устройства каждые 10 секунд
  Form1.Button3.Enabled:=True; 
end; 

procedure TSerialThread.UpdateStatus;
//обновить статус в StatusBar
begin
  Form1.StatusBar1.SimpleText:=fStatusText;
end;

И, наконец, основная программа запускаемого потока:

procedure TSerialThread.Execute;
var
  ser: TBlockSerial;
  answer: String;
begin
  ser:=TBlockSerial.Create;
  try
    fStatusText := 'Инициализация порта ввода\вывода...';
    Synchronize(@UpdateStatus);
    ser.connect(fPortName);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    fStatusText := 'Подключение...';
    Synchronize(@UpdateStatus);
    ser.config(9600,8,'N',0,false,false);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    fStatusText := 'Посылка команды...';
    Synchronize(@UpdateStatus);
    ser.sendstring(fDataIn);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    fStatusText := 'Ожидание ответа...';
    Synchronize(@UpdateStatus);
    answer := ser.RecvTerminated(2000,#13);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    if fStatusGet then
    begin
      fStatusText := 'Ожидание информации о состоянии...';
      Synchronize(@UpdateStatus);
      fStatus := ser.RecvTerminated(2000,#13);
      fStatus := ExtractWord(2, fStatus, StdWordDelims);
      if ser.LastError>0 then
        begin
          fStatusText := ser.LastErrorDesc;
          Synchronize(@UpdateStatus);
          Exit;
        end;
      if fStatus = '' then fStatus:='0000';
      Synchronize(@Draw);
    end;
    fStatusText := 'Команда выполнена';
    Synchronize(@UpdateStatus);
  finally
    ser.free;
  end;
end;

На этом создание нового класса завершено. Теперь в основной программе нужно создать поток и запустить его выполнение.

  SerThread := TSerialThread.Create(True);
  SerThread.fPortName:=Form1.Edit1.Text;
  SerThread.fDataIn:=chr(5)+chr(0)+chr(0)+chr(0);
  SerThread.fStatusGet:=True;
  SerThread.Resume;

Переменная fStatusGet заставит вызываться не только функцию обновления StatusBar, но и вторую функцию обновления интерфейса.

Обновление от 18.08.2012: Очереди и блокировки

На момент написания первой версии статьи программа была в зачаточном состоянии и практически ничего не умела. Основная проблема состояла в том, что я работал с последовательным портом, который не может работать одновременно с двумя процессами. Проблема программы состояла в том, что при нажатии на кнопку “выключить все” запускался не один поток, а сразу два, которые работали параллельно. В итоге посылалась только команда выключить, а вторая команда отваливалась в связи с невозможностью открыть порт. В программу пришлось ввести несколько переменных, несколько процедур в класс потока и слегка изменить алгоритм. Начнем с изменений в самом классе потока.

    fBusy: boolean;
    procedure Busy;
    procedure CheckBusy;
    procedure ThreadTerminate;

Переменная fBusy это внутренний флаг статуса занятости порта, копирующий состояние флага занятости в основной программе. Он изменяется прямо в потоке, а процедурой Busy переностися в глобальную переменную SerialBusy: boolean;. Процедура CheckBusy выполняет перенос глобального флага занятости порта в переменную fBusy.

Для визуальных эффектов на форму добавлен обычный TShape, показывающий занятость порта, а также дополнительный TStatusBar (я знаю что в TStatusBar есть встроеные панельки; меня просто ломает все переписывать) в котором показывается количество заданий.

procedure TSerialThread.Busy;
begin
  if fBusy = True then
  begin
    Form1.Shape1.Brush.Color:=clRed;
    SerialBusy := True;
  end else
  begin
    Form1.Shape1.Brush.Color:=clGreen;
    SerialBusy :=False;
  end;
end;

procedure TSerialThread.CheckBusy;
begin
  if SerialBusy = True then
  begin
    Form1.Shape1.Brush.Color:=clRed;
    fBusy := True;
  end else
  begin
    Form1.Shape1.Brush.Color:=clGreen;
    fBusy :=False;
  end;
end;

Чтобы количество заданий работало, необходимо завести глобальную переменную в теле оснофной программы SerialQueued: Integer;. Именно ей нужно делать инкремент или декремент при создании или завершении потока. Я добавил эти действия в конструктор Create и процедуру ThreadTerminate.

constructor TSerialThread.Create(CreateSuspended: boolean);
begin
  FreeOnTerminate := True;
  inherited Create(CreateSuspended);
  Form1.Shape1.Brush.Color:=clRed;
  inc(SerialQueued);
  Form1.StatusBar2.SimpleText:=IntToStr(SerialQueued);
end;

procedure TSerialThread.ThreadTerminate;
begin
  Dec(SerialQueued);
  Form1.StatusBar2.SimpleText:=IntToStr(SerialQueued);
  if SerialQueued > 0 then Form1.Shape1.Brush.Color:=clRed;
end;

Теперь необходимо сделать проверку флагов прямо в процедуре Execute и ждать освобождения порта. Обратите внимание на условие (not Terminated) в цикле. Оно обязательно для всех циклов внутри потоков!

procedure TSerialThread.Execute;
var
  ser: TBlockSerial;
  answer: string;
begin
  Synchronize(@CheckBusy);
  while (not Terminated) and (fBusy) do
  begin
    //fStatusText := 'Ожидание очереди...';
    //Synchronize(@UpdateStatus);
    sleep(1500);
    Synchronize(@CheckBusy);
  end;
  fBusy := True;
  Synchronize(@Busy);
  ser := TBlockSerial.Create;
  try
    fStatusText := 'Инициализация порта ввода\вывода...';
    Synchronize(@UpdateStatus);
    ser.connect(fPortName);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    fStatusText := 'Подключение...';
    Synchronize(@UpdateStatus);
    ser.config(9600, 8, 'N', 0, False, False);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      ser.Free;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    fStatusText := 'Посылка команды...';
    Synchronize(@UpdateStatus);
    ser.sendstring(fDataIn);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      ser.Free;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    fStatusText := 'Ожидание ответа...';
    Synchronize(@UpdateStatus);
    answer := ser.RecvTerminated(2000, #13);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      ser.Free;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    if fStatusGet then
    begin
      fStatusText := 'Ожидание информации о состоянии...';
      Synchronize(@UpdateStatus);
      fStatus := ser.RecvTerminated(2000, #13);
      fStatus := ExtractWord(2, fStatus, StdWordDelims);
      if ser.LastError > 0 then
      begin
        fStatusText := ser.LastErrorDesc;
        Synchronize(@UpdateStatus);
        fBusy := False;
        ser.Free;
        Synchronize(@Busy);
        Synchronize(@ThreadTerminate);
        Terminate;
        Exit;
      end;
      if fStatus = '' then
        fStatus := '0000';
      Synchronize(@Draw);
    end;
    fStatusText := 'Команда выполнена';
    Synchronize(@UpdateStatus);
  finally

  end;
  ser.Free;
  fBusy := False;
  Synchronize(@Busy);
  Synchronize(@ThreadTerminate);
  Terminate;
end;

Заметьте, что в каждой обработке ошибки я начал уничтожать объект ser. Это связано с тем, что он не уничтожится простым Terminate. Всегда очищайте память от созданых объектов! Это позволит избежать утечек и прочих “непонятных” ошибок.

Теперь дело осталось за малым. В теле основной программы нужно запустить поочередно 2 потока с командами и ждать результата 🙂

procedure TForm1.Button5Click(Sender: TObject);
begin
  Timer1.Enabled := False;
  Button3.Enabled := False;

  SerThread := TSerialThread.Create(True);
  SerThread.fPortName := Edit1.Text;
  SerThread.fDataIn := chr(4) + chr(0) + chr(1) + chr(0);
  SerThread.Resume;

  SerThread := TSerialThread.Create(True);
  SerThread.fPortName := Form1.Edit1.Text;
  SerThread.fDataIn := chr(5) + chr(0) + chr(0) + chr(0);
  SerThread.fStatusGet := True;
  SerThread.Resume;
  Timer1.Enabled := True;
  Button3.Enabled := True;
end;

Ну и, конечно же, обещаное в начале статьи видео с демонстрацией работы:

А про критические секции (когда кусок кода не может быть выполнен одновременно несколькими процессами) я расскажу вам в следующий раз.

Всего 1 комментарий »

One response to “Lazarus: многопоточность в Linux и Windows”

  1. House says:
    August 4, 2012 at 17:14:18

    Познавательно.

Leave a Reply

Your email address will not be published. Required fields are marked *

CAPTCHA

*

Облачная платформа
Яндекс.Метрика

Fortune cookie: "Religion is the highest vanity." [Friedrich Hebbel]