paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-28 17:03:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Try to avoid deadlocks with worker threads:

Browse Source 
* Add three separate try/except blocks:
       - Around thread create calls to handle fails in constructor
       - Around ProcessThreadResult calls
       - Around Terminate calls
    Set ErrorState and ErrorMessage if an exception is raised
    inside those try/except blocks.

git-svn-id: trunk@46684 -
This commit is contained in:
pierre 2020-08-25 12:20:52 +00:00
parent 1e8aa99f81
commit 4739762790
1 changed files with 59 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
packages/fpmkunit/src/fpmkunit.pp
View File

@ -8204,7 +8204,7 @@ procedure TBuildEngine.Compile(Packages: TPackages);
Var
I : integer;
{$ifndef NO_THREADING}
Thr : Integer;
Thr, ThreadCount : Integer;
Finished : boolean;
ErrorState: boolean;
ErrorMessage: string;
@ -8299,34 +8299,71 @@ begin
ErrorState := False;
Finished := False;
I := 0;
ThreadCount:=0;
// This event is set by the worker-threads to notify the main/this thread
// that a package finished it's task.
NotifyThreadWaiting := RTLEventCreate;
SetLength(Threads,Defaults.ThreadsAmount);
// Create all worker-threads
for Thr:=0 to Defaults.ThreadsAmount-1 do
Threads[Thr] := TCompileWorkerThread.Create(self,NotifyThreadWaiting);
try
// When a thread notifies this thread that it is ready, loop on all
// threads to check their state and if possible assign a new package
// to them to compile.
while not Finished do
begin
RTLeventWaitFor(NotifyThreadWaiting);
for Thr:=0 to Defaults.ThreadsAmount-1 do if not Finished then
ProcessThreadResult(Threads[Thr]);
end;
// Compilation finished or aborted. Wait for all threads to end.
for thr:=0 to Defaults.ThreadsAmount-1 do
begin
Threads[Thr].Terminate;
RTLeventSetEvent(Threads[Thr].NotifyStartTask);
Threads[Thr].WaitFor;
end;
try
// Create all worker-threads
try
for Thr:=0 to Defaults.ThreadsAmount-1 do
begin
Threads[Thr] := TCompileWorkerThread.Create(self,NotifyThreadWaiting);
if assigned(Threads[Thr]) then
inc(ThreadCount);
end;
except
on E: Exception do
begin
ErrorMessage := E.Message;
ErrorState:=true;
end;
end;
try
// When a thread notifies this thread that it is ready, loop on all
// threads to check their state and if possible assign a new package
// to them to compile.
while not Finished do
begin
RTLeventWaitFor(NotifyThreadWaiting);
for Thr:=0 to Defaults.ThreadsAmount-1 do
if assigned(Threads[Thr]) and not Finished then
ProcessThreadResult(Threads[Thr]);
end;
except
on E: Exception do
begin
if not ErrorState then
ErrorMessage := E.Message;
ErrorState:=true;
end;
end;
try
// Compilation finished or aborted. Wait for all threads to end.
for thr:=0 to Defaults.ThreadsAmount-1 do
if assigned(Threads[Thr]) then
begin
Threads[Thr].Terminate;
RTLeventSetEvent(Threads[Thr].NotifyStartTask);
Threads[Thr].WaitFor;
end;
except
on E: Exception do
begin
if not ErrorState then
ErrorMessage := E.Message;
ErrorState:=true;
end;
end;
finally
RTLeventdestroy(NotifyThreadWaiting);
for thr:=0 to Defaults.ThreadsAmount-1 do
Threads[Thr].Free;
if assigned(Threads[Thr]) then
begin
Threads[Thr].Free;
dec(ThreadCount);
end;
end;
if ErrorState then
raise Exception.Create(ErrorMessage);