Delphi service always runs at 15% processor load - delphi

I just encountered a problem with a service I wrote some time ago. This service is meant to translate various programs by calling a multilizer application via CreateProcess. The problem is that once the checks of the given directories cleared and the actual translation method is called the cpu load will rise to about 15-20% and remain at this level even if all files have been processed. The OnStart-event of the service creates a non delayed thread which has an execute-method that looks like this:
procedure TTranslateThread.Execute;
var count : integer;
begin
sleep(ServiceObject.hInterval);
while not Terminated do
begin
Inc(Count);
if Count>= 10 then
begin
Count :=0;
if ServiceObject.CheckDirCount>0 then
begin
ServiceObject.TranslateService;
sleep(ServiceObject.hInterval);
end;
end;
end;
However I suppose the main cause of the problem lies in the way I have to call the multilizer. That is because the service has to wait for the multilizer to finish translating. I used WaitForSingleObject to wait for the multilizer to finish although I know it's kind of a bad idea. This is the method that calls the multilizer:
procedure WaitForML7(hName: string);
var
si: TStartupInfo;
pi: TProcessInformation;
hCreateOK: Boolean;
AParameterFinal,AFileName: String;
begin
AFileName := hMultilizerPath+'Ml7Build.exe';
AParameterFinal := 'b '+hName+'.exe.m7p';
FillChar(si,SizeOf(TStartupInfo),#0);
FillChar(pi,SizeOf(TProcessInformation),#0);
si.cb := SizeOf(TStartupInfo);
AParameterFinal := Format ('"%s" %s', [AFilename, TrimRight(AParameterFinal)]);
slog.Info('CreateProcess wird versucht');
hCReateOK := CreateProcess(nil,PChar(AParameterFinal), nil, nil, false, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
PChar(hMultilizerPath) ,si,pi);
if hCreateOK then
begin
slog.Error('Multilizeraufruf war erfolgreich für Prg: '+hName);
WaitForSingleObject(pi.hProcess,INFINITE);
end
else
begin
slog.Error('Aufruf war nicht erfolgreich -> keine Uebersetzung');
end;
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
end;
I don't really understand why the processor load remains high even there is nothing more to do. Thanks in advance.

Your thread runs a busy loop.
while not Terminated do
begin
Inc(Count);
if Count>= 10 then
begin
Count :=0;
if ServiceObject.CheckDirCount>0 then
begin
ServiceObject.TranslateService;
sleep(ServiceObject.hInterval);
end;
end;
end;
Note that I've added the missing end from your code. I hope that's the only error you made, because obviously when you post code that is not the real code, it's plausible that the problem lies in the real code rather than the code you posted.
Anyway, suppose that CheckDirCount always evaluates to 0, then the loop looks like this:
while not Terminated do
begin
Inc(Count);
if Count>= 10 then
begin
Count :=0;
ServiceObject.CheckDirCount;
end;
end;
That is a busy loop. When you run a busy loop, the processor gets hot.
I don't really want to propose solutions to this because I don't know any of the details of what your program is doing. I'm just trying to answer the question of why your thread consumes CPU.

Your wait loop will run without waiting within a Sleep(), so will burn some CPU until Sleep() is reached. This is not a good implementation pattern.
A common solution is to use semaphores to notify the thread to wake up and handle the pending tasks. It won't use any CPU until the semaphore (e.g. TEvent) is triggered.
Take a look at TEvent documentation.
For more complex multi-thread content, consider using a dedicated library like OmniThreadLibrary. It features high-level lists and parallel processing, tuned and stable. Using such a library will save you plenty of time and money. Multi-threading programming can be very difficult to stabilize, so OmniThreadLibrary is worth a look.

In addition to David's answer:
your main execute block can be simplified, doing Sleep unconditionally to prevent a busy loop:
procedure TTranslateThread.Execute;
begin
while not Terminated do
begin
sleep(ServiceObject.hInterval);
if ServiceObject.CheckDirCount>0 then
ServiceObject.TranslateService;
end;
end;
Please note that you can avoid the sleep loop by using Shell notification events.

Related

Prevent Delphi Service from not responding

my problem is the following:
I implemented a Windows Service with Delphi Tokyo but imho this is no version problem rather than a design problem.
I use the following code to pause my service and be responsive in that state.
procedure TMyService.ServiceExecute(Sender: TService);
begin
while not Terminated do
begin
MyProductiveFunction;
Delay(10000);
end;
end;
procedure TMyService.Delay(Milliseconds: integer);
var
Tick: DWord;
Event: THandle;
begin
LogOnLevel(clogger, CAS_LOGGER.Debug, '', ['Delay', 'ENTER', 'Delayed for ' + Milliseconds.ToString]);
Event := CreateEvent(nil, False, False, nil);
try
Tick := GetTickCount + DWord(Milliseconds);
while (Milliseconds > 0) and (MsgWaitForMultipleObjects(1, Event, False, Milliseconds, QS_ALLINPUT) <>
WAIT_TIMEOUT) do
begin
ServiceThread.ProcessRequests(False);
if Terminated then
exit;
Milliseconds := Tick - GetTickCount;
end;
finally
CloseHandle(Event);
end;
end;
The Function I run sometimes is very time consuming. When I try to Stop the Service while it is in the Delay procedure it stops and everything is fine. But when I try to stop the Service while running "MyProductiveFunction" it will say Service is not responding and after that there is no other way to terminate the Service than killing it by Taskmanager.
Is there a better way to implement that so the Service will be responding independently from its actual state?
You have to write MyProductiveFunction like you programmed your Delay function: periodically process requests and terminate the function if the service is asked to terminate.
Instead, you may also create another thread to execute MyProductiveFunction and from the ServiceExecute call ProcessRequest and check for termination. When termination is requested, you have to terminate the other thread. The best is to have this other thread check something shared such a TEvent for terminating, or ServiceExecute may kill/abort that thread.
Thanks for your Support.
I used the code skeleton from Remys post here:
Delphi Windows Service Design
Works great. Thx to that great community and thx to Remy

What is a better method to suspend program execution until a condition is met?

I need to wait until a mapped network folder (\HostName\NetworkPath) become empty. What I mean is that program flow cannot continue until that network folder is empty.
So far I have the following logic in place but I noticed that it takes time before FindFirst notices that the network folder become empty.
If I keep observing an opened explorer windows, pointing to that network folder, I notice that it become empty far before FindFirst notices it.
I used Sleep(5000) to introduce some delay in calling again CheckNetworkFolderIsEmpty in my while loop, otherwise it is being called too often. But maybe that folder will become empty far before 5 seconds, so 5 seconds is an arbitrary time delay that may results in an unnecessary dealy in program execution, in the event that the folder become empty before.
What can be the culprit, what can be a better alternative?
Also I do not know what else to use instead of a simple Sleep.
while not CheckRawFolderIsEmpty do begin
Sleep(5000);
end;
function TForm1.CheckNetworkFolderIsEmpty: Boolean;
begin
Result := (CountFilesInFolder('\\HostName\NetworkPath', '*.txt') = 0);
end;
function CountFilesInFolder(const aPath, aFileMask: string): Integer;
var
Path: string;
SearchRec: TSearchRec;
begin
Path := IncludeTrailingPathDelimiter(aPath);
Result := 0;
if FindFirst(Path + aFileMask, faAnyFile and not faDirectory, SearchRec) = 0 then begin
repeat
Inc(Result);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
end;
Observing file system changes like you do is inefficient (FindFirst, FindNext) and inacurate as you've learned. Windows provides API FindFirstChangeNotification for that purpose as J... has pointed out in the comment under your question.
Good news is that you don't need to start studying the API from scratch, because some other people did the hard work for you. Check out some freeware wrappers for Delphi around the API:
https://torry.net/pages.php?id=252
http://www.angusj.com/delphi/dirwatch.html
...

Want asynchronous function execution one after the other with AsyncCalls and unable to reproduce demo

My primary goal is to run two time consuming functions or procedures one after the other has finished executing. My current approach is to place the second function invocation after the while loop (assuming I have passed one Interface type object to it in the AsyncMultiSync array param) in the code below I got from AsyncCalls Documentation.md in Github. Additionally, when I am trying to run the exact provided code below, I see that the threads do their job and the execution reaches to the first access to the vcl thread Memo but the second access to the memo freezes the application (for directories having quite a lot of files in the GetFiles call) P.S. English is not my first language and I might have trouble explaining it but if you demote this for title or MCVE, it will be my last question here as per SO rules.
uses
..AsyncCalls;
{ Ex - 2 using global function }
function GetFiles(Directory: string; Filenames: TStrings): Integer;
var
h: THandle;
FindData: TWin32FindData;
begin
h := FindFirstFile(PChar(Directory + '\*.*'), FindData);
if h <> INVALID_HANDLE_VALUE then
begin
repeat
if (StrComp(FindData.cFileName, '.') <> 0) and (StrComp(FindData.cFileName, '..') <> 0) then
begin
Filenames.Add(Directory + '\' + FindData.cFileName);
if FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <> 0 then
GetFiles(Filenames[Filenames.Count - 1], Filenames);
end;
until not FindNextFile(h, FindData);
Winapi.Windows.FindClose(h);
end;
Result := 0;
end;
procedure TForm1.ButtonGetFilesClick(Sender: TObject);
var
i: integer;
Dir1Files, Dir2Files: TStrings;
Dir1, Dir2 IAsyncCall;
begin
Dir1Files := TStringList.Create;
Dir2Files := TStringList.Create;
ButtonGetFiles.Enabled := False;
try
Dir1 := TAsyncCalls.Invoke<string, TStrings>(GetFiles, 'C:\portables\autoit-v3', Dir1Files);
Dir2 := TAsyncCalls.Invoke<string, TStrings>(GetFiles, 'E:\mySyntax-Repository-works', Dir2Files);
{ Wait until both async functions have finished their work. While waiting make the UI
reacting on user interaction. }
while AsyncMultiSync([Dir1, Dir2], True, 10) = WAIT_TIMEOUT do
Application.ProcessMessages;
{ Form1.Caption := 'after file search';}
MemoFiles.Lines.Assign(Dir1Files);
MemoFiles.Lines.AddStrings(Dir2Files); {-->causes freeze}
finally
ButtonGetFiles.Enabled := True;
Dir2Files.Free;
Dir1Files.Free;
end;
end;
One alternative solution to use is JvThread as it contains well commented demos. Multiple JvThread objects can be wired via onFinish events to start one after another. If required, that many Sync functions can be constructed to talk to the VCL thread where race risk exists(between the thread and the VCL thread). And if required, each JvThread can be force-finished i.e.'breaked' by terminating it, based on some logic, inside of the thread execution code or in the associated Sync function in the VCL thread. How is it different from using timers or threaded timers triggering each other one after another in the first place given we use quite a few global form fields? Answer is there is no onFinish equivalent for timers and it will take more effort and less elegance to achieve the same. Omnithread is somewhat restrictive for its BSD licence, Native threads beat the RAD spirit of Delphi, and Task library not available in lighter installs like XE5.

Delphi: How to prevent a single thread app from losing responses?

I am developing a single thread app with Delphi, which will do a time-consuming task, like this:
// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
DoTask();
End;
When the loop starts, the application will lose responses to the end user. That is not very good. I also do not want to convert it into a multi-thread application because of its complexity, so I add Application.ProcessMessages accordingly,
// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
DoTask();
Application.ProcessMessages;
End;
However, this time although the application will response to user operations, the time-consumed in the loop is much more than the original loop, about 10 times.
Is there a solution to make sure the application does not lose the response while do not increase the consumed time too much?
You really should use a worker thread. This is what threads are good for.
Using Application.ProcessMessages() is a band-aid, not a solution. Your app will still be unresponsive while DoTask() is doing its work, unless you litter DoTask() with additional calls to Application.ProcessMessages(). Plus, calling Application.ProcessMessages() directly introduces reentrant issues if you are not careful.
If you must call Application.ProcessMessages() directly, then don't call it unless there are messages actually waiting to be processed. You can use the Win32 API GetQueueStatus() function to detect that condition, for example:
// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
DoTask();
if GetQueueStatus(QS_ALLINPUT) <> 0 then
Application.ProcessMessages;
End;
Otherwise, move the DoTask() loop into a thread (yeah yeah) and then have your main
loop use MsgWaitForMultipleObjects() to wait for the task thread to finish.
That still allows you to detect when to process messages, eg:
procedure TMyTaskThread.Execute;
begin
// time-consuming loop
for I := 0 to 1024 * 65536 do
begin
if Terminated then Exit;
DoTask();
end;
end;
var
MyThread: TMyTaskThread;
Ret: DWORD;
begin
...
MyThread := TMyTaskThread.Create;
repeat
Ret := MsgWaitForMultipleObjects(1, Thread.Handle, FALSE, INFINITE, QS_ALLINPUT);
if (Ret = WAIT_OBJECT_0) or (Ret = WAIT_FAILED) then Break;
if Ret = (WAIT_OBJECT_0+1) then Application.ProcessMessages;
until False;
MyThread.Terminate;
MyThread.WaitFor;
MyThread.Free;
...
end;
You say :
I also do not want to convert it into a multi-thread application
because of its complexity
I can take this to mean one of two things :
Your application is a sprawling mess of legacy code that is so huge and so badly written that encapsulating DoTask in a thread would mean an enormous amount of refactoring for which a viable business case cannot be made.
You feel that writing multithreaded code is too "complex" and you don't want to learn how to do it.
If the case is #2 then there is no excuse whatsoever - multithreading is the clear answer to this problem. It's not so scary to roll a method into a thread and you'll become a better developer for learning how to do it.
If the case is #1, and I leave this to you to decide, then I'll note that for the duration of the loop you will be calling Application.ProcessMessages 67 million times with this :
For I := 0 to 1024 * 65536 do
Begin
DoTask();
Application.ProcessMessages;
End;
The typical way that this crime is covered up is simply by not calling Application.ProcessMessages every time you run through the loop.
For I := 0 to 1024 * 65536 do
Begin
DoTask();
if I mod 1024 = 0 then Application.ProcessMessages;
End;
But if Application.ProcessMessages is actually taking ten times longer than DoTask() to execute then I really question how complex DoTask really is and whether it really is such a hard job to refactor it into a thread. If you fix this with ProcessMessages, you really should consider it a temporary solution.
Especially take care that using ProcessMessages means that you must make sure that all of your message handlers are re-entrant.
Application.ProcessMessages should be avoided. It can cause all sorts of strange things to your program. A must read: The Dark Side of Application.ProcessMessages in Delphi Applications.
In your case a thread is the solution, even though DoTask() may have to be refactored a bit to run in a thread.
Here is a simple example using an anonymous thread. (Requires Delphi-XE or newer).
uses
System.Classes;
procedure TForm1.MyButtonClick( Sender : TObject);
var
aThread : TThread;
begin
aThread :=
TThread.CreateAnonymousThread(
procedure
var
I: Integer;
begin
// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
if TThread.CurrentThread.CheckTerminated then
Break;
DoTask();
End;
end
);
// Define a terminate thread event call
aThread.OnTerminate := Self.TaskTerminated;
aThread.Start;
// Thread is self freed on terminate by default
end;
procedure TForm1.TaskTerminated(Sender : TObject);
begin
// Thread is ready, inform the user
end;
The thread is self destroyed, and you can add a OnTerminate call to a method in your form.
Calling Application.ProcessMessages at every iteration will indeed slow down performance, and calling it every few times doesn't always work well if you can't predict how long each iteration will take, so I typically will use GetTickCount to time when 100 milliseconds have passed (1). This is long enough to not slow down performance too much, and fast enough to make the application appear responsive.
var
tc:cardinal;
begin
tc:=GetTickCount;
while something do
begin
if cardinal(GetTickCount-tc)>=100 then
begin
Application.ProcessMessages;
tc:=GetTickCount;
end;
DoSomething;
end;
end;
(1): not exactly 100 milliseconds, but somewhere close. There are more precise ways to measure time like QueryPerformanceTimer, but again this is more work and may hinder performance.
#user2704265, when you mention “application will lose responses to the end user”, do you mean that you want your user to continue working around in your application clicking and typing away? In that case - heed the previous answers and use threading.
If it’s good enough to provide feedback that your application is busy with a lengthy operation [and hasn't frozen] there are some options you can consider:
Dissable user input
Change the cursor to “busy”
Use a progressbar
Add a cancel button
Abiding to your request for a single threaded solution I recommend you start by disabling user input and change the cursor to “busy”.
procedure TForm1.ButtonDoLengthyTaskClick(Sender: TObject);
var i, j : integer;
begin
Screen.Cursor := crHourGlass;
//Disable user input capabilities
ButtonDoLengthyTask.Enabled := false;
Try
// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
DoTask();
// Calling Processmessages marginally increases the process time
// If we don't call and user clicks the disabled button while waiting then
// at the end of ButtonDoLengthyTaskClick the proc will be called again
// doubling the execution time.
Application.ProcessMessages;
End;
Finally
Screen.Cursor := crDefault;
ButtonDoLengthyTask.Enabled := true;
End;
End;

Deadlock when closing thread

I created a class that opens a COM port and handles overlapped read and write operations. It contains two independent threads - one that reads and one that writes data. Both of them call OnXXX procedures (eg OnRead or OnWrite) notifying about finished read or write operation.
The following is a short example of the idea how the threads work:
TOnWrite = procedure (Text: string);
TWritingThread = class(TThread)
strict private
FOnWrite: TOnWrite;
FWriteQueue: array of string;
FSerialPort: TAsyncSerialPort;
protected
procedure Execute; override;
public
procedure Enqueue(Text: string);
{...}
end;
TAsyncSerialPort = class
private
FCommPort: THandle;
FWritingThread: TWritingThread;
FLock: TCriticalSection;
{...}
public
procedure Open();
procedure Write(Text: string);
procedure Close();
{...}
end;
var
AsyncSerialPort: TAsyncSerialPort;
implementation
{$R *.dfm}
procedure OnWrite(Text: string);
begin
{...}
if {...} then
AsyncSerialPort.Write('something');
{...}
end;
{ TAsyncSerialPort }
procedure TAsyncSerialPort.Close;
begin
FLock.Enter;
try
FWritingThread.Terminate;
if FWritingThread.Suspended then
FWritingThread.Resume;
FWritingThread.WaitFor;
FreeAndNil(FWritingThread);
CloseHandle(FCommPort);
FCommPort := 0;
finally
FLock.Leave;
end;
end;
procedure TAsyncSerialPort.Open;
begin
FLock.Enter;
try
{open comm port}
{create writing thread}
finally
FLock.Leave;
end;
end;
procedure TAsyncSerialPort.Write(Text: string);
begin
FLock.Enter;
try
{add Text to the FWritingThread's queue}
FWritingThread.Enqueue(Text);
finally
FLock.Leave;
end;
end;
{ TWritingThread }
procedure TWritingThread.Execute;
begin
while not Terminated do
begin
{GetMessage() - wait for a message informing about a new value in the queue}
{pop a value from the queue}
{write the value}
{call OnWrite method}
end;
end;
When you look at the Close() procedure, you will see that it enters the critical section, terminates the writing thread and then waits for it to finish.
Because of the fact that the writing thread can enqueue a new value to be written when it calls the OnWrite method, it will try to enter the same critical section when calling the Write() procedure of the TAsyncSerialPort class.
And here we've got a deadlock. The thread that called the Close() method entered the critical section and then waits for the writing thread to be closed, while at the same time that thread waits for the critical section to be freed.
I've been thinking for quite a long time and I didn't manage to find a solution to that problem. The thing is that I would like to be sure that no reading/writing thread is alive when the Close() method is left, which means that I cannot just set the Terminated flag of those threads and leave.
How can I solve the problem? Maybe I should change my approach to handling serial port asynchronously?
Thanks for your advice in advance.
Mariusz.
--------- EDIT ----------
How about such a solution?
procedure TAsyncSerialPort.Close;
var
lThread: TThread;
begin
FLock.Enter;
try
lThread := FWritingThread;
if Assigned(lThread) then
begin
lThread.Terminate;
if lThread.Suspended then
lThread.Resume;
FWritingThread := nil;
end;
if FCommPort <> 0 then
begin
CloseHandle(FCommPort);
FCommPort := 0;
end;
finally
FLock.Leave;
end;
if Assigned(lThread) then
begin
lThread.WaitFor;
lThread.Free;
end;
end;
If my thinking is correct, this should eliminate the deadlock problem. Unfortunately, however, I close the comm port handle before the writing thread is closed. This means that when it calls any method that takes the comm port handle as one of its arguments (eg Write, Read, WaitCommEvent) an exception should be raised in that thread. Can I be sure that if I catch that exception in that thread it will not affect the work of the whole application? This question may sound stupid, but I think some exceptions may cause the OS to close the application that caused it, right? Do I have to worry about that in this case?
Yes, you should probably reconsider your approach. Asynchronous operations are available exactly to eliminate the need for threads. If you use threads, then use synchronous (blocking) calls. If you use asynchronous operations, then handle everything in one thread - not necessarily the main thread, but it doesn't make sense IMO to do the sending and receiving in different threads.
There are of course ways around your synchronization problem, but I'd rather change the design.
You can take the lock out of the Close. By the time it returns from the WaitFor, the thread body has noticed it has been terminated, completed the last loop, and ended.
If you don't feel happy doing this, then you could move setting the lock just before the FreeAndNil. This explicitly lets the thread shutdown mechanisms work before you apply the lock (so it won't have to compete with anything for the lock)
EDIT:
(1) If you also want to close the comms handle do it after the loop in the Execute, or in the thread's destructor.
(2) Sorry, but your edited solution is a terrible mess. Terminate and Waitfor will do everything you need, perfectly safely.
The main problem seems to be that you place the entire content of Close in a critical section. I'm almost sure (but you'll have to check the docs) that TThread.Terminate and TThread.WaitFor are safe to call from outside the section. By pulling that part outside the critical section you will solve the deadlock.

Resources