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

lcl: make lcl resource cache thread-safe (based on patch of Bernd Engelhardt, issue #0016092)

Browse Source 
git-svn-id: trunk@24716 -
This commit is contained in:
paul 2010-04-19 09:01:04 +00:00
parent 4a245a3f0d
commit d20b80df76
4 changed files with 122 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
lcl/include/brush.inc
View File

@ -174,10 +174,15 @@ begin
Changing;
if FBrushHandleCached then
begin
BrushResourceCache.Lock;
try
CacheItem := BrushResourceCache.FindItem(FReference.Handle);
if CacheItem <> nil then
CacheItem.DecreaseRefCount;
FBrushHandleCached := False;
finally
BrushResourceCache.Unlock;
end;
end else
DeleteObject(HGDIOBJ(FReference.Handle));
FReference._lclHandle := 0;
@ -219,6 +224,8 @@ begin
lbColor := ColorRef(FColor);
end;
BrushResourceCache.Lock;
try
CachedBrush := BrushResourceCache.FindDescriptor(@LogBrush);
if CachedBrush <> nil then
begin
@ -233,6 +240,9 @@ begin
BrushResourceCache.AddResource(FReference.Handle, @LogBrush);
end;
FBrushHandleCached := True;
finally
BrushResourceCache.Unlock;
end;
FInternalUpdateIndex := GraphicsUpdateCount;
end;

14
lcl/include/font.inc
View File

@ -1110,6 +1110,8 @@ begin
lfPitchAndFamily := DEFAULT_PITCH;
end;
end;
FontResourceCache.Lock;
try
// ask the font cache for the nearest font
CachedFont := FontResourceCache.FindFontDesc(ALogFont, Name);
//DebugLn(['TFont.GetHandle in cache: ',CachedFont<>nil]);
@ -1124,6 +1126,9 @@ begin
FontResourceCache.Add(FReference.Handle, ALogFont, Name);
end;
FFontHandleCached := True;
finally
FontResourceCache.Unlock;
end;
FCanUTF8Valid := False;
FIsMonoSpaceValid := False;
end;
@ -1170,9 +1175,16 @@ begin
Changing;
if FFontHandleCached then
begin
if FontResourceCache <> nil then
if Assigned(FontResourceCache) then
begin
FontResourceCache.Lock;
try
FontResourceCache.FindFont(FReference.Handle).DecreaseRefCount;
FFontHandleCached := False;
finally
FontResourceCache.Unlock;
end;
end;
end else
DeleteObject(HGDIOBJ(FReference.Handle));
FReference._lclHandle := 0;

10
lcl/include/pen.inc
View File

@ -388,6 +388,8 @@ begin
elpColor := FColor;
end;
PenResourceCache.Lock;
try
if Style = psPattern then
CachedPen := PenResourceCache.FindPenDesc(AExtPen, FPattern)
else
@ -429,6 +431,9 @@ begin
PenResourceCache.Add(FReference.Handle, AExtPen, nil);
end;
FPenHandleCached := True;
finally
PenResourceCache.Unlock;
end;
end;
procedure TPen.SetCosmetic(const AValue: Boolean);
@ -466,8 +471,13 @@ begin
Changing;
if FPenHandleCached then
begin
PenResourceCache.Lock;
try
PenResourceCache.FindPen(FReference.Handle).DecreaseRefCount;
FPenHandleCached := False;
finally
PenResourceCache.Unlock;
end;
end else
DeleteObject(HGDIOBJ(FReference.Handle));
FReference._lclHandle := 0;

18
lcl/lclrescache.pas
View File

@ -25,7 +25,8 @@ unit LCLResCache;
interface
uses
Classes, SysUtils, FPCAdds, Types, LCLType, LCLProc, AvgLvlTree, WSReferences;
Classes, SysUtils, FPCAdds, Types, LCLType, LCLProc, AvgLvlTree, WSReferences,
syncobjs;
{off $DEFINE CheckResCacheConsistency}
@ -86,6 +87,7 @@ type
FMaxUnusedItem: integer; // how many freed resources to keep
FFirstUnusedItem, FLastUnusedItem: TResourceCacheItem;
FUnUsedItemCount: integer;
FLock: TCriticalSection;
procedure RemoveItem(Item: TResourceCacheItem); virtual;
procedure RemoveDescriptor(Desc: TResourceCacheDescriptor); virtual;
procedure ItemUsed(Item: TResourceCacheItem);
@ -98,6 +100,8 @@ type
function CompareItems(Tree: TAvgLvlTree; Item1, Item2: Pointer): integer; virtual;
function CompareDescriptors(Tree: TAvgLvlTree; Desc1, Desc2: Pointer): integer; virtual; abstract;
procedure ConsistencyCheck;
procedure Lock;
procedure Unlock;
public
property MaxUnusedItem: integer read FMaxUnusedItem
write FMaxUnusedItem;
@ -358,6 +362,7 @@ begin
FDescriptors := TAvgLvlTree.CreateObjectCompare(@CompareDescriptors);
FResourceCacheItemClass := TResourceCacheItem;
FResourceCacheDescriptorClass := TResourceCacheDescriptor;
FLock := TCriticalSection.Create;
end;
procedure TResourceCache.Clear;
@ -376,6 +381,7 @@ begin
FItems := nil;
FDescriptors.Free;
FDescriptors := nil;
FLock.Free;
inherited Destroy;
end;
@ -445,6 +451,16 @@ begin
end;
end;
procedure TResourceCache.Lock;
begin
FLock.Enter;
end;
procedure TResourceCache.Unlock;
begin
FLock.Leave;
end;
{ THandleResourceCache }
function THandleResourceCache.FindItem(Handle: TLCLHandle): TResourceCacheItem;