paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-07 12:18:03 +02:00
Code Issues Packages Projects Releases Wiki Activity

Debugger: Allow to suspend/resume individual threads / only with FpDebug, only while paused - for the next run/step.

Browse Source
This commit is contained in:
Martin 2022-09-11 03:28:53 +02:00
parent cbf0b6b0d6
commit 45b69e8d9d
9 changed files with 176 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
components/debuggerintf/dbgintfdebuggerbase.pp
View File

@ -62,7 +62,8 @@ type
EDBGExceptions = class(EDebuggerException);
TDBGFeature = (
dfEvalFunctionCalls // The debugger supports calling functions in watches/expressions. defAllowFunctionCall in TWatcheEvaluateFlags
dfEvalFunctionCalls, // The debugger supports calling functions in watches/expressions. defAllowFunctionCall in TWatcheEvaluateFlags
dfThreadSuspension
);
TDBGFeatures = set of TDBGFeature;
@ -1289,6 +1290,7 @@ type
const AThreadId: Integer; const AThreadName: String;
const AThreadState: TDbgThreadState;
AState: TDebuggerDataState = ddsValid);
procedure SetThreadStateOnly(AValue: TDbgThreadState); virtual;
function CreateCopy: TThreadEntry; virtual;
destructor Destroy; override;
procedure Assign(AnOther: TThreadEntry); virtual;
@ -1345,6 +1347,7 @@ type
procedure DoCleanAfterPause; virtual;
public
procedure RequestMasterData; virtual;
procedure SetSuspended(AThread: TThreadEntry; ASuspended: Boolean); virtual;
procedure ChangeCurrentThread({%H-}ANewId: Integer); virtual;
procedure Changed; // TODO: needed because entries can not notify the monitor
property CurrentThreads: TThreads read GetCurrentThreads;
@ -1362,6 +1365,7 @@ type
public
constructor Create;
destructor Destroy; override;
procedure SetSuspended(AThread: TThreadEntry; ASuspended: Boolean);
property Threads: TThreads read FThreads;
property Supplier: TThreadsSupplier read GetSupplier write SetSupplier;
end;
@ -2300,6 +2304,11 @@ begin
FThreadState := AValue;
end;
procedure TThreadEntry.SetThreadStateOnly(AValue: TDbgThreadState);
begin
SetThreadState(AValue);
end;
function TThreadEntry.CreateStackEntry: TCallStackEntry;
begin
Result := TCallStackEntry.Create;
@ -2484,6 +2493,13 @@ begin
FreeAndNil(FThreads);
end;
procedure TThreadsMonitor.SetSuspended(AThread: TThreadEntry;
ASuspended: Boolean);
begin
if GetSupplier <> nil then
GetSupplier.SetSuspended(AThread, ASuspended);
end;
{ TRegistersMonitor }
function TRegistersMonitor.GetSupplier: TRegisterSupplier;
@ -4399,6 +4415,12 @@ begin
//
end;
procedure TThreadsSupplier.SetSuspended(AThread: TThreadEntry;
ASuspended: Boolean);
begin
//
end;
procedure TThreadsSupplier.DoStateChange(const AOldState: TDBGState);
begin
if (Debugger.State = dsStop) and (CurrentThreads <> nil) then

17
components/fpdebug/fpdbgclasses.pp
View File

@ -203,6 +203,7 @@ type
FPausedAtRemovedBreakPointState: (rbUnknown, rbNone, rbFound{, rbFoundAndDec});
FPausedAtHardcodeBreakPoint: Boolean;
FPausedAtRemovedBreakPointAddress: TDBGPtr;
FSuspendCount: Integer;
function GetRegisterValueList: TDbgRegisterValueList;
protected
@ -221,6 +222,7 @@ type
procedure DoBeforeBreakLocationMapChange; // A new location added / or a location removed => memory will change
procedure ValidateRemovedBreakPointInfo;
function GetName: String; virtual;
public
constructor Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle); virtual;
procedure DoBeforeProcessLoop;
@ -265,6 +267,10 @@ type
// Use ClearExceptionSignal to remove/eat this signal.
procedure ClearExceptionSignal; virtual;
procedure IncSuspendCount;
procedure DecSuspendCount;
property SuspendCount: Integer read FSuspendCount;
destructor Destroy; override;
function CompareStepInfo(AnAddr: TDBGPtr = 0; ASubLine: Boolean = False): TFPDCompareStepInfo;
function IsAtStartOfLine: boolean;
@ -3288,6 +3294,17 @@ begin
// To be implemented in sub-classes
end;
procedure TDbgThread.IncSuspendCount;
begin
inc(FSuspendCount);
end;
procedure TDbgThread.DecSuspendCount;
begin
dec(FSuspendCount);
DebugLn((DBG_VERBOSE or DBG_WARNINGS) and (FSuspendCount < 0), ['DecSuspendCount went negative: ', FSuspendCount])
end;
{ TFpWatchPointData }
function TFpWatchPointData.AddOwnedWatchpoint(AnOwner: Pointer;

8
components/fpdebug/fpdbglinuxclasses.pas
View File

@ -1549,7 +1549,9 @@ begin
// check other threads if they need a singlestep
for TDbgThread(ThreadToContinue) in FThreadMap do
if (ThreadToContinue <> AThread) and ThreadToContinue.FIsPaused then begin
if (ThreadToContinue <> AThread) and ThreadToContinue.FIsPaused and
(ThreadToContinue.SuspendCount <= 0)
then begin
IP := ThreadToContinue.GetInstructionPointerRegisterValue;
if HasInsertedBreakInstructionAtLocation(IP) or ThreadToContinue.NextIsSingleStep then begin
TempRemoveBreakInstructionCode(IP);
@ -1614,7 +1616,9 @@ begin
// start all other threads
for TDbgThread(ThreadToContinue) in FThreadMap do begin
if (ThreadToContinue <> AThread) and (ThreadToContinue.FIsPaused) then begin
if (ThreadToContinue <> AThread) and (ThreadToContinue.FIsPaused) and
(ThreadToContinue.SuspendCount <= 0)
then begin
fpseterrno(0);
{$IFDEF DebuglnLinuxDebugEvents}
Debugln(FPDBG_LINUX, ['RUN other TID: ', ThreadToContinue.ID]);

3
components/fpdebug/fpdbgwinclasses.pas
View File

@ -869,6 +869,9 @@ debugln(FPDBG_WINDOWS, ['TDbgWinProcess.Continue ',SingleStep, ' # ', ' # ',DbgS
TDbgWinThread(t).SuspendForStepOverBreakPoint;
end;
for t in FThreadMap do
if (t <> AThread) and (t.SuspendCount > 0) then
TDbgWinThread(t).Suspend;
AProcess.ThreadsBeforeContinue;
if AThread<>nil then debugln(FPDBG_WINDOWS, ['## ath.iss ',AThread.NextIsSingleStep]);

57
components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas
View File

@ -315,6 +315,8 @@ type
// procedure ClearState;
end;
TThreadIdList = specialize TFPGList<Integer>;
{ TFpDebugDebugger }
TFpDebugDebugger = class(TFpDebugDebuggerBase)
@ -405,6 +407,7 @@ type
protected
// Helper vars to run in debug-thread
FSuspendedThreads: TThreadIdList;
FCallStackEntryListThread: TDbgThread;
FCallStackEntryListFrameRequired: Integer;
procedure DoAddBreakFuncLib;
@ -542,6 +545,7 @@ type
destructor Destroy; override;
procedure RequestMasterData; override;
procedure ChangeCurrentThread(ANewId: Integer); override;
procedure SetSuspended(AThread: TThreadEntry; ASuspended: Boolean); override;
end;
{ TFPDBGDisassembler }
@ -914,6 +918,7 @@ var
FpThr: TDbgThread;
c: TDbgCallstackEntry;
dbg: TFpDebugDebuggerBase;
ThrState: TDbgThreadState;
begin
Threads := FDebugger.Threads;
@ -921,26 +926,30 @@ begin
ThreadArray := FpDebugger.FDbgController.CurrentProcess.GetThreadArray;
for i := 0 to high(ThreadArray) do begin
FpThr := ThreadArray[i];
ThrState := dtsPaused;
if FpDebugger.FSuspendedThreads.IndexOf(FpThr.ID) >= 0 then
ThrState := dtsSuspended;
CallStack := FpThr.CallStackEntryList;
t := Threads.CurrentThreads.EntryById[FpThr.ID];
if Assigned(CallStack) and (CallStack.Count > 0) then begin
c := CallStack.Items[0];
if t = nil then begin
n := Threads.CurrentThreads.CreateEntry(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, dtsPaused);
n := Threads.CurrentThreads.CreateEntry(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, ThrState);
Threads.CurrentThreads.Add(n);
n.Free;
end
else
t.Init(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, dtsPaused);
t.Init(c.AnAddress, nil, c.FunctionName, c.SourceFile, '', c.Line, FpThr.ID, FpThr.Name, ThrState);
end
else begin
if t = nil then begin
n := Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, dtsPaused);
n := Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, ThrState);
Threads.CurrentThreads.Add(n);
n.Free;
end
else
t.Init(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, dtsPaused);
t.Init(0, nil, '', '', '', 0, FpThr.ID, FpThr.Name, ThrState);
end;
end;
@ -1426,7 +1435,10 @@ begin
ThreadArray := TFpDebugDebugger(Debugger).FDbgController.CurrentProcess.GetThreadArray;
for i := 0 to high(ThreadArray) do begin
// TODO: Maybe get the address. If FpDebug has already read the ThreadState.
ThreadEntry := CurrentThreads.CreateEntry(0, nil, '', '', '', 0, ThreadArray[i].ID, 'Thread ' + IntToStr(ThreadArray[i].ID), dtsPaused);
if TFpDebugDebugger(Debugger).FSuspendedThreads.IndexOf(ThreadArray[i].ID) < 0 then
ThreadEntry := CurrentThreads.CreateEntry(0, nil, '', '', '', 0, ThreadArray[i].ID, 'Thread ' + IntToStr(ThreadArray[i].ID), dtsPaused)
else
ThreadEntry := CurrentThreads.CreateEntry(0, nil, '', '', '', 0, ThreadArray[i].ID, 'Thread ' + IntToStr(ThreadArray[i].ID), dtsSuspended);
try
CurrentThreads.Add(ThreadEntry);
finally
@ -1475,6 +1487,37 @@ begin
Changed;
end;
procedure TFPThreads.SetSuspended(AThread: TThreadEntry; ASuspended: Boolean);
var
FpThread: TDbgThread;
begin
//inherited SetSuspended(AThreadId, ASuspended);
if (AThread = nil) or (TFpDebugDebugger(Debugger).State <> dsPause) then
exit;
if (not TFpDebugDebugger(Debugger).FDbgController.CurrentProcess.GetThread(AThread.ThreadId, FpThread)) or
(FpThread = nil)
then
exit;
if ASuspended then begin
if TFpDebugDebugger(Debugger).FSuspendedThreads.IndexOf(AThread.ThreadId) < 0 then begin
TFpDebugDebugger(Debugger).FSuspendedThreads.Add(AThread.ThreadId);
FpThread.IncSuspendCount;
AThread.SetThreadStateOnly(dtsSuspended);
end;
end
else begin
if TFpDebugDebugger(Debugger).FSuspendedThreads.IndexOf(AThread.ThreadId) >= 0 then begin
TFpDebugDebugger(Debugger).FSuspendedThreads.Remove(AThread.ThreadId);
FpThread.DecSuspendCount;
AThread.SetThreadStateOnly(dtsPaused);
end;
end;
Changed;
end;
{ TFpWaitForConsoleOutputThread }
procedure TFpWaitForConsoleOutputThread.DoHasConsoleOutput(Data: PtrInt);
@ -4248,6 +4291,7 @@ constructor TFpDebugDebugger.Create(const AExternalDebugger: String);
begin
ProcessMessagesProc := @DoProcessMessages;
inherited Create(AExternalDebugger);
FSuspendedThreads := TThreadIdList.Create;
FLockList := TFpDbgLockList.Create;
FWorkQueue := TFpThreadPriorityWorkerQueue.Create(100);
FWorkQueue.OnQueueIdle := @CheckAndRunIdle;
@ -4303,6 +4347,7 @@ begin
inherited Destroy;
FreeAndNil(FWorkQueue);
FreeAndNil(FLockList);
FreeAndNil(FSuspendedThreads);
end;
function TFpDebugDebugger.GetLocationRec(AnAddress: TDBGPtr;
@ -4448,7 +4493,7 @@ end;
class function TFpDebugDebugger.SupportedFeatures: TDBGFeatures;
begin
Result := [dfEvalFunctionCalls];
Result := [dfEvalFunctionCalls, dfThreadSuspension];
end;
initialization

1
debugger/debuggerstrconst.pp
View File

@ -79,6 +79,7 @@ resourcestring
dlgBackendConvOptDebugConverter = 'Backend Converter:';
dlgBackendConvOptDefault = '- Default -';
dlgBackendConvOptDisabled = '- Disabled -';
drsSuspend = 'Suspend';
implementation

19
debugger/threaddlg.lfm
View File

@ -1,11 +1,14 @@
inherited ThreadsDlg: TThreadsDlg
object ThreadsDlg: TThreadsDlg
Left = 345
Height = 240
Top = 428
Width = 774
BorderStyle = bsSizeToolWin
Caption = 'Threads'
ClientHeight = 240
ClientWidth = 774
object lvThreads: TListView[0]
LCLVersion = '2.3.0.0'
object lvThreads: TListView
Left = 0
Height = 214
Top = 26
@ -41,9 +44,11 @@ inherited ThreadsDlg: TThreadsDlg
SortType = stText
TabOrder = 0
ViewStyle = vsReport
OnClick = lvThreadsClick
OnDblClick = lvThreadsDblClick
OnSelectItem = lvThreadsSelectItem
end
object ToolBar1: TToolBar[1]
object ToolBar1: TToolBar
Left = 0
Height = 26
Top = 0
@ -58,10 +63,16 @@ inherited ThreadsDlg: TThreadsDlg
OnClick = tbCurrentClick
end
object tbGoto: TToolButton
Left = 70
Left = 60
Top = 2
Caption = 'tbGoto'
OnClick = lvThreadsDblClick
end
object tbSuspend: TToolButton
Left = 105
Top = 2
Caption = 'tbSuspend'
OnClick = tbSuspendClick
end
end
end

57
debugger/threaddlg.pp
View File

@ -5,9 +5,9 @@ unit ThreadDlg;
interface
uses
Classes, SysUtils, ComCtrls, LCLProc, LazLoggerBase,
Debugger, DebuggerDlg, Forms, LazarusIDEStrConsts, IDEWindowIntf, DebuggerStrConst,
BaseDebugManager, IDEImagesIntf, LazDebuggerIntfBaseTypes;
Classes, SysUtils, ComCtrls, LCLProc, LazLoggerBase, Debugger, DebuggerDlg,
Forms, LazarusIDEStrConsts, IDEWindowIntf, DebuggerStrConst, BaseDebugManager,
IDEImagesIntf, DbgIntfDebuggerBase, LazDebuggerIntfBaseTypes;
type
@ -18,8 +18,13 @@ type
ToolBar1: TToolBar;
tbCurrent: TToolButton;
tbGoto: TToolButton;
tbSuspend: TToolButton;
procedure lvThreadsClick(Sender: TObject);
procedure lvThreadsDblClick(Sender: TObject);
procedure lvThreadsSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
procedure tbCurrentClick(Sender: TObject);
procedure tbSuspendClick(Sender: TObject);
private
imgCurrentLine: Integer;
FUpdateFlags: set of (ufThreadChanged);
@ -152,6 +157,8 @@ begin
finally
lvThreads.EndUpdate;
EndUpdate;
lvThreadsClick(nil);
end;
finally DebugLnExit(DBG_DATA_MONITORS, ['DebugDataMonitor: <<EXIT: TThreadsDlg.ThreadsChanged']); end;
end;
@ -199,11 +206,55 @@ begin
end;
end;
procedure TThreadsDlg.tbSuspendClick(Sender: TObject);
var
Entry: TIdeThreadEntry;
Item: TListItem;
begin
Item := lvThreads.Selected;
if Item = nil then exit;
Entry := TIdeThreadEntry(Item.Data);
if Entry = nil then Exit;
DebugBoss.Threads.SetSuspended(Entry, Entry.ThreadState <> dtsSuspended);
end;
procedure TThreadsDlg.lvThreadsDblClick(Sender: TObject);
begin
JumpToSource;
end;
procedure TThreadsDlg.lvThreadsSelectItem(Sender: TObject; Item: TListItem;
Selected: Boolean);
begin
lvThreadsClick(nil);
end;
procedure TThreadsDlg.lvThreadsClick(Sender: TObject);
var
Entry: TIdeThreadEntry;
Item: TListItem;
begin
if (DebugBoss = nil) or (DebugBoss.Debugger = nil) then begin
tbSuspend.Visible := False;
exit;
end;
tbSuspend.Visible := dfThreadSuspension in DebugBoss.Debugger.SupportedFeatures;
tbSuspend.Caption := drsSuspend;
tbSuspend.Enabled := False;
Item := lvThreads.Selected;
if Item = nil then exit;
Entry := TIdeThreadEntry(Item.Data);
if Entry = nil then Exit;
tbSuspend.Enabled := True;
if Entry.ThreadState = dtsSuspended then
tbSuspend.Caption := lisDebugOptionsFrmResume
else
end;
procedure TThreadsDlg.JumpToSource;
var
Entry: TIdeThreadEntry;

6
ide/packages/idedebugger/debugger.pp
View File

@ -1487,6 +1487,7 @@ type
AUnitInvoPrv: TDebuggerUnitInfoProvider = nil
); reintroduce;
public
procedure SetThreadStateOnly(AValue: TDbgThreadState); override;
function CreateCopy: TThreadEntry; override;
property TopFrame: TIdeThreadFrameEntry read GetTopFrame;
end;
@ -5308,6 +5309,11 @@ begin
TopFrame.ClearLocation;
end;
procedure TIdeThreadEntry.SetThreadStateOnly(AValue: TDbgThreadState);
begin
inherited SetThreadState(AValue);
end;
procedure TIdeThreadEntry.LoadDataFromXMLConfig(const AConfig: TXMLConfig; const APath: string;
AUnitInvoPrv: TDebuggerUnitInfoProvider = nil);
begin