多个线程的同步执行，优先级控制

实现多个线程共用一个资源的同步问题，并且根据优先级别高低，获取执行权限。

线程类例子三个在execute方法中根据自己的优先级获取令牌：

unit unitWorkThread1;
{*******************************************************}
{                                                       }
{       Delphi Thread Sample 4                          }
{       Creation Date 2012.12.21                        }
{       Created By: ming                                }
{                                                       }
{*******************************************************}

interface

uses
  Classes,Windows, Messages, SysUtils, Graphics, StdCtrls,
    unitMultiThreadManager;

type
  TWorkThread1 = class(TBaseThread)
  private
    { Private declarations }
    FEvent: HWND;
    FMsg: string;
    FMemo:  TMemo;
    FInterval,FTickTimes: Cardinal;
    FThreadManager: TMultiThreadManager;
    procedure doSyncProc1;
    procedure syncOutputMsg;
    procedure addLog(const msg: string); overload;
    procedure addLog(const fmtStr:string; const params: array of const); overload;
    procedure _sleep(millisecond:Cardinal);
  protected
    procedure Execute; override;
  public
    constructor Create(Suspend: boolean); overload;
    constructor Create(Suspend: boolean; mmoOutput: TMemo); overload;
    destructor Destroy; override;
  private
    FThreadPause,FThreadStop: Boolean;
    procedure doSomething;
  public
    function ThreadStart: Boolean;
    function ThreadPause: Boolean;
    function ThreadStop: Boolean;
    procedure ThreadTerminate;
  public
    property Interval: Cardinal read FInterval write FInterval;
    property ThreadManager: TMultiThreadManager read FThreadManager write FThreadManager;
  end;

implementation

{ TWorkThread1 }

constructor TWorkThread1.Create(Suspend: boolean);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,True,False,nil);
  FreeOnTerminate := True;
  FInterval := 1000;
end;

procedure TWorkThread1.addLog(const msg: string);
begin
  FMsg := msg;
  Synchronize(syncOutputMsg);
end;

procedure TWorkThread1.addLog(const fmtStr: string;
  const params: array of const);
begin
  FMsg := Format(fmtStr,params);
  Synchronize(syncOutputMsg);
end;

constructor TWorkThread1.Create(Suspend: boolean; mmoOutput: TMemo);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,True,False,nil);
  FreeOnTerminate := True;
  FInterval := 1000;
  FMemo := mmoOutput;
end;

destructor TWorkThread1.Destroy;
begin
  CloseHandle(FEvent);
  inherited;
end;

procedure TWorkThread1.doSomething;
begin
  //addLog(FormatDateTime('c',now));
  addLog('WorkThread1 is working...');
end;

procedure TWorkThread1.doSyncProc1;
begin

end;

procedure TWorkThread1.syncOutputMsg;
var
  dt: string;
begin
  dt := FormatDateTime('hh:nn:ss',now);
  FMsg := Format('[%s] - ',[dt]) + FMsg;
  if Assigned(FMemo) then
    FMemo.Lines.Add(FMsg);
end;

procedure TWorkThread1.Execute;
begin
  inherited;
  while not Terminated do
  begin
    if WaitForSingleObject(FEvent,1000)=WAIT_OBJECT_0 then
    begin
      Break;
    end;
    if FThreadManager.GetToken(Self) then
    try
      addLog('WorkThread1 GetToken');
      if (GetTickCount - FTickTimes) >= FInterval then
      try
        if not FThreadStop then
        begin
          doSomething;
          FTickTimes := GetTickCount;
        end;
      except on e:Exception do
        addLog(e.Message);
      end;
      _sleep(5 * 1000);
    finally
      addLog('WorkThread1 ReleaseToken');
      FThreadManager.ReleaseToken(Self)
    end
    else
      addLog('WorkThread1 is waiting...');
    if FThreadStop then
      Suspend;
  end;
end;

function TWorkThread1.ThreadStart: Boolean;
begin
  FThreadStop := False;
  if Suspended then Resume;
end;

function TWorkThread1.ThreadPause: Boolean;
begin
  FThreadPause := True;
  if not Suspended then Suspend;
end;

function TWorkThread1.ThreadStop: Boolean;
begin
  FThreadPause := False;
  FThreadStop := True;
  if Suspended then Resume;
end;

procedure TWorkThread1.ThreadTerminate;
begin
  FThreadStop := False;
  if FEvent>0 then
  begin
    SetEvent(FEvent);
    if Suspended then Resume;
  end;
end;

procedure TWorkThread1._sleep(millisecond: Cardinal);
begin
  //WaitForSingleObject(Self.Handle,millisecond);
  WaitForSingleObject(FEvent,millisecond);
end;

end.

unit unitWorkThread2;

{*******************************************************}
{                                                       }
{       Delphi Thread Sample 4                          }
{       Creation Date 2012.12.21                        }
{       Created By: ming                                }
{                                                       }
{*******************************************************}

interface

uses
  Classes,Windows, Messages, SysUtils, Graphics, StdCtrls,
    unitMultiThreadManager;

type
  TWorkThread2 = class(TBaseThread)
  private
    { Private declarations }
    FEvent: HWND;
    FMsg: string;
    FMemo:  TMemo;
    FInterval,FTickTimes: Cardinal;
    FThreadManager: TMultiThreadManager;
    procedure doSyncProc1;
    procedure syncOutputMsg;
    procedure addLog(const msg: string); overload;
    procedure addLog(const fmtStr:string; const params: array of const); overload;
    procedure _sleep(millisecond:Cardinal);
  protected
    procedure Execute; override;
  public
    constructor Create(Suspend: boolean); overload;
    constructor Create(Suspend: boolean; mmoOutput: TMemo); overload;
    destructor Destroy; override;
  private
    FThreadPause,FThreadStop: Boolean;
    procedure doSomething;
  public
    function ThreadStart: Boolean;
    function ThreadPause: Boolean;
    function ThreadStop: Boolean;
    procedure ThreadTerminate;
  public
    property Interval:Cardinal read FInterval write FInterval;
    property ThreadManager: TMultiThreadManager read FThreadManager write FThreadManager;    
  end;

implementation

{ TWorkThread2 }

constructor TWorkThread2.Create(Suspend: boolean);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,True,False,nil);
  FreeOnTerminate := True;
  FInterval := 1000;
end;

procedure TWorkThread2.addLog(const msg: string);
begin
  FMsg := msg;
  Synchronize(syncOutputMsg);
end;

procedure TWorkThread2.addLog(const fmtStr: string;
  const params: array of const);
begin
  FMsg := Format(fmtStr,params);
  Synchronize(syncOutputMsg);
end;

constructor TWorkThread2.Create(Suspend: boolean; mmoOutput: TMemo);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,True,False,nil);
  FreeOnTerminate := True;
  FInterval := 1000;
  FMemo := mmoOutput;
end;

destructor TWorkThread2.Destroy;
begin
  CloseHandle(FEvent);
  inherited;
end;

procedure TWorkThread2.doSomething;
begin
  //addLog(FormatDateTime('c',now));
  addLog('WorkThread2 is working...');  
end;

procedure TWorkThread2.doSyncProc1;
begin

end;

procedure TWorkThread2.syncOutputMsg;
var
  dt: string;
begin
  dt := FormatDateTime('hh:nn:ss',now);
  FMsg := Format('[%s] - ',[dt]) + FMsg;
  if Assigned(FMemo) then
    FMemo.Lines.Add(FMsg);
end;

procedure TWorkThread2.Execute;
begin
  inherited;
  while not Terminated do
  begin
    if WaitForSingleObject(FEvent,1000)=WAIT_OBJECT_0 then
    begin
      Break;
    end;
    if FThreadManager.GetToken(Self) then
    try
      addLog('WorkThread2 GetToken');
      if (GetTickCount - FTickTimes) >= FInterval then
      try
        if not FThreadStop then
        begin
          doSomething;
          FTickTimes := GetTickCount;
        end;
      except on e:Exception do
        addLog(e.Message);
      end;
    finally
      addLog('WorkThread2 ReleaseToken');
      FThreadManager.ReleaseToken(Self)
    end
    else
      addLog('WorkThread2 is waiting...');
    if FThreadStop then
      Suspend;
  end;
end;

function TWorkThread2.ThreadStart: Boolean;
begin
  FThreadStop := False;
  if Suspended then Resume;
end;

function TWorkThread2.ThreadPause: Boolean;
begin
  FThreadPause := True;
  if not Suspended then Suspend;
end;

function TWorkThread2.ThreadStop: Boolean;
begin
  FThreadPause := False;
  FThreadStop := True;
  if Suspended then Resume;
end;

procedure TWorkThread2.ThreadTerminate;
begin
  FThreadStop := False;
  if FEvent>0 then
  begin
    SetEvent(FEvent);
    if Suspended then Resume;
  end;
end;

procedure TWorkThread2._sleep(millisecond: Cardinal);
begin
  //WaitForSingleObject(Self.Handle,millisecond);
  WaitForSingleObject(FEvent,millisecond);
end;

end.

unit unitWorkThread3;

{*******************************************************}
{                                                       }
{       Delphi Thread Sample 4                          }
{       Creation Date 2012.12.21                        }
{       Created By: ming                                }
{                                                       }
{*******************************************************}

interface

uses
  Classes,Windows, Messages, SysUtils, Graphics, StdCtrls,
    unitMultiThreadManager;

type
  TWorkThread3 = class(TBaseThread)
  private
    { Private declarations }
    FEvent: HWND;
    FMsg: string;
    FMemo:  TMemo;
    FInterval,FTickTimes: Cardinal;
    FThreadManager: TMultiThreadManager;
    procedure doSyncProc1;
    procedure syncOutputMsg;
    procedure addLog(const msg: string); overload;
    procedure addLog(const fmtStr:string; const params: array of const); overload;
    procedure _sleep(millisecond:Cardinal);
  protected
    procedure Execute; override;
  public
    constructor Create(Suspend: boolean); overload;
    constructor Create(Suspend: boolean; mmoOutput: TMemo); overload;
    destructor Destroy; override;
  private
    FThreadPause,FThreadStop: Boolean;
    procedure doSomething;
  public
    function ThreadStart: Boolean;
    function ThreadPause: Boolean;
    function ThreadStop: Boolean;
    procedure ThreadTerminate;
  public
    property Interval:Cardinal read FInterval write FInterval;
    property ThreadManager: TMultiThreadManager read FThreadManager write FThreadManager;    
  end;

implementation

{ TWorkThread3 }

constructor TWorkThread3.Create(Suspend: boolean);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,True,False,nil);
  FreeOnTerminate := True;
  FInterval := 1000;
end;

procedure TWorkThread3.addLog(const msg: string);
begin
  FMsg := msg;
  Synchronize(syncOutputMsg);
end;

procedure TWorkThread3.addLog(const fmtStr: string;
  const params: array of const);
begin
  FMsg := Format(fmtStr,params);
  Synchronize(syncOutputMsg);
end;

constructor TWorkThread3.Create(Suspend: boolean; mmoOutput: TMemo);
begin
  inherited Create(Suspend);
  FEvent := CreateEvent(nil,True,False,nil);
  FreeOnTerminate := True;
  FInterval := 1000;
  FMemo := mmoOutput;
end;

destructor TWorkThread3.Destroy;
begin
  CloseHandle(FEvent);
  inherited;
end;

procedure TWorkThread3.doSomething;
begin
  addLog('WorkThread3 is working...');
end;

procedure TWorkThread3.doSyncProc1;
begin

end;

procedure TWorkThread3.syncOutputMsg;
var
  dt: string;
begin
  dt := FormatDateTime('hh:nn:ss',now);
  FMsg := Format('[%s] - ',[dt]) + FMsg;
  if Assigned(FMemo) then
    FMemo.Lines.Add(FMsg);
end;

procedure TWorkThread3.Execute;
begin
  inherited;
  while not Terminated do
  begin
    if WaitForSingleObject(FEvent,1000)=WAIT_OBJECT_0 then
    begin
      Break;
    end;
    if FThreadManager.GetToken(Self) then
    try
      addLog('WorkThread3 GetToken');
      if (GetTickCount - FTickTimes) >= FInterval then
      try
        if not FThreadStop then
        begin
          doSomething;
          FTickTimes := GetTickCount;
        end;
      except on e:Exception do
        addLog(e.Message);
      end;
    finally
      addLog('WorkThread3 ReleaseToken');
      FThreadManager.ReleaseToken(Self)
    end
    else
      addLog('WorkThread3 is waiting...');
    if FThreadStop then
      Suspend;
  end;
end;

function TWorkThread3.ThreadStart: Boolean;
begin
  FThreadStop := False;
  if Suspended then Resume;
end;

function TWorkThread3.ThreadPause: Boolean;
begin
  FThreadPause := True;
  if not Suspended then Suspend;
end;

function TWorkThread3.ThreadStop: Boolean;
begin
  FThreadPause := False;
  FThreadStop := True;
  if Suspended then Resume;
end;

procedure TWorkThread3.ThreadTerminate;
begin
  FThreadStop := False;
  if FEvent>0 then
  begin
    SetEvent(FEvent);
    if Suspended then Resume;
  end;
end;

procedure TWorkThread3._sleep(millisecond: Cardinal);
begin
  //WaitForSingleObject(Self.Handle,millisecond);
  WaitForSingleObject(FEvent,millisecond);
end;

end.

临界区同步类

unit RTLCriticalSection;

interface

uses Windows,Classes;

type
  TCriticalSection = class(TObject)
  protected
    FSection: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Enter;
    procedure Leave;
    function TryEnter: Boolean;
  end;

implementation

{TCriticalSection}
constructor TCriticalSection.Create;
begin
  InitializeCriticalSection(FSection);
end;

destructor TCriticalSection.Destroy;
begin
  DeleteCriticalSection(FSection);
end;

procedure TCriticalSection.Enter;
begin
  EnterCriticalSection(FSection);
end;

procedure TCriticalSection.Leave;
begin
  LeaveCriticalSection(FSection);
end;

function TCriticalSection.TryEnter: Boolean;
begin
  Result := TryEnterCriticalSection(FSection);
end;

end.

线程同步管理器

unit unitMultiThreadManager;
{*******************************************************}
{                                                       }
{       unitMultiThreadManager                          }
{       Creation Date 2013.03.29                        }
{       Created By: ming                                }
{                                                       }
{*******************************************************}

interface

uses
  Classes,Windows, Messages, SysUtils, StdCtrls,
  RTLCriticalSection;

type
  TBaseThread = class(TThread)
    private
      FQueueOrder: Byte;
    public
      property QueueOrder: Byte read FQueueOrder write FQueueOrder;
  end;

  TMultiThreadManager = class(TObject)
  private
    { Private declarations }
  public
    constructor Create;
    destructor Destroy; override;
  private
    FTokenLock,FQueueLock: TCriticalSection;
    FQueue: TList;
    function GetQueueOrder(a: TBaseThread): Byte;
    procedure LeaveQueue(a: TBaseThread);
  public
    function GetToken(a: TBaseThread): Boolean;
    function ReleaseToken(a: TBaseThread): Boolean;
  end;

implementation

{ TMultiThreadManager }

constructor TMultiThreadManager.Create;
begin
  FTokenLock := TCriticalSection.Create;
  FQueueLock := TCriticalSection.Create;
  FQueue := TList.Create;
end;

destructor TMultiThreadManager.Destroy;
begin
  FTokenLock.Free;
  FQueueLock.Free;
  FQueue.Free;
  inherited;
end;

function TMultiThreadManager.GetQueueOrder(a: TBaseThread):Byte;
var
  i: Integer;
begin
  FQueueLock.Enter;
  try
    if FQueue.IndexOf(a) <> - 1 then
    begin
      Result := TBaseThread(FQueue.Items[0]).QueueOrder;
      Exit;
    end;
    if FQueue.Count = 0 then
      FQueue.Add(a)
    else
    for i := 0 to FQueue.Count - 1 do
    begin
      if TBaseThread(FQueue.Items[i]).QueueOrder > a.QueueOrder then
      begin
        FQueue.Insert(i,a);
        Break;
      end;
    end;
    if i = FQueue.Count then
      FQueue.Add(a);
  finally
    FQueueLock.Leave;
  end;
  Result := TBaseThread(FQueue.Items[0]).QueueOrder;
end;

procedure TMultiThreadManager.LeaveQueue(a: TBaseThread);
var
  idx: Integer;
begin
  idx := FQueue.IndexOf(a);
  if idx <> - 1 then
    FQueue.Delete(idx);
end;

function TMultiThreadManager.GetToken(a: TBaseThread): Boolean;
begin
  Result := False;
  if GetQueueOrder(a) = a.QueueOrder then
  begin
    Result := FTokenLock.TryEnter;
  end;
end;

function TMultiThreadManager.ReleaseToken(a: TBaseThread): Boolean;
begin
  LeaveQueue(a);
  FTokenLock.Leave;
end;

end.

测试主窗体

unit unitMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, unitWorkThread1, unitWorkThread2, unitWorkThread3,
  unitMultiThreadManager;

type
  TfrmMain = class(TForm)
    btnStartAll: TButton;
    Memo1: TMemo;
    btnPuaseAll: TButton;
    btnStopAll: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnStartAllClick(Sender: TObject);
    procedure btnPuaseAllClick(Sender: TObject);
    procedure btnStopAllClick(Sender: TObject);
  private
    { Private declarations }
    FThread1: TWorkThread1;
    FThread2: TWorkThread2;
    FThread3: TWorkThread3;
    FThreadManager: TMultiThreadManager;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation


{$R *.dfm}

procedure TfrmMain.btnPuaseAllClick(Sender: TObject);
begin
  FThread1.ThreadPause;
  FThread2.ThreadPause;
  FThread3.ThreadPause;
end;

procedure TfrmMain.btnStartAllClick(Sender: TObject);
begin
  FThread1.ThreadStart;
  FThread2.ThreadStart;
  FThread3.ThreadStart;
end;

procedure TfrmMain.btnStopAllClick(Sender: TObject);
begin
  FThread1.ThreadStop;
  FThread2.ThreadStop;
  FThread3.ThreadStop;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FThread1 := TWorkThread1.Create(False,Memo1);
  FThread2 := TWorkThread2.Create(False,Memo1);
  FThread3 := TWorkThread3.Create(False,Memo1);
  FThreadManager := TMultiThreadManager.Create;
  FThread1.ThreadManager := FThreadManager;
  FThread1.QueueOrder := 1;
  FThread2.ThreadManager := FThreadManager;
  FThread2.QueueOrder := 2;
  FThread3.ThreadManager := FThreadManager;
  FThread3.QueueOrder := 3;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FThread1.ThreadTerminate;
  FThread2.ThreadTerminate;
  FThread3.ThreadTerminate;
  FThreadManager.Free;
end;

end.