mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-16 10:19:36 +02:00
FpDebug: Run some tasks in threads during startup
git-svn-id: trunk@63812 -
This commit is contained in:
martin
parent
b61fd4c937
commit
2d8cf332f9
@ -42,9 +42,8 @@ interface
|
||||
|
||||
uses
|
||||
Classes, Types, SysUtils, FpDbgUtil, FpDbgInfo, FpDbgDwarfConst, Maps, Math,
|
||||
FpDbgLoader, FpImgReaderBase, FpdMemoryTools, FpErrorMessages,
|
||||
LazLoggerBase, LazClasses, LazFileUtils, LazUTF8, contnrs, DbgIntfBaseTypes,
|
||||
FpDbgCommon;
|
||||
FpDbgLoader, FpImgReaderBase, FpdMemoryTools, FpErrorMessages, LazLoggerBase,
|
||||
LazClasses, LazFileUtils, LazUTF8, contnrs, DbgIntfBaseTypes;
|
||||
|
||||
type
|
||||
TDwarfSection = (dsAbbrev, dsARanges, dsFrame, dsInfo, dsLine, dsLoc, dsMacinfo, dsPubNames, dsPubTypes, dsRanges, dsStr);
|
||||
@ -535,6 +534,29 @@ type
|
||||
end;
|
||||
PDwarfDebugFile = ^TDwarfDebugFile;
|
||||
|
||||
{ TFpThreadWorkerComputeNameHashes }
|
||||
|
||||
TFpThreadWorkerComputeNameHashes = class(TFpThreadWorkerItem)
|
||||
protected
|
||||
FCU: TDwarfCompilationUnit;
|
||||
FReadyToRun: Cardinal;
|
||||
procedure DoExecute; override;
|
||||
public
|
||||
constructor Create(CU: TDwarfCompilationUnit);
|
||||
procedure MarkReadyToRun; // will queue to run on the 2nd call
|
||||
end;
|
||||
|
||||
{ TFpThreadWorkerScanAll }
|
||||
|
||||
TFpThreadWorkerScanAll = class(TFpThreadWorkerItem)
|
||||
protected
|
||||
FCU: TDwarfCompilationUnit;
|
||||
FCompNameHashWorker: TFpThreadWorkerComputeNameHashes;
|
||||
procedure DoExecute; override;
|
||||
public
|
||||
constructor Create(CU: TDwarfCompilationUnit; ACompNameHashWorker: TFpThreadWorkerComputeNameHashes);
|
||||
end;
|
||||
|
||||
{ TDwarfCompilationUnit }
|
||||
|
||||
TDwarfCompilationUnitClass = class of TDwarfCompilationUnit;
|
||||
@ -592,9 +614,11 @@ type
|
||||
FMaxPC: QWord; //
|
||||
FScope: TDwarfScopeInfo;
|
||||
FScopeList: TDwarfScopeList;
|
||||
FScannedToEnd: Boolean;
|
||||
FKnownNameHashes: TKnownNameHashesArray;
|
||||
|
||||
FScanAllWorker: TFpThreadWorkerScanAll;
|
||||
FComputeNameHashesWorker: TFpThreadWorkerComputeNameHashes;
|
||||
|
||||
procedure BuildAddressMap;
|
||||
function GetAddressMap: TMap;
|
||||
function GetKnownNameHashes: PKnownNameHashesArray; inline;
|
||||
@ -621,7 +645,8 @@ type
|
||||
public
|
||||
constructor Create(AOwner: TFpDwarfInfo; ADebugFile: PDwarfDebugFile; ADataOffset: QWord; ALength: QWord; AVersion: Word; AAbbrevOffset: QWord; AAddressSize: Byte; AIsDwarf64: Boolean); virtual;
|
||||
destructor Destroy; override;
|
||||
procedure ScanAllEntries; inline;
|
||||
procedure WaitForScopeScan; inline; // MUST be called, before accessing the CU
|
||||
procedure WaitForComputeHashes; inline;
|
||||
function GetDefinition(AAbbrevPtr: Pointer; out ADefinition: TDwarfAbbrev): Boolean; inline;
|
||||
function GetLineAddressMap(const AFileName: String): PDWarfLineMap;
|
||||
function GetLineAddresses(const AFileName: String; ALine: Cardinal; var AResultList: TDBGPtrArray): boolean;
|
||||
@ -667,6 +692,7 @@ type
|
||||
|
||||
TFpDwarfInfo = class(TDbgInfo)
|
||||
private
|
||||
FWorkQueue: TFpGlobalThreadWorkerQueue;
|
||||
FCompilationUnits: TList;
|
||||
FImageBase: QWord;
|
||||
FFiles: array of TDwarfDebugFile;
|
||||
@ -690,6 +716,7 @@ type
|
||||
property CompilationUnits[AIndex: Integer]: TDwarfCompilationUnit read GetCompilationUnit;
|
||||
|
||||
property ImageBase: QWord read FImageBase;
|
||||
property WorkQueue: TFpGlobalThreadWorkerQueue read FWorkQueue;
|
||||
end;
|
||||
|
||||
TDwarfLocationExpression = class;
|
||||
@ -3306,6 +3333,9 @@ var
|
||||
p: PDbgImageSection;
|
||||
i: Integer;
|
||||
begin
|
||||
FWorkQueue := FpDbgGlobalWorkerQueue;
|
||||
FWorkQueue.AddRef;
|
||||
|
||||
inherited Create(ALoaderList, AMemManager);
|
||||
FTargetInfo := ALoaderList.TargetInfo;
|
||||
FCompilationUnits := TList.Create;
|
||||
@ -3332,9 +3362,11 @@ destructor TFpDwarfInfo.Destroy;
|
||||
var
|
||||
n: integer;
|
||||
begin
|
||||
FWorkQueue.DecRef;
|
||||
for n := 0 to FCompilationUnits.Count - 1 do
|
||||
TObject(FCompilationUnits[n]).Free;
|
||||
FreeAndNil(FCompilationUnits);
|
||||
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
@ -3366,6 +3398,7 @@ end;
|
||||
function TFpDwarfInfo.GetCompilationUnit(AIndex: Integer): TDwarfCompilationUnit;
|
||||
begin
|
||||
Result := TDwarfCompilationUnit(FCompilationUnits[Aindex]);
|
||||
Result.WaitForScopeScan;
|
||||
end;
|
||||
|
||||
function TFpDwarfInfo.GetCompilationUnitClass: TDwarfCompilationUnitClass;
|
||||
@ -3392,7 +3425,9 @@ begin
|
||||
|
||||
Result := TDwarfCompilationUnit(FCompilationUnits[h]);
|
||||
if (p < Result.FInfoData) or (p > Result.FInfoData + Result.FLength) then
|
||||
Result := nil;
|
||||
Result := nil
|
||||
else
|
||||
Result.WaitForScopeScan;
|
||||
end;
|
||||
|
||||
function TFpDwarfInfo.FindDwarfProcSymbol(AAddress: TDbgPtr
|
||||
@ -3413,6 +3448,7 @@ begin
|
||||
for n := 0 to FCompilationUnits.Count - 1 do
|
||||
begin
|
||||
CU := TDwarfCompilationUnit(FCompilationUnits[n]);
|
||||
CU.WaitForScopeScan;
|
||||
if not CU.Valid then Continue;
|
||||
MinMaxSet := CU.FMinPC <> CU.FMaxPC;
|
||||
if MinMaxSet and ((AAddress < CU.FMinPC) or (AAddress > CU.FMaxPC))
|
||||
@ -3458,6 +3494,7 @@ begin
|
||||
for n := 0 to FCompilationUnits.Count - 1 do
|
||||
begin
|
||||
CU := TDwarfCompilationUnit(FCompilationUnits[n]);
|
||||
CU.WaitForScopeScan;
|
||||
if not CU.Valid then Continue;
|
||||
MinMaxSet := CU.FMinPC <> CU.FMaxPC;
|
||||
if (not MinMaxSet) or ((AAddress < CU.FMinPC) or (AAddress > CU.FMaxPC))
|
||||
@ -3481,6 +3518,7 @@ begin
|
||||
for n := 0 to FCompilationUnits.Count - 1 do
|
||||
begin
|
||||
CU := TDwarfCompilationUnit(FCompilationUnits[n]);
|
||||
CU.WaitForScopeScan;
|
||||
Result := CU.GetLineAddresses(AFileName, ALine, AResultList) or Result;
|
||||
end;
|
||||
end;
|
||||
@ -3494,6 +3532,7 @@ begin
|
||||
for n := 0 to FCompilationUnits.Count - 1 do
|
||||
begin
|
||||
CU := TDwarfCompilationUnit(FCompilationUnits[n]);
|
||||
CU.WaitForScopeScan;
|
||||
Result := CU.GetLineAddressMap(AFileName);
|
||||
if Result <> nil then Exit;
|
||||
end;
|
||||
@ -3551,6 +3590,9 @@ begin
|
||||
end;
|
||||
end;
|
||||
Result := FCompilationUnits.Count;
|
||||
|
||||
for i := 0 to Result - 1 do
|
||||
TDwarfCompilationUnit(FCompilationUnits[i]).FComputeNameHashesWorker.MarkReadyToRun;
|
||||
end;
|
||||
|
||||
function TFpDwarfInfo.PointerFromRVA(ARVA: QWord): Pointer;
|
||||
@ -3832,6 +3874,49 @@ begin
|
||||
FDefaultMap := AMap;
|
||||
end;
|
||||
|
||||
{ TFpThreadWorkerScanAll }
|
||||
|
||||
procedure TFpThreadWorkerScanAll.DoExecute;
|
||||
var
|
||||
ResultScope: TDwarfScopeInfo;
|
||||
begin
|
||||
FCU.LocateEntry(0, ResultScope);
|
||||
FCompNameHashWorker.MarkReadyToRun;
|
||||
end;
|
||||
|
||||
constructor TFpThreadWorkerScanAll.Create(CU: TDwarfCompilationUnit;
|
||||
ACompNameHashWorker: TFpThreadWorkerComputeNameHashes);
|
||||
begin
|
||||
FCU := CU;
|
||||
FCompNameHashWorker := ACompNameHashWorker;
|
||||
end;
|
||||
|
||||
{ TFpThreadWorkerComputeNameHashes }
|
||||
|
||||
procedure TFpThreadWorkerComputeNameHashes.DoExecute;
|
||||
var
|
||||
InfoEntry: TDwarfInformationEntry;
|
||||
begin
|
||||
InfoEntry := TDwarfInformationEntry.Create(FCU, nil);
|
||||
InfoEntry.ScopeIndex := FCU.FirstScope.Index;
|
||||
InfoEntry.ComputeKnownHashes(@FCU.FKnownNameHashes);
|
||||
InfoEntry.ReleaseReference;
|
||||
end;
|
||||
|
||||
constructor TFpThreadWorkerComputeNameHashes.Create(CU: TDwarfCompilationUnit);
|
||||
begin
|
||||
FCU := CU;
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerComputeNameHashes.MarkReadyToRun;
|
||||
var
|
||||
c: Cardinal;
|
||||
begin
|
||||
c := InterLockedIncrement(FReadyToRun);
|
||||
if c = 2 then
|
||||
FCU.FOwner.WorkQueue.PushItem(Self);
|
||||
end;
|
||||
|
||||
{ TDwarfCompilationUnit }
|
||||
|
||||
procedure TDwarfCompilationUnit.BuildLineInfo(AAddressInfo: PDwarfAddressInfo; ADoAll: Boolean);
|
||||
@ -3920,6 +4005,7 @@ end;
|
||||
|
||||
function TDwarfCompilationUnit.GetKnownNameHashes: PKnownNameHashesArray;
|
||||
begin
|
||||
WaitForComputeHashes;
|
||||
Result := @FKnownNameHashes;
|
||||
end;
|
||||
|
||||
@ -3944,14 +4030,22 @@ begin
|
||||
Result := FAbbrevList.FindLe128bFromPointer(AAbbrevPtr, ADefinition) <> nil;
|
||||
end;
|
||||
|
||||
procedure TDwarfCompilationUnit.ScanAllEntries;
|
||||
var
|
||||
ResultScope: TDwarfScopeInfo;
|
||||
procedure TDwarfCompilationUnit.WaitForScopeScan;
|
||||
begin
|
||||
if FScannedToEnd then exit;
|
||||
FScannedToEnd := True;
|
||||
// scan to end
|
||||
LocateEntry(0, ResultScope);
|
||||
if FScanAllWorker <> nil then begin
|
||||
FOwner.WorkQueue.WaitForItem(FScanAllWorker);
|
||||
FScanAllWorker.DecRef;
|
||||
end;
|
||||
FScanAllWorker := nil;
|
||||
end;
|
||||
|
||||
procedure TDwarfCompilationUnit.WaitForComputeHashes;
|
||||
begin
|
||||
if FComputeNameHashesWorker <> nil then begin
|
||||
FOwner.WorkQueue.WaitForItem(FComputeNameHashesWorker);
|
||||
FComputeNameHashesWorker.DecRef;
|
||||
end;
|
||||
FComputeNameHashesWorker := nil;
|
||||
end;
|
||||
|
||||
procedure TDwarfCompilationUnit.BuildAddressMap;
|
||||
@ -4109,7 +4203,6 @@ var
|
||||
Form: Cardinal;
|
||||
StatementListOffs, Offs: QWord;
|
||||
Scope: TDwarfScopeInfo;
|
||||
InfoEntry: TDwarfInformationEntry;
|
||||
begin
|
||||
//DebugLn(FPDBG_DWARF_VERBOSE, ['-- compilation unit --']);
|
||||
//DebugLn(FPDBG_DWARF_VERBOSE, [' data offset: ', ADataOffset]);
|
||||
@ -4164,11 +4257,12 @@ begin
|
||||
end;
|
||||
FValid := True;
|
||||
|
||||
ScanAllEntries;
|
||||
InfoEntry := TDwarfInformationEntry.Create(Self, nil);
|
||||
InfoEntry.ScopeIndex := FirstScope.Index;
|
||||
InfoEntry.ComputeKnownHashes(@FKnownNameHashes);
|
||||
InfoEntry.ReleaseReference;
|
||||
FComputeNameHashesWorker := TFpThreadWorkerComputeNameHashes.Create(Self);
|
||||
FComputeNameHashesWorker.AddRef;
|
||||
|
||||
FScanAllWorker := TFpThreadWorkerScanAll.Create(Self, FComputeNameHashesWorker);
|
||||
FScanAllWorker.AddRef;
|
||||
FOwner.WorkQueue.PushItem(FScanAllWorker);
|
||||
|
||||
AttribList.EvalCount := 0;
|
||||
/// TODO: (dafHasName in Abbrev.flags)
|
||||
@ -4227,6 +4321,11 @@ destructor TDwarfCompilationUnit.Destroy;
|
||||
end;
|
||||
|
||||
begin
|
||||
FOwner.WorkQueue.RemoveItem(FComputeNameHashesWorker);
|
||||
FOwner.WorkQueue.RemoveItem(FScanAllWorker);
|
||||
FComputeNameHashesWorker.DecRef;
|
||||
FScanAllWorker.DecRef;
|
||||
|
||||
FreeAndNil(FAbbrevList);
|
||||
FreeAndNil(FAddressMap);
|
||||
FreeLineNumberMap;
|
||||
|
||||
@ -38,12 +38,93 @@ unit FpDbgUtil;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LazUTF8;
|
||||
Classes, SysUtils, fgl, math, LazUTF8, lazCollections, LazClasses,
|
||||
UTF8Process, syncobjs;
|
||||
|
||||
type
|
||||
THexValueFormatFlag = (hvfSigned, hvfPrefixPositive, hvfIncludeHexchar);
|
||||
THexValueFormatFlags = set of THexValueFormatFlag;
|
||||
|
||||
TFpThreadWorkerQueue = class;
|
||||
TFpWorkerThread = class;
|
||||
|
||||
{ TFpThreadWorkerItem }
|
||||
|
||||
TFpThreadWorkerItem = class
|
||||
private const
|
||||
TWSTATE_NEW = cardinal(0);
|
||||
TWSTATE_RUNNING = cardinal(1);
|
||||
TWSTATE_WAITING = cardinal(2);
|
||||
TWSTATE_DONE = cardinal(3);
|
||||
private
|
||||
FDone: Cardinal;
|
||||
FRefCnt: LongInt;
|
||||
protected
|
||||
procedure DoExecute; virtual;
|
||||
procedure DoFinished; virtual;
|
||||
|
||||
procedure Execute(MyWorkerThread: TFpWorkerThread); // called by worker thread
|
||||
procedure WaitFor(AnMainWaitEvent: PRTLEvent); // called by main thread => calls DoExecute, if needed
|
||||
procedure Cancel(AnMainWaitEvent: PRTLEvent); // called by main thread => calls DoExecute, if needed
|
||||
public
|
||||
procedure AddRef;
|
||||
procedure DecRef;
|
||||
end;
|
||||
|
||||
{ TFpWorkerThread }
|
||||
|
||||
TFpWorkerThread = class(TThread)
|
||||
private
|
||||
FQueue: TFpThreadWorkerQueue;
|
||||
public
|
||||
constructor Create(AQueue: TFpThreadWorkerQueue);
|
||||
procedure Execute; override;
|
||||
property Queue: TFpThreadWorkerQueue read FQueue;
|
||||
end;
|
||||
|
||||
{ TFpThreadWorkerQueue }
|
||||
|
||||
TFpThreadWorkerQueue = class(specialize TLazThreadedQueue<TFpThreadWorkerItem>)
|
||||
private type
|
||||
TFpWorkerThreadList = specialize TFPGObjectList<TFpWorkerThread>;
|
||||
strict private
|
||||
FWantedCount, FCurrentCount: Integer;
|
||||
FThreadMonitor: TLazMonitor;
|
||||
FWorkerThreadList: TFpWorkerThreadList;
|
||||
FMainWaitEvent: PRTLEvent;
|
||||
function GetCurrentCount: Integer;
|
||||
function GetThreadCount: integer;
|
||||
function GetWantedCount: Integer;
|
||||
procedure SetThreadCount(AValue: integer);
|
||||
protected
|
||||
function RemoveThread(Item: TFpWorkerThread): Integer;
|
||||
property WantedCount: Integer read GetWantedCount;
|
||||
property CurrentCount: Integer read GetCurrentCount;
|
||||
property ThreadMonitor: TLazMonitor read FThreadMonitor;
|
||||
public
|
||||
constructor Create(AQueueDepth: Integer = 10; PushTimeout: cardinal = INFINITE; PopTimeout: cardinal = INFINITE);
|
||||
destructor Destroy; override; // Will not wait for the threads.
|
||||
|
||||
procedure Clear; // Not thread safe // remove all none running items
|
||||
function PushItem(const AItem: TFpThreadWorkerItem): TWaitResult;
|
||||
|
||||
procedure WaitForItem(const AItem: TFpThreadWorkerItem); // called by main thread => calls DoExecute, if needed
|
||||
procedure RemoveItem(const AItem: TFpThreadWorkerItem); // wait but do not execute
|
||||
|
||||
property ThreadCount: integer read GetThreadCount write SetThreadCount; // Not thread safe
|
||||
property MainWaitEvent: PRTLEvent read FMainWaitEvent;
|
||||
end;
|
||||
|
||||
{ TFpGlobalThreadWorkerQueue }
|
||||
|
||||
TFpGlobalThreadWorkerQueue = class(TFpThreadWorkerQueue)
|
||||
private
|
||||
FRefCnt: LongInt;
|
||||
public
|
||||
destructor Destroy; override;
|
||||
procedure AddRef;
|
||||
procedure DecRef;
|
||||
end;
|
||||
|
||||
function CompareUtf8BothCase(AnUpper, AnLower, AnUnknown: PChar): Boolean;
|
||||
|
||||
@ -57,6 +138,9 @@ procedure Log(const AText: String; const AParams: array of const); overload;
|
||||
procedure Log(const AText: String); overload;
|
||||
function FormatAddress(const AAddress): String;
|
||||
|
||||
function GetFpDbgGlobalWorkerQueue: TFpGlobalThreadWorkerQueue;
|
||||
|
||||
property FpDbgGlobalWorkerQueue: TFpGlobalThreadWorkerQueue read GetFpDbgGlobalWorkerQueue;
|
||||
|
||||
implementation
|
||||
|
||||
@ -64,6 +148,17 @@ uses
|
||||
LazLoggerBase,
|
||||
FpDbgClasses;
|
||||
|
||||
var
|
||||
TheFpDbgGlobalWorkerQueue: TFpGlobalThreadWorkerQueue = nil;
|
||||
|
||||
function GetFpDbgGlobalWorkerQueue: TFpGlobalThreadWorkerQueue;
|
||||
begin
|
||||
if TheFpDbgGlobalWorkerQueue = nil then
|
||||
TheFpDbgGlobalWorkerQueue := TFpGlobalThreadWorkerQueue.Create(50);
|
||||
|
||||
Result := TheFpDbgGlobalWorkerQueue;
|
||||
end;
|
||||
|
||||
function CompareUtf8BothCase(AnUpper, AnLower, AnUnknown: PChar): Boolean;
|
||||
var
|
||||
p: PChar;
|
||||
@ -232,5 +327,283 @@ begin
|
||||
DebugLn(AText);
|
||||
end;
|
||||
|
||||
type
|
||||
|
||||
{ TFpThreadWorkerTerminateItem }
|
||||
|
||||
TFpThreadWorkerTerminateItem = class(TFpThreadWorkerItem)
|
||||
end;
|
||||
|
||||
{ TFpGlobalThreadWorkerQueue }
|
||||
|
||||
destructor TFpGlobalThreadWorkerQueue.Destroy;
|
||||
begin
|
||||
Assert(InterLockedExchangeAdd(FRefCnt, 0) = 0);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TFpGlobalThreadWorkerQueue.AddRef;
|
||||
begin
|
||||
(* There are
|
||||
- The current/fpdebug-main thread
|
||||
- Maybe the IDE/main thread (if used LazDebuggerFp)
|
||||
(however, fpdebug and IDE will rarely run both at high load => they can be counted as one)
|
||||
- At least one, maybe more threads in the debugged target app
|
||||
So no more than half the cpu-core count will be allocated for workers
|
||||
*)
|
||||
if InterLockedIncrement(FRefCnt) = 1 then
|
||||
ThreadCount := Min(Max(1, GetSystemThreadCount div 2), 10);
|
||||
end;
|
||||
|
||||
procedure TFpGlobalThreadWorkerQueue.DecRef;
|
||||
begin
|
||||
if InterLockedDecrement(FRefCnt) = 0 then
|
||||
ThreadCount := 0;
|
||||
end;
|
||||
|
||||
{ TFpThreadWorkerItem }
|
||||
|
||||
procedure TFpThreadWorkerItem.DoExecute;
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerItem.DoFinished;
|
||||
begin
|
||||
if InterLockedExchangeAdd(FRefCnt, 0) <= 0 then
|
||||
Destroy;
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerItem.Execute(MyWorkerThread: TFpWorkerThread);
|
||||
var
|
||||
st: Cardinal;
|
||||
begin
|
||||
st := InterLockedExchange(FDone, TWSTATE_RUNNING);
|
||||
if st = TWSTATE_NEW then begin
|
||||
DoExecute;
|
||||
|
||||
st := InterLockedExchange(FDone, TWSTATE_DONE);
|
||||
if st = TWSTATE_WAITING then
|
||||
RTLeventSetEvent(MyWorkerThread.Queue.MainWaitEvent);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerItem.WaitFor(AnMainWaitEvent: PRTLEvent);
|
||||
var
|
||||
st: Cardinal;
|
||||
begin
|
||||
st := InterLockedExchange(FDone, TWSTATE_WAITING);
|
||||
if st = TWSTATE_NEW then begin
|
||||
DoExecute;
|
||||
end
|
||||
else
|
||||
if st = TWSTATE_RUNNING then begin
|
||||
RTLeventWaitFor(AnMainWaitEvent);
|
||||
RTLeventResetEvent(AnMainWaitEvent);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerItem.Cancel(AnMainWaitEvent: PRTLEvent);
|
||||
var
|
||||
st: Cardinal;
|
||||
begin
|
||||
st := InterLockedExchange(FDone, TWSTATE_WAITING); // Prevent thread form executing this
|
||||
if st = TWSTATE_RUNNING then begin
|
||||
RTLeventWaitFor(AnMainWaitEvent);
|
||||
RTLeventResetEvent(AnMainWaitEvent);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerItem.AddRef;
|
||||
begin
|
||||
InterLockedIncrement(FRefCnt);
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerItem.DecRef;
|
||||
begin
|
||||
if Self = nil then
|
||||
exit;
|
||||
if InterLockedDecrement(FRefCnt) <= 0 then
|
||||
DoFinished;
|
||||
end;
|
||||
|
||||
{ TFpWorkerThread }
|
||||
|
||||
constructor TFpWorkerThread.Create(AQueue: TFpThreadWorkerQueue);
|
||||
begin
|
||||
FQueue := AQueue;
|
||||
FreeOnTerminate := True;
|
||||
inherited Create(False);
|
||||
end;
|
||||
|
||||
procedure TFpWorkerThread.Execute;
|
||||
var
|
||||
WorkItem: TFpThreadWorkerItem;
|
||||
begin
|
||||
while not Terminated do begin
|
||||
FQueue.PopItem(WorkItem);
|
||||
if WorkItem = nil then
|
||||
Continue;
|
||||
|
||||
if WorkItem is TFpThreadWorkerTerminateItem then begin
|
||||
WorkItem.DecRef;
|
||||
if Terminated then // no need to check
|
||||
break;
|
||||
|
||||
if FQueue.CurrentCount > FQueue.WantedCount then begin
|
||||
FQueue.ThreadMonitor.Enter;
|
||||
try
|
||||
if FQueue.ThreadCount > FQueue.WantedCount then
|
||||
break;
|
||||
finally
|
||||
FQueue.ThreadMonitor.Leave;
|
||||
end;
|
||||
end;
|
||||
Continue;
|
||||
end;
|
||||
|
||||
WorkItem.Execute(Self);
|
||||
WorkItem.DecRef;
|
||||
end;
|
||||
FQueue.RemoveThread(Self);
|
||||
end;
|
||||
|
||||
{ TFpThreadWorkerQueue }
|
||||
|
||||
function TFpThreadWorkerQueue.GetThreadCount: integer;
|
||||
begin
|
||||
FThreadMonitor.Enter;
|
||||
try
|
||||
Result := FWorkerThreadList.Count;
|
||||
finally
|
||||
FThreadMonitor.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFpThreadWorkerQueue.GetCurrentCount: Integer;
|
||||
begin
|
||||
Result := InterLockedExchangeAdd(FCurrentCount, 0);
|
||||
end;
|
||||
|
||||
function TFpThreadWorkerQueue.GetWantedCount: Integer;
|
||||
begin
|
||||
Result := InterLockedExchangeAdd(FWantedCount, 0);
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerQueue.SetThreadCount(AValue: integer);
|
||||
var
|
||||
c: Integer;
|
||||
begin
|
||||
FThreadMonitor.Enter;
|
||||
try
|
||||
InterLockedExchange(FWantedCount, AValue);
|
||||
FWantedCount := AValue;
|
||||
|
||||
c := FWorkerThreadList.Count;
|
||||
if c > AValue then begin
|
||||
while c > AValue do begin
|
||||
dec(c);
|
||||
PushItem(TFpThreadWorkerTerminateItem.Create); // will terminate one thread, if no more work is to be done
|
||||
end;
|
||||
InterLockedExchange(FCurrentCount, FWorkerThreadList.Count);
|
||||
end
|
||||
|
||||
else
|
||||
begin
|
||||
// increase
|
||||
FWorkerThreadList.Count := AValue;
|
||||
InterLockedExchange(FCurrentCount, AValue);
|
||||
while c < AValue do begin
|
||||
FWorkerThreadList[c] := TFpWorkerThread.Create(Self);
|
||||
inc(c);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
FThreadMonitor.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFpThreadWorkerQueue.RemoveThread(Item: TFpWorkerThread): Integer;
|
||||
begin
|
||||
FThreadMonitor.Enter;
|
||||
try
|
||||
FWorkerThreadList.Remove(Item);
|
||||
InterLockedExchange(FCurrentCount, FWorkerThreadList.Count);
|
||||
finally
|
||||
FThreadMonitor.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
constructor TFpThreadWorkerQueue.Create(AQueueDepth: Integer;
|
||||
PushTimeout: cardinal; PopTimeout: cardinal);
|
||||
begin
|
||||
FThreadMonitor:=TLazMonitor.create;
|
||||
inherited create(AQueueDepth, PushTimeout, PopTimeout);
|
||||
FMainWaitEvent := RTLEventCreate;
|
||||
FWorkerThreadList := TFpWorkerThreadList.Create(False);
|
||||
end;
|
||||
|
||||
destructor TFpThreadWorkerQueue.Destroy;
|
||||
var
|
||||
WorkItem: TFpThreadWorkerItem;
|
||||
i: Integer;
|
||||
begin
|
||||
FThreadMonitor.Enter;
|
||||
try
|
||||
for i := 0 to FWorkerThreadList.Count - 1 do
|
||||
FWorkerThreadList[i].Terminate; // also signals that the queue is no longer valid
|
||||
finally
|
||||
FThreadMonitor.Leave;
|
||||
end;
|
||||
|
||||
Clear;
|
||||
ThreadCount := 0;
|
||||
|
||||
// Wait for threads.
|
||||
while CurrentCount > 0 do begin
|
||||
sleep(1);
|
||||
if TotalItemsPushed = TotalItemsPopped then
|
||||
ThreadCount := 0; // Add more TFpThreadWorkerTerminateItem
|
||||
end;
|
||||
|
||||
// Free any TFpThreadWorkerTerminateItem items that were not picked up
|
||||
Clear;
|
||||
|
||||
inherited Destroy;
|
||||
FWorkerThreadList.Free;
|
||||
RTLeventdestroy(FMainWaitEvent);
|
||||
FThreadMonitor.Free;
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerQueue.Clear;
|
||||
var
|
||||
WorkItem: TFpThreadWorkerItem;
|
||||
begin
|
||||
while PopItemTimeout(WorkItem, 1) = wrSignaled do
|
||||
WorkItem.DecRef;
|
||||
end;
|
||||
|
||||
function TFpThreadWorkerQueue.PushItem(const AItem: TFpThreadWorkerItem
|
||||
): TWaitResult;
|
||||
begin
|
||||
if TotalItemsPopped = TotalItemsPushed then
|
||||
Grow(Min(QueueSize, 100));
|
||||
AItem.AddRef;
|
||||
Result := inherited PushItem(AItem);
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerQueue.RemoveItem(const AItem: TFpThreadWorkerItem);
|
||||
begin
|
||||
if AItem <> nil then
|
||||
AItem.Cancel(Self.MainWaitEvent);
|
||||
end;
|
||||
|
||||
procedure TFpThreadWorkerQueue.WaitForItem(const AItem: TFpThreadWorkerItem);
|
||||
begin
|
||||
AItem.WaitFor(Self.MainWaitEvent);
|
||||
end;
|
||||
|
||||
finalization
|
||||
TheFpDbgGlobalWorkerQueue.Free;
|
||||
end.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user