paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-28 15:20:49 +02:00
Code Issues Packages Projects Releases Wiki Activity

gtk1+2 intf: made FMessageQueue thread safe

Browse Source 
git-svn-id: trunk@16328 -
This commit is contained in:
mattias 2008-08-31 11:18:41 +00:00
parent 6acd41dad9
commit 5e37b07ce5
5 changed files with 203 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
lcl/include/application.inc
View File

@ -837,14 +837,18 @@ end;
procedure TApplication.ProcessAsyncCallQueue;
var
lItem: PAsyncCallQueueItem;
Event: TDataEvent;
Data: PtrInt;
begin
// take care: we may be called from within lItem^.Method
while FAsyncCallQueue <> nil do
begin
lItem := FAsyncCallQueue;
FAsyncCallQueue := lItem^.NextItem;
lItem^.Method(lItem^.Data);
Event:=lItem^.Method;
Data:=lItem^.Data;
Dispose(lItem);
Event(Data);
end;
FAsyncCallQueueLast := nil;
end;

2
lcl/interfaces/gtk/gtkint.pp
View File

@ -86,7 +86,7 @@ type
FKeyStateList_: TFPList; // Keeps track of which keys are pressed
FDeviceContexts: TDynHashArray;// hasharray of HDC
FGDIObjects: TDynHashArray; // hasharray of PGdiObject
FMessageQueue: TGtkMessageQueue; // queue of PMsg
FMessageQueue: TGtkMessageQueue; // queue of PMsg (must be thread safe!)
WaitingForMessages: boolean;
MovedPaintMessageCount: integer;// how many paint messages moved to he end of the queue

107
lcl/interfaces/gtk/gtkmsgqueue.pp
View File

@ -42,9 +42,13 @@ type
constructor Create;
end;
{ TGtkMessageQueue }
TGtkMessageQueue=class(TLinkList)
private
FPaintMessages: TDynHashArray; // Hash for paint messages
FCritSec: TRTLCriticalSection;
fLock: integer;
protected
function CreateItem : TLinkListItem;override;
function CalculateHash(ParWnd : Hwnd):integer;
@ -52,11 +56,13 @@ type
public
constructor Create;
destructor destroy;override;
function FirstMessageItem : TGtkMessageQueueItem;
function LastMessageItem : TGtkMessageQueueItem;
function FirstMessage : PMsg;
function LastMessage : PMsg;
procedure AddMessage(ParMsg : PMsg);
procedure Lock;
procedure UnLock;
function FirstMessageItem: TGtkMessageQueueItem;
function LastMessageItem: TGtkMessageQueueItem;
function FirstMessage: PMsg;
function LastMessage: PMsg;
procedure AddMessage(ParMsg: PMsg);
procedure RemoveMessage(ParItem: TGtkMessageQueueItem;
ParFinalOnlyInternal: TFinalPaintMessageFlag;
DisposeMessage: boolean);
@ -105,12 +111,28 @@ begin
inherited Create;
FPaintMessages := TDynHashArray.Create(-1);
FPaintMessages.OwnerHashFunction := @HashPaintMessage;
InitCriticalSection(FCritSec);
end;
destructor TGtkMessageQueue.destroy;
begin
inherited Destroy;
fPaintMessages.destroy;
DoneCriticalsection(FCritSec);
end;
procedure TGtkMessageQueue.Lock;
begin
inc(fLock);
if fLock=1 then
EnterCriticalsection(FCritSec);
end;
procedure TGtkMessageQueue.UnLock;
begin
dec(fLock);
if fLock=0 then
LeaveCriticalsection(FCritSec);
end;
{------------------------------------------------------------------------------
@ -176,24 +198,44 @@ end;
function TGtkMessageQueue.FirstMessageItem : TGtkMessageQueueItem;
begin
Result :=TGtkMessageQueueItem(First);
Lock;
try
Result :=TGtkMessageQueueItem(First);
finally
UnLock;
end;
end;
function TGtkMessageQueue.FirstMessage : PMsg;
begin
Result := nil;
if FirstMessageItem <> nil then Result := FirstMessageItem.fMsg;
Lock;
try
if FirstMessageItem <> nil then Result := FirstMessageItem.fMsg;
finally
UnLock;
end;
end;
function TGtkMessageQueue.LastMessageItem : TGtkMessageQueueItem;
begin
result:= TGtkMessageQueueItem(Last);
Lock;
try
Result:=TGtkMessageQueueItem(Last);
finally
UnLock;
end;
end;
function TGtkMessageQueue.LastMessage : PMsg;
begin
Result := nil;
if LastMessageItem <> nil then result := LastMessageItem.fMsg;
Lock;
try
Result := nil;
if LastMessageItem <> nil then result := LastMessageItem.fMsg;
finally
UnLock;
end;
end;
{ Remove from queue and destroy message
@ -202,34 +244,59 @@ end;
procedure TGtkMessageQueue.RemoveMessage(ParItem: TGtkMessageQueueItem;
ParFinalOnlyInternal: TFinalPaintMessageFlag; DisposeMessage: boolean);
begin
if (ParItem.IsPaintMessage) then
fPaintMessages.Remove(ParItem);
ParItem.DestroyMessage(ParFinalOnlyInternal, DisposeMessage);
Delete(ParItem);
Lock;
try
if (ParItem.IsPaintMessage) then
fPaintMessages.Remove(ParItem);
ParItem.DestroyMessage(ParFinalOnlyInternal, DisposeMessage);
Delete(ParItem);
finally
UnLock;
end;
end;
function TGtkMessageQueue.HasPaintMessages:boolean;
begin
result := fPaintMessages.Count > 0;
Lock;
try
Result := fPaintMessages.Count > 0;
finally
UnLock;
end;
end;
function TGtkMessageQueue.NumberOfPaintMessages:integer;
begin
result := fPaintMessages.Count;
Lock;
try
Result := fPaintMessages.Count;
finally
UnLock;
end;
end;
function TGtkMessageQueue.HasNonPaintMessages:boolean;
begin
result := fPaintMessages.Count <> count;
Lock;
try
Result := fPaintMessages.Count <> count;
finally
UnLock;
end;
end;
function TGtkMessageQueue.PopFirstMessage: PMsg;
var
vlItem : TGtkMessageQueueItem;
begin
vlItem := FirstMessageItem;
Result := vlItem.Msg;
RemoveMessage(vlItem,FPMF_none,false);
Lock;
try
vlItem := FirstMessageItem;
Result := vlItem.Msg;
RemoveMessage(vlItem,FPMF_none,false);
finally
UnLock;
end;
end;
end.

127
lcl/interfaces/gtk/gtkwidgetset.inc
View File

@ -381,18 +381,23 @@ begin
end;
// tidy up the paint messages
QueueItem:=FMessageQueue.FirstMessageItem;
while (QueueItem<>nil) do begin
NextQueueItem := TGtkMessageQueueItem(QueueItem.Next);
if QueueItem.IsPaintMessage then
fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true);
QueueItem := NextQueueItem;
end;
FMessageQueue.Lock;
try
QueueItem:=FMessageQueue.FirstMessageItem;
while (QueueItem<>nil) do begin
NextQueueItem := TGtkMessageQueueItem(QueueItem.Next);
if QueueItem.IsPaintMessage then
fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true);
QueueItem := NextQueueItem;
end;
// warn about unremoved paint messages
if fMessageQueue.HasPaintMessages then begin
DebugLn(ProcName, Format(rsWarningUnremovedPaintMessages,
[IntToStr(fMessageQueue.NumberOfPaintMessages)]));
// warn about unremoved paint messages
if fMessageQueue.HasPaintMessages then begin
DebugLn(ProcName, Format(rsWarningUnremovedPaintMessages,
[IntToStr(fMessageQueue.NumberOfPaintMessages)]));
end;
finally
FMessageQueue.UnLock;
end;
// warn about unreleased DC
@ -445,14 +450,13 @@ begin
for GDIType := Low(GDIType) to High(GDIType) do
if GDITypeCount[GDIType] > 0 then
DebugLn(ProcName,Format(' %s: %d', [dbgs(GDIType), GDITypeCount[GDIType]]));
end;
// tidy up messages
if FMessageQueue.Count > 0 then begin
DebugLn(ProcName, Format(rsWarningUnreleasedMessagesInQueue,[FMessageQueue.Count]));
while FMessageQueue.First<>nil do
fMessageQueue.RemoveMessage(fMessageQueue.FirstMessageItem,FPMF_All,true);
// tidy up messages
if FMessageQueue.Count > 0 then begin
DebugLn(ProcName, Format(rsWarningUnreleasedMessagesInQueue,[FMessageQueue.Count]));
while FMessageQueue.First<>nil do
fMessageQueue.RemoveMessage(fMessageQueue.FirstMessageItem,FPMF_All,true);
end;
end;
// warn about unreleased timers
@ -513,13 +517,13 @@ begin
FreeAndNil(FWidgetsWithResizeRequest);
FreeAndNil(FWidgetsResized);
FreeAndNil(FFixWidgetsResized);
FMessageQueue.Free;
FDeviceContexts.Free;
FGDIObjects.Free;
FreeAndNil(FMessageQueue);
FreeAndNil(FDeviceContexts);
FreeAndNil(FGDIObjects);
{$IFDEF Use_KeyStateList}
FKeyStateList_.Free;
FreeAndNil(FKeyStateList_);
{$ENDIF}
FTimerData.Free;
FreeAndNil(FTimerData);
GtkDefDone;
FreeAndNil(FDCManager);
@ -1169,38 +1173,46 @@ begin
// then handle our own messages
while not Application.Terminated do begin
// fetch first message
vlItem := fMessageQueue.FirstMessageItem;
if vlItem = nil then break;
fMessageQueue.Lock;
try
// fetch first message
vlItem := fMessageQueue.FirstMessageItem;
if vlItem = nil then break;
// remove message from queue
if vlItem.IsPaintMessage then begin
//DebugLn(['TGtkWidgetSet.AppProcessMessages Paint: ',DbgSName(GetLCLObject(Pointer(vlItem.Msg^.hwnd)))]);
// paint messages are the most expensive messages in the LCL,
// therefore they are sent after all other
if MovedPaintMessageCount<10 then begin
inc(MovedPaintMessageCount);
if fMessageQueue.HasNonPaintMessages then begin
// there are non paint messages -> move paint message to the end
fMessageQueue.MoveToLast(FMessageQueue.First);
continue;
// remove message from queue
if vlItem.IsPaintMessage then begin
//DebugLn(['TGtkWidgetSet.AppProcessMessages Paint: ',DbgSName(GetLCLObject(Pointer(vlItem.Msg^.hwnd)))]);
// paint messages are the most expensive messages in the LCL,
// therefore they are sent after all other
if MovedPaintMessageCount<10 then begin
inc(MovedPaintMessageCount);
if fMessageQueue.HasNonPaintMessages then begin
// there are non paint messages -> move paint message to the end
fMessageQueue.MoveToLast(FMessageQueue.First);
continue;
end else begin
// there are only paint messages left in the queue
// -> check other queues
if PendingGtkMessagesExists then break;
end;
end else begin
// there are only paint messages left in the queue
// -> check other queues
if PendingGtkMessagesExists then break;
// handle this paint message now
MovedPaintMessageCount:=0;
end;
end else begin
// handle this paint message now
MovedPaintMessageCount:=0;
end;
//DebugLn(['TGtkWidgetSet.AppProcessMessages SendMessage: ',DbgSName(GetLCLObject(Pointer(vlItem.Msg^.hwnd)))]);
vlMsg:=fMessageQueue.PopFirstMessage;
finally
fMessageQueue.UnLock;
end;
//DebugLn(['TGtkWidgetSet.AppProcessMessages SendMessage: ',DbgSName(GetLCLObject(Pointer(vlItem.Msg^.hwnd)))]);
vlMsg:=fMessageQueue.PopFirstMessage;
// Send message
with vlMsg^ do SendMessage(hWND, Message, WParam, LParam);
Dispose(vlMsg);
try
with vlMsg^ do SendMessage(hWND, Message, WParam, LParam);
finally
Dispose(vlMsg);
end;
end;
// proceed until all messages are handled
@ -3687,13 +3699,18 @@ begin
DestroyWidget(Widget);
// remove all remaining messages to this widget
QueueItem:=FMessageQueue.FirstMessageItem;
while (QueueItem<>nil) do begin
MsgPtr := QueueItem.Msg;
NextItem := TGtkMessagequeueItem(QueueItem.Next);
if (PGtkWidget(MsgPtr^.hWnd)=Widget) then
fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true);
QueueItem := NextItem;
fMessageQueue.Lock;
try
QueueItem:=FMessageQueue.FirstMessageItem;
while (QueueItem<>nil) do begin
MsgPtr := QueueItem.Msg;
NextItem := TGtkMessagequeueItem(QueueItem.Next);
if (PGtkWidget(MsgPtr^.hWnd)=Widget) then
fMessageQueue.RemoveMessage(QueueItem,FPMF_All,true);
QueueItem := NextItem;
end;
finally
fMessageQueue.UnLock;
end;
end;

61
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -7055,13 +7055,18 @@ var
begin
//TODO Filtering
DebugLn('Peek !!!' );
vlItem := fMessageQueue.FirstMessageItem;
Result := vlItem <> nil;
fMessageQueue.Lock;
try
vlItem := fMessageQueue.FirstMessageItem;
Result := vlItem <> nil;
if Result then begin
lpMsg := vlItem.Msg^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE then
fMessageQueue.RemoveMessage(vlItem,FPMF_Internal,true);
if Result then begin
lpMsg := vlItem.Msg^;
if (wRemoveMsg and PM_REMOVE) = PM_REMOVE then
fMessageQueue.RemoveMessage(vlItem,FPMF_Internal,true);
end;
finally
fMessageQueue.UnLock;
end;
end;
@ -7314,32 +7319,42 @@ begin
Result := True;
New(AMessage);
FillByte(AMessage^,SizeOf(TMsg),0);
AMessage^.HWnd := Handle; // this is normally the main gtk widget
AMessage^.Message := Msg;
AMessage^.WParam := WParam;
AMessage^.LParam := LParam;
// Message^.Time :=
if (AMessage^.Message = LM_PAINT) or (AMessage^.Message = LM_GTKPAINT) then
begin
{ Obsolete, because InvalidateRectangle now works.
fMessageQueue.Lock;
try
if (AMessage^.Message = LM_PAINT) or (AMessage^.Message = LM_GTKPAINT) then
begin
{ Obsolete, because InvalidateRectangle now works.
// paint messages are the most expensive messages in the LCL
// A paint message to a control will also repaint all child controls.
// -> check if there is already a paint message for one of its parents
// if yes, then skip this message
if ParentPaintMessageInQueue then begin
FinalizePaintTagMsg(AMessage^);
exit;
end;}
// paint messages are the most expensive messages in the LCL
// A paint message to a control will also repaint all child controls.
// -> check if there is already a paint message for one of its parents
// if yes, then skip this message
if ParentPaintMessageInQueue then begin
FinalizePaintTagMsg(AMessage^);
exit;
end;}
// delete old paint message to this widget,
// so that the widget repaints only once
// delete old paint message to this widget,
// so that the widget repaints only once
CombinePaintMessages(AMessage);
CombinePaintMessages(AMessage);
end;
FMessageQueue.AddMessage(AMessage);
if GetThreadID<>MainThreadID then begin
// awake gtk loop
DebugLn(['TGtkWidgetSet.PostMessage ToDo: wake up gtk']);
end;
finally
fMessageQueue.UnLock;
end;
FMessageQueue.AddMessage(AMessage);
end;
{------------------------------------------------------------------------------