What is TMonitor in Delphi System unit good for? - delphi

After reading the articles "Simmering Unicode, bring DPL to a boil" and "Simmering Unicode, bring DPL to a boil (Part 2)" of "The Oracle at Delphi" (Allen Bauer), Oracle is all I understand :)
The article mentions Delphi Parallel Library (DPL), lock free data structures, mutual exclusion locks and condition variables (this Wikipedia article forwards to 'Monitor (synchronization)', and then introduces the new TMonitor record type for thread synchronization and describes some of its methods.
Are there introduction articles with examples which show when and how this Delphi record type can be used? There is some documentation online.
What is the main difference between TCriticalSection and TMonitor?
What can I do with the Pulse and PulseAllmethods?
Does it have a counterpart for example in C# or the Java language?
Is there any code in the RTL or the VCL which uses this type (so it could serve as an example)?
Update: the article Why Has the Size of TObject Doubled In Delphi 2009? explains that every object in Delphi now can be locked using a TMonitor record, at the price of four extra bytes per instance.
It looks like TMonitor is implemented similar to Intrinsic Locks in the Java language:
Every object has an intrinsic lock
associated with it. By convention, a
thread that needs exclusive and
consistent access to an object's
fields has to acquire the object's
intrinsic lock before accessing them,
and then release the intrinsic lock
when it's done with them.
Wait, Pulse and PulseAll in Delphi seem to be counterparts of wait(), notify() and notifyAll() in the Java programming language. Correct me if I am wrong :)
Update 2: Example code for a Producer/Consumer application using TMonitor.Wait and TMonitor.PulseAll, based on an article about guarded methods in the Java(tm) tutorials (comments are welcome):
This kind of application shares data
between two threads: the producer,
that creates the data, and the
consumer, that does something with it.
The two threads communicate using a
shared object. Coordination is
essential: the consumer thread must
not attempt to retrieve the data
before the producer thread has
delivered it, and the producer thread
must not attempt to deliver new data
if the consumer hasn't retrieved the
old data.
In this example, the data is a series of text messages, which are shared through an object of type Drop:
program TMonitorTest;
// based on example code at http://download.oracle.com/javase/tutorial/essential/concurrency/guardmeth.html
{$APPTYPE CONSOLE}
uses
SysUtils, Classes;
type
Drop = class(TObject)
private
// Message sent from producer to consumer.
Msg: string;
// True if consumer should wait for producer to send message, false
// if producer should wait for consumer to retrieve message.
Empty: Boolean;
public
constructor Create;
function Take: string;
procedure Put(AMessage: string);
end;
Producer = class(TThread)
private
FDrop: Drop;
public
constructor Create(ADrop: Drop);
procedure Execute; override;
end;
Consumer = class(TThread)
private
FDrop: Drop;
public
constructor Create(ADrop: Drop);
procedure Execute; override;
end;
{ Drop }
constructor Drop.Create;
begin
Empty := True;
end;
function Drop.Take: string;
begin
TMonitor.Enter(Self);
try
// Wait until message is available.
while Empty do
begin
TMonitor.Wait(Self, INFINITE);
end;
// Toggle status.
Empty := True;
// Notify producer that status has changed.
TMonitor.PulseAll(Self);
Result := Msg;
finally
TMonitor.Exit(Self);
end;
end;
procedure Drop.Put(AMessage: string);
begin
TMonitor.Enter(Self);
try
// Wait until message has been retrieved.
while not Empty do
begin
TMonitor.Wait(Self, INFINITE);
end;
// Toggle status.
Empty := False;
// Store message.
Msg := AMessage;
// Notify consumer that status has changed.
TMonitor.PulseAll(Self);
finally
TMonitor.Exit(Self);
end;
end;
{ Producer }
constructor Producer.Create(ADrop: Drop);
begin
FDrop := ADrop;
inherited Create(False);
end;
procedure Producer.Execute;
var
Msgs: array of string;
I: Integer;
begin
SetLength(Msgs, 4);
Msgs[0] := 'Mares eat oats';
Msgs[1] := 'Does eat oats';
Msgs[2] := 'Little lambs eat ivy';
Msgs[3] := 'A kid will eat ivy too';
for I := 0 to Length(Msgs) - 1 do
begin
FDrop.Put(Msgs[I]);
Sleep(Random(5000));
end;
FDrop.Put('DONE');
end;
{ Consumer }
constructor Consumer.Create(ADrop: Drop);
begin
FDrop := ADrop;
inherited Create(False);
end;
procedure Consumer.Execute;
var
Msg: string;
begin
repeat
Msg := FDrop.Take;
WriteLn('Received: ' + Msg);
Sleep(Random(5000));
until Msg = 'DONE';
end;
var
ADrop: Drop;
begin
Randomize;
ADrop := Drop.Create;
Producer.Create(ADrop);
Consumer.Create(ADrop);
ReadLn;
end.
Now this works as expected, however there is a detail which I could improve: instead of locking the whole Drop instance with TMonitor.Enter(Self);, I could choose a fine-grained locking approach, with a (private) "FLock" field, using it only in the Put and Take methods by TMonitor.Enter(FLock);.
If I compare the code with the Java version, I also notice that there is no InterruptedException in Delphi which can be used to cancel a call of Sleep.
Update 3: in May 2011, a blog entry about the OmniThreadLibrary presented a possible bug in the TMonitor implementation. It seems to be related to an entry in Quality Central. The comments mention a patch has been provided by a Delphi user, but it is not visible.
Update 4: A blog post in 2013 showed that while TMonitor is 'fair', its performance is worse than that of a critical section.

TMonitor combines the notion of a critical section (or a simple mutex) along with a condition variable. You can read about what a "monitor" is here:
http://en.wikipedia.org/wiki/Monitor_%28synchronization%29
Any place you would use a critical section, you can use a monitor. Instead of declaring a TCriticalSection, you can simple create a TObject instance and then use that:
TMonitor.Enter(FLock);
try
// protected code
finally
TMonitor.Exit(FLock);
end;
Where FLock is any object instance. Normally, I just create a TObject:
FLock := TObject.Create;

Related

How to detect that a form is being destroyed across the Application?

We have many forms in our application, and I need a global event handler to detect when one of the forms is being destroyed (and then take some action).
p.s: I want to avoid adding code to each form that will need to send a message to the main form when it's about to destroy. also most of the forms are created and destroyed dynamicaly at run-time.
I was thinking about maybe use a global TApplicationEvents.
What is the best approach for this?
Contrary to David's answer, there is a suitable framework. It's built in higher up in the class hierarchy at TComponent. Sir Rufo is on the right track, but you don't need to force your forms to be owned by this object.
You're welcome to write any number of classes that can take specialised action when a form (or any other component for that matter) is destroyed. E.g.
TDestroyedFormLogger = class(TComponent)
protected
{ Write to log file when forms are destroyed. }
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
end;
TMenuManager = class(TComponent)
protected
{ Remove/hide a menu item corresponding to the form that has been destroyed. }
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
end;
Now whenever you create a form, simply set a notification as follows (assuming you have given yourself access to suitable instances of the above objects):
LForm := TMyForm.Create(Application);
LForm.FreeNotification(DestroyedFormLogger);
LForm.FreeNotification(MenuManager);
This approach is better than using the OnDestroy event because that permits only 1 observer, whereas FreeNotification permits any number of observers.
NOTE: As with any useful technique, don't force-fit a problem to the technique. There may be a more appropriate technique to your specific problem. E.g. The MenuManager idea might be better solved by using the global Screen object to iterate forms OnPopup.
EDIT: Explanation of Observer Pattern
The TComponent notification mechanism is a built-in implementation of the Observer Pattern for when a component is destroyed. FreeNotification (perhaps not ideally named) is the equivalent of registerObserver and RemoveNotification the equivalent of unregisterObserver.
The whole point of the observer pattern is that the subject being observed (sometimes called publisher) has no type-specific knowledge of the objects that are observing it (sometimes called subscribers). Publishers only know that they are able to call a generic notification method on each registered subscriber (observer). This allows objects to be loosely coupled from those that are watching it. In fact the publisher doesn't even need to be observed at all. Obviously the registration method needs to be called either from the subscribers themselves or from a third-party - otherwise the decoupling objective is defeated.
Observers can be implemented at varying degrees of complexity. The simplest being an event or callback. The most complex being a dispatcher that manages registrations in-between and independent of both publishers and subscribers. The dispatcher might even implement thread switching so that publishers don't even get impacted by performance side-effects of slow subscribers.
TComponent's observer implementation has a limitation that both the publisher and subscriber must inherit from TComponent. Basically any component can register with another component to be notified of its destruction.
Perhaps the most common use of this feature in Delphi is: When component A has a reference to component B; If component B is destroyed, component A is notified so that it can set its reference to nil.
What you are wanting is for the framework to fire an event when a form is destroyed. When a form is destroyed, its destructor is run. So, in order for the framework to fire such an event, it would need to be implemented from within the form's destructor. If you take a look inside TCustomForm.Destroy, you will find that there is not such event.
From this we can conclude that there can be no application wide event fired whenever a form is destroyed. This means that you will have to implement a solution yourself. One obvious way to make this happen is to introduce a common base class for all your forms. Ensure that every form in your program derives ultimately from this common base class. Then arrange for the base class to surface an event that is fired whenever an instance is destroyed.
There seems to be some mis-understanding about what I am saying above. Craig demonstrates how to subscribe to notification of a single form's destruction. The ability to do that does not contradict what I am saying. My point is that there is no mechanism in place that allows you to subscribe to receive notification when any form is destroyed.
A constraint on modifying code in existing forms, or creation of forms, as can be seen from other answers and comments, leaves hacks and hooks. A local CBT hook, f.i., would be a little work but probably work fine. Below is one of the simpler hacky solutions.
Screen global object holds a list of forms at all times via a regular TList. TList has a virtual Notify procedure which is called every time an item is added/removed. The idea is to employ a TList derivative that overrides this method and use it in the Screen object.
type
TNotifyList = class(TList)
protected
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
end;
procedure TNotifyList.Notify(Ptr: Pointer; Action: TListNotification);
begin
inherited;
if (Action = lnDeleted) and (csDestroying in TForm(Ptr).ComponentState) and
(TForm(Ptr) <> Application.MainForm) then
// do not use ShowMessage or any 'TForm' based dialog here
MessageBox(0,
PChar(Format('%s [%s]', [TForm(Ptr).ClassName, TForm(Ptr).Name])), '', 0);
end;
Testing for csDestroying is required because the Screen adds/removes forms to its list not only when forms are created/destroyed but also when they are activated etc..
Then make the Screen use this list. This requires an "accessing private fields" hack, as the FForms list is private. You can read about this hack on Hallvard Vassbotn's blog. It also requires "changing the class of an object at run time" hack. You can read about this hack on Hallvard Vassbotn's blog.
type
THackScreenFForms = class
{$IF CompilerVersion = 15}
Filler: array [1..72] of Byte;
{$ELSE}
{$MESSAGE ERROR 'verify/modify field position before compiling'}
{$IFEND}
Forms: TList;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
PPointer(THackScreenFForms(Screen).Forms)^ := TNotifyList;
end;
Note that the notification will be called for every form destruction. This also includes forms created through MessageDlg, ShowMessage etc..
This is not the best practice (have a look at David's answer) but a way to go.
Since every form can have an owner (type TComponent) and this owner gets notified, if a child component is destroyed, just create a global form owner and pass this as the owner of every created form you want to get notified on destroy.
You have to override the TComponent.Notification method and do what you have to (e.g. fire an event)
unit GlobalViewHolder;
interface
uses
Forms,
Classes;
type
TComponentNotificationEvent = procedure( Sender : TObject; AComponent : TComponent; Operation : TOperation ) of object;
TGlobalViewHolder = class( TComponent )
private
FOnNotification : TComponentNotificationEvent;
protected
procedure Notification( AComponent : TComponent; Operation : TOperation ); override;
public
property OnNotification : TComponentNotificationEvent read FOnNotification write FOnNotification;
end;
// small and simple singleton :o)
function ViewHolder : TGlobalViewHolder;
implementation
var
_ViewHolder : TGlobalViewHolder;
function ViewHolder : TGlobalViewHolder;
begin
if not Assigned( _ViewHolder )
then
_ViewHolder := TGlobalViewHolder.Create( Application );
Result := _ViewHolder;
end;
{ TGlobalViewHolder }
procedure TGlobalViewHolder.Notification( AComponent : TComponent; Operation : TOperation );
begin
inherited;
if Assigned( OnNotification )
then
OnNotification( Self, AComponent, Operation );
end;
end.
The main form owner is always Application but there is no need to track this.
Personally I'd prefer David Heffernan's solution since all my forms are allways based on a template and it would be the cleanest and easiest to implement way.
But coming from you demand
p.s: I want to avoid adding code to each form that will need to send a message to the main form when it's about to destroy. also most of the forms are created and destroyed dynamicaly at run-time.
you would be able to patch Destroy to an own method.
I'd take the latest called destructor in the chain and patch TObject.Destroy to TMyClass.Destroy. The place to implement should be the project.
The code for patching is taken from David Heffernan 's answer on Patch routine call in delphi and only included to keep the answer complete, credits regarding this code go there.
program AInformOnCloseForms;
uses
Forms,
Classes,
Windows,
Dialogs,
Unit3 in 'Unit3.pas' {Mainform},
Unit4 in 'Unit4.pas' {Form2};
{$R *.res}
// PatchCode and RedirectProcedure are taken from David Heffernans answer
// https://stackoverflow.com/a/8978266/1699210
// on "Patch routine call in delphi" , credits regarding this code go there
procedure PatchCode(Address: Pointer; const NewCode; Size: Integer);
var
OldProtect: DWORD;
begin
if VirtualProtect(Address, Size, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
Move(NewCode, Address^, Size);
FlushInstructionCache(GetCurrentProcess, Address, Size);
VirtualProtect(Address, Size, OldProtect, #OldProtect);
end;
end;
type
PInstruction = ^TInstruction;
TInstruction = packed record
Opcode: Byte;
Offset: Integer;
end;
procedure RedirectProcedure(OldAddress, NewAddress: Pointer);
var
NewCode: TInstruction;
begin
NewCode.Opcode := $E9;//jump relative
NewCode.Offset := NativeInt(NewAddress)-NativeInt(OldAddress)-SizeOf(NewCode);
PatchCode(OldAddress, NewCode, SizeOf(NewCode));
end;
type
TMyClass=Class(TObject) // Dummy to handle "events"
public
Destructor Destroy;override;
End;
destructor TMyClass.Destroy;
begin
// pervent recursion from call to Showmessage
if (Self.InheritsFrom(TCustomForm)) and (Self.ClassName<>'TTaskMessageDialog') then
Showmessage(Self.ClassName);
end;
begin
RedirectProcedure(#TObject.Destroy,#TMyClass.Destroy);
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TMainform, Mainform);
Application.CreateForm(TForm2, Form2);
Application.Run;
end.
As per Vlad's request this expands on my original answer by explaining how to register all forms owned by Application without any changes to the construction of each form. I.e. forms created using TMyForm.Create(Application); and by implication also Application.CreateForm(TMyForm, MyForm);.
The original answer doesn't specify any particular means of registering for FreeNotification because the options vary according to how forms are created. Since the question answered did not put any constraints on how the forms are created, the original answer is more appropriate in the general case.
If we could ensure that Application referred to a custom subclass of TApplication, the problem would be fairly easy to solve by overriding TApplication.Notification;. That's not possible, so this special case leverages the fact that the component ownership framework notifies all owned components when another component is added or removed. So basically all we need is a component tracker also owned by Application and we can react on its "sibling" notifications.
The following test case will demonstrate that new notifications work.
procedure TComponentTrackerTests.TestNewNotifications;
var
LComponentTracker: TComponentTracker;
LInitialFormCount: Integer;
LForm: TObject;
begin
LComponentTracker := TComponentTracker.Create(Application);
try
LComponentTracker.OnComponentNotification := CountOwnedForms;
LInitialFormCount := FOwnedFormCount;
LForm := TForm.Create(Application);
CheckEquals(LInitialFormCount + 1, FOwnedFormCount, 'Form added');
LForm.Free;
CheckEquals(LInitialFormCount, FOwnedFormCount, 'Form removed');
finally
LComponentTracker.Free;
end;
end;
procedure TComponentTrackerTests.CountOwnedForms(AComponent: TComponent; AOperation: TOperation);
begin
if (AComponent is TCustomForm) then
begin
case AOperation of
opInsert: Inc(FOwnedFormCount);
opRemove: Dec(FOwnedFormCount);
end;
end;
end;
TComponentTracker is implemented as follows:
TComponentNotificationEvent = procedure (AComponent: TComponent; AOperation: TOperation) of object;
TComponentTracker = class(TComponent)
private
FOnComponentNotification: TComponentNotificationEvent;
procedure SetOnComponentNotification(const Value: TComponentNotificationEvent);
procedure DoComponentNotification(AComponent: TComponent; AOperation: TOperation);
protected
procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
public
property OnComponentNotification: TComponentNotificationEvent read FOnComponentNotification write SetOnComponentNotification;
end;
procedure TComponentTracker.DoComponentNotification(AComponent: TComponent; AOperation: TOperation);
begin
if Assigned(FOnComponentNotification) then
begin
FOnComponentNotification(AComponent, AOperation);
end;
end;
procedure TComponentTracker.Notification(AComponent: TComponent; AOperation: TOperation);
begin
inherited Notification(AComponent, AOperation);
DoComponentNotification(AComponent, AOperation);
end;
procedure TComponentTracker.SetOnComponentNotification(const Value: TComponentNotificationEvent);
var
LComponent: TComponent;
begin
FOnComponentNotification := Value;
if Assigned(Value) then
begin
{ Report all currently owned components }
for LComponent in Owner do
begin
DoComponentNotification(LComponent, opInsert);
end;
end;
end;
WARNING
You could implement anything you choose in the OnComponentNotification event handler. This would include logging that the form is "destroyed". However, such a simplistic approach would actually be flawed because TComponent.InsertComponent allows a component's owner to be changed without destroying it.
Therefore to accurately report destruction, you would have to combine this with using FreeNotification as in my first answer.
This is quite easily done by setting LComponentTracker.OnComponentNotification := FDestructionLogger.RegisterFreeNotification; where RegisterFreeNotification is implemented as follows:
procedure TDestructionLogger.RegisterFreeNotification(AComponent: TComponent; AOperation: TOperation);
begin
if (AComponent is TCustomForm) then
begin
case AOperation of
opInsert: AComponent.FreeNotification(Self);
end;
end;
end;
A very simple approach could be keeping track of the Form count. When it lowers, then there is a Form destroyed. Check in Application.OnIdle:
procedure TMainForm.ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
begin
if Screen.CustomFormCount < FFormCount then
FormDestroyed;
if FFormCount <> Screen.CustomFormCount then
FFormCount := Screen.CustomFormCount;
end;
Depending on what action should be taken, you can loop through Screen.CustomForms to determine which Form was destroyed.

TThreadedQueue not capable of multiple consumers?

Trying to use the TThreadedQueue (Generics.Collections) in a single producer multiple consumer scheme. (Delphi-XE).
The idea is to push objects into a queue and let several worker threads draining the queue.
It does not work as expected, though.
When two or more worker threads are calling PopItem, access violations are thrown from the TThreadedQueue.
If the call to PopItem is serialized with a critical section, all is fine.
Surely the TThreadedQueue should be able to handle multiple consumers, so am I missing something or is this a pure bug in TThreadedQueue ?
Here is a simple example to produce the error.
program TestThreadedQueue;
{$APPTYPE CONSOLE}
uses
// FastMM4 in '..\..\..\FastMM4\FastMM4.pas',
Windows,
Messages,
Classes,
SysUtils,
SyncObjs,
Generics.Collections;
type TThreadTaskMsg =
class(TObject)
private
threadID : integer;
threadMsg : string;
public
Constructor Create( ID : integer; const msg : string);
end;
type TThreadReader =
class(TThread)
private
fPopQueue : TThreadedQueue<TObject>;
fSync : TCriticalSection;
fMsg : TThreadTaskMsg;
fException : Exception;
procedure DoSync;
procedure DoHandleException;
public
Constructor Create( popQueue : TThreadedQueue<TObject>;
sync : TCriticalSection);
procedure Execute; override;
end;
Constructor TThreadReader.Create( popQueue : TThreadedQueue<TObject>;
sync : TCriticalSection);
begin
fPopQueue:= popQueue;
fMsg:= nil;
fSync:= sync;
Self.FreeOnTerminate:= FALSE;
fException:= nil;
Inherited Create( FALSE);
end;
procedure TThreadReader.DoSync ;
begin
WriteLn(fMsg.threadMsg + ' ' + IntToStr(fMsg.threadId));
end;
procedure TThreadReader.DoHandleException;
begin
WriteLn('Exception ->' + fException.Message);
end;
procedure TThreadReader.Execute;
var signal : TWaitResult;
begin
NameThreadForDebugging('QueuePop worker');
while not Terminated do
begin
try
{- Calling PopItem can return empty without waittime !? Let other threads in by sleeping. }
Sleep(20);
{- Serializing calls to PopItem works }
if Assigned(fSync) then fSync.Enter;
try
signal:= fPopQueue.PopItem( TObject(fMsg));
finally
if Assigned(fSync) then fSync.Release;
end;
if (signal = wrSignaled) then
begin
try
if Assigned(fMsg) then
begin
fMsg.threadMsg:= '<Thread id :' +IntToStr( Self.threadId) + '>';
fMsg.Free; // We are just dumping the message in this test
//Synchronize( Self.DoSync);
//PostMessage( fParentForm.Handle,WM_TestQueue_Message,Cardinal(fMsg),0);
end;
except
on E:Exception do begin
end;
end;
end;
except
FException:= Exception(ExceptObject);
try
if not (FException is EAbort) then
begin
{Synchronize(} DoHandleException; //);
end;
finally
FException:= nil;
end;
end;
end;
end;
Constructor TThreadTaskMsg.Create( ID : Integer; Const msg : string);
begin
Inherited Create;
threadID:= ID;
threadMsg:= msg;
end;
var
fSync : TCriticalSection;
fThreadQueue : TThreadedQueue<TObject>;
fReaderArr : array[1..4] of TThreadReader;
i : integer;
begin
try
IsMultiThread:= TRUE;
fSync:= TCriticalSection.Create;
fThreadQueue:= TThreadedQueue<TObject>.Create(1024,1,100);
try
{- Calling without fSync throws exceptions when two or more threads calls PopItem
at the same time }
WriteLn('Creating worker threads ...');
for i:= 1 to 4 do fReaderArr[i]:= TThreadReader.Create( fThreadQueue,Nil);
{- Calling with fSync works ! }
//for i:= 1 to 4 do fReaderArr[i]:= TThreadReader.Create( fThreadQueue,fSync);
WriteLn('Init done. Pushing items ...');
for i:= 1 to 100 do fThreadQueue.PushItem( TThreadTaskMsg.Create( i,''));
ReadLn;
finally
for i:= 1 to 4 do fReaderArr[i].Free;
fThreadQueue.Free;
fSync.Free;
end;
except
on E: Exception do
begin
Writeln(E.ClassName, ': ', E.Message);
ReadLn;
end;
end;
end.
Update : The error in TMonitor that caused TThreadedQueue to crash is fixed in Delphi XE2.
Update 2 : The above test stressed the queue in the empty state. Darian Miller found that stressing the queue at full state, still could reproduce the error in XE2. The error once again is in the TMonitor. See his answer below for more information. And also a link to the QC101114.
Update 3 :
With Delphi-XE2 update 4 there was an announced fix for TMonitor that would cure the problems in TThreadedQueue. My tests so far are not able to reproduce any errors in TThreadedQueue anymore.
Tested single producer/multiple consumer threads when queue is empty and full.
Also tested multiple producers/multiple consumers. I varied the reader threads and writer threads from 1 to 100 without any glitch. But knowing the history, I dare others to break TMonitor.
Well, it's hard to be sure without a lot of testing, but it certainly looks like this is a bug, either in TThreadedQueue or in TMonitor. Either way it's in the RTL and not your code. You ought to file this as a QC report and use your example above as the "how to reproduce" code.
I recommend you to use OmniThreadLibrary http://www.thedelphigeek.com/search/label/OmniThreadLibrary when working with threads, parallelism, etc. Primoz made a very good job, and on the site you'll find a lot of useful documentation.
Your example seems to work fine under XE2, but if we fill your queue it fails with AV on a PushItem. (Tested under XE2 Update1)
To reproduce, just increase your task creation from 100 to 1100 (your queue depth was set at 1024)
for i:= 1 to 1100 do fThreadQueue.PushItem( TThreadTaskMsg.Create( i,''));
This dies for me every time on Windows 7. I initially tried a continual push to stress test it, and it failed at loop 30...then at loop 16...then at 65 so at different intervals but it consistently failed at some point.
iLoop := 0;
while iLoop < 1000 do
begin
Inc(iLoop);
WriteLn('Loop: ' + IntToStr(iLoop));
for i:= 1 to 100 do fThreadQueue.PushItem( TThreadTaskMsg.Create( i,''));
end;
I looked for the TThreadedQueue class but don't seem to have it in my D2009. I'm not exactly going to kill myself over this - Delphi thread support has always been err.. errm... 'non-optimal' and I suspect that TThreadedQueue is no different :)
Why use generics for P-C (Producer / Consumer) objects? A simple TObjectQueue descendant will do fine - been using this for decades - works fine with multiple producers/consumers:
unit MinimalSemaphorePCqueue;
{ Absolutely minimal P-C queue based on TobjectQueue and a semaphore.
The semaphore count reflects the queue count
'push' will always succeed unless memory runs out, then you're stuft anyway.
'pop' has a timeout parameter as well as the address of where any received
object is to be put.
'pop' returns immediately with 'true' if there is an object on the queue
available for it.
'pop' blocks the caller if the queue is empty and the timeout is not 0.
'pop' returns false if the timeout is exceeded before an object is available
from the queue.
'pop' returns true if an object is available from the queue before the timeout
is exceeded.
If multiple threads have called 'pop' and are blocked because the queue is
empty, a single 'push' will make only one of the waiting threads ready.
Methods to push/pop from the queue
A 'semaHandle' property that can be used in a 'waitForMultipleObjects' call.
When the handle is signaled, the 'peek' method will retrieve the queued object.
}
interface
uses
Windows, Messages, SysUtils, Classes,syncObjs,contnrs;
type
pObject=^Tobject;
TsemaphoreMailbox=class(TobjectQueue)
private
countSema:Thandle;
protected
access:TcriticalSection;
public
property semaHandle:Thandle read countSema;
constructor create; virtual;
procedure push(aObject:Tobject); virtual;
function pop(pResObject:pObject;timeout:DWORD):boolean; virtual;
function peek(pResObject:pObject):boolean; virtual;
destructor destroy; override;
end;
implementation
{ TsemaphoreMailbox }
constructor TsemaphoreMailbox.create;
begin
{$IFDEF D2009}
inherited Create;
{$ELSE}
inherited create;
{$ENDIF}
access:=TcriticalSection.create;
countSema:=createSemaphore(nil,0,maxInt,nil);
end;
destructor TsemaphoreMailbox.destroy;
begin
access.free;
closeHandle(countSema);
inherited;
end;
function TsemaphoreMailbox.pop(pResObject: pObject;
timeout: DWORD): boolean;
// dequeues an object, if one is available on the queue. If the queue is empty,
// the caller is blocked until either an object is pushed on or the timeout
// period expires
begin // wait for a unit from the semaphore
result:=(WAIT_OBJECT_0=waitForSingleObject(countSema,timeout));
if result then // if a unit was supplied before the timeout,
begin
access.acquire;
try
pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
end;
procedure TsemaphoreMailbox.push(aObject: Tobject);
// pushes an object onto the queue. If threads are waiting in a 'pop' call,
// one of them is made ready.
begin
access.acquire;
try
inherited push(aObject); // shove the object onto the queue
finally
access.release;
end;
releaseSemaphore(countSema,1,nil); // release one unit to semaphore
end;
function TsemaphoreMailbox.peek(pResObject: pObject): boolean;
begin
access.acquire;
try
result:=(count>0);
if result then pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
end.
I don't think TThreadedQueue is supposed to support multiple consumers. It's a FIFO, as per the help file. I am under the impression that there's one thread pushing and another one (just one!) popping.

The application called an interface that was marshalled for a different thread

i'm writing a delphi app that communicates with excel. one thing i noticed is that if i call the Save method on the Excel workbook object, it can appear to hang because excel has a dialog box open for the user. i'm using the late binding.
i'd like for my app to be able to notice when Save takes several seconds and then take some kind of action like show a dialog box telling this is what's happening.
i figured this'd be fairly easy. all i'd need to do is create a thread that calls Save and have that thread call Excel's Save routine. if it takes too long, i can take some action.
procedure TOfficeConnect.Save;
var
Thread:TOfficeHangThread;
begin
// spin off as thread so we can control timeout
Thread:=TOfficeSaveThread.Create(m_vExcelWorkbook);
if WaitForSingleObject(Thread.Handle, 5 {s} * 1000 {ms/s})=WAIT_TIMEOUT then
begin
Thread.FreeOnTerminate:=true;
raise Exception.Create(_('The Office spreadsheet program seems to be busy.'));
end;
Thread.Free;
end;
TOfficeSaveThread = class(TThread)
private
{ Private declarations }
m_vExcelWorkbook:variant;
protected
procedure Execute; override;
procedure DoSave;
public
constructor Create(vExcelWorkbook:variant);
end;
{ TOfficeSaveThread }
constructor TOfficeSaveThread.Create(vExcelWorkbook:variant);
begin
inherited Create(true);
m_vExcelWorkbook:=vExcelWorkbook;
Resume;
end;
procedure TOfficeSaveThread.Execute;
begin
m_vExcelWorkbook.Save;
end;
i understand this problem happens because the OLE object was created from another thread (absolutely).
how can i get around this problem? most likely i'll need to "re-marshall" for this call somehow...
any ideas?
The real problem here is that Office applications aren't intended for multithreaded use. Because there can be any number of client applications issuing commands through COM, those commands are serialized to calls and processed one by one. But sometimes Office is in a state where it doesn't accept new calls (for example when it is displaying a modal dialog) and your call gets rejected (giving you the "Call was rejected by callee"-error). See also the answer of Geoff Darst in this thread.
What you need to do is implement a IMessageFilter and take care of your calls being rejected. I did it like this:
function TIMessageFilterImpl.HandleInComingCall(dwCallType: Integer;
htaskCaller: HTASK; dwTickCount: Integer;
lpInterfaceInfo: PInterfaceInfo): Integer;
begin
Result := SERVERCALL_ISHANDLED;
end;
function TIMessageFilterImpl.MessagePending(htaskCallee: HTASK;
dwTickCount, dwPendingType: Integer): Integer;
begin
Result := PENDINGMSG_WAITDEFPROCESS;
end;
function ShouldCancel(aTask: HTASK; aWaitTime: Integer): Boolean;
var
lBusy: tagOLEUIBUSYA;
begin
FillChar(lBusy, SizeOf(tagOLEUIBUSYA), 0);
lBusy.cbStruct := SizeOf(tagOLEUIBUSYA);
lBusy.hWndOwner := Application.Handle;
if aWaitTime < 20000 then //enable cancel button after 20 seconds
lBusy.dwFlags := BZ_NOTRESPONDINGDIALOG;
lBusy.task := aTask;
Result := OleUIBusy(lBusy) = OLEUI_CANCEL;
end;
function TIMessageFilterImpl.RetryRejectedCall(htaskCallee: HTASK;
dwTickCount, dwRejectType: Integer): Integer;
begin
if dwRejectType = SERVERCALL_RETRYLATER then
begin
if dwTickCount > 10000 then //show Busy dialog after 10 seconds
begin
if ShouldCancel(htaskCallee, dwTickCount) then
Result := -1
else
Result := 100;
end
else
Result := 100; //value between 0 and 99 means 'try again immediatly', value >= 100 means wait this amount of milliseconds before trying again
end
else
begin
Result := -1; //cancel
end;
end;
The messagefilter has to be registered on the same thread as the one issuing the COM calls. My messagefilter implementation will wait 10 seconds before displaying the standard OLEUiBusy dialog. This dialog gives you the option to retry the rejected call (in your case Save) or switch to the blocking application (Excel displaying the modal dialog).
After 20 seconds of blocking, the cancel button will be enabled. Clicking the cancel button will cause your Save call to fail.
So forget messing around with threads and implement the messagefilter, which is the way
to deal with these issues.
Edit:
The above fixes "Call was rejected by callee" errors, but you have a Save that hangs. I suspect that Save brings up a popup that needs your attention (Does your workbook has a filename already?). If it is a popup that is in the way, try the following (not in a separate thread!):
{ Turn off Messageboxes etc. }
m_vExcelWorkbook.Application.DisplayAlerts := False;
try
{ Saves the workbook as a xls file with the name 'c:\test.xls' }
m_vExcelWorkbook.SaveAs('c:\test.xls', xlWorkbookNormal);
finally
{ Turn on Messageboxes again }
m_vExcelWorkbook.Application.DisplayAlerts := True;
end;
Also try to debug with Application.Visible := True; If there are any popups, there is a change you will see them and take actions to prevent them in the future.
Rather than accessing the COM object from two threads, just show the message dialog in the secondary thread. The VCL isn't thread-safe, but Windows is.
type
TOfficeHungThread = class(TThread)
private
FTerminateEvent: TEvent;
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure Terminate; override;
end;
...
constructor TOfficeHungThread.Create;
begin
inherited Create(True);
FTerminateEvent := TSimpleEvent.Create;
Resume;
end;
destructor TOfficeHungThread.Destroy;
begin
FTerminateEvent.Free;
inherited;
end;
procedure TOfficeHungThread.Execute;
begin
if FTerminateEvent.WaitFor(5000) = wrTimeout then
MessageBox(Application.MainForm.Handle, 'The Office spreadsheet program seems to be busy.', nil, MB_OK);
end;
procedure TOfficeHungThread.Terminate;
begin
FTerminateEvent.SetEvent;
end;
...
procedure TMainForm.Save;
var
Thread: TOfficeHungThread;
begin
Thread := TOfficeHungThread.Create;
try
m_vExcelWorkbook.Save;
Thread.Terminate;
Thread.WaitFor;
finally
Thread.Free;
end;
end;
Try calling CoInitializeEx with COINIT_MULTITHREADED since MSDN states:
Multi-threading (also called free-threading) allows calls to methods of objects created by this thread to be run on any thread.
'Marshalling' an interface from one thread to another can be done by using CoMarshalInterThreadInterfaceInStream to put the interface into a stream, move the stream to the other thread and then use CoGetInterfaceAndReleaseStream to get the interface back from the stream. see here for an example in Delphi.
Lars' answer is along the right lines I think. An alternative to his suggestion is to use the GIT (Global Interface Table), which can be used as a cross-thread repository for interfaces.
See this SO thread here for code for interacting with the GIT, where I posted a Delphi unit that provides simple access to the GIT.
It should simply be a question of registering your Excel interface into the GIT from your main thread, and then getting a separate reference to the interface from within your TOfficeHangThread thread using the GetInterfaceFromGlobal method.

How does one access the 'NameThreadForDebugging' in Delphi 2010

How do I access the 'NameThreadForDebugging' in a delphi Thread in Delphi 2010 ?
type
TMyThread = class(TThread)
protected
procedure Execute; override;
procedure UpdateCaption;
end;
implementation
procedure TMyThread.UpdateCaption;
begin
Form1.Caption := 'Name Thread For Debugging';
// how I get 'TestThread1' displayed in the caption
end;
procedure TMyThread.Execute;
begin
NameThreadForDebugging('TestThread1');
Synchronize(UpdateCaption);
Sleep(5000);
end;
The NameThreadForDebugging function is, as its name suggests, for debugging only. If you want to keep track of the name for other purposes, then reserve a field in the thread object and store the name there. Use that field for naming the thread and for populating your form's caption on demand.
There is no API for retrieving a thread's name because threads don't have names at the API level. NameThreadForDebugging raises a special exception that the IDE recognizes as the "name this thread" exception. It sees the exception (since it's a debugger), makes a note about the thread's name in its own internal debugging data structures, and then allows the application to continue running. The application catches and ignores the exception.
That data transfer is one-way, though. The application can send information to the debugger via an exception, but the debugger can't send data back. And the OS is oblivious to everything. To the OS, it's just like any other exception.
To do what you ask, you need to store the Name inside your thread class where you can access it, eg:
type
TMyThread = class(TThread)
protected
FName: String;
procedure Execute; override;
procedure UpdateCaption;
end;
procedure TMyThread.UpdateCaption;
begin
Form1.Caption := FName;
end;
procedure TMyThread.Execute;
begin
FName := 'TestThread1';
  NameThreadForDebugging(FName);
  Synchronize(UpdateCaption);
  Sleep(5000);
end;
The unit DebugThreadSupport on Code Central example ID: 21893, Named Pipes, shows how to set thread name in older versions of Delphi.
AFAICS Delphi supports settings the name only. You'll have to call some windows API function to get the name.

Looking for an alternative to windows messages used in inter-process communication

I a have a multithread application (MIDAS) that makes uses of windows messages to communicate with itself.
MAIN FORM
The main form receives windows messages sent by the RDM
LogData(‘DataToLog’)
Because windows messages are used they have the following attributes
Received messages are Indivisible
Received messages are Queued in the order they are sent
QUESTION:
Can you Suggest a better way doing this without using windows messages ?
MAIN FORM CODE
const
UM_LOGDATA = WM_USER+1002;
type
TLogData = Record
Msg : TMsgNum;
Src : Integer;
Data : String;
end;
PLogData = ^TLogData;
TfrmMain = class(TForm)
//
private
procedure LogData(var Message: TMessage); message UM_LOGDATA;
public
//
end;
procedure TfrmMain.LogData(var Message: TMessage);
var LData : PLogData;
begin
LData := PLogData(Message.LParam);
SaveData(LData.Msg,LData.Src,LData.Data);
Dispose(LData);
end;
RDM CODE
procedure TPostBoxRdm.LogData(DataToLog : String);
var
WMsg : TMessage;
LData : PLogData;
Msg : TMsgNum;
begin
Msg := MSG_POSTBOX_RDM;
WMsg.LParamLo := Integer(Msg);
WMsg.LParamHi := Length(DataToLog);
new(LData);
LData.Msg := Msg;
LData.Src := 255;
LData.Data := DataToLog;
WMsg.LParam := Integer(LData);
PostMessage(frmMain.Handle, UM_LOGDATA, Integer(Msg), WMsg.LParam);
end;
EDIT:
Why I want to get rid of the windows messages:
I would like to convert the application into a windows service
When the system is busy – the windows message buffer gets full and things slows down
Use Named Pipes. If you don't know how to use them, then now is the time to learn.
With named pipes, you can send any type of data structure (as long as both the server and the client know what that data structure is). I usually use an array of records to send large collections of info back and forth. Very handy.
I use Russell Libby's free (and open-source) named pipe components. Comes with a TPipeServer and a TPipeClient visual component. They make using named pipes incredibly easy, and named pipes are great for inter-process communication (IPC).
You can get the component here. The description from the source is: // Description : Set of client and server named pipe components for Delphi, as
// well a console pipe redirection component.
Also, Russell helped me out on Experts-Exchange with using an older version of this component to work in a console app to send/receive messages over named pipes. This may help as a guide in getting you up and running with using his components. Please note, that in a VCL app or service, you don't need to write your own message loop as I did in this console app.
program CmdClient;
{$APPTYPE CONSOLE}
uses
Windows, Messages, SysUtils, Pipes;
type
TPipeEventHandler = class(TObject)
public
procedure OnPipeSent(Sender: TObject; Pipe: HPIPE; Size: DWORD);
end;
procedure TPipeEventHandler.OnPipeSent(Sender: TObject; Pipe: HPIPE; Size: DWORD);
begin
WriteLn('On Pipe Sent has executed!');
end;
var
lpMsg: TMsg;
WideChars: Array [0..255] of WideChar;
myString: String;
iLength: Integer;
pcHandler: TPipeClient;
peHandler: TPipeEventHandler;
begin
// Create message queue for application
PeekMessage(lpMsg, 0, WM_USER, WM_USER, PM_NOREMOVE);
// Create client pipe handler
pcHandler:=TPipeClient.CreateUnowned;
// Resource protection
try
// Create event handler
peHandler:=TPipeEventHandler.Create;
// Resource protection
try
// Setup clien pipe
pcHandler.PipeName:='myNamedPipe';
pcHandler.ServerName:='.';
pcHandler.OnPipeSent:=peHandler.OnPipeSent;
// Resource protection
try
// Connect
if pcHandler.Connect(5000) then
begin
// Dispatch messages for pipe client
while PeekMessage(lpMsg, 0, 0, 0, PM_REMOVE) do DispatchMessage(lpMsg);
// Setup for send
myString:='the message I am sending';
iLength:=Length(myString) + 1;
StringToWideChar(myString, wideChars, iLength);
// Send pipe message
if pcHandler.Write(wideChars, iLength * 2) then
begin
// Flush the pipe buffers
pcHandler.FlushPipeBuffers;
// Get the message
if GetMessage(lpMsg, pcHandler.WindowHandle, 0, 0) then DispatchMessage(lpMsg);
end;
end
else
// Failed to connect
WriteLn('Failed to connect to ', pcHandler.PipeName);
finally
// Show complete
Write('Complete...');
// Delay
ReadLn;
end;
finally
// Disconnect event handler
pcHandler.OnPipeSent:=nil;
// Free event handler
peHandler.Free;
end;
finally
// Free pipe client
pcHandler.Free;
end;
end.
Option 1: Custom Message Queue
You can build a custom message queue, and push messages to the queue, sort the queue based on business rules, and pop messages from queue from the main thread for processing. Use a critical section for synchronization.
Option 2: Callbacks
Use callbacks to send data back and forth from the threads. Again, use a critical section for synchronization.
OmniThreadLibrary contains very efficient message queue in OtlComm.pas unit.
Documentation is not very good at the moment (start here) but you can always use the forum.
Yes – Gabr you can use windows messages in a service.
==============================
Before Windows Vista, you could have configured your service to interact with the desktop. That makes the service run on the same desktop as a logged-in user, so a program running as that user could send messages to your service's windows. Windows Vista isolates services, though; they can't interact with any user's desktop anymore.
=============================
A Quote from Rob Kennedy answer to ‘TService won’t process messages’
But I will not able to use 'frmMain.Handle' to post messages from the RDM to the main form in windows Vista.
All I need to do is find a different way of posting & receive the message
Windows Messages CAN still be used in Windows Vista! The issue at hand is that a technology in vista called User Interface Privilege Isolation (UIPI) prevents processes with a lower integrity level (IL) from sending messages to a proccess with a high IL (e.g. a windows service has a high IL and user-mode apps have medium IL).
However, this can be bypassed and medium IL apps can be allowed to send wm's to high IL processes.
Wikipedia says it best:
UIPI is not a security boundary, and does not aim to protect against
all shatter attacks. UI Accessibility
Applications can bypass UIPI by
setting their "uiAccess" value to TRUE
as part of their manifest file. This
requires the application to be in the
Program Files or Windows directory, as
well as to be signed by a valid code
signing authority, but these
requirements will not necessarily stop
malware from respecting them.
Additionally, some messages are still allowed through, such as
WM_KEYDOWN, which allows a lower IL
process to drive input to an elevated
command prompt.
Finally, the function
ChangeWindowMessageFilter allows a
medium IL process (all non-elevated
processes except Internet Explorer
Protected Mode) to change the messages
that a high IL process can receive
from a lower IL process. This
effectively allows bypassing UIPI,
unless running from Internet Explorer
or one of its child processes.
Someone over at Delphi-PRAXIS (link is in German. Use Google to Translate the page) has already tackled this problem and posted their code using ChangeWindowMessageFilter. I believe their issue is that WM_COPYDATA would not work on Vista until they modified their code to bypass UIPI for WM_COPYDATA.
Original Link (German)
unit uMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, uallHook, uallProcess, uallUtil, uallKernel;
type
TfrmMain = class(TForm)
lbl1: TLabel;
tmrSearchCondor: TTimer;
mmo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure tmrSearchCondorTimer(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private-Deklarationen }
fCondorPID : DWord;
fInjected : Boolean;
fDontWork : Boolean;
procedure SearchCondor;
procedure InjectMyFunctions;
procedure UnloadMyFunctions;
function GetDebugPrivileges : Boolean;
procedure WriteText(s : string);
procedure WMNOTIFYCD(var Msg: TWMCopyData); message WM_COPYDATA;
public
{ Public-Deklarationen }
end;
var
frmMain: TfrmMain;
ChangeWindowMessageFilter: function (msg : Cardinal; dwFlag : Word) : BOOL; stdcall;
implementation
{$R *.dfm}
type Tmydata = packed record
datacount: integer;
ind: boolean;
end;
const cCondorApplication = 'notepad.exe';
cinjComFuntionsDLL = 'injComFunctions.dll';
var myData : TMydata;
procedure TfrmMain.WMNOTIFYCD(var Msg: TWMCopyData);
begin
if Msg.CopyDataStruct^.cbData = sizeof(TMydata) then
begin
CopyMemory(#myData,Msg.CopyDataStruct^.lpData,sizeof(TMyData));
WriteText(IntToStr(mydata.datacount))
end;
end;
procedure TfrmMain.WriteText(s : string);
begin
mmo1.Lines.Add(DateTimeToStr(now) + ':> ' + s);
end;
procedure TfrmMain.InjectMyFunctions;
begin
if not fInjected then begin
if InjectLibrary(fCondorPID, PChar(GetExeDirectory + cinjComFuntionsDLL)) then fInjected := True;
end;
end;
procedure TfrmMain.UnloadMyFunctions;
begin
if fInjected then begin
UnloadLibrary(fCondorPID, PChar(GetExeDirectory + cinjComFuntionsDLL));
fInjected := False;
end;
end;
procedure TfrmMain.SearchCondor;
begin
fCondorPID := FindProcess(cCondorApplication);
if fCondorPID <> 0 then begin
lbl1.Caption := 'Notepad is running!';
InjectMyFunctions;
end else begin
lbl1.Caption := 'Notepad isn''t running!';
end;
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
UnloadMyFunctions;
end;
function TfrmMain.GetDebugPrivileges : Boolean;
begin
Result := False;
if not SetDebugPrivilege(SE_PRIVILEGE_ENABLED) then begin
Application.MessageBox('No Debug rights!', 'Error', MB_OK);
end else begin
Result := True;
end;
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
#ChangeWindowMessageFilter := GetProcAddress(LoadLibrary('user32.dll'), 'ChangeWindowMessageFilter');
ChangeWindowMessageFilter(WM_COPYDATA, 1);
fInjected := False;
fDontWork := not GetDebugPrivileges;
tmrSearchCondor.Enabled := not fDontWork;
end;
procedure TfrmMain.tmrSearchCondorTimer(Sender: TObject);
begin
tmrSearchCondor.Enabled := False;
SearchCondor;
tmrSearchCondor.Enabled := True;
end;
end.
The creators of the madExcept library etc provide IPC functionality which can be used instead of Windows messages.
http://help.madshi.net/IPC.htm
I developed a Windows screensaver at one stage, and I wanted to get my screensaver to send some notification to another program, and while the screensaver was active, I was unable to get window messages to work between the two apps.
I replaced it with the IPC functionality mentioned above.
Worked a treat.
I use this library for IPc (uses shared memory + mutex):
http://17slon.com/gp/gp/gpsync.htm
It has TGpMessageQueueReader and TGpMessageQueueWriter. Use "Global\" in front of the name, so you can use it to communicate between a Windows Service and a "Service GUI Helper" when a user logs in. (the Global\ prefix is needed for Vista because of session security rings, but also for Windows XP/2003 between user sessions).
It is very fast, multithreaded, etc. I would use this one instead of WM_COPYDATA (slow & much overhead if you use it a lot, but for small things messages can be OK)

Resources