mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-22 15:29:25 +02:00
Fix for Mantis #28271.
rtl/objpas/classes/classes.inc: + new variable ExternalThreadsCleanup to keep track whether ExternalThreads list is currently cleared * TExternalThread.Create: add the thread instance to the external thread list * TExetrnalThread.Destroy: remove the thread instance from the external thread list (if not in system cleanup anyway) * CommonCleanup: set ExternalThreadsCleanup to true so that the threads don't remove themselves from the list anymore + added test git-svn-id: trunk@31028 -
This commit is contained in:
parent
8214e72841
commit
b0fa341006
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -14513,6 +14513,7 @@ tests/webtbs/tw2809.pp svneol=native#text/plain
|
|||||||
tests/webtbs/tw2812.pp svneol=native#text/plain
|
tests/webtbs/tw2812.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2815.pp svneol=native#text/plain
|
tests/webtbs/tw2815.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2817.pp svneol=native#text/plain
|
tests/webtbs/tw2817.pp svneol=native#text/plain
|
||||||
|
tests/webtbs/tw28271.pp svneol=native#text/pascal
|
||||||
tests/webtbs/tw2829.pp svneol=native#text/plain
|
tests/webtbs/tw2829.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2830.pp svneol=native#text/plain
|
tests/webtbs/tw2830.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2832.pp svneol=native#text/plain
|
tests/webtbs/tw2832.pp svneol=native#text/plain
|
||||||
|
@ -83,6 +83,9 @@ var
|
|||||||
{ this list holds all instances of external threads that need to be freed at
|
{ this list holds all instances of external threads that need to be freed at
|
||||||
the end of the program }
|
the end of the program }
|
||||||
ExternalThreads: TThreadList;
|
ExternalThreads: TThreadList;
|
||||||
|
{ this list signals that the ExternalThreads list is cleared and thus the
|
||||||
|
thread instances don't need to remove themselves }
|
||||||
|
ExternalThreadsCleanup: Boolean = False;
|
||||||
|
|
||||||
{ this must be a global var, otherwise unwanted optimizations might happen in
|
{ this must be a global var, otherwise unwanted optimizations might happen in
|
||||||
TThread.SpinWait() }
|
TThread.SpinWait() }
|
||||||
@ -135,6 +138,7 @@ type
|
|||||||
procedure Execute; override;
|
procedure Execute; override;
|
||||||
public
|
public
|
||||||
constructor Create;
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
@ -149,6 +153,25 @@ begin
|
|||||||
FExternalThread := True;
|
FExternalThread := True;
|
||||||
{ the parameter is unimportant if FExternalThread is True }
|
{ the parameter is unimportant if FExternalThread is True }
|
||||||
inherited Create(False);
|
inherited Create(False);
|
||||||
|
with ExternalThreads.LockList do
|
||||||
|
try
|
||||||
|
Add(Self);
|
||||||
|
finally
|
||||||
|
ExternalThreads.UnlockList;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
destructor TExternalThread.Destroy;
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
if not ExternalThreadsCleanup then
|
||||||
|
with ExternalThreads.LockList do
|
||||||
|
try
|
||||||
|
Extract(Self);
|
||||||
|
finally
|
||||||
|
ExternalThreads.UnlockList;
|
||||||
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
@ -2184,6 +2207,7 @@ begin
|
|||||||
InitHandlerList:=Nil;
|
InitHandlerList:=Nil;
|
||||||
FindGlobalComponentList.Free;
|
FindGlobalComponentList.Free;
|
||||||
FindGlobalComponentList:=nil;
|
FindGlobalComponentList:=nil;
|
||||||
|
ExternalThreadsCleanup:=True;
|
||||||
with ExternalThreads.LockList do
|
with ExternalThreads.LockList do
|
||||||
try
|
try
|
||||||
for i := 0 to Count - 1 do
|
for i := 0 to Count - 1 do
|
||||||
|
65
tests/webtbs/tw28271.pp
Normal file
65
tests/webtbs/tw28271.pp
Normal file
@ -0,0 +1,65 @@
|
|||||||
|
{ %OPT=-gh }
|
||||||
|
|
||||||
|
program tw28271;
|
||||||
|
|
||||||
|
{$mode delphi}{$H+}
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$IFDEF UNIX}
|
||||||
|
cthreads,
|
||||||
|
{$ENDIF}
|
||||||
|
Classes
|
||||||
|
{ you can add units after this };
|
||||||
|
|
||||||
|
type
|
||||||
|
TMyMsgDlg=class
|
||||||
|
private
|
||||||
|
class procedure SyncFree;
|
||||||
|
class procedure SyncCreate;
|
||||||
|
public
|
||||||
|
class procedure StaticCreate;
|
||||||
|
class procedure StaticFree;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
Dlg:TMyMsgDlg;
|
||||||
|
|
||||||
|
class procedure TMyMsgDlg.SyncCreate;
|
||||||
|
begin
|
||||||
|
Dlg:=TMyMsgDlg.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TmyMsgDlg.SyncFree;
|
||||||
|
begin
|
||||||
|
if Assigned(Dlg) then
|
||||||
|
Dlg.free;
|
||||||
|
Dlg:=nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TMyMsgDlg.StaticCreate;
|
||||||
|
begin
|
||||||
|
if IsLibrary then
|
||||||
|
SyncCreate
|
||||||
|
else
|
||||||
|
TThread.Synchronize(nil,SyncCreate);
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TMyMsgDlg.StaticFree;
|
||||||
|
begin
|
||||||
|
if IsLibrary then
|
||||||
|
SyncFree
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
TThread.Synchronize(nil,SyncFree)
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
HaltOnNotReleased := True;
|
||||||
|
//writeln('Create');
|
||||||
|
TMyMsgDlg.StaticCreate;
|
||||||
|
//writeln('Free');
|
||||||
|
TMyMsgDlg.StaticFree;
|
||||||
|
//writeln('Done');
|
||||||
|
end.
|
||||||
|
|
Loading…
Reference in New Issue
Block a user