TDaemon: Thread synchronization is freezed (does not work) on FPC 3.2 but was working on previous releases
Original Reporter info from Mantis: bpascalblockchain@gmail.com
-
Reporter name: Albert Molina
Original Reporter info from Mantis: bpascalblockchain@gmail.com
- Reporter name: Albert Molina
Description:
(Similar to old bug #24511 (closed))
Thread synchronization is not possible with TDaemon on current fpc 3.2 version
Next code fails in FPC 3.2.0 (Latest Lazarus fpc version) but was working as expected on previous FPC version (3.0.4 and older)
Steps to reproduce:
run next application on Linux by calling
$ ./bug_daemon_synchronize -r
---------------------------
program bug_daemon_synchronize;
{$mode objfpc}{$H+}
{$define usecthreads}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
sysutils,
classes,
daemonapp;
Procedure DoLog(const AMessage : String);
var LLogMessage : String;
begin
LLogMessage:=Format('%s %s',[FormatDateTime('hh:nn:ss.zzz',Now),AMessage]);
Application.Log(etInfo,LLogMessage);
Writeln(LLogMessage);
end;
Type
TExampleThread = class(TThread)
FCallTickCount : QWord;
Procedure CallMethod;
protected
procedure Execute; override;
end;
TTestDaemon = Class(TCustomDaemon)
Private
FThread : TExampleThread;
Procedure ThreadTerminated(Sender : TObject);
public
Function Start : Boolean; override;
Function Stop : Boolean; override;
end;
TTestDaemonMapper = Class(TCustomDaemonMapper)
protected
public
Constructor Create(AOwner : TComponent); override;
end;
{ TExampleThread }
procedure TExampleThread.CallMethod;
begin
DoLog(Format('Synchronized call with %d milliseconds deviation',[GetTickCount64() - FCallTickCount]));
end;
procedure TExampleThread.Execute;
begin
repeat
DoLog('Starting sleep time...');
Sleep(1000);
FCallTickCount := GetTickCount64;
DoLog('Trying to Synchronize call...');
Synchronize(@CallMethod);
until (Terminated);
end;
{ TTestDaemon }
procedure TTestDaemon.ThreadTerminated(Sender: TObject);
begin
DoLog('Thread terminated');
FreeAndNil(FThread);
end;
function TTestDaemon.Start: Boolean;
begin
Result:=inherited Start;
DoLog('Daemon Start');
FThread:=TExampleThread.Create(True);
FThread.OnTerminate := @ThreadTerminated;
FThread.Start;
end;
function TTestDaemon.Stop: Boolean;
begin
Result:=inherited Stop;
DoLog('Daemon Stop');
FThread.Terminate;
FThread.WaitFor;
FThread := Nil;
end;
{ TTestDaemonMapper }
constructor TTestDaemonMapper.Create(AOwner: TComponent);
Var
D : TDaemonDef;
begin
inherited Create(AOwner);
D:=DaemonDefs.Add as TDaemonDef;
D.DisplayName:='Bug Daemon Synchronize';
D.Name:='BugDaemonSynchronize';
D.DaemonClassName:='TTestDaemon';
D.Options:=[doAllowStop];
D.WinBindings.ServiceType:=stWin32;
end;
begin
DoLog('App Start');
IsConsole:=True;
Application.Title:='Bug Daemon Synchronize';
RegisterDaemonClass(TTestDaemon);
RegisterDaemonMapper(TTestDaemonMapper);
Application.Run;
DoLog('App End');
end.
Mantis conversion info:
- Mantis ID: 38032
- Version: 3.2.0
- Monitored by: » halmariane (halmariane), » papelhigienico (Fabio Luis Girardi), » bpascalblockchain@gmail.com (Albert Molina)