The following code minimally demonstrates the problem. In a background thread, I create a valid handle array and pass it to WaitForMultipleObjects and this successfully waits on the objects.
When passing the exact same array to MsgWaitForMultipleObjects, however, the function call fails (WAIT_FAILED) with ERROR_INVALID_HANDLE.
What am I doing wrong?
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows, SyncObjs, Classes;
type
TMyThread = class(TThread)
protected
procedure Execute; override;
end;
procedure TMyThread.Execute;
var
LEvent : TEvent;
LWaitHandles : TWOHandleArray;
LPWaitHandles : PWOHandleArray;
LWaitResult : Cardinal;
begin
LEvent := TEvent.Create;
LWaitHandles[0] := LEvent.Handle;
LPWaitHandles := #LWaitHandles;
while not Terminated do begin
{Works -> LWaitResult := WaitForMultipleObjects(1, LPWaitHandles, false, INFINITE);}
{Fails ->} LWaitResult := MsgWaitForMultipleObjects(1, LPWaitHandles, false, INFINITE, QS_ALLINPUT);
case LWaitResult of
WAIT_OBJECT_0: WriteLn('Event 1 Signaled');
{ etc... }
WAIT_FAILED : WriteLn(SysErrorMessage(GetLastError));
end;
end;
end;
var
lt : TMyThread;
begin
lt := TMyThread.Create(false);
ReadLn;
end.
Although the WinAPI signature for the handles parameter is identical for these two calls :
_In_ const HANDLE *pHandles,
the RTL nevertheless wraps these functions in different ways. WaitForMultipleObjects uses the pointer type:
lpHandles: PWOHandleArray;
while MsgWaitForMultipleObjects uses an untyped var parameter:
var pHandles;
The handle array must therefore be passed directly to MsgWaitForMultipleObjects.
ie:
LWaitResult := MsgWaitForMultipleObjects(1, LWaitHandles, false, INFINITE, QS_ALLINPUT);
Related
I want to make an integer result from a thread. It's just a simple calculation.
My problem, I can not have an "instant" result from it. I have execute more than once, then I got the correct result.
Here the unit form :
unit Unit1;
interface
uses
System.SysUtils,
System.Classes,
Vcl.Controls, Vcl.Forms, Vcl.StdCtrls;
type
TForm1 = class(TForm)
btn1: TButton;
mmo1: TMemo;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure CaclDone(Sender: TObject);
procedure BeginCal(calA, calB: Integer);
function StartCalc(const calA, calB: Integer): Int64;
end;
var
nOut: Int64;
Form1: TForm1;
implementation
{$R *.dfm}
uses uCalculationThread;
procedure TForm1.BeginCal(calA: Integer; calB: Integer);
var
P: TCalc;
begin
nOut := 0;
P := TCalc.Create;
P.numa := calA;
P.numb := calB;
P.OnTerminate := CaclDone;
P.Start;
end;
procedure TForm1.CaclDone(Sender: TObject);
var
P: TCalc;
begin
P := TCalc(Sender);
nOut := P.iOut;
mmo1.Lines.Add('on thread finished : ' + IntToStr(nOut)); // < here is instant result
end;
function TForm1.StartCalc(const calA, calB: Integer): Int64;
begin
BeginCal(calA, calB);
Result := nOut;
end;
procedure TForm1.btn1Click(Sender: TObject);
var
i: Int64;
begin
i := StartCalc(10, 20);
mmo1.Lines.Add('on function call : ' + IntToStr(i)); // first result always 0
end;
end.
And here is the threading unit
unit uCalculationThread;
interface
uses
System.Classes;
type
TCalc = class(TThread)
private
fiOut: Int64;
fnumA, fNumB: Integer;
protected
procedure Execute; override;
public
property numA: Integer read fnumA write fnumA;
property numb: Integer read fNumB write fNumB;
property iOut: Int64 read fiOut write fiOut;
constructor Create;
end;
implementation
constructor TCalc.Create;
begin
inherited Create(True);
FreeOnTerminate := True;
end;
procedure TCalc.Execute;
begin
fiOut := fnumA + fNumB;
end;
end.
What I need is a simple function to have the result from that thread.
Consider this method:
function TForm1.StartCalc(const calA, calB: Integer): Int64;
begin
BeginCal(calA, calB);
Result := nOut;
end;
It calls BeginCal, which creates a thread and starts its execution. The result of the thread is passed through the OnTerminate event which calls CaclDone and assigns the result to the nOut variable.
Since the OnTerminate event is executed in the main thread, this will happen after the execution of StartCalc. Hence, there will be no valid value for StartCalc to return.
What I need is a simple function to have the result from that thread.
This means that the main thread will have to wait for the thread to finish its execution. That defeats the way the GUI is supposed to behave.
You already have a mechanism for getting the result in the CaclDone method.
The way to handle an async calculation chain in this situation is to do something like this (uses System.Threading):
function MyAdd( a,b : Int64): Int64;
begin
Result := a + b;
end;
procedure TForm1.btn1Click(Sender: TObject);
begin
TTask.Create(
procedure
var
i: Int64;
begin
i := MyAdd(10,20);
TThread.Queue(nil, // Result is presented in the main thread.
procedure
begin
mmo1.Lines.Add('on function call : ' + IntToStr(i));
if (i <> 4) then
mmo1.Lines.Add('on function call : <> 4');
end);
end).Start;
end;
Continue from my other question:
How do I pass and retrieve memory stream from my Application to/from DLL?
I have wrote the DLL using IStream as input/output. The DLL uses IXMLDocument (which at first I thought was related to the follow problem)
Tested it, and it worked well in the main UI. Problems began when I was calling the DLL from a worker thread.
The DLL:
library MyDLL;
uses
Windows,
Variants,
SysUtils,
Classes,
AxCtrls,
ActiveX,
XMLDoc,
XMLIntf;
{$R *.res}
procedure Debug(V: Variant);
begin
OutputDebugString(PChar(VarToStr(V)));
end;
procedure DoProcess(InStream, OutStream: TStream);
var
Doc: IXMLDocument;
begin
InStream.Position := 0;
Doc := TXMLDocument.Create(nil);
Doc.LoadFromStream(InStream);
// plans to do some real work...
OutStream.Position := 0;
Debug('MyDLL DoProcess OK');
end;
function Process(AInStream, AOutStream: IStream): Integer; stdcall;
var
InStream, OutStream: TStream;
begin
try
InStream := TOleStream.Create(AInStream);
try
OutStream := TOleStream.Create(AOutStream);
try
DoProcess(InStream, OutStream);
Result := 0;
finally
OutStream.Free;
end;
finally
InStream.Free;
end;
except
on E: Exception do
begin
Result := -1;
Debug('MyDLL Error: ' + E.Message);
end;
end;
end;
exports
Process;
begin
end.
And my caller application:
implementation
uses
ActiveX,ComObj;
{$R *.dfm}
procedure Debug(V: Variant);
begin
OutputDebugString(PChar(VarToStr(V)));
end;
const
MyDLL = 'MyDLL.dll';
{$DEFINE STATIC_DLL}
{$IFDEF STATIC_DLL}
function Process(AInStream, AOutStream: IStream): Integer; stdcall; external MyDLL;
{$ENDIF}
type
// Dynamic
TDLLProcessProc = function(AInStream, AOutStream: IStream): Integer; stdcall;
function DLLProcess(AInStream, AOutStream: TStream): Integer;
var
InStream, OutStream: IStream;
Module: HMODULE;
DLLProc: TDLLProcessProc;
begin
InStream := TStreamAdapter.Create(AInStream, soReference);
OutStream := TStreamAdapter.Create(AOutStream, soReference);
{$IFDEF STATIC_DLL}
Result := Process(InStream, OutStream); // Static
Exit;
{$ENDIF}
// Dynamic load DLL ...
Module := LoadLibrary(MyDLL);
if Module = 0 then RaiseLastOSError;
try
DLLProc := GetProcAddress(Module, 'Process');
if #DLLProc = nil then RaiseLastOSError;
Result := DLLProc(InStream, OutStream);
finally
FreeLibrary(Module);
end;
end;
type
TDLLThread = class(TThread)
private
FFileName: string;
public
constructor Create(CreateSuspended: Boolean; AFileName: string);
procedure Execute(); override;
end;
constructor TDLLThread.Create(CreateSuspended: Boolean; AFileName: string);
begin
FreeOnTerminate := True;
FFileName := AFileName;
inherited Create(CreateSuspended);
end;
procedure TDLLThread.Execute;
var
InStream, OutStream: TMemoryStream;
RetValue: Integer;
begin
try
//CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
CoInitialize(nil);
try
InStream := TMemoryStream.Create;
try
InStream.LoadFromFile(FFileName);
OutStream := TMemoryStream.Create;
try
RetValue := DLLProcess(InStream, OutStream);
Sleep(0);
Debug('TDLLThread Result=> ' + IntToStr(RetValue));
if RetValue = 0 then
begin
Debug('TDLLThread OK');
end;
finally
OutStream.Free;
end;
finally
InStream.Free;
end;
finally
CoUninitialize;
end;
except
on E: Exception do
begin
Debug('TDLLThread Error: ' + E.Message);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject); // Test
var
I: Integer;
begin
for I := 1 to 5 do
TDLLThread.Create(False, '1.xml');
end;
When running some tests I sometimes get Access Violations which even the exceptions blocks can't catch. And the program simply crashes with Runtime error 216 at xxxxxxx or Invalid pointer operation.
I have tried both static and dynamic DLL linking (figured maybe the dynamic linking has race condition in the LoadLibrary/FreeLibrary).
First I thought IXMLDocument was the main issue:
Doc := TXMLDocument.Create(nil);
Doc.LoadFromStream(InStream);
This sometimes randomly failed with no apparent reason with:
Invalid at the top level of the
document.
Or:
A name was started with an invalid character.
I thought maybe it used some shared resources. but even omitting these lines caused AVs!
So the DLL is practically doing nothing special.
I also Don't see anything special which could infect DLLMain.
I have no Idea what is going on... Can someone suggest how to handle this situation? (Can someone reproduce this behavior?)
EDIT: I just wanted to add a related question (with similar IsMultiThread solution):
Delphi DLL - thread safe
And some tips about IsMultiThread:
IsMultiThread Variable
The memory manager in Delphi has optimisations for single threaded use. These are enabled by default. If your code is multi-threaded then this optimisation needs to be disabled. Do that by setting IsMultiThread to True.
In a module that creates a Delphi thread, the framework sets IsMultiThread to True when a thread is created. In your program the threads are created by the host and so nothing in the library sets IsMultiThread to True. So you must do that explicitly in the DLL. In the main section of the library .dpr file write this:
begin
IsMultiThread := True;
end.
I am designing a thread pool with following features.
New thread should be spawned only when all other threads are running.
Maximum number of thread should be configurable.
When a thread is waiting, it should be able to handle new requests.
Each IO operation should call a callback on completion
Thread should have a way to manage request its serving and IO callbacks
Here is the code:
unit ThreadUtilities;
interface
uses
Windows, SysUtils, Classes;
type
EThreadStackFinalized = class(Exception);
TSimpleThread = class;
// Thread Safe Pointer Queue
TThreadQueue = class
private
FFinalized: Boolean;
FIOQueue: THandle;
public
constructor Create;
destructor Destroy; override;
procedure Finalize;
procedure Push(Data: Pointer);
function Pop(var Data: Pointer): Boolean;
property Finalized: Boolean read FFinalized;
end;
TThreadExecuteEvent = procedure (Thread: TThread) of object;
TSimpleThread = class(TThread)
private
FExecuteEvent: TThreadExecuteEvent;
protected
procedure Execute(); override;
public
constructor Create(CreateSuspended: Boolean; ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
end;
TThreadPoolEvent = procedure (Data: Pointer; AThread: TThread) of Object;
TThreadPool = class(TObject)
private
FThreads: TList;
fis32MaxThreadCount : Integer;
FThreadQueue: TThreadQueue;
FHandlePoolEvent: TThreadPoolEvent;
procedure DoHandleThreadExecute(Thread: TThread);
procedure SetMaxThreadCount(const pis32MaxThreadCount : Integer);
function GetMaxThreadCount : Integer;
public
constructor Create( HandlePoolEvent: TThreadPoolEvent; MaxThreads: Integer = 1); virtual;
destructor Destroy; override;
procedure Add(const Data: Pointer);
property MaxThreadCount : Integer read GetMaxThreadCount write SetMaxThreadCount;
end;
implementation
constructor TThreadQueue.Create;
begin
//-- Create IO Completion Queue
FIOQueue := CreateIOCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
FFinalized := False;
end;
destructor TThreadQueue.Destroy;
begin
//-- Destroy Completion Queue
if (FIOQueue = 0) then
CloseHandle(FIOQueue);
inherited;
end;
procedure TThreadQueue.Finalize;
begin
//-- Post a finialize pointer on to the queue
PostQueuedCompletionStatus(FIOQueue, 0, 0, Pointer($FFFFFFFF));
FFinalized := True;
end;
function TThreadQueue.Pop(var Data: Pointer): Boolean;
var
A: Cardinal;
OL: POverLapped;
begin
Result := True;
if (not FFinalized) then
//-- Remove/Pop the first pointer from the queue or wait
GetQueuedCompletionStatus(FIOQueue, A, Cardinal(Data), OL, INFINITE);
//-- Check if we have finalized the queue for completion
if FFinalized or (OL = Pointer($FFFFFFFF)) then begin
Data := nil;
Result := False;
Finalize;
end;
end;
procedure TThreadQueue.Push(Data: Pointer);
begin
if FFinalized then
Raise EThreadStackFinalized.Create('Stack is finalized');
//-- Add/Push a pointer on to the end of the queue
PostQueuedCompletionStatus(FIOQueue, 0, Cardinal(Data), nil);
end;
{ TSimpleThread }
constructor TSimpleThread.Create(CreateSuspended: Boolean;
ExecuteEvent: TThreadExecuteEvent; AFreeOnTerminate: Boolean);
begin
FreeOnTerminate := AFreeOnTerminate;
FExecuteEvent := ExecuteEvent;
inherited Create(CreateSuspended);
end;
Changed the code as suggested by J... also added critical sections but the problem i am facing now is that when i am trying call multiple task only one thread is being used, Lets say if i added 5 threads in the pool then only one thread is being used which is thread 1. Please check my client code as well in the below section.
procedure TSimpleThread.Execute;
begin
// if Assigned(FExecuteEvent) then
// FExecuteEvent(Self);
while not self.Terminated do begin
try
// FGoEvent.WaitFor(INFINITE);
// FGoEvent.ResetEvent;
EnterCriticalSection(csCriticalSection);
if self.Terminated then break;
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
finally
LeaveCriticalSection(csCriticalSection);
// HandleException;
end;
end;
end;
In the Add method, how can I check if there is any thread which is not busy, if it is not busy then reuse it else create a new thread and add it in ThreadPool list?
{ TThreadPool }
procedure TThreadPool.Add(const Data: Pointer);
begin
FThreadQueue.Push(Data);
// if FThreads.Count < MaxThreadCount then
// begin
// FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
// end;
end;
constructor TThreadPool.Create(HandlePoolEvent: TThreadPoolEvent;
MaxThreads: Integer);
begin
FHandlePoolEvent := HandlePoolEvent;
FThreadQueue := TThreadQueue.Create;
FThreads := TList.Create;
FThreads.Add(TSimpleThread.Create(False, DoHandleThreadExecute, False));
end;
destructor TThreadPool.Destroy;
var
t: Integer;
begin
FThreadQueue.Finalize;
for t := 0 to FThreads.Count-1 do
TThread(FThreads[t]).Terminate;
while (FThreads.Count = 0) do begin
TThread(FThreads[0]).WaitFor;
TThread(FThreads[0]).Free;
FThreads.Delete(0);
end;
FThreadQueue.Free;
FThreads.Free;
inherited;
end;
procedure TThreadPool.DoHandleThreadExecute(Thread: TThread);
var
Data: Pointer;
begin
while FThreadQueue.Pop(Data) and (not TSimpleThread(Thread).Terminated) do begin
try
FHandlePoolEvent(Data, Thread);
except
end;
end;
end;
function TThreadPool.GetMaxThreadCount: Integer;
begin
Result := fis32MaxThreadCount;
end;
procedure TThreadPool.SetMaxThreadCount(const pis32MaxThreadCount: Integer);
begin
fis32MaxThreadCount := pis32MaxThreadCount;
end;
end.
Client Code :
This the client i created to log the data in text file :
unit ThreadClient;
interface
uses Windows, SysUtils, Classes, ThreadUtilities;
type
PLogRequest = ^TLogRequest;
TLogRequest = record
LogText: String;
end;
TThreadFileLog = class(TObject)
private
FFileName: String;
FThreadPool: TThreadPool;
procedure HandleLogRequest(Data: Pointer; AThread: TThread);
public
constructor Create(const FileName: string);
destructor Destroy; override;
procedure Log(const LogText: string);
procedure SetMaxThreadCount(const pis32MaxThreadCnt : Integer);
end;
implementation
(* Simple reuse of a logtofile function for example *)
procedure LogToFile(const FileName, LogString: String);
var
F: TextFile;
begin
AssignFile(F, FileName);
if not FileExists(FileName) then
Rewrite(F)
else
Append(F);
try
Writeln(F, DateTimeToStr(Now) + ': ' + LogString);
finally
CloseFile(F);
end;
end;
constructor TThreadFileLog.Create(const FileName: string);
begin
FFileName := FileName;
//-- Pool of one thread to handle queue of logs
FThreadPool := TThreadPool.Create(HandleLogRequest, 5);
end;
destructor TThreadFileLog.Destroy;
begin
FThreadPool.Free;
inherited;
end;
procedure TThreadFileLog.HandleLogRequest(Data: Pointer; AThread: TThread);
var
Request: PLogRequest;
los32Idx : Integer;
begin
Request := Data;
try
for los32Idx := 0 to 100 do
begin
LogToFile(FFileName, IntToStr( AThread.ThreadID) + Request^.LogText);
end;
finally
Dispose(Request);
end;
end;
procedure TThreadFileLog.Log(const LogText: string);
var
Request: PLogRequest;
begin
New(Request);
Request^.LogText := LogText;
FThreadPool.Add(Request);
end;
procedure TThreadFileLog.SetMaxThreadCount(const pis32MaxThreadCnt: Integer);
begin
FThreadPool.MaxThreadCount := pis32MaxThreadCnt;
end;
end.
This is the form application where i added three buttons, each button click will write some value to the file with thread id and text msg. But the problem is thread id is always same
unit ThreadPool;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ThreadClient;
type
TForm5 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
private
{ Private declarations }
fiFileLog : TThreadFileLog;
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
procedure TForm5.Button1Click(Sender: TObject);
begin
fiFileLog.Log('Button one click');
end;
procedure TForm5.Button2Click(Sender: TObject);
begin
fiFileLog.Log('Button two click');
end;
procedure TForm5.Button3Click(Sender: TObject);
begin
fiFileLog.Log('Button three click');
end;
procedure TForm5.Edit1Change(Sender: TObject);
begin
fiFileLog.SetMaxThreadCount(StrToInt(Edit1.Text));
end;
procedure TForm5.FormCreate(Sender: TObject);
begin
fiFileLog := TThreadFileLog.Create('C:/test123.txt');
end;
end.
First, and probably most strongly advisable, you might consider using a library like OmniThread to implement a threadpool. The hard work is done for you and you will likely end up making a substandard and buggy product with a roll-your-own solution. Unless you have special requirements this is probably the fastest and easiest solution.
That said, if you want to try to do this...
What you might consider is to just make all of the threads in your pool at startup rather than on-demand. If the server is going to busy at any point then it will eventually end up with a pool of MaxThreadCount soon enough anyway.
In any case, if you want to keep a pool of threads alive and available for work then they would need to follow a slightly different model than what you have written.
Consider:
procedure TSimpleThread.Execute;
begin
if Assigned(FExecuteEvent) then
FExecuteEvent(Self);
end;
Here when you run your thread it will execute this callback and then terminate. This doesn't seem to be what you want. What you seem to want is to keep the thread alive but waiting for its next work package. I use a base thread class (for pools) with an execute method that looks something like this (this is somewhat simplified):
procedure TMyCustomThread.Execute;
begin
while not self.Terminated do begin
try
FGoEvent.WaitFor(INFINITE);
FGoEvent.ResetEvent;
if self.Terminated then break;
MainExecute;
except
HandleException;
end;
end;
end;
Here FGoEvent is a TEvent. The implementing class defines what the work package looks like in the abstract MainExecute method, but whatever it is the thread will perform its work and then return to waiting for the FGoEvent to signal that it has new work to do.
In your case, you need to keep track of which threads are waiting and which are working. You will probably want a manager class of some sort to keep track of these thread objects. Assigning something simple like a threadID to each one seems sensible. For each thread, just before launching it, make a record that it is currently busy. At the very end of your work package you can then post a message back to the manager class telling it that the work is done (and that it can flag the thread as available for work).
When you add work to the queue you can first check for available threads to run the work (or create a new one if you wish to follow the model you outlined). If there are threads then launch the task, if there are not then push the work onto the work queue. When worker threads report complete the manager can check the queue for outstanding work. If there is work it can immediately re-deploy the thread. If there isn't work it can flag the thread as available for work (here you might use a second queue for available workers).
A full implementation is too complex to document in a single answer here - this aims just to rough out some general ideas.
I have the following problem/question.
I have a unit named "myGlobalFunctions.pas".
Inside this unit I have implemented multiple procedures/functions that are used by several projects.
project 1 use this unit
project 3 use this unit
project 6 use this unit
etc
inside "project 1" there is a thread that use functions inside the "global function" unit.
inside project 3 there is no thread but the functions are used.
so far this thread (project1) provide almost no update of the application interface and the update was made AFTER or BEFORE calling a function from "myGlobalFunctions.pas"
like "before start function1"
... the calling
"after function1".
this way I can know what the program is doing.
However now I want to implement inside the "function1" update of the application interface (with synchronize).
I want to reflect in the application interface "processing step1 ... xx records". (there is a while loop there for a dataset).
using Synchronize for "project1" and with normal label1.caption = 'message'; application.process messages for any other project.
is it possible?
how can I do such a thing.
can be Thread Safe ?
tks a lot
Razvan
here is some code to understand better
THREAD UNIT
procedure TThreadSyncronizeProcess.SignalStart;
begin
frmMain.sbMain.Panels[2].Text := 'Syncronizare in desfasurare...'; -- exist all the time
if Assigned(frmSyncronize) then begin -- check if exist this
frmSyncronize.logMain.WriteFeedBackMessage('Pornire syncronizare...', '', EVENTLOG_INFORMATION_TYPE, True);
end;
end;
procedure TThreadSyncronizeProcess.Execute;
var ..... declarations
begin
Synchronize(SignalStart); -- this is normal call within thread update interface
try
try
workSession := TIB_Session.Create(nil);
workDatabase := TIB_Database.Create(workSession);
... creating more components and setup them ...
uSyncronizareFunctions.SetupDatabase(workDatabase, workSession, transactionWrite, transactionRead);
uSyncronizareFunctions.SetupDataSnapConnection(workConnectionRead, providerRead);
if Assigned(frmSyncronize) then begin
uSyncronizareFunctions.SetupFeedBack(frmSyncronize.logMain);
end;
try
Synchronize(SignalMessage);
// this next function is from the "global unit"
isAllOk := uSyncronizareFunctions.ImportOperatoriAutorizati(workImage, workLabelProgress, True);
isAllOk := isAllOk and uSyncronizareFunctions.ImportJudete;
isAllOk := isAllOk and uSyncronizareFunctions.ImportLocalitati;
isAllOk := isAllOk and uSyncronizareFunctions.ImportUM;
isAllOk := isAllOk and uSyncronizareFunctions.ImportFurnizori;
isAllOk := isAllOk and uSyncronizareFunctions.ImportClasificari;
except
on e : Exception do begin
raise Exception.Create(dmMain.GetDataSnapExceptionMessage(e.Message));
end;
end;
except
on e : Exception do begin
baseMessage := e.Message;
Synchronize(SignalMessage);
end;
end;
finally
workDatabase.ForceDisconnect;
FreeAndNil(transactionRead);
... etc
end;
Synchronize(SignalFinish);
end;
global function unit
unit uSyncronizareFunctions;
function ImportOperatoriAutorizati(imgDone : TImage; labelProgress : TLabel; isThread : Boolean) : Boolean;
var workQuery : TIB_Query;
serverData : TClientDataSet;
begin
Result := True;
try
... create all that we need
serverData.Close;
serverData.CommandText := 'SELECT * FROM OPERATORI_AUTORIZATI WHERE REC_VERSION > :ARECVERSION ORDER BY REC_VERSION, ID';
serverData.Params.Clear;
serverData.Params.CreateParam(ftInteger, 'ARECVERSION', ptInput);
serverData.Params.ParamByName('ARECVERSION').AsInteger := lastVersion;
serverData.Active := True;
...... I want here to signal start
while not serverData.Eof do begin
try
globalInsert_Tran.StartTransaction;
workQuery.Close;
workQuery.ParamByName('AIDGLOBAL').AsString := serverData.FieldByName('IDGLOBAL').AsString;
workQuery.Open;
if workQuery.IsEmpty then begin
workQuery.Insert;
workQuery.FieldByName('IDGLOBAL').AsString := serverData.FieldByName('IDGLOBAL').AsString;
end else begin
workQuery.Edit;
end;
workQuery.FieldByName('NUME').AsString := serverData.FieldByName('NUME').AsString;
workQuery.FieldByName('COD_AUTORIZARE').AsString := serverData.FieldByName('COD_AUTORIZARE').AsString;
workQuery.FieldByName('OTHER_INFO').AsString := serverData.FieldByName('OTHER_INFO').AsString;
workQuery.FieldByName('DATASTERGERE').AsVariant := GetValueDate(serverData.FieldByName('DATASTERGERE').AsDateTime);
workQuery.FieldByName('REC_VERSION').AsInteger := serverData.FieldByName('REC_VERSION').AsInteger;
workQuery.Post;
MarkRecordAsDirtyFalse(workQuery);
globalInsert_Tran.Commit;
...... I want here to signal progress and to see in the application interface "processing record xx/100" or any other message
except
on e : Exception do begin
Result := False;
globalInsert_Tran.Rollback;
end;
end;
serverData.Next;
end;
finally
FreeAndNil(serverData);
FreeAndNil(workQuery);
end;
end;
It looks like you would like your global function to execute a callback. You might try an approach like this:
unit MyGlobalMethods;
interface
uses
System.SysUtils;
type
// define a method signature for your callback
TSomeCallback = procedure(progress : integer) of object;
// add a callback argument to your function (initializing to nil will make
// the parameter optional and will not break your previous implementations)
function GlobalFunction(arg1 : integer;
AMethodCallback : TSomeCallback = nil) : boolean;
implementation
function GlobalFunction(arg1 : integer;
AMethodCallback : TSomeCallback) : boolean;
var i : integer;
begin
for i := 0 to arg1 do begin
sleep(10); // Do some work
// report progress by executing the callback method
// only do this if a method has been passed as argument
if (i mod 100 = 0) and (Assigned(AMethodCallback)) then AMethodCallback(i);
end;
result := true;
end;
end.
Adding a method callback as an argument allows you to pass in any function you like to have the method execute. For example :
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
procedure UpdateProgress(progress : integer);
end;
TSomeThread = class(TThread)
private
FProgressCallback : TSomeCallback;
FProgress : integer;
procedure SynchronizeCallback(progress : integer);
procedure DoCallback;
public
procedure Execute; override;
property OnFunctionProgress : TSomeCallback
read FProgressCallback write FProgressCallback;
end;
implement as :
procedure TSomeThread.Execute;
begin
GlobalFunction(1000, SynchronizeCallback);
end;
procedure TSomeThread.SynchronizeCallback(progress: Integer);
begin
FProgress := progress;
Synchronize(DoCallback);
end;
procedure TSomeThread.DoCallback;
begin
if Assigned(FProgressCallback) then FProgressCallback(FProgress);
end;
You haven't told us what version of Delphi you are using. If you are using D2009 or newer you can bundle the above two calls into one using anonymous methods (and get rid of FProgress) :
procedure TSomeThread.SynchronizeCallback(progress: Integer);
begin
Synchronize(procedure
begin
if Assigned(FProgressCallback) then FProgressCallback(progress);
end;);
end;
Where in your form you would do :
procedure TForm1.UpdateProgress(progress: Integer);
begin
label1.Caption := IntToStr(progress);
end;
procedure TForm1.Button1Click(Sender: TObject);
var someThread : TSomeThread;
begin
someThread := TSomeThread.Create(true);
someThread.FreeOnTerminate := true;
someThread.OnFunctionProgress := UpdateProgress;
someThread.Start;
end;
This nicely separates the responsibilities. The main form passes an update method to the thread (a method, in this case, to update a label). The thread is responsible for synchronizing the call and the global function, therefore, does not need to care whether or not the callback it is executing originates from the main thread or from any other thread. The thread knows it needs to synchronize the method so it should take that responsibility.
I'm using the WaitForMultipleObjects function to wait for the finalization of several threads, but I'm doing something wrong because the result is not the expected
see this sample code
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
end;
TFoo = class(TThread)
private
Factor: Double;
procedure ShowData;
protected
procedure Execute; override;
constructor Create(AFactor : Double);
end;
var
Form1: TForm1;
implementation
Uses
Math;
{$R *.dfm}
{ TFoo }
constructor TFoo.Create(AFactor: Double);
begin
inherited Create(False);
Factor := AFactor;
FreeOnTerminate := True;
end;
procedure TFoo.Execute;
const
Max=100000000;
var
i : Integer;
begin
inherited;
for i:=1 to Max do
Factor:=Sqrt(Factor);
Synchronize(ShowData);
end;
procedure TFoo.ShowData;
begin
Form1.Memo1.Lines.Add(FloatToStr(Factor));
end;
procedure TForm1.Button1Click(Sender: TObject);
const
nThreads=5;
Var
tArr : Array[1..nThreads] of TFoo;
hArr : Array[1..nThreads] of THandle;
i : Integer;
rWait : Cardinal;
begin
for i:=1 to nThreads do
begin
tArr[i]:=TFoo.Create(Pi*i);
hArr[i]:=tArr[i].Handle;
end;
repeat
rWait:= WaitForMultipleObjects(nThreads, #hArr, True, 100);
Application.ProcessMessages;
until rWait<>WAIT_TIMEOUT;
//here I want to show this message when all the threads are terminated
Memo1.Lines.Add('Wait done');
end;
end.
this is the current output of the demo app
1
Wait done
1
1
1
1
but I want something like this
1
1
1
1
1
Wait done
How I must use the WaitForMultipleObjects function to wait until all the thread are terminated?
Fix: Remove the FreeOnTerminate.
Your code causes the threads to be freed, when you still need the handles. That's a big bug, and you can get access violations somewhere else in your code, or error return codes coming back from your WaitFormMultipleObjects.
TThread.handle becomes invalid when the TThread is freed, and this terminates your wait loop early because the handle is no longer valid. You could also experience an access access violation, if you tried to access the TThread after it was freed in the background, so I believe it's better to free them intentionally, and at a known time.
Using the thread handle as an event handle works fine, but you should not use FreeOnTerminate to free the thread when it terminates it as this destroys the handles too soon.
I also agree with the people who said that doing a busy-waiting loop with Application.Processmessages is pretty ugly. There are other ways to do that.
unit threadUnit2;
interface
uses Classes, SyncObjs,Windows, SysUtils;
type
TFoo = class(TThread)
private
FFactor: Double;
procedure ShowData;
protected
procedure Execute; override;
constructor Create(AFactor : Double);
destructor Destroy; override;
end;
procedure WaitForThreads;
implementation
Uses
Forms,
Math;
procedure Trace(msg:String);
begin
if Assigned(Form1) then
Form1.Memo1.Lines.Add(msg);
end;
{ TFoo }
constructor TFoo.Create(AFactor: Double);
begin
inherited Create(False);
FFactor := AFactor;
// FreeOnTerminate := True;
end;
destructor TFoo.Destroy;
begin
inherited;
end;
procedure TFoo.Execute;
const
Max=100000000;
var
i : Integer;
begin
inherited;
for i:=1 to Max do
FFactor:=Sqrt(FFactor);
Synchronize(ShowData);
end;
procedure TFoo.ShowData;
begin
Trace(FloatToStr(FFactor));
end;
procedure WaitForThreads;
const
nThreads=5;
Var
tArr : Array[1..nThreads] of TFoo;
hArr : Array[1..nThreads] of THandle;
i : Integer;
rWait : Cardinal;
begin
for i:=1 to nThreads do
begin
tArr[i]:=TFoo.Create(Pi*i);
hArr[i]:=tArr[i].handle; // Event.Handle;
end;
repeat
rWait:= WaitForMultipleObjects(nThreads, #hArr[1],{waitAll} True, 150);
Application.ProcessMessages;
until rWait<>WAIT_TIMEOUT;
Sleep(0);
//here I want to show this message when all the threads are terminated
Trace('Wait done');
for i:=1 to nThreads do
begin
tArr[i].Free;
end;
end;
end.
If you really want to learn how multithreading works, you're on a correct path - learn through code and ask questions as you did here. If, however, you just want to use multithreading in your application, you can do it in much simpler way with OmniThreadLibrary provided you use at least Delphi 2009.
uses
Math,
OtlTask,
OtlParallel;
function Calculate(factor: real): real;
const
Max = 100000000;
var
i: integer;
begin
Result := factor;
for i := 1 to Max do
Result := Sqrt(Result);
end;
procedure TForm35.btnClick(Sender: TObject);
const
nThreads = 5;
begin
Parallel.ForEach(1, nThreads).Execute(
procedure (const task: IOmniTask; const value: integer)
var
res: real;
begin
res := Calculate(Pi*value);
task.Invoke(
procedure begin
Form35.Memo1.Lines.Add(FloatToStr(res));
end
);
end
);
Memo1.Lines.Add('All done');
end;
Here's what is happening.
Your code is returning WAIT_FAILED from WaitForMultipleObjects.
Calling GetLastError results in error code 6, The handle is invalid.
The only handles you are passing to WaitForMultipleObjects are the thread handles, ergo one of the thread handles is invalid.
The only way one of the thread handles could become invalid is if it has been closed.
As others have indicated, you are closing the handles by setting FreeOnTerminate.
The moral of the story is to check your return values correctly from all functions, and let GetLastError lead you to the root cause of the problem.
Don't pass such a short timeout period as the last parameter.
According to MSDN
dwMilliseconds
[in] The time-out interval, in milliseconds. The function returns if the interval elapses, even if the conditions specified by the bWaitAll parameter are not met. If dwMilliseconds is zero, the function tests the states of the specified objects and returns immediately. If dwMilliseconds is INFINITE, the function's time-out interval never elapses.
Pay special attention to the second sentence. You're telling it to wait for all the handles, but to time out after 100 ms. So pass INFINITE as the last parameter instead, and use WAIT_OBJECT_0 instead of WAIT_TIMEOUT as the exit test.
Whenever you wait and it is involving message, you must use MsgWait... and specify the mask to deal with expected message
repeat
rWait:= MsgWaitForMultipleObjects(nThreads, #hArr[1], True, INFINITE, QS_ALLEVENTS);
Application.ProcessMessages;
until (rWait<>WAIT_TIMEOUT) and (rWait <> (WAIT_OBJECT_0 + nThreads));
nThreads
I couldn't pass on this opportunity to create a working example of starting a couple of threads and using messaging to report the results back to the GUI.
The threads that will be started are declared as:
type
TWorker = class(TThread)
private
FFactor: Double;
FResult: Double;
FReportTo: THandle;
protected
procedure Execute; override;
public
constructor Create(const aFactor: Double; const aReportTo: THandle);
property Factor: Double read FFactor;
property Result: Double read FResult;
end;
The constructor just sets the private members and sets FreeOnTerminate to False. This is essential as it will allow the main thread to query the instance for the result. The execute method does its calculation and then posts a message to the handle it received in its constructor to say its done.
procedure TWorker.Execute;
const
Max = 100000000;
var
i : Integer;
begin
inherited;
FResult := FFactor;
for i := 1 to Max do
FResult := Sqrt(FResult);
PostMessage(FReportTo, UM_WORKERDONE, Self.Handle, 0);
end;
The declarations for the custom UM_WORKERDONE message are declared as:
const
UM_WORKERDONE = WM_USER + 1;
type
TUMWorkerDone = packed record
Msg: Cardinal;
ThreadHandle: Integer;
unused: Integer;
Result: LRESULT;
end;
The form starting the threads has this added to its declaration:
private
FRunning: Boolean;
FThreads: array of record
Instance: TThread;
Handle: THandle;
end;
procedure StartThreads(const aNumber: Integer);
procedure HandleThreadResult(var Message: TUMWorkerDone); message UM_WORKERDONE;
The FRunning is used to prevent the button from being clicked while the work is going on. FThreads is used to hold the instance pointer and the handle of the created threads.
The procedure to start the threads has a pretty straightforward implementation:
procedure TForm1.StartThreads(const aNumber: Integer);
var
i: Integer;
begin
Memo1.Lines.Add(Format('Starting %d worker threads', [aNumber]));
SetLength(FThreads, aNumber);
for i := 0 to aNumber - 1 do
begin
FThreads[i].Instance := TWorker.Create(pi * (i+1), Self.Handle);
FThreads[i].Handle := FThreads[i].Instance.Handle;
end;
end;
The fun is in the HandleThreadResult implementation:
procedure TForm1.HandleThreadResult(var Message: TUMWorkerDone);
var
i: Integer;
ThreadIdx: Integer;
Thread: TWorker;
Done: Boolean;
begin
// Find thread in array
ThreadIdx := -1;
for i := Low(FThreads) to High(FThreads) do
if FThreads[i].Handle = Cardinal(Message.ThreadHandle) then
begin
ThreadIdx := i;
Break;
end;
// Report results and free the thread, nilling its pointer so we can detect
// when all threads are done.
if ThreadIdx > -1 then
begin
Thread := TWorker(FThreads[i].Instance);
Memo1.Lines.Add(Format('Thread %d returned %f', [ThreadIdx, Thread.Result]));
FreeAndNil(FThreads[i].Instance);
end;
// See whether all threads have finished.
Done := True;
for i := Low(FThreads) to High(FThreads) do
if Assigned(FThreads[i].Instance) then
begin
Done := False;
Break;
end;
if Done then
Memo1.Lines.Add('Work done');
end;
Enjoy...
There is one condition that satisfies your 'until' condition in the repeat loop that you are ignoring, WAIT_FAILED:
until rWait<>WAIT_TIMEOUT;
Memo1.Lines.Add('Wait done');
Since your timeout is somewhat tight, one (or more) of the threads finishes and frees itself rendering one (or more) handle invalid for the next WaitForMultipleObjects, which causes it to return 'WAIT_FAILED' resulting in a 'Wait done' message displayed.
For each iteration in the repeat loop, you should remove the handles of finished threads from your hArr. Then again do not forget to test for 'WAIT_FAILED' in any case.
edit:
Below is some sample code showing how this can be done. The difference of this approach instead of keeping threads alive is that, it doesn't leave unused kernel and RTL objects around. This wouldn't matter for the sample at hand, but for a lot of threads doing lengthy business it might be preferred.
In the code, WaitForMultipleObjects is called with passing 'false' for 'bWaitAll' parameter to be able to remove a thread handle without using an additional API call to find out if it is invalid or not. But it allows otherwise since the code also has to be able to handle threads finishing outside the wait call.
procedure TForm1.Button1Click(Sender: TObject);
const
nThreads=5;
Var
tArr : Array[1..nThreads] of TFoo;
hArr : Array[1..nThreads] of THandle;
i : Integer;
rWait : Cardinal;
hCount: Integer; // total number of supposedly running threads
Flags: DWORD; // dummy variable used in a call to find out if a thread handle is valid
procedure RemoveHandle(Index: Integer); // Decrement valid handle count and leave invalid handle out of range
begin
if Index <> hCount then
hArr[Index] := hArr[hCount];
Dec(hCount);
end;
begin
Memo1.Clear;
for i:=1 to nThreads do
begin
tArr[i]:=TFoo.Create(Pi*i);
hArr[i]:=tArr[i].Handle;
end;
hCount := nThreads;
repeat
rWait:= WaitForMultipleObjects(hCount, #hArr, False, 100);
case rWait of
// one of the threads satisfied the wait, remove its handle
WAIT_OBJECT_0..WAIT_OBJECT_0 + nThreads - 1: RemoveHandle(rWait + 1);
// at least one handle has become invalid outside the wait call,
// or more than one thread finished during the previous wait,
// find and remove them
WAIT_FAILED:
begin
if GetLastError = ERROR_INVALID_HANDLE then
begin
for i := hCount downto 1 do
if not GetHandleInformation(hArr[i], Flags) then // is handle valid?
RemoveHandle(i);
end
else
// the wait failed because of something other than an invalid handle
RaiseLastOSError;
end;
// all remaining threads continue running, process messages and loop.
// don't process messages if the wait returned WAIT_FAILED since we didn't wait at all
// likewise WAIT_OBJECT_... may return soon
WAIT_TIMEOUT: Application.ProcessMessages;
end;
until hCount = 0; // no more valid thread handles, we're done
Memo1.Lines.Add('Wait done');
end;
Note that this is to answer the question as it is asked. I'd rather use the TThreads' OnTerminate event to decrement a counter and output the 'Wait done' message when it reaches '0'. This, or as others have recommended, moving the wait to a thread of its own, would be easier and probably cleaner, and would avoid the need for Application.ProcessMessages.
I added the following lines to the end of the routine:
memo1.Lines.add(intToHex(rWait, 2));
if rWait = $FFFFFFFF then
RaiseLastOSError;
Turns out that WaitForMultipleObjects is failing with an Access Denied error, most likely because some but not all of the threads are finishing and cleaning themselves up between iterations.
You've got a sticky issue here. You need to keep the message pump running, or the Synchronize calls won't work, so you can't pass INFINITE like Ken suggested. But if you do what you're currently doing, you run into this problem.
The solution is to move the WaitForMultipleObjects call and the code around it into a thread of its own as well. It should wait for INFINITE, then when it's finished it should signal the UI thread in some way to let it know it's done. (For example, when you click the button, disable the button, and then when the monitor thread finishes, it enables the button again.)
You could refactor your code to wait for just one object instead of many.
I'd like to introduce you to a little helper which usually helps me in cases like this. This time his name is IFooMonitor:
IFooMonitor = interface
function WaitForAll(ATimeOut: Cardinal): Boolean;
procedure ImDone;
end;
TFoo and IFooMonitor will be friends:
TFoo = class(TThread)
strict private
FFactor: Double;
FMonitor: IFooMonitor;
procedure ShowData;
protected
procedure Execute; override;
public
constructor Create(const AMonitor: IFooMonitor; AFactor: Double);
end;
constructor TFoo.Create(const ACountDown: ICountDown; AFactor: Double);
begin
FCountDown := ACountDown;
FFactor := AFactor;
FreeOnTerminate := True;
inherited Create(False);// <- call inherited constructor at the end!
end;
When TFoo is done with his job it wiil tell about it to his new friend:
procedure TFoo.Execute;
const
Max = 100000000;
var
i: Integer;
begin
for i := 1 to Max do
FFactor := Sqrt(FFactor);
Synchronize(ShowData);
FMonitor.ImDone();
end;
Now we can refactor the event handler to look like this:
procedure TForm1.Button1Click(Sender: TObject);
const
nThreads = 5;
var
i: Integer;
monitor: IFooMonitor;
begin
monitor := TFooMonitor.Create(nThreads); // see below for the implementation.
for i := 1 to nThreads do
TFoo.Create(monitor, Pi*i);
while not monitor.WaitForAll(100) do
Application.ProcessMessages;
Memo1.Lines.Add('Wait done');
end;
And this is how we can implement IFooMonitor:
uses
SyncObjs;
TFooMonitor = class(TInterfacedObject, IFooMonitor)
strict private
FCounter: Integer;
FEvent: TEvent;
FLock: TCriticalSection;
private
{ IFooMonitor }
function WaitForAll(ATimeOut: Cardinal): Boolean;
procedure ImDone;
public
constructor Create(ACount: Integer);
destructor Destroy; override;
end;
constructor TFooMonitor.Create(ACount: Integer);
begin
inherited Create;
FCounter := ACount;
FEvent := TEvent.Create(nil, False, False, '');
FLock := TCriticalSection.Create;
end;
procedure TFooMonitor.ImDone;
begin
FLock.Enter;
try
Assert(FCounter > 0);
Dec(FCounter);
if FCounter = 0 then
FEvent.SetEvent;
finally
FLock.Leave
end;
end;
destructor TFooMonitor.Destroy;
begin
FLock.Free;
FEvent.Free;
inherited;
end;
function TFooMonitor.WaitForAll(ATimeOut: Cardinal): Boolean;
begin
Result := FEvent.WaitFor(ATimeOut) = wrSignaled
end;