FMX and TMediaplayer playing several audio files - multithreading

I am converting a Windows game to FMX 2D. Several audio files for music effects have to play asynchronous. With Windows Mediaplayer and VCL it was running very good. Now with Windows Mediaplayer unexspected C5 errors sometimes occur. Therfore I tried the TMediaplayer from FMX. But this player is not eligable, because the game does not run smoothly. It jerks when music effects are played. It seems the main thread is used. The logic for starting music effects runs in a separate thread. In Windows Mediaplayer it is running very good.
Asynchronous playback of music effects is essential for a game. I cannot understand why a relatively new component is not suitable for this. I haven't found a solution on the internet. Is there any component that offers FMX the appropriate features for this case?
This is a sample program to demonstrate FMX MediaPlayer with Threads:
unit Unit1;
// Demo pgm to demonstrate FMX MediaPlayer using Threads, written by Peter Kloß
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Controls.Presentation, FMX.StdCtrls, FMX.Layouts, FMX.ListBox, FMX.Media;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
ListBox1: TListBox;
LoadButton: TButton;
PlayButton: TButton;
MoveButton: TButton;
Timer1: TTimer;
procedure LoadButtonClick(Sender: TObject);
procedure PlayButtonClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
type
TMsgRecord = record
Filename : string;
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
ThreadVar
msgPtr : ^TMsgRecord;
function PlayMusic(Parameter: Pointer): Integer;
var
MediaPlayer: TMediaPlayer;
begin
Result := 0;
MediaPlayer := TMediaPlayer.Create(Application);
msgPtr := Parameter;
MediaPlayer.FileName := msgPtr.Filename;
MediaPlayer.Play;
repeat
sleep(5);
Application.ProcessMessages;
until MediaPlayer.State <> TMediaState.Playing;
//MediaPlayer.Free; // leads to C5 error in FMX at end of pgm
FreeMem(msgPtr);
EndThread(0);
end;
procedure TForm1.LoadButtonClick(Sender: TObject);
begin
if OpenDialog1.Execute then
ListBox1.Items.AddStrings(OpenDialog1.Files);
end;
procedure TForm1.PlayButtonClick(Sender: TObject);
var
id: LongWord;
thread: Integer;
msg: ^TMsgRecord;
begin
if ListBox1.ItemIndex < 0 then
exit;
GetMem(msg, Sizeof(TMsgRecord));
msg.Filename := ListBox1.Items[ListBox1.ItemIndex];
thread := BeginThread(nil, 0, Addr(PlayMusic), msg, 0, id);
//CloseHandle(thread);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if MoveButton.Tag = 0 then
begin
MoveButton.Position.X := MoveButton.Position.X - 1;
if MoveButton.Position.X = 0 then
MoveButton.Tag := 1;
end
else
begin
MoveButton.Position.X := MoveButton.Position.X + 1;
if MoveButton.Position.X = Form1.Width - MoveButton.Width then
MoveButton.Tag := 0;
end
end;
end.
On Form1 there are 2 buttons. One for loading filenames into Listbox1. And one Play button. When Play button is clicked, a thread is started which creates a MediaPlayer and plays the sound given by parameter filename. To see the influence to the programs main activity there is a MoveButton sliding from left to right and vice versa on Form1. For that Timer1 is used, fired every 15 msecs. One can see (and hear) when several sounds are started and playing parallel. The sound should take some seconds so that overlapping occurs and the negative effect is noticeable.

Related

Delphi TMonitor.Wait multi-threading problem

We have run into this multi-threading problem in our backend services:
In a multi-threading Windows service app, with 30+ threads, problem in SysUtils.EventCache arise. The problem is that NewWaitObj function sometimes return NIL instead of Event object. This function is used in TMonitor sync methods Wait. TMonitor.Wait stops working when it get NIL for event object. That affects many VCL and RTL thread sync source code and it cause different side problems in multi-threading apps, for example TThreadedQueue.PopItem doesnt wait for new item to arrive in Queue and returns immediately with timeout result.
Problem occurs in NewWaitObj function:
function NewWaitObj: Pointer;
var
EventItem: PEventItemHolder;
begin
EventItem := Pop(EventCache);
if EventItem <> nil then
begin
Result := EventItem.Event;
EventItem.Event := nil;
Push(EventItemHolders, EventItem);
end else
Result := NewSyncWaitObj;
ResetSyncWaitObj(Result);
end;
Looks like Pop function is not well protected in heavy multi-threaded app and at some number of concurrent threads it starts to return one and the same EventItem instance to two (or more) threads. Then race conditions are happening in NewWaitObj:
One thread takes EventItem.Event and return it as Result and zero it with NIL, the racing parallel thread is getting the same EventItem.Event but it is already cleared by first thread.
That cause one of racing threads to return valid Event handle and the other(s) racing threads return NIL.
TMonitor.Wait function doesnt work, because it get NIL as Event handle.
TThreadedQueue.PopItem doesnt wait, other sync methods also doesnt work correctly.
For some reason thread sync in Pop method doesnt work when app have many concurrent threads:
function Pop(var Stack: PEventItemHolder): PEventItemHolder;
begin
repeat
Result := Stack;
if Result = nil then
Exit;
until AtomicCmpExchange(Pointer(Stack), Result.Next, Result) = Result;
end;
In test app on 60 test threads problem arise in about 10-20 secs, with 30 threads its much harder to happens, usually 5-10 mins are needed. Once problem occurs - it never stop until restart of App. In test app after thread sync get broken - about one of each 5 operations with EventCache return NIL. Looks like something get broken in AtomicCmpExchange, I've checked the generated code - it's just one CMPXCHG instruction and few more to setup registers. I am not quite sure what cause the problem - can one thread get intervention from other thread for example while it setups registers to call CMPXCHG or after the call while it process the results?
Trying to understand what cause the problem, so I can find best workaround. For now I am planning to replace original NewWaitObj with my own, which will just call the original version till it return valid object. This problem occurs constantly in our dev, test and prod environments, for real middle-ware services on production servers it's needed few hours (sometimes couple of days) for problem to arise, after that only restart fix the problem.
Test app can be downloaded from issue in Embarcadero JIRA: https://quality.embarcadero.com/browse/RSP-31154
EDIT: TestApp: https://quality.embarcadero.com/secure/attachment/31605/EventCacheBug.zip
Example Delphi source code:
unit FormMainEventCacheBugU;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Math, Vcl.StdCtrls;
const
MaxProducers = 60;
type
TFormEventCacheBug = class(TForm)
BtnMaxProducers: TButton;
BtnRemoveProducer: TButton;
BtnAddProducer: TButton;
procedure BtnMaxProducersClick(Sender: TObject);
procedure BtnRemoveProducerClick(Sender: TObject);
procedure BtnAddProducerClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TEventEater = class(TThread)
private
SleepTime: Integer;
SMsg, EMsg, NMsg: PChar;
procedure EatEvent;
protected
procedure Execute; override;
public
constructor Create;
end;
var
FormEventCacheBug: TFormEventCacheBug;
Producers: array[1..MaxProducers] of TThread;
ProdCount: Integer;
implementation
{$R *.dfm}
procedure AddProducer;
begin
if ProdCount < MaxProducers then
begin
Inc(ProdCount);
Producers[ProdCount] := TEventEater.Create;
Producers[ProdCount].FreeOnTerminate := True;
end;
end;
procedure RemoveProducer;
begin
if ProdCount > 0 then
begin
Producers[ProdCount].Terminate;
Dec(ProdCount);
end;
end;
{ TEventEater }
constructor TEventEater.Create;
begin
inherited Create(False);
SleepTime := RandomRange(1, 3);
end;
procedure TEventEater.EatEvent;
var
EventHandle: Pointer;
begin
//OutputDebugString(SMsg);
EventHandle := System.MonitorSupport.NewWaitObject;
try
if EventHandle = nil then
OutputDebugString('NIL');
Sleep(SleepTime);
finally
if EventHandle <> nil then
System.MonitorSupport.FreeWaitObject(EventHandle);
// OutputDebugString(EMsg);
end;
end;
procedure TEventEater.Execute;
begin
SMsg := PChar('S:' + GetCurrentThreadId.ToString);
EMsg := PChar('E:' + GetCurrentThreadId.ToString);
NMsg := PChar('NIL:' + GetCurrentThreadId.ToString);
while not Terminated do
begin
EatEvent;
Sleep(SleepTime);
end;
end;
procedure TFormEventCacheBug.BtnAddProducerClick(Sender: TObject);
begin
AddProducer;
end;
procedure TFormEventCacheBug.BtnRemoveProducerClick(Sender: TObject);
begin
RemoveProducer;
end;
procedure TFormEventCacheBug.BtnMaxProducersClick(Sender: TObject);
var
i: Integer;
begin
for i := ProdCount + 1 to MaxProducers do
AddProducer;
end;
end.
Thanks for any ideas,
#MiroslavPenchev, thank you for the post!
Working in XE2 and had similar issue.
Delphi 10.4.1 got TMonitor ABA problem solved using the linked list head with a counter and 128-bit Compare Exchange.
Unfortunately this is not an easy option for XE2.
Again, thanks to your suggestion to override some of MonitorSupport methods calling original ones.
The following is the solution that I'm using. It is not 100% perfect as involves locking, but for less concurrent environment it at least makes system stable and free from 100% CPU issue.
var
MonitorSupportFix: TMonitorSupport;
OldMonitorSupport: PMonitorSupport;
NewWaitObjCS: TCriticalSection;
function NewWaitObjFix: Pointer;
begin
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Enter;
try
Result := OldMonitorSupport.NewWaitObject;
finally
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Leave;
end;
end;
procedure FreeWaitObjFix(WaitObject: Pointer);
begin
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Enter;
try
OldMonitorSupport.FreeWaitObject(WaitObject);
finally
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Leave;
end;
end;
procedure InitMonitorSupportFix;
begin
OldMonitorSupport := System.MonitorSupport;
MonitorSupportFix := OldMonitorSupport^;
MonitorSupportFix.NewWaitObject := NewWaitObjFix;
MonitorSupportFix.FreeWaitObject := FreeWaitObjFix;
System.MonitorSupport := #MonitorSupportFix;
end;
initialization
NewWaitObjCS := TCriticalSection.Create;
InitMonitorSupportFix;
finalization
FreeAndNil(NewWaitObjCS);
end.

Better methodology for indicating thread finished than MsgWaitForMultipleObjects?

So I came across some code similar to this:
aThread := TmyThread.Create(param1, param2);
h := aThread.handle;
repeat
if (MsgWaitForMultipleObjects(1, h, False, INFINITE, QS_ALLINPUT) = WAIT_OBJECT_0)
then break;
Application.ProcessMessages
until False;
aThread.Free;
myProgressBar.Progress := myProgressBar.Max; //an internal component, not really important here
Which, I assume, is meant to provide a way of updating the GUI so it doesn't appear blocked, but also allow for the end process GUI to be updated (the progress bar), while some long task is taking place.
But it contains the dreaded Application.ProcessMessages.
I've read The Darkside of Application.ProcessMessages and many other Delphi blogs suggesting it's time to use a new thread instead when Application.ProcessMessages is being used.
So, is it wise to phase out this method of keeping the main/GUI threaded idle for something like the AnonymousThread approach shown here? Or something else?
This Noob is confused as to why it's suggested that a process that calls Application.ProcessMessages is a good candidate for a Thread, but the thread in question relies on the very thing we're being told not to do!
The main idea is not to wait for the thread. Thread should inform your form when it finished. In other words the code which should be executed after the the thread is finished should be isolated to a separate procedure (see TForm1.ThreadCompletedHandler) and thread should call it after it is finished.
Here is a small sample:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls;
type
TmyThread = class(TThread)
private
FParam1, FParam2: Integer;
FUpdateProc: TProc<TmyThread, Integer>;
FCompleteProc: TProc<TmyThread>;
procedure SyncCompleteProc;
procedure QueueUpdateProc(APosition: Integer);
protected
procedure Execute; override;
public
constructor Create(AParam1, AParam2: Integer;
AUpdateProc: TProc<TmyThread, Integer>;
ACompleteProc: TProc<TmyThread>);
end;
TForm1 = class(TForm)
Button1: TButton;
myProgressBar: TProgressBar;
procedure Button1Click(Sender: TObject);
private
FThread: TThread;
procedure ThreadUpdateHandler(AThread: TMyThread; APosition: Integer);
procedure ThreadCompletedHandler(AThread: TMyThread);
protected
procedure UpdateActions; override;
public
destructor Destroy; override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TmyThread }
constructor TmyThread.Create(AParam1, AParam2: Integer; AUpdateProc: TProc<TMyThread, Integer>;
ACompleteProc: TProc<TMyThread>);
begin
FParam1 := AParam1;
FParam2 := AParam2;
FUpdateProc := AUpdateProc;
FCompleteProc := ACompleteProc;
inherited Create(False);
end;
procedure TmyThread.Execute;
var
I: Integer;
begin
//inherited; - abstract
try
I := FParam1;
while not Terminated and (I < FParam2) do
begin
Sleep(1000);
Inc(I);
QueueUpdateProc(I);
end;
finally
if Assigned(FCompleteProc) then
TThread.Queue(Self, SyncCompleteProc);
end;
end;
procedure TmyThread.QueueUpdateProc(APosition: Integer);
begin
if Terminated or not Assigned(FUpdateProc) then
Exit;
TThread.Queue(Self,
procedure
begin
FUpdateProc(Self, APosition);
end);
end;
procedure TmyThread.SyncCompleteProc;
begin
FCompleteProc(Self);
end;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
const
param1 = 1;
param2 = 5;
begin
myProgressBar.Min := param1;
myProgressBar.Max := param2 + 1;
myProgressBar.Position := param1;
FThread := TmyThread.Create(param1, param2, ThreadUpdateHandler, ThreadCompletedHandler);
end;
destructor TForm1.Destroy;
begin
if Assigned(FThread) then
FThread.Terminate;
inherited;
end;
procedure TForm1.ThreadCompletedHandler(AThread: TmyThread);
begin
try
if not AThread.Terminated then // check form is not destroye yet
begin
FThread := nil;
myProgressBar.Position := myProgressBar.Max; //an internal component, not really important}
end;
finally
FreeAndNil(AThread);
end;
end;
procedure TForm1.ThreadUpdateHandler(AThread: TMyThread; APosition: Integer);
begin
if not AThread.Terminated then // check form is not destroye yet
myProgressBar.Position := APosition;
end;
procedure TForm1.UpdateActions;
begin
inherited;
Button1.Enabled := not Assigned(FThread);
end;
end.
and DFM file
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 290
ClientWidth = 554
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 24
Top = 16
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object myProgressBar: TProgressBar
Left = 120
Top = 108
Width = 150
Height = 17
TabOrder = 1
end
end
NB In this sample form does not wait for the thread so potentially we may close the application before the thread is terminated. It should not be a problem for this sample as it simple enough but in real live you may need to wait for the thread in Form.Destroy or create some thread manager which should wait for all running threads before application is finished.

A thread fails to update the image as expected

I am trying to write a Delphi code to update the TImage components on a from. I was using C++ for long time but don't have much experience in Delphi;however, I need to use Delphi for some reason. I obtained and modified a similar code to do the task as shown as follows. I have 4 TImages components placed on a form, I start a thread to update the images when the player press the button. I have 6 resource bitmaps with numbered in 1 to 6 embedded in the project and the code will randomly pick and load the resource bitmap into the TImage. I find that using the thread sometimes, some images will not be drawn (just blank like no image being loaded). I know you may be wondering why I need to use a thread and why not just call ShowRanodmImage when the button is pressed. In this simple case, surely I don't have to use thread instead but I am going to apply to some situation that threading must be used. So my question is why the following code will occationally not show the proper image? How to fix that? Thanks a lot.
unit TTUnit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type
TTestThread = class;
TTestForm = class(TForm)
NextBTN: TButton;
P11: TPanel;
P12: TPanel;
P13: TPanel;
P14: TPanel;
CELL11: TImage;
CELL12: TImage;
CELL22: TImage;
CELL21: TImage;
procedure FormCreate(Sender: TObject);
procedure NextBTNClick(Sender: TObject);
private
myThread :TTestThread;
pImgs: array[1..2, 1..2] of TImage;
public
procedure ShowRandomImg;
end;
TTestThread = class(TThread)
private
myForm :TTestForm;
protected
procedure Execute(); override;
public
constructor Create(aFrom :TTestForm; CreateSuspended: Boolean);
end;
var
TestForm: TTestForm;
implementation
{$R *.dfm}
procedure TTestForm.FormCreate(Sender: TObject);
begin
myThread := TTestThread.Create(Self, True);
pImgs[1][1]:=CELL11; pImgs[1][2]:=CELL12;
pImgs[2][1]:=CELL21; pImgs[2][2]:=CELL22;
end;
procedure TTestForm.NextBTNClick(Sender: TObject);
begin
myThread.Resume;
end;
procedure TTestForm.ShowRandomImg;
var
i, j :Integer;
r :array[1..2, 1..2] of Integer;
begin
Self.NextBTN.Enabled := false;
r[1][1] := Random(6)+1;
r[1][2] := Random(6)+1;
r[2][1] := Random(6)+1;
r[2][2] := Random(6)+1;
for i := 1 to 2 do
begin
for j := 1 to 2 do
begin
pImgs[i][j].Picture.Bitmap.LoadFromResourceID(HInstance, r[i][j]);
pImgs[i][j].Canvas.Font.Size := 38;
pImgs[i][j].Canvas.Font.Color := clRed;
pImgs[i][j].Canvas.Font.Style := [fsBold];
pImgs[i][j].Canvas.TextOut(20, 20, inttostr(r[i][j]));
end;
end;
Self.NextBTN.Enabled := true;
end;
////////////////////
constructor TTestThread.Create(aFrom: TTestForm; CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
Self.myForm := aFrom;
end;
procedure TTestThread.Execute;
begin
inherited;
Repeat
Self.myForm.ShowRandomImg;
Self.Suspend;
Until Terminated;
end;
end.

How to open ClientDataSet (master/detail) in separate thread(different of main thread)

Using: Delphi XE2, DBExpress, Firebird
I can't access any VCL control outside the main thread safely, that includes forms, panels, edits, etc and the Timage and Timage descendants. I'm need to open ClientDataSet (Master/Detail) in separate Thread(different of main thread).
I'm need to create animated splash screen while accessing database
Can someone show me a simple example of how to do this?
I'm assuming that the database access in a thread is of no problem for you.
For a complete example of a threaded access to a dbExpress database (including feedback to the main thread), see the examples made by Marco Cantù here: dbexpress_firebird_examples.
It involves putting all the database connection setup in a TDataModule and creating an instance of this datamodule for each threaded access.
Anyway,
to make the GUI informed about the background thread process with an animated Gif, here is an example:
unit TestAnimatedScreen;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Imaging.GIFImg,
Vcl.ExtCtrls;
type
TMyEndNotify = procedure (value: Boolean) of object;
type
TMyThread = class(TThread)
private
fEndNotification : TMyEndNotify;
procedure NotifyEndOfThread;
protected
procedure Execute; override;
public
Constructor Create(endNotification : TMyEndNotify);
end;
type
TMainForm = class(TForm)
Image1: TImage;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
FShowAnimation : Boolean;
procedure SetShowAnimation(value : Boolean);
public
{ Public declarations }
property ShowAnimation : Boolean read FShowAnimation write SetShowAnimation;
end;
var
MainForm: TMainForm;
implementation
{$R *.dfm}
procedure TMyThread.NotifyEndOfThread;
begin
if Assigned(fEndNotification) then
fEndNotification(False);
end;
constructor TMyThread.Create(endNotification: TMyEndNotify);
begin
Inherited Create(false);
fEndNotification := endNotification;
Self.FreeOnTerminate := True; // Free automatically
end;
procedure TMyThread.Execute;
begin
try
{Add your database access code here}
Sleep(5000); // Simulate lengthy process
finally
Synchronize(NotifyEndOfThread);
end;
end;
{ TMainForm }
procedure TMainForm.Button1Click(Sender: TObject);
begin
ShowAnimation := True;
TMyThread.Create(Self.SetShowAnimation);
end;
procedure TMainForm.SetShowAnimation(value: Boolean);
begin
FShowAnimation := Value;
if FShowAnimation then
begin
{Add animation code here}
Button1.Enabled := false;
Button1.Caption := 'Processing, please wait ...';
(Image1.Picture.Graphic as TGIFImage).AnimateLoop := glEnabled;
(Image1.Picture.Graphic as TGIFImage).Animate := true;
end
else
begin
{Stop animation}
(Image1.Picture.Graphic as TGIFImage).Animate := false;
Button1.Caption := 'Start lengthy process';
Button1.Enabled := True;
end;
end;
end.
object MainForm: TMainForm
Left = 0
Top = 0
Caption = 'MainForm'
ClientHeight = 265
ClientWidth = 236
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Image1: TImage
Left = 8
Top = 8
Width = 200
Height = 200
AutoSize = True
IncrementalDisplay = True
end
object Button1: TButton
Left = 8
Top = 224
Width = 200
Height = 25
Caption = 'Start lengthy process'
TabOrder = 0
OnClick = Button1Click
end
end
Should you have an older Delphi version than Delphi 2007, see How to use Animated Gif in a delphi form for more information about how to implement an animated GIF.
The animated GIF I used can be found here.

Delphi 2010: No thread vs threads

I'm user of delphi 2010, my current machine is intel core i7, running windows 7 x64. I've write the following codes:
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
FCount: Integer;
FTickCount: Cardinal;
procedure DoTest;
procedure OnTerminate(Sender: TObject);
end;
TMyThread = class(TThread)
private
FMethod: TProc;
protected
procedure Execute; override;
public
constructor Create(const aCreateSuspended: Boolean; const aMethod: TProc);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var i: integer;
T1, T2: Cardinal;
begin
T1 := GetTickCount;
for i := 0 to 9 do
DoTest;
T2 := GetTickCount;
Memo1.Lines.Add(Format('no thread=%4f', [(T2 - T1)/1000]));
end;
procedure TForm1.Button2Click(Sender: TObject);
var T: TMyThread;
i: integer;
begin
FCount := 0;
FTickCount := GetTickCount;
for i := 0 to 9 do begin
T := TMyThread.Create(True, DoTest);
T.OnTerminate := OnTerminate;
T.Priority := tpTimeCritical;
if SetThreadAffinityMask(T.Handle, 1 shl (i mod 8)) = 0 then
raise Exception.Create(IntToStr(GetLastError));
Inc(FCount);
T.Start;
end;
end;
procedure TForm1.DoTest;
var i: integer;
begin
for i := 1 to 10000000 do
IntToStr(i);
end;
procedure TForm1.OnTerminate(Sender: TObject);
begin
Dec(FCount);
if FCount = 0 then
Memo1.Lines.Add(Format('thread=%4f', [(GetTickCount - FTickCount)/1000]));
end;
constructor TMyThread.Create(const aCreateSuspended: Boolean; const aMethod:
TProc);
begin
inherited Create(aCreateSuspended);
FMethod := aMethod;
FreeOnTerminate := True;
end;
procedure TMyThread.Execute;
begin
FMethod;
end;
Click on Button1 will shows 12.25 seconds, while Button2 will shows 12.14 seconds. My problem is why i cannot get more obvious difference of time taken (less than 10 seconds) although i'm running parallel threads ?
Memory allocation seems to be the main problem here.
If you replace the payload with
procedure TForm6.DoTest;
var i: integer;
a: double;
begin
a := 0;
for i := 1 to 10000000 do
a := Cos(a);
end;
the code will parallelize nicely indicating that there's no real problem with your framework.
If you, however, replace the payload with memory allocation/deallocation
procedure TForm6.DoTest;
var i: integer;
p: pointer;
begin
for i := 1 to 10000000 do begin
GetMem(p, 10);
FreeMem(p);
end;
end;
the parallel version will run much slower than the single-threaded one.
When calling IntToStr, a temporary string is allocated and destroyed and this allocations/deallocations are creating the bottleneck.
BTW1: Unless you really really know what you're doing, I'm strongly advising against running threads at tpTimeCritical priority. Even if you really really know what you're doing you shouldn't be doing that.
BTW2: Unless you really really know what you're doing, you should not mess with affinity masks on thread level. System is smart enough to schedule threads nicely.
If you have memory intensive threads (many memory allocations/deallocations) you better use TopMM instead of FastMM: http://www.topsoftwaresite.nl/
FastMM uses a lock which blocks all other threads, TopMM does not so it scales much better on multi cores/cpus!
I'm not 100% sure, but there's a chance that the OnTerminate event is called from the context of the TThread. If that's the case (I must admit I haven't checked this), you'd be better off using InterlockedDecrement on FCount, and synchronizing the GUI updates. Just a minor point, but in production code these things matter.

Resources