I want to run multiple thread. Each thread should convert JPEG to Bitmap. Conversion works but my whole application is always using 12%-13% of CPU. I have an 8 core CPU so it seems the whole application uses just a single core. Also while the threads are working the main form is frozen and doesn't respond.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics,
Controls, Forms, Jpeg, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Str: TMemoryStream;
procedure OnTerminate(Sender: TObject);
end;
TMakeThumbThread= class(TThread)
private
FStream: TStream;
public
FBmp: TBitmap;
constructor Create(Str: TStream);
procedure Execute; override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TMakeThumbThread.Create(Str: TStream);
begin
inherited Create(True);
FStream := Str;
FreeOnTerminate := True;
end;
procedure TMakeThumbThread.Execute;
var Jpg: TJpegImage;
begin
FBmp := TBitmap.Create;
FBmp.PixelFormat := pf32bit;
FBmp.Width := 300;
FBmp.Height := 200;
Jpg := TJpegImage.Create;
FStream.Position := 0;
Jpg.LoadFromStream(FStream);
FBmp.Canvas.Draw(0,0, Jpg);
Jpg.Free;
DoTerminate;
FBmp.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var F: TFileStream;
i: Integer;
MT: TMakeThumbThread;
begin
Str := TMemoryStream.Create;
F := TFileStream.Create('test.jpg', fmOpenRead or fmShareDenyWrite);
Str.CopyFrom(F, F.Size);
F.Free;
for i:=0 to 500 do begin
MT := TMakeThumbThread.Create(Str);
MT.OnTerminate := OnTerminate;
MT.Execute;
end;
end;
procedure TForm1.OnTerminate(Sender: TObject);
var Bmp: TBitmap;
begin
Bmp := TMakeThumbThread(Sender).FBmp;
Form1.Canvas.Draw(1,1, Bmp );
end;
end.
You are manually calling the thread's Execute() method in the context of the main thread. DON'T DO THAT! That is why your UI is freezing. You are creating your threads in a suspended state and never resuming them.
You need to change this line:
MT.Execute;
To either this:
MT.Resume;
Or this:
MT.Start;
Depending on which version of Delphi you are using.
There are several other problems with your code, too.
The VCL's TBitmap class is not entirely thread-safe. You MUST Lock() the TBitmap.Canvas when working with a TBitmap in a worker thread, to prevent the main thread from ripping GDI resources away from the TBitmap unexpectedly.
You are sharing a single TMemoryStream with multiple threads to have them all load the same JPG image simultaneously. That will not work unless you wrap access to the TMemoryStream with a synchronization object, like a TCriticalSection or TMutex. Or, another option would be to use TCustomMemoryStream to create multiple streams that share a single memory block. Otherwise, you would be better off simply passing the JPG filename to each thread and let Execute() call TJpegImage.LoadFromFile() instead of TJpegImage.LoadFromStream().
You are calling FBmp.Free() at the end of Execute(), but then you are accessing FBmp afterwards in the OnTerminate event handler. You need to delay the call to FBmp.Free() until after the OnTerminate event handler exits, such as in the thread's destructor.
You are drawing the bitmaps directly on the TForm.Canvas from outside of the Form's OnPaint event. As such, as soon as your Form need to redraw itself for any reason, your drawn images will be lost. If you want the images to be persistent for the Form's lifetime, you need to save them and draw them whenever the OnPaint event fires. Or, you can simply assign them to TImage components and let them handle the drawing for you.
Related
I'm using Delphi XE7 on Windows 10.
I have been using the following code for a long time, and just read the documentation on SetTimer(). To state it simply, I am setting timers from non-UI threads, but Microsoft's documentation says they should only be set on the UI thread. Extensive tests show my code works fine, but I can't trust my system to behave the same as other systems, or the Microsoft documentation to be 100% accurate. Can anyone verify whether this code is OK or not OK?
The Delphi code will not deadlock, it pretty much just calls SetTimer() (I am aware there is a race condition setting TTimer.FEnabled).
The MSDN documentation says:
hWnd
Type: HWND
A handle to the window to be associated with the timer. This window must be owned by the calling thread.
What I'm trying to accomplish is worker threads doing stuff, and when appropriate, they notify the main thread that elements of the UI must be updated, and the main thread updates the UI. I know how to use TThread.Synchronize(), but deadlocks can happen in certain cases. I can use PostMessage() from my worker threads and handle the message in the UI thread.
Is there any other way in Delphi to notify and update the UI thread?
unit FormTestSync;
interface
uses SysUtils, Classes, Forms, StdCtrls, ExtCtrls, Controls;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
timer_update: TTimer;
Label1: TLabel;
procedure timer_updateTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
m_thread: TypeThreadTest;
m_value: integer;
private
procedure Notify(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while (not terminated) do begin
//do work...
form1.Notify(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
timer_update.enabled := false;
timer_update.interval := 1;
m_thread := TypeThreadTest.Create();
end;
procedure TForm1.Notify(value: integer);
begin
//run on worker thread
//Race conditions here, I left out the synchronization for simplicity
m_value := value;
timer_update.Enabled := true;
end;
procedure TForm1.timer_updateTimer(Sender: TObject);
begin
timer_update.Enabled := false;
label1.Caption := IntToStr(m_value);
end;
end.
The TTimer is being constructed in the main UI thread, when the TForm streams in its DFM resource. The TTimer's constructor creates an internal HWND for the timer to receive WM_TIMER messages with. That HWND is thus owned by the main UI thread.
TForm.Notify() is setting the timer's Enabled property to true, which will call SetTimer(). Notify() is being called in the context of the worker thread, not the main UI thread. This SHOULD NOT work, as stated in SetTimer()'s documentation. Only the main UI thread should be able to start the timer running, since the main UI thread owns the timer's HWND.
TTimer.UpdateTimer(), which is called internally by the setters of the timer's Enabled, Interval and OnTimer properties, will raise an EOutOfResources exception if SetTimer() fails. So, calling form1.Notify() in TypeThreadTest.Execute() SHOULD NOT work. The only way SetTimer() would not be called in that situation is if either:
Interval is 0
Enabled is false
OnTimer is unassigned
Otherwise, your worker thread SHOULD be crashing.
As you have noted, your worker thread can alternatively use TThread.Synchronize() (or TThread.Queue()), or PostMessage() (or SendMessage()), when it wants to notify the main UI thread to do something. These are viable and preferred solutions. Personally, I would opt for TThread.Queue(), eg:
unit FormTestSync;
interface
uses
SysUtils, Classes, Forms, StdCtrls, ExtCtrls, Controls;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
m_thread: TypeThreadTest;
private
procedure Notify(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while not Terminated do begin
//do work...
Form1.Notify(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
m_thread := TypeThreadTest.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
m_thread.Terminate;
m_thread.WaitFor;
m_thread.Free;
end;
procedure TForm1.Notify(value: integer);
begin
//runs on worker thread
TThread.Queue(nil,
procedure
begin
//runs on main UI thread
Label1.Caption := IntToStr(value);
end
);
end;
end.
If you want to use TTimer instead for this work, what you could do is simply enable the timer in the main UI thread and leave it enabled, and just synchronize access to the data that the timer accesses periodically. That would be perfectly safe, eg:
unit FormTestSync;
interface
uses
SysUtils, Classes, Forms, StdCtrls, ExtCtrls, Controls, SyncObjs;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
timer_update: TTimer;
Label1: TLabel;
procedure timer_updateTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
m_thread: TypeThreadTest;
m_value: integer;
m_updated: boolean;
m_lock: TCriticalSection;
private
procedure UpdateValue(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while not Terminated do begin
//do work...
Form1.UpdateValue(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
m_lock := TCriticalSection.Create;
timer_update.Interval := 100;
timer_update.Enabled := true;
m_thread := TypeThreadTest.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
m_thread.Terminate;
m_thread.WaitFor;
m_thread.Free;
m_lock.Free;
end;
procedure TForm1.UpdateValue(value: integer);
begin
//runs on worker thread
m_lock.Enter;
try
m_value := value;
m_updated := true;
finally
m_lock.Leave;
end;
end;
procedure TForm1.timer_updateTimer(Sender: TObject);
begin
//runs on main UI thread
if m_updated then
begin
m_lock.Enter;
try
Label1.Caption := IntToStr(m_value);
m_updated := false;
finally
m_lock.Leave;
end;
end;
end;
end.
UPDATE:
I did a quick test. When SetTimer() is called with a non-NULL HWND that is owned by another thread, sure enough on Windows XP, 7 and 10 (I did not test Vista or 8), SetTimer() succeeds, and the WM_TIMER/TimerProc is called in the context of the thread that owns the HWND, not the thread that is calling SetTimer(). This is NOT documented behavior, so do not rely on it! SetTimer()'s documentation clearly says the HWND "must be owned by the calling thread", as you stated in your question.
In any case, TTimer is a VCL component, and the VCL is inherently not thread-safe in general. Even though your TTimer code "works", it is not a good idea to access UI components outside of the main UI thread anyway, that is just bad code design. Stick with an alternative solution that is known to be thread-safe.
Edit: Thread safety is extremely difficult. I inserted AllocateHwnd() to replace self.handle according to mghie's comment.
Here is how I am planning to implement the UI notification + update. It's not any more complicated than the TTimer approach, and it doesn't have any thread safety issues that I know of. Different messages can be defined for different items that need to be updated.
If update notifications could be sent very rapidly, a variation on this theme is necessary to reduce the number of PostMessage calls. Also modifications are necessary if value cannot fit into WParam.
unit FormTestSync;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Forms, StdCtrls,
Controls;
type
TypeThreadTest = class(TThread)
protected
procedure Execute; override;
end;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
const
WM_UPDATE = WM_USER + 1;
procedure OnMessage_Update(var message: TMessage);
private
m_thread: TypeThreadTest;
m_hwndAlwaysThere: HWND;
private
procedure Notify(value: integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TypeThreadTest.Execute;
begin
while (not terminated) do begin
//do work...
form1.Notify(random(MaxInt));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
m_hwndAlwaysThere := AllocateHWnd(self.OnMessage_Update);
m_thread := TypeThreadTest.Create();
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
m_thread.Terminate;
m_thread.WaitFor;
m_thread.Free;
DeallocateHWnd(m_hwndAlwaysThere);
end;
procedure TForm1.Notify(value: integer);
begin
//run on worker thread
PostMessage(m_hwndAlwaysThere, WM_UPDATE, value, 0);
end;
procedure TForm1.OnMessage_Update(var message: TMessage);
begin
//run on UI thread
label1.Caption := IntToStr(message.WParam);
end;
end.
I'm using the TThread.DoTerminate method to notify to the main thread which the TThread has terminated. but as soon try to change the properties of some controls (buttons) from inside of the DoTerminate both controls just disappear of the form.
Also when I close the Form I'm getting this message
Project ProjectTest.exe raised exception class EOSError with message
'System Error. Code: 1400. Invalid window handle'.
This is a sample application to reproduce the issue.
type
TFooThread = class;
TFormSample = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
ProgressBar1: TProgressBar;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FooThread : TFooThread;
procedure ThreadIsDone;
public
end;
TFooThread = class(TThread)
private
FForm : TFormSample;
protected
procedure DoTerminate; override;
public
procedure Execute; override;
constructor Create(AForm : TFormSample); reintroduce;
destructor Destroy; override;
end;
var
FormSample: TFormSample;
implementation
{$R *.dfm}
{ TFooThread }
constructor TFooThread.Create(AForm: TFormSample);
begin
inherited Create(False);
FreeOnTerminate := False;
FForm := AForm;
end;
destructor TFooThread.Destroy;
begin
inherited;
end;
procedure TFooThread.DoTerminate;
begin
FForm.ThreadIsDone;
inherited;
end;
procedure TFooThread.Execute;
var
i : Integer;
begin
for i := 1 to 100 do
begin
Synchronize(
procedure
begin
FForm.ProgressBar1.Position := i;
end
);
Sleep(50);
end;
Terminate();
end;
{ TFormSample }
procedure TFormSample.Button1Click(Sender: TObject);
begin
FooThread := TFooThread.Create(Self);
TButton(Sender).Enabled := false;
end;
procedure TFormSample.FormCreate(Sender: TObject);
begin
FooThread := nil;
Button3.Visible := False;
end;
procedure TFormSample.FormDestroy(Sender: TObject);
begin
if (FooThread<>nil) then
begin
if not FooThread.Terminated then
FooThread.WaitFor;
FooThread.Free;
end;
end;
procedure TFormSample.ThreadIsDone;
begin
//this code is executed but the controls are not updated
//both buttons just disappear from the form !!!!
//Also if I remove these lines, no error is raised.
Button2.Visible := False;
Button3.Visible := True;
end;
end.
The question is : How I can update the properties of some VCL control as soon the TThread is finished?
It should be fine to update controls inside DoTerminate (as you are).
DoTerminate runs in the context of the thread. Therefore it is not safe to update controls from that method. The base implementation synchronises a call to the OnTerminate event.
So OnTerminate is already synchronised. And it will be safe to update controls from an OnTerminate event handler.
However, I would be more inclined to not have code inside the thread class calling the form because this creates a circular dependency. Rather have the form assign a handler for the OnTerminateevent. This way code that controls the form will be in the form class. You can do the same with the control updates to indicate thread progress.
FooThread := TFooThread.Create(...);
//WARNING: If you need to do **any**
//initialisation after creating a
//thread, it's better to create it
//in a Suspended state.
FooThread.OnTerminate := ThreadIsDone;
//Of course you'll have to change the signature of ThreadIsDone accordingly.
FooThread.OnProgress := ThreadProgress;
//You'd have to define a suitable callback event on the thread.
//Finally, if the thread started in a suspended state, resume it.
FooThread.Start;
Avoiding circular dependencies is a little more work, but greatly simplifies an application.
David mentions that you can create your thread in a running state. To do so safely you must:
Pass all necessary initialisation information into the constructor.
And inside the constructor perform all initialisation before calling the inherited constructor.
Also you have a mistake in your Execute method:
procedure TFooThread.Execute;
var
i : Integer;
begin
...
Terminate(); //This is pointless.
//All it does is set Terminated := True;
end;
The thread terminates when it exits. All the call to Terminate does is set an internal flag to indicate the thread should terminate. You'd normally write your Execute method as follows:
begin
while not Terminated do
begin
...
end;
end;
Then your form might have a button which calls: FooThread.Terminate();
This will cause your while loop to exit at the end of the current iteration. This allows the thread to exit "gracefully".
I am implementing a pool of objects in Delphi. I need to synchronize the threads to get the objects from the pool.
Thread Code:
uClientQueryPool.CLIENT_POOL_GUARD.Acquire();
QueryClient := QUERY_POOL.GetClient();
uClientQueryPool.CLIENT_POOL_GUARD.Release;
Pool Code:
var
CLIENT_POOL_GUARD: TCriticalSection;
type
TClientQueryPool = class
public
function GetClient(): TQueryClient;
end;
The CLIENT_POOL_GUARD is a unit variable. The pool is working well, but can I use "uClientQueryPool.CLIENT_POOL_GUARD.Acquire();" and "uClientQueryPool.CLIENT_POOL_GUARD.Release;" inside the GetClient method?
Like this:
function TClientQueryPool.GetClient: TQueryClient;
begin
CLIENT_POOL_GUARD.Acquire();
...
CLIENT_POOL_GUARD.Release;
end;
Moving the lock inside the get/pop/whatever method is just fine, as is making the CriticalSection instance a private member of the pool class. Use the same CS in the release() call that pushes the objects back onto the pool.
Been doing this for decades, usually with TObjectQueue as the pool queue, a CS to protect it and a semaphore to count the pool contents and something for requesting threads to block on if the pool empties temporarily.
Don't know where that 'double acquire' thread came from. Either the lock is inside the pool class, or outside. I really can't imagine why anyone would code up both!
Example classes:
First, thread-safe P-C queue, for holding the pooled objects:
unit tinySemaphoreQueue;
interface
uses
Windows, Messages, SysUtils, Classes,syncObjs,contnrs;
type
pObject=^Tobject;
TsemaphoreMailbox=class(TobjectQueue)
private
countSema:Thandle;
protected
access:TcriticalSection;
public
property semaHandle:Thandle read countSema;
constructor create; virtual;
procedure push(aObject:Tobject); virtual;
function pop(pResObject:pObject;timeout:DWORD):boolean; virtual;
end;
implementation
{ TsemaphoreMailbox }
constructor TsemaphoreMailbox.create;
begin
inherited Create;
access:=TcriticalSection.create;
countSema:=createSemaphore(nil,0,maxInt,nil);
end;
function TsemaphoreMailbox.pop(pResObject: pObject;
timeout: DWORD): boolean;
begin // wait for a unit from the semaphore
result:=(WAIT_OBJECT_0=waitForSingleObject(countSema,timeout));
if result then // if a unit was supplied before the timeout,
begin
access.acquire;
try
pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
end;
procedure TsemaphoreMailbox.push(aObject: Tobject);
begin
access.acquire;
try
inherited push(aObject); // shove the object onto the queue
finally
access.release;
end;
releaseSemaphore(countSema,1,nil); // release one unit to semaphore
end;
end.
then object pool:
unit tinyObjectPool;
interface
uses
Windows, Messages, SysUtils, Classes,syncObjs,contnrs,
tinySemaphoreQueue;
type
TobjectPool=class;
TpooledObject=class(TObject)
private
FmyPool:TObjectPool;
protected
Fparameter:TObject;
public
procedure release;
constructor create(parameter:TObject); virtual;
end;
TpooledObjectClass=class of TpooledObject;
TobjectPool=class(TsemaphoreMailbox)
private
Fparameter:TObject;
function getPoolLevel: integer;
public
property poolLevel:integer read getPoolLevel;
constructor create(poolDepth:integer;
pooledObjectClass:TpooledObjectClass;parameter:TObject); reintroduce; virtual;
end;
implementation
{ TobjectPool }
constructor TobjectPool.create(poolDepth: integer;
pooledObjectClass: TpooledObjectClass;parameter:TObject);
var objectCount:integer;
thisObject:TpooledObject;
begin
inherited create;
Fparameter:=parameter; // a user parameter passed to all objects
for objectCount:=0 to poolDepth-1 do // fill up the pool with objects
begin
thisObject:=pooledObjectClass.create(parameter);
thisObject.FmyPool:=self;
inherited push(thisObject);
end;
end;
function TobjectPool.getPoolLevel: integer;
begin
access.acquire;
result:=inherited count;
access.release;
end;
{ TpooledObject }
constructor TpooledObject.create(parameter: TObject);
begin
inherited create;
Fparameter:=parameter;
end;
procedure TpooledObject.release;
begin
FmyPool.push(self);
end;
end.
Yes you can. Note, though that although you can pull an object from the pool in a thread-safe manner, it may not be thread-safe to use it if the object itself isn't thread-safe. For instance, in the example below, the pool is thread safe and even makes threads wait if all objects in the pool are in use, but once an object is in use, using it still is not thread safe, because it uses global data.
uses
SyncObjs;
var
GlobalData: Integer = 0;
type
TDataObject = class
Used: Boolean;
procedure UpdateData;
end;
type
TPool = class
FLock: TCriticalSection;
FSemaphore: TSemaphore;
FDataObjects: array[0..9] of TDataObject;
constructor Create;
destructor Destroy; override;
function GetDataObject: TDataObject;
procedure ReleaseDataObject(AObject: TDataObject);
end;
var
Pool: TPool;
type
TDataThread = class(TThread)
constructor Create;
procedure Execute; override;
end;
{ TPool }
constructor TPool.Create;
var
i: Integer;
begin
inherited Create;
FLock := TCriticalSection.Create;
FSemaphore := TSemaphore.Create(nil, Length(FDataObjects), Length(FDataObjects), '', False);
for i := Low(FDataObjects) to High(FDataObjects) do
FDataObjects[i] := TDataObject.Create;
end;
destructor TPool.Destroy;
var
i: Integer;
begin
for i := Low(FDataObjects) to High(FDataObjects) do
FDataObjects[i].Free;
FSemaphore.Free;
FLock.Free;
end;
function TPool.GetDataObject: TDataObject;
var
i: Integer;
begin
Result := nil;
FLock.Acquire;
try
FSemaphore.Acquire;
for i := Low(FDataObjects) to High(FDataObjects) do
if not FDataObjects[i].Used then
begin
Result := FDataObjects[i];
Result.Used := True;
Exit;
end;
Assert(Result <> nil, 'Pool did not return an object');
finally
FLock.Release;
end;
end;
procedure TPool.ReleaseDataObject(AObject: TDataObject);
begin
if not AObject.Used then
raise Exception.Create('Data object cannot be released, because it is not in use.');
AObject.Used := False;
FSemaphore.Release;
end;
{ TDataObject }
procedure TDataObject.UpdateData;
begin
Inc(GlobalData);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TDataThread.Create;
end;
{ TDataThread }
constructor TDataThread.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
Resume;
end;
procedure TDataThread.Execute;
var
DataObject: TDataObject;
begin
DataObject := Pool.GetDataObject;
DataObject.UpdateData; // <-- Not thread-safe!
Pool.ReleaseDataObject(DataObject);
end;
initialization
Pool := TPool.Create;
finalization
Pool.Free;
end.
1) I'd remove Acquire/Release code from threads code - it is fragile. In one thread you forget to call it - and ba-bang! Security measures, as a rule of thumb, should be centralized and enforced by server, not distributed in fuzzy way in clients.
2) Acquire/Release calls should be guarded from errors, else any stray exception would forever lock all the threads.
function TClientQueryPool.GetClient: TQueryClient;
begin
CS.Acquire;
try
// actually getting object, preferably just calling
// internal non-public thread-unsafe method for it
finally
CS.Release;
end;
end;
3) Critical section itself should better be a Pool's internal, non-public member. That way you would be allowed in future, when you forget of implementation details, easy refactoring, like:
3.1) implementing several pools
3.2) moving pool code to another unit
3.3) ensuring any stray erroneous code outside pool would not be able to crash the application be randomly acquiring or releasing the CS
4) Double calling of acquire/release over TCriticalSection object puts all your bets over implications from a single note in TCriticalSection documentation, pointed to by The_Fox.
"Each call to Release should be balance by an earlier call to Acquire"
http://docwiki.embarcadero.com/Libraries/en/System.SyncObjs.TCriticalSection.Release
And over the hope that all other Pascal implementations today and tomorrow would not miss it.
That is fragile practice. And multi-threading code is famous for creating Heisenbugs, when there are problems at clients sites, but you can not reproduce and find it in house.
If in future your company would expand to different platform or different language implementation, that puts a potential land mine. And the kind of mine, that would be hard to find by testing in house. Multithreading code is the place where you'd better be over-defeinsive and just do not allow ANY uncertainty to happen.
I'm new to multithreading, but not a complete novice. I need to perform a call to a webservice in a worker thread.
In the main thread I have a form (TForm) with a private data member (private string) that only the worker thread will write to (I pass the a pointer to it into the thread before it resumes). When the worker thread has finished its webservice call and written the resultant response xml to the private member on the form, the worker thread uses PostMessage to send a message to the form's handle (which I also passed into the thread before it resumed).
interface
const WM_WEBSERVCALL_COMPLETE = WM_USER + 1;
type
TWebServiceResponseXML = string;
PWebServiceResponseXML = ^TWebServiceResponseXML;
TMyForm = class(TForm)
...
private
...
fWorkerThreadID: Cardinal;
fWebServiceResponseXML: TWebServiceResponseXML;
public
...
procedure StartWorkerThread;
procedure OnWebServiceCallComplete(var Message: TMessage); Message WM_WEBSERVCALL_COMPLETE;
end;
TMyThread = class(TThread)
private
protected
procedure Execute; override;
public
SenderHandle: HWnd;
RequestXML: string;
ResponseXML: string;
IMyService: IService;
PResponseXML: PWebServiceResponseXML;
end;
implementation
procedure TMyForm.StartWorkerThread;
var
MyWorkerThread: TMyThread;
begin
MyWorkerThread := TMyThread.Create(True);
MyWorkerThread.FreeOnTerminate := True;
MyWorkerThread.SenderHandle := self.Handle;
MyWorkerThread.RequestXML := ComposeRequestXML;
MyWorkerThread.PResponseXML := ^fWebServiceResponseXML;
MyWorkerThread.Resume;
end;
procedure TMyForm.OnWebServiceCallComplete(var Message: TMessage);
begin
// Do what you want with the response xml string in fWebServiceResponseXML
end;
procedure TMyThread.Execute;
begin
inherited;
CoInitialize(nil);
try
IMyService := IService.GetMyService(URI);
ResponseXML := IMyService.Search(RequestXML);
PResponseXML := ResponseXML;
PostMessage(SenderHandle, WM_WEBSERVCALL_COMPLETE, 0, 0);
finally
CoUninitialize;
end;
end;
It works great, but now I want to do the same thing from a datamodule (which doesn't have a Handle)... so I would really appreciate some useful code to supplement the working model I have.
EDIT
What I really want is the code (if possible) that would allow me to replace the line
MyWorkerThread.SenderHandle := self.Handle;
with
MyWorkerThread.SenderHandle := GetHandleForThisSOAPDataModule;
I have used this technique before with some success: Sending messages to non-windowed applications
Basically, use a second thread as a message pump on a handle obtained via AllocateHWND. This is admittedly irritating, and you would be better off using a library to handle all the details. I prefer OmniThreadLibrary but there are others - see How Do I Choose Between the Various Ways to do Threading in Delphi? and Delphi - Threading frameworks.
You can allocate you own handle with AllocateHwnd and use that as a PostMessage target.
TTestThread = class(TThread)
private
FSignalShutdown: boolean;
// hidden window handle
FWinHandle: HWND;
protected
procedure Execute; override;
// our window procedure
procedure WndProc(var msg: TMessage);
public
constructor Create;
destructor Destroy; override;
procedure PrintMsg;
end;
constructor TTestThread.Create;
begin
FSignalShutdown := False;
// create the hidden window, store it's
// handle and change the default window
// procedure provided by Windows with our
// window procedure
FWinHandle := AllocateHWND(WndProc);
inherited Create(False);
end;
destructor TTestThread.Destroy;
begin
// destroy the hidden window and free up memory
DeallocateHWnd(FWinHandle);
inherited;
end;
procedure TTestThread.WndProc(var msg: TMessage);
begin
if Msg.Msg = WM_SHUTDOWN_THREADS then
// if the message id is WM_SHUTDOWN_THREADS
// do our own processing
FSignalShutdown := True
else
// for all other messages call
// the default window procedure
Msg.Result := DefWindowProc(FWinHandle, Msg.Msg,
Msg.wParam, Msg.lParam);
end;
You can apply this to anything not just threads. Just beware that AllocateHWND is NOT threade safe as indicated here.
Alternatives based on the use of an event:
Use OnTerminate of the thread (already present) in combination with a flag:
TMyDataModule = class(TDataModule)
private
procedure OnWebServiceCallComplete(Sender: TObject);
...
TMyThread = class(TThread)
public
property TerminateFlag: Integer ...
...
procedure TMyDataModule.StartWorkerThread;
...
MyWorkerThread.OnTerminate := <Self.>OnWebServiceCallComplete;
...
procedure TMyDataModule.OnWebServiceCallComplete(Sender: TObject);
begin
if MyWorkerThread.TerminateFlag = WEBCALL_COMPLETE then
...
end;
Set the TerminateFlag in the Execute routine. OnTerminate will automatically fire, even if FreeOnTerminate is True.
Add a new event property to the thread class in which you may provide the flag as a parameter to indicate termination/thread result. Something like shown here. Be sure to synchronize the event call. Or forget the parameter and just only call the event if execution completed gracefully (like you're doing now).
I make a logging application and I have a LogEvent object with some string properties on it. I want to make this logging asynchronous and in another thread for not blocking the applications GUI thread.
Idea is that when I start application, some LogEventThread is running on the background all the time. If LogEvent property has changed then thread is executed, after execution thread suspends and waits another LogEvent object property change and run it again if new property change is captured.
Which are the best practises to design this?
EDIT:
I created an example. Please tell me if I'm on the correct path.
I have a Form1:
unit MainWindow;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, TrackEventSenderThread, Generics.Collections, TrackEvent;
type
TForm1 = class(TForm)
btnTest: TButton;
procedure FormCreate(Sender: TObject);
procedure btnTestClick(Sender: TObject);
private
teqTrackEventSenderThread: TTrackEventSenderThread;
trackEventQueue: TThreadedQueue<TTrackEvent>;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btnTestClick(Sender: TObject);
var
trackEvent: TTrackEvent;
begin
trackEvent := TTrackEvent.Create;
trackEvent.Category := 'test';
trackEvent.Action := 'test';
trackEventQueue.PushItem(trackEvent);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
trackEventQueue := TThreadedQueue<TTrackEvent>.Create;
teqTrackEventSenderThread := TTrackEventSenderThread.Create(True);
teqTrackEventSenderThread.TrackEventQueue := trackEventQueue;
teqTrackEventSenderThread.Start;
end;
end.
TrackEvent class:
unit TrackEvent;
interface
type
TTrackEvent = class(TObject)
private
sCategory: string;
sAction: string;
public
property Category: string read sCategory write sCategory;
property Action: string read sAction write sAction;
end;
implementation
end.
And thread class:
unit TrackEventSenderThread;
interface
uses Classes, Generics.Collections, TrackEvent;
type
TTrackEventSenderThread = class(TThread)
private
trackEvent: TTrackEvent;
teqTrackEventQueue: TThreadedQueue<TTrackEvent>;
public
constructor Create(CreateSuspended: Boolean);
property TrackEventQueue: TThreadedQueue<TTrackEvent> read teqTrackEventQueue write teqTrackEventQueue;
protected
procedure Execute; override;
end;
implementation
constructor TTrackEventSenderThread.Create(CreateSuspended: Boolean);
begin
inherited;
end;
procedure TTrackEventSenderThread.Execute;
begin
while not Terminated do
begin
if teqTrackEventQueue.QueueSize > 0 then
begin
trackEvent := teqTrackEventQueue.PopItem;
//send data to server
end;
end;
end;
end.
You can build a thread-safe Queue class which is used in a Producer-Consumer model. Your TThread descendant class should own an instance of this Queue class.
When you start your application, your queue is empty, and your logging thread is blocked waiting for queue. When you push a new string into the queue from the main thread, your queue pulses the logging thread, your logging thread wakes up and pops items from the queue until the queue is empty again.
To implement the queue in Delphi 2010, you can use TQueue generic class as the base type, and use System.TMonitor for synchronization. In Delphi XE, there is already a class which implements this for you, named TThreadedQueue. So If you are using Delphi XE, create an instance of TThreadedQueue, and in your logging thread try to call its PopItem() method.
EDIT:
Here is a sample logging thread which receives string logs:
unit uLoggingThread;
interface
uses
SysUtils, Classes, Generics.Collections, SyncObjs {$IFDEF MSWINDOWS} , Windows {$ENDIF};
type
TLoggingThread = class(TThread)
private
FFileName : string;
FLogQueue : TThreadedQueue<string>;
protected
procedure Execute; override;
public
constructor Create(const FileName: string);
destructor Destroy; override;
property LogQueue: TThreadedQueue<string> read FLogQueue;
end;
implementation
{ TLoggingThread }
constructor TLoggingThread.Create(const FileName: string);
begin
inherited Create(False);
FFileName := FileName;
FLogQueue := TThreadedQueue<string>.Create;
end;
destructor TLoggingThread.Destroy;
begin
FLogQueue.Free;
inherited;
end;
procedure TLoggingThread.Execute;
var
LogFile : TFileStream;
FileMode : Word;
ALog : string;
begin
NameThreadForDebugging('Logging Thread');
// FreeOnTerminate := True;
if FileExists(FFileName) then
FileMode := fmOpenWrite or fmShareDenyWrite
else
FileMode := fmCreate or fmShareDenyWrite;
LogFile := TFileStream.Create(FFileName,FileMode);
try
while not Terminated do
begin
ALog := FLogQueue.PopItem;
if (ALog <> '') then
LogFile.Write(ALog[1],Length(ALog)*SizeOf(Char));
end;
finally
LogFile.Free;
end;
end;
end.
This TThread descendant uses a TThreadedQueue object as a buffer. When FLogQueue.PopItem is called, if the queue is empty, the thread goes to sleep, and waits until something is pushed into the queue. When an item is available in the queue, the thread pops it, and writes it to a file. This is a very simple code to just let you understand the basics of what you should do.
And here is a sample code for a form which is running in the context of main thread, and is logging a sample message:
unit fMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, uLogginThread;
type
TfrmMain = class(TForm)
btnAddLog: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnAddLogClick(Sender: TObject);
private
FLoggingThread : TLoggingThread;
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
FLoggingThread := TLoggingThread.Create(ExtractFilePath(Application.ExeName) + 'Logs.txt');
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
FLoggingThread.Terminate;
FLoggingThread.LogQueue.DoShutDown;
FLoggingThread.WaitFor;
FreeAndNil(FLoggingThread);
end;
procedure TfrmMain.btnAddLogClick(Sender: TObject);
begin
FLoggingThread.LogQueue.PushItem('This is a test log. ');
end;
end.
Here an instance of TLoggingThread is created when the form is initialized. When you press btnAddLog, a sample message is sent to the logger thread via its LogQueue property.
Take note of how the thread is terminated in FormDestroy method. First the thread is signaled that it is terminated, then we tell LogQueue to release any lock, so if the logger thread is waiting for the queue, it will wake up automatically after calling DoShutDown. Then we wait for the thread to finish up by calling WaitFor method, and eventually we destroy the thread instance.
Good Luck
In a multi-threaded application, use
TEvent to allow one thread to signal
to other threads that an event has
occurred.
http://docwiki.embarcadero.com/VCL/en/SyncObjs.TEvent
I would use a Queue of strings with a critical section inside push() and pop(). Inside the thread I would pop strings off, and log them. Inside the GUI thread I would push strings on the queue. I have done something similar before, and it is simple to implement.
Edit
Interface:
TThreadSafeQueue = class(TQueue)
protected
procedure PushItem(AItem: Pointer); override;
function PopItem: Pointer; override;
function PeekItem: Pointer; override;
end;
var
CRITICAL_SECTION: TCriticalSection;
Implementation:
function TThreadSafeQueue.PeekItem: Pointer;
begin
CRITICAL_SECTION.Enter;
Result := inherited PeekItem;
CRITICAL_SECTION.Leave;
end;
function TThreadSafeQueue.PopItem: Pointer;
begin
CRITICAL_SECTION.Enter;
Result := inherited PopItem;
CRITICAL_SECTION.Leave;
end;
procedure TThreadSafeQueue.PushItem(AItem: Pointer);
begin
CRITICAL_SECTION.Enter;
inherited PushItem(AItem);
CRITICAL_SECTION.Leave;
end;
Initialization
CRITICAL_SECTION := TCriticalSection.Create;
Finalization
FreeAndNil(CRITICAL_SECTION);
This code uses pointers to objects, but you can create storage for your strings inside the object, using a stringlist or array or whatever best fits your purpose, and change the pop and push methods to operate on your own storage.
Edit
Something like this:
procedure TMyThread.Execute;
var
Msg: string;
begin
while not Terminated do
begin
if FQueue.Count > 0 then
begin
Msg := FQueue.pop();
PerformLog(Msg); {Whatever your logging method is}
end;
Sleep(0);
end;
end;