diff --git a/.gitattributes b/.gitattributes index d487bd2910..9b52a8d8fc 100644 --- a/.gitattributes +++ b/.gitattributes @@ -11407,6 +11407,7 @@ tests/tbs/tb0628.pp svneol=native#text/pascal tests/tbs/tb0629.pp svneol=native#text/pascal tests/tbs/tb0630.pp svneol=native#text/pascal tests/tbs/tb0631.pp svneol=native#text/pascal +tests/tbs/tb0632.pp svneol=native#text/pascal tests/tbs/tb205.pp svneol=native#text/plain tests/tbs/tb610.pp svneol=native#text/pascal tests/tbs/tb613.pp svneol=native#text/plain diff --git a/rtl/objpas/classes/classes.inc b/rtl/objpas/classes/classes.inc index 10cf40de0f..b89cd41c8f 100644 --- a/rtl/objpas/classes/classes.inc +++ b/rtl/objpas/classes/classes.inc @@ -289,11 +289,11 @@ begin end; -procedure ThreadQueueAppend(aEntry: TThread.PThreadQueueEntry); +procedure ThreadQueueAppend(aEntry: TThread.PThreadQueueEntry; aQueueIfMain: Boolean); begin { do we really need a synchronized call? } {$ifdef FPC_HAS_FEATURE_THREADING} - if GetCurrentThreadID = MainThreadID then + if (GetCurrentThreadID = MainThreadID) and (not aQueueIfMain or not IsMultiThread) then {$endif} begin ExecuteThreadQueueEntry(aEntry); @@ -383,7 +383,7 @@ class procedure TThread.Synchronize(AThread: TThread; AMethod: TThreadMethod); syncentry^.Exception := Nil; syncentry^.Method := AMethod; - ThreadQueueAppend(syncentry); + ThreadQueueAppend(syncentry, False); syncentry^.Method := Nil; syncentry^.Next := Nil; @@ -502,6 +502,12 @@ end; class procedure TThread.Queue(aThread: TThread; aMethod: TThreadMethod); static; +begin + InternalQueue(aThread, aMethod, False); +end; + + +class procedure TThread.InternalQueue(aThread: TThread; aMethod: TThreadMethod; aQueueIfMain: Boolean); static; var queueentry: PThreadQueueEntry; begin @@ -516,10 +522,21 @@ begin queueentry^.Method := aMethod; { the queueentry is freed by CheckSynchronize (or by RemoveQueuedEvents) } - ThreadQueueAppend(queueentry); + ThreadQueueAppend(queueentry, aQueueIfMain); end; +procedure TThread.ForceQueue(aMethod: TThreadMethod); +begin + ForceQueue(Self, aMethod); +end; + + +class procedure TThread.ForceQueue(aThread: TThread; aMethod: TThreadMethod); static; +begin + InternalQueue(aThread, aMethod, True); +end; + class procedure TThread.RemoveQueuedEvents(aThread: TThread; aMethod: TThreadMethod); var entry, tmpentry, lastentry: PThreadQueueEntry; diff --git a/rtl/objpas/classes/classesh.inc b/rtl/objpas/classes/classesh.inc index 3e1a0b184c..70dcce1d0d 100644 --- a/rtl/objpas/classes/classesh.inc +++ b/rtl/objpas/classes/classesh.inc @@ -1649,6 +1649,7 @@ type FSynchronizeEntry: PThreadQueueEntry; class function GetCurrentThread: TThread; static; class function GetIsSingleProcessor: Boolean; static; inline; + class procedure InternalQueue(aThread: TThread; aMethod: TThreadMethod; aQueueIfMain: Boolean); static; procedure CallOnTerminate; function GetPriority: TThreadPriority; procedure SetPriority(Value: TThreadPriority); @@ -1666,6 +1667,7 @@ type procedure Execute; virtual; abstract; procedure Synchronize(AMethod: TThreadMethod); procedure Queue(aMethod: TThreadMethod); + procedure ForceQueue(aMethod: TThreadMethod); inline; property ReturnValue: Integer read FReturnValue write FReturnValue; property Terminated: Boolean read FTerminated; {$if defined(windows) or defined(OS2)} @@ -1714,6 +1716,7 @@ type class function CheckTerminated: Boolean; static; class procedure Synchronize(AThread: TThread; AMethod: TThreadMethod); class procedure Queue(aThread: TThread; aMethod: TThreadMethod); static; + class procedure ForceQueue(aThread: TThread; aMethod: TThreadMethod); inline; static; class procedure RemoveQueuedEvents(aThread: TThread; aMethod: TThreadMethod); static; class procedure RemoveQueuedEvents(aMethod: TThreadMethod); static; class procedure RemoveQueuedEvents(aThread: TThread); static; diff --git a/tests/tbs/tb0632.pp b/tests/tbs/tb0632.pp new file mode 100644 index 0000000000..d759fca5f7 --- /dev/null +++ b/tests/tbs/tb0632.pp @@ -0,0 +1,77 @@ +{ Note: needs multi threading } +program tb0632; + +{$mode objfpc} + +uses +{$ifdef unix} + cthreads, +{$endif} + classes; + +type + TTest = class + private + fValue: LongInt; + procedure DoTest; + public + procedure Test; + end; + + TDummyThread = class(TThread) + public + constructor Create; + protected + procedure Execute; override; + end; + +{ TDummyThread } + +constructor TDummyThread.Create; +begin + inherited Create(True); + FreeOnTerminate := True; +end; + +procedure TDummyThread.Execute; +begin + { empty } +end; + +{ TTest } + +procedure TTest.DoTest; +begin + Inc(fValue); +end; + +procedure TTest.Test; +begin + TThread.Queue(Nil, @DoTest); + if fValue <> 1 then + Halt(1); + TThread.ForceQueue(Nil, @DoTest); + if fValue <> 1 then + Halt(2); + CheckSynchronize; + if fValue <> 2 then + Halt(3); + Writeln('Ok'); +end; + +var + t: TTest; +begin +{$ifdef FPC_HAS_FEATURE_THREADING} + { ensure that the RTL is in multi threading mode, otherwise CheckSynchronize + ignores the queue } + TDummyThread.Create.Start; + + t := TTest.Create; + try + t.Test; + finally + t.Free; + end; +{$endif} +end.