mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-07 00:38:10 +02:00
LLDB Debugger: New debugger based on lldb / early alpha
git-svn-id: trunk@58253 -
This commit is contained in:
martin
parent
0e76843ab5
commit
fa3981c22e
9
.gitattributes
vendored
9
.gitattributes
vendored
@ -2528,6 +2528,10 @@ components/lazdebuggergdbmi/test/testexception.pas svneol=native#text/pascal
|
||||
components/lazdebuggergdbmi/test/testgdbtype.pas svneol=native#text/pascal
|
||||
components/lazdebuggergdbmi/test/testinstructionqueue.pas svneol=native#text/pascal
|
||||
components/lazdebuggergdbmi/test/testwatches.pas svneol=native#text/pascal
|
||||
components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.lpk svneol=native#text/plain
|
||||
components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.pas svneol=native#text/plain
|
||||
components/lazdebuggers/cmdlinedebuggerbase/debuginstructions.pas svneol=native#text/plain
|
||||
components/lazdebuggers/cmdlinedebuggerbase/debugprocess.pas svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerfp/fpdebugdebugger.pas svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerfp/lazdebuggerfp.lpk svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerfp/lazdebuggerfp.pas svneol=native#text/plain
|
||||
@ -2548,6 +2552,11 @@ components/lazdebuggers/lazdebuggerfpgdbmi/test/TestFpGdbmi.lpr svneol=native#te
|
||||
components/lazdebuggers/lazdebuggerfpgdbmi/test/fpclist.txt.sample svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerfpgdbmi/test/gdblist.txt.sample svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerfpgdbmi/test/testwatches.pas svneol=native#text/pascal
|
||||
components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.lpk svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.pas svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerlldb/lldbdebugger.pas svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerlldb/lldbhelper.pas svneol=native#text/plain
|
||||
components/lazdebuggers/lazdebuggerlldb/lldbinstructions.pas svneol=native#text/plain
|
||||
components/lazreport/doc/contributors.txt svneol=native#text/plain
|
||||
components/lazreport/doc/fr_eng.odt -text
|
||||
components/lazreport/doc/fr_eng.pdf -text
|
||||
|
||||
@ -0,0 +1,42 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="4">
|
||||
<PathDelim Value="\"/>
|
||||
<Name Value="CmdLineDebuggerBase"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Other>
|
||||
<CustomOptions Value="$(IDEBuildOptions)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Files Count="2">
|
||||
<Item1>
|
||||
<Filename Value="debugprocess.pas"/>
|
||||
<UnitName Value="DebugProcess"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="debuginstructions.pas"/>
|
||||
<UnitName Value="DebugInstructions"/>
|
||||
</Item2>
|
||||
</Files>
|
||||
<RequiredPkgs Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="LCLBase"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="FCL"/>
|
||||
</Item2>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,21 @@
|
||||
{ This file was automatically created by Lazarus. Do not edit!
|
||||
This source is only used to compile and install the package.
|
||||
}
|
||||
|
||||
unit CmdLineDebuggerBase;
|
||||
|
||||
{$warn 5023 off : no warning about unused units}
|
||||
interface
|
||||
|
||||
uses
|
||||
DebugProcess, DebugInstructions, LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterPackage('CmdLineDebuggerBase', @Register);
|
||||
end.
|
||||
@ -0,0 +1,665 @@
|
||||
unit DebugInstructions;
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, LazClasses, LazLoggerBase, debugprocess;
|
||||
|
||||
type
|
||||
|
||||
{ TDBGInstruction }
|
||||
|
||||
TDBGInstructionFlag = (
|
||||
ifRequiresThread,
|
||||
ifRequiresStackFrame
|
||||
);
|
||||
TDBGInstructionFlags = set of TDBGInstructionFlag;
|
||||
|
||||
TDBGInstructionState = (
|
||||
disNew,
|
||||
disQueued,
|
||||
disDataSent,
|
||||
disContentReceived, //may still wait for closing token
|
||||
disComleted,
|
||||
disFailed
|
||||
);
|
||||
|
||||
TDBGInstructionErrorFlag = (
|
||||
ifeContentError, // the imput from debugger was not in the expected format
|
||||
ifeWriteError, // writing to debugger (pipe) failed
|
||||
ifeReadError,
|
||||
ifeDbgNotRunning,
|
||||
ifeTimedOut,
|
||||
ifeRecoveredTimedOut, // not an error
|
||||
ifeInvalidStackFrame,
|
||||
ifeInvalidThreadId,
|
||||
ifeQueueContextError, // The thread or stack command went ok, but something else interfered with setting th econtext
|
||||
ifeCancelled
|
||||
);
|
||||
TDBGInstructionErrorFlags = set of TDBGInstructionErrorFlag;
|
||||
|
||||
TDBGInstructionQueue = class;
|
||||
|
||||
{ TDBGInstruction }
|
||||
|
||||
TDBGInstruction = class(TRefCountedObject)
|
||||
private
|
||||
FCommand: String;
|
||||
FOnFailure: TNotifyEvent;
|
||||
FOnFinish: TNotifyEvent;
|
||||
FOnSuccess: TNotifyEvent;
|
||||
FStackFrame: Integer;
|
||||
FThreadId: Integer;
|
||||
FFlags: TDBGInstructionFlags;
|
||||
FState: TDBGInstructionState;
|
||||
FErrorFlags: TDBGInstructionErrorFlags;
|
||||
FTimeOut: Integer;
|
||||
FQueue: TDBGInstructionQueue;
|
||||
protected
|
||||
FNextQueuedInstruction, FPrevQueuedInstruction: TDBGInstruction;
|
||||
protected
|
||||
function GetCommandAsString(): String; virtual;
|
||||
procedure SendCommandDataToDbg(); virtual;
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; virtual; abstract; // True if data was handled
|
||||
|
||||
// function GetTimeOutVerifier: TDBGInstruction; virtual;
|
||||
procedure Init; virtual;
|
||||
procedure SetQueued(AQueue: TDBGInstructionQueue);
|
||||
procedure SetContentReceieved;
|
||||
procedure InternalCreate(ACommand: String;
|
||||
AThread, AFrame: Integer; // ifRequiresThread, ifRequiresStackFrame will always be included
|
||||
AFlags: TDBGInstructionFlags;
|
||||
ATimeOut: Integer
|
||||
);
|
||||
property Queue: TDBGInstructionQueue read FQueue;
|
||||
property NextInstruction: TDBGInstruction read FNextQueuedInstruction;
|
||||
public
|
||||
constructor Create(ACommand: String;
|
||||
AFlags: TDBGInstructionFlags = [];
|
||||
ATimeOut: Integer = 0
|
||||
);
|
||||
constructor Create(ACommand: String;
|
||||
AThread: Integer; // ifRequiresThread will always be included
|
||||
AOtherFlags: TDBGInstructionFlags = [];
|
||||
ATimeOut: Integer = 0
|
||||
);
|
||||
constructor Create(ACommand: String;
|
||||
AThread, AFrame: Integer; // ifRequiresThread, ifRequiresStackFrame will always be included
|
||||
AOtherFlags: TDBGInstructionFlags = [];
|
||||
ATimeOut: Integer = 0
|
||||
);
|
||||
procedure Cancel;
|
||||
function IsSuccess: Boolean;
|
||||
function IsCompleted: boolean;
|
||||
procedure MarkAsSuccess; // calls DoInstructionFinished // releases the instruction
|
||||
procedure MarkAsFailed; // calls DoInstructionFinished // releases the instruction
|
||||
|
||||
procedure HandleWriteError; virtual;
|
||||
procedure HandleReadError; virtual;
|
||||
procedure HandleTimeOut; virtual;
|
||||
procedure HandleRecoveredTimeOut; virtual;
|
||||
procedure HandleNoDbgRunning; virtual;
|
||||
procedure HandleContentError; virtual;
|
||||
procedure HandleError(AnError: TDBGInstructionErrorFlag; AMarkAsFailed: Boolean = True); virtual;
|
||||
function DebugText: String;
|
||||
|
||||
property Command: String read GetCommandAsString;
|
||||
property ThreadId: Integer read FThreadId;
|
||||
property StackFrame: Integer read FStackFrame;
|
||||
property Flags: TDBGInstructionFlags read FFlags;
|
||||
property State: TDBGInstructionState read FState;
|
||||
property ErrorFlags: TDBGInstructionErrorFlags read FErrorFlags;
|
||||
property TimeOut: Integer read FTimeOut;
|
||||
|
||||
property OnFinish: TNotifyEvent read FOnFinish write FOnFinish;
|
||||
property OnSuccess: TNotifyEvent read FOnSuccess write FOnSuccess;
|
||||
property OnFailure: TNotifyEvent read FOnFailure write FOnFailure;
|
||||
end;
|
||||
|
||||
{ TDBGInstructionQueue }
|
||||
|
||||
TDBGInstructionQueueFlag = (
|
||||
iqfValidThread,
|
||||
iqfValidStackFrame
|
||||
);
|
||||
TDBGInstructionQueueFlags = set of TDBGInstructionQueueFlag;
|
||||
|
||||
TLineReceivedNotification = procedure(var ALine: String) of object;
|
||||
|
||||
|
||||
TDBGInstructionQueue = class
|
||||
private
|
||||
FDebugProcess: TDebugProcess;
|
||||
FFirstQueuedInstruction, FLastQueuedInstruction: TDBGInstruction;
|
||||
FCurrentInstruction, FRunningInstruction: TDBGInstruction;
|
||||
FOnBeginLinesReceived: TNotifyEvent;
|
||||
FOnEndLinesReceived: TNotifyEvent;
|
||||
FOnDebuggerTerminated: TNotifyEvent;
|
||||
FOnAfterHandleLineReceived: TLineReceivedNotification;
|
||||
FOnBeforeHandleLineReceived: TLineReceivedNotification;
|
||||
|
||||
FFlags: TDBGInstructionQueueFlags;
|
||||
FLockQueueRun: Integer;
|
||||
FCurrentStackFrame: Integer;
|
||||
FCurrentThreadId: Integer;
|
||||
|
||||
procedure DoDbgLineReceived(Sender: TObject; ALine: String);
|
||||
procedure DoBeginLinesReceived(Sender: TObject);
|
||||
procedure DoEndLinesReceived(Sender: TObject);
|
||||
procedure DoDbgSendError(Sender: TObject; ALine: String);
|
||||
procedure DoDbgTerminated(Sender: TObject);
|
||||
|
||||
procedure RunInstruction(AnInstruction: TDBGInstruction);
|
||||
protected
|
||||
procedure RunQueue;
|
||||
function GetNextInstructionToRun: TDBGInstruction; virtual;
|
||||
function GetChangeContextInstruction(AnInstruction: TDBGInstruction): TDBGInstruction; virtual;
|
||||
|
||||
function GetSelectThreadInstruction(AThreadId: Integer): TDBGInstruction; virtual; abstract;
|
||||
function GetSelectFrameInstruction(AFrame: Integer): TDBGInstruction; virtual; abstract;
|
||||
|
||||
procedure DoBeforeHandleLineReceived(var ALine: String); virtual;
|
||||
procedure DoAfterHandleLineReceived(var ALine: String); virtual;
|
||||
procedure DoDebuggerTerminated; virtual;
|
||||
procedure DoInstructionFinished(Sender: TDBGInstruction); virtual;
|
||||
|
||||
procedure SendDataToDBG(ASender: TDBGInstruction; AData: String);
|
||||
procedure SendDataToDBG(ASender: TDBGInstruction; AData: String; const AValues: array of const);
|
||||
|
||||
procedure RemoveInstruction(AnInstruction: TDBGInstruction);
|
||||
property FirstInstruction: TDBGInstruction read FFirstQueuedInstruction;
|
||||
public
|
||||
constructor Create(ADebugProcess: TDebugProcess);
|
||||
destructor Destroy; override;
|
||||
procedure LockQueueRun; // prevent next instruction from running, until unLockQueueRun
|
||||
procedure UnLockQueueRun;
|
||||
|
||||
procedure InvalidateThredAndFrame(AStackFrameOnly: Boolean = False);
|
||||
procedure SetKnownThread(AThread: Integer);
|
||||
procedure SetKnownThreadAndFrame(AThread, AFrame: Integer);
|
||||
procedure QueueInstruction(AnInstruction: TDBGInstruction); // Wait for instruction to be finished, not queuing
|
||||
property CurrentThreadId: Integer read FCurrentThreadId;
|
||||
property CurrentStackFrame: Integer read FCurrentStackFrame;
|
||||
property Debugger: TDebugProcess read FDebugProcess;
|
||||
property CurrentInstruction: TDBGInstruction read FCurrentInstruction;
|
||||
property RunningInstruction: TDBGInstruction read FRunningInstruction;
|
||||
public
|
||||
property OnBeforeHandleLineReceived: TLineReceivedNotification
|
||||
read FOnBeforeHandleLineReceived write FOnBeforeHandleLineReceived;
|
||||
property OnAfterHandleLineReceived: TLineReceivedNotification
|
||||
read FOnAfterHandleLineReceived write FOnAfterHandleLineReceived;
|
||||
property OnDebuggerTerminated: TNotifyEvent read FOnDebuggerTerminated write FOnDebuggerTerminated;
|
||||
property OnBeginLinesReceived: TNotifyEvent read FOnBeginLinesReceived write FOnBeginLinesReceived;
|
||||
property OnEndLinesReceived: TNotifyEvent read FOnEndLinesReceived write FOnEndLinesReceived;
|
||||
end;
|
||||
|
||||
function dbgs(AState: TDBGInstructionState): String; overload;
|
||||
function dbgs(AFlag: TDBGInstructionQueueFlag): String; overload;
|
||||
function dbgs(AFlags: TDBGInstructionQueueFlags): String; overload;
|
||||
function dbgs(AFlag: TDBGInstructionFlag): String; overload;
|
||||
function dbgs(AFlags: TDBGInstructionFlags): String; overload;
|
||||
function dbgsInstr(AnInstr: TDBGInstruction): String;
|
||||
|
||||
implementation
|
||||
|
||||
var
|
||||
DBGMI_TIMEOUT_DEBUG, DBG_THREAD_AND_FRAME, DBG_VERBOSE: PLazLoggerLogGroup;
|
||||
|
||||
function dbgs(AState: TDBGInstructionState): String;
|
||||
begin
|
||||
writestr(Result{%H-}, AState);
|
||||
end;
|
||||
|
||||
function dbgs(AFlag: TDBGInstructionQueueFlag): String;
|
||||
begin
|
||||
writestr(Result{%H-}, AFlag);
|
||||
end;
|
||||
|
||||
function dbgs(AFlags: TDBGInstructionQueueFlags): String;
|
||||
var
|
||||
i: TDBGInstructionQueueFlag;
|
||||
begin
|
||||
Result := '';
|
||||
for i := low(TDBGInstructionQueueFlags) to high(TDBGInstructionQueueFlags) do
|
||||
if i in AFlags then
|
||||
if Result = '' then
|
||||
Result := Result + dbgs(i)
|
||||
else
|
||||
Result := Result + ', ' +dbgs(i);
|
||||
if Result <> '' then
|
||||
Result := '[' + Result + ']';
|
||||
end;
|
||||
|
||||
function dbgs(AFlag: TDBGInstructionFlag): String;
|
||||
begin
|
||||
writestr(Result{%H-}, AFlag);
|
||||
end;
|
||||
|
||||
function dbgs(AFlags: TDBGInstructionFlags): String;
|
||||
var
|
||||
i: TDBGInstructionFlag;
|
||||
begin
|
||||
Result := '';
|
||||
for i := low(TDBGInstructionFlags) to high(TDBGInstructionFlags) do
|
||||
if i in AFlags then
|
||||
if Result = '' then
|
||||
Result := Result + dbgs(i)
|
||||
else
|
||||
Result := Result + ', ' +dbgs(i);
|
||||
if Result <> '' then
|
||||
Result := '[' + Result + ']';
|
||||
end;
|
||||
|
||||
function dbgsInstr(AnInstr: TDBGInstruction): String;
|
||||
begin
|
||||
if AnInstr = nil then
|
||||
Result := 'nil'
|
||||
else
|
||||
Result := AnInstr.DebugText;
|
||||
end;
|
||||
|
||||
{ TDBGInstruction }
|
||||
|
||||
function TDBGInstruction.GetCommandAsString: String;
|
||||
begin
|
||||
Result := FCommand;
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.SendCommandDataToDbg();
|
||||
begin
|
||||
FQueue.SendDataToDBG(Self, GetCommandAsString);
|
||||
FState := disDataSent;
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.Init;
|
||||
begin
|
||||
//
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.SetQueued(AQueue: TDBGInstructionQueue);
|
||||
begin
|
||||
FState := disQueued;
|
||||
FQueue := AQueue;
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.SetContentReceieved;
|
||||
begin
|
||||
FState := disContentReceived;
|
||||
debugln('disContentReceived');
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.InternalCreate(ACommand: String; AThread,
|
||||
AFrame: Integer; AFlags: TDBGInstructionFlags; ATimeOut: Integer);
|
||||
begin
|
||||
inherited Create;
|
||||
AddReference;
|
||||
FState := disNew;
|
||||
FCommand := ACommand;
|
||||
FThreadId := AThread;
|
||||
FStackFrame := AFrame;
|
||||
FFlags := AFlags;
|
||||
FTimeOut := ATimeOut;
|
||||
Init;
|
||||
end;
|
||||
|
||||
constructor TDBGInstruction.Create(ACommand: String;
|
||||
AFlags: TDBGInstructionFlags; ATimeOut: Integer);
|
||||
begin
|
||||
InternalCreate(ACommand, -1, -1, AFlags, ATimeOut);
|
||||
end;
|
||||
|
||||
constructor TDBGInstruction.Create(ACommand: String; AThread: Integer;
|
||||
AOtherFlags: TDBGInstructionFlags; ATimeOut: Integer);
|
||||
begin
|
||||
InternalCreate(ACommand, AThread, -1,
|
||||
AOtherFlags + [ifRequiresThread], ATimeOut);
|
||||
end;
|
||||
|
||||
constructor TDBGInstruction.Create(ACommand: String; AThread, AFrame: Integer;
|
||||
AOtherFlags: TDBGInstructionFlags; ATimeOut: Integer);
|
||||
begin
|
||||
InternalCreate(ACommand, AThread, AFrame,
|
||||
AOtherFlags + [ifRequiresThread, ifRequiresStackFrame], ATimeOut);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.Cancel;
|
||||
begin
|
||||
debugln(['TDBGInstruction.Cancel ', Command]);
|
||||
if FState = disQueued then
|
||||
FQueue.RemoveInstruction(Self)
|
||||
else
|
||||
HandleError(ifeCancelled);
|
||||
end;
|
||||
|
||||
function TDBGInstruction.IsSuccess: Boolean;
|
||||
begin
|
||||
Result := FState = disComleted;
|
||||
end;
|
||||
|
||||
function TDBGInstruction.IsCompleted: boolean;
|
||||
begin
|
||||
Result := (FState = disComleted) or (FState = disFailed);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.MarkAsSuccess;
|
||||
begin
|
||||
debugln(['TDBGInstruction.MarkAsSuccess SUCCESS ', Command]);
|
||||
FState := disComleted;
|
||||
if FOnSuccess <> nil then FOnSuccess(Self);
|
||||
if FOnFinish <> nil then FOnFinish(Self);
|
||||
|
||||
If FQueue <> nil then
|
||||
FQueue.DoInstructionFinished(Self);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.MarkAsFailed;
|
||||
begin
|
||||
debugln(['TDBGInstruction.MarkAsFailed FAILED ',Command]);
|
||||
FState := disFailed;
|
||||
if FOnFailure <> nil then FOnFailure(Self);
|
||||
if FOnFinish <> nil then FOnFinish(Self);
|
||||
|
||||
If FQueue <> nil then
|
||||
FQueue.DoInstructionFinished(Self);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.HandleWriteError;
|
||||
begin
|
||||
HandleError(ifeWriteError, False);
|
||||
// if (FTimeOut = 0) or (FTimeOut > TIMEOUT_AFTER_WRITE_ERROR) then
|
||||
// FTimeOut := TIMEOUT_AFTER_WRITE_ERROR;
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.HandleReadError;
|
||||
begin
|
||||
HandleError(ifeReadError);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.HandleTimeOut;
|
||||
begin
|
||||
HandleError(ifeTimedOut);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.HandleRecoveredTimeOut;
|
||||
begin
|
||||
Include(FErrorFlags, ifeRecoveredTimedOut);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.HandleNoDbgRunning;
|
||||
begin
|
||||
HandleError(ifeDbgNotRunning);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.HandleContentError;
|
||||
begin
|
||||
HandleError(ifeContentError);
|
||||
end;
|
||||
|
||||
procedure TDBGInstruction.HandleError(AnError: TDBGInstructionErrorFlag;
|
||||
AMarkAsFailed: Boolean);
|
||||
begin
|
||||
Include(FErrorFlags, AnError);
|
||||
if AMarkAsFailed then
|
||||
MarkAsFailed;
|
||||
end;
|
||||
|
||||
function TDBGInstruction.DebugText: String;
|
||||
begin
|
||||
Result := ClassName + ': "' + FCommand + '", ' + dbgs(FFlags) + ', ' + dbgs(FState)+' # refcnt '+dbgs(RefCount);
|
||||
if ifRequiresThread in FFlags then
|
||||
Result := Result + ' Thr=' + IntToStr(FThreadId);
|
||||
if ifRequiresStackFrame in FFlags then
|
||||
Result := Result + ' Frm=' + IntToStr(FStackFrame);
|
||||
end;
|
||||
|
||||
{ TDBGInstructionQueue }
|
||||
|
||||
procedure TDBGInstructionQueue.RunQueue;
|
||||
var
|
||||
ContextInstr: TDBGInstruction;
|
||||
begin
|
||||
if FLockQueueRun > 0 then
|
||||
exit;
|
||||
if FRunningInstruction <> nil then
|
||||
exit;
|
||||
debugln(['TDBGInstructionQueue.RunQueue ', dbgsInstr(FCurrentInstruction), ' / ', dbgsInstr(FRunningInstruction)]);
|
||||
|
||||
if FCurrentInstruction = nil then begin
|
||||
FCurrentInstruction := GetNextInstructionToRun;
|
||||
if FCurrentInstruction = nil then
|
||||
exit;
|
||||
FCurrentInstruction.AddReference;
|
||||
RemoveInstruction(FCurrentInstruction);
|
||||
DebugLnEnter(['>> Current Instruction: ', FCurrentInstruction.Command]);
|
||||
end;
|
||||
|
||||
// set FCurrentInstruction to a pre running state, while changing stack....
|
||||
|
||||
ContextInstr := GetChangeContextInstruction(FCurrentInstruction);
|
||||
if ContextInstr <> nil then begin
|
||||
ContextInstr.SetQueued(Self);
|
||||
RunInstruction(ContextInstr);
|
||||
ContextInstr.ReleaseReference;
|
||||
exit; // run will be called again
|
||||
end;
|
||||
|
||||
RunInstruction(FCurrentInstruction);
|
||||
ReleaseRefAndNil(FCurrentInstruction);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoDbgLineReceived(Sender: TObject; ALine: String
|
||||
);
|
||||
begin
|
||||
// Lock DoInstructionFinished
|
||||
DoBeforeHandleLineReceived(ALine);
|
||||
if (FRunningInstruction <> nil) and (ALine <> '') then begin
|
||||
if FRunningInstruction.ProcessInputFromDbg(ALine) then
|
||||
ALine := '';
|
||||
end;
|
||||
if ALine <> '' then
|
||||
DoAfterHandleLineReceived(ALine);
|
||||
|
||||
if (FRunningInstruction = nil) and (ALine <> '') then
|
||||
DebugLn(DBG_VERBOSE, ['TDBGInstructionQueue: Got Data, but no command running: ', ALine]);
|
||||
// unlock DoInstructionFinished
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoBeginLinesReceived(Sender: TObject);
|
||||
begin
|
||||
if FOnBeginLinesReceived <> nil then
|
||||
FOnBeginLinesReceived(Self);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoEndLinesReceived(Sender: TObject);
|
||||
begin
|
||||
if FOnEndLinesReceived <> nil then
|
||||
FOnEndLinesReceived(Self);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoDbgSendError(Sender: TObject; ALine: String);
|
||||
begin
|
||||
if FRunningInstruction <> nil then
|
||||
FRunningInstruction.HandleWriteError;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoDbgTerminated(Sender: TObject);
|
||||
begin
|
||||
if FRunningInstruction <> nil then
|
||||
FRunningInstruction.HandleNoDbgRunning;
|
||||
DoDebuggerTerminated;
|
||||
end;
|
||||
|
||||
function TDBGInstructionQueue.GetNextInstructionToRun: TDBGInstruction;
|
||||
begin
|
||||
Result := FFirstQueuedInstruction;
|
||||
end;
|
||||
|
||||
function TDBGInstructionQueue.GetChangeContextInstruction(
|
||||
AnInstruction: TDBGInstruction): TDBGInstruction;
|
||||
begin
|
||||
Result := nil;
|
||||
if (ifRequiresThread in AnInstruction.Flags) and
|
||||
( (CurrentThreadId <> AnInstruction.ThreadId) or not (iqfValidThread in FFlags) )
|
||||
then begin
|
||||
Result := GetSelectThreadInstruction(AnInstruction.ThreadId);
|
||||
exit;
|
||||
end;
|
||||
|
||||
if (ifRequiresStackFrame in AnInstruction.Flags) and
|
||||
( (CurrentStackFrame <> AnInstruction.StackFrame) or not (iqfValidStackFrame in FFlags) )
|
||||
then begin
|
||||
Result := GetSelectFrameInstruction(AnInstruction.StackFrame);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoBeforeHandleLineReceived(var ALine: String);
|
||||
begin
|
||||
if FOnBeforeHandleLineReceived <> nil then
|
||||
FOnBeforeHandleLineReceived(ALine);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoAfterHandleLineReceived(var ALine: String);
|
||||
begin
|
||||
if FOnAfterHandleLineReceived <> nil then
|
||||
FOnAfterHandleLineReceived(ALine);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoDebuggerTerminated;
|
||||
begin
|
||||
if FOnDebuggerTerminated <> nil then
|
||||
FOnDebuggerTerminated(self);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.DoInstructionFinished(Sender: TDBGInstruction);
|
||||
begin
|
||||
DebugLnExit(['<< Finished Instruction: ', FRunningInstruction.Command, ' // ', Sender=FRunningInstruction]);
|
||||
if nil = FCurrentInstruction then DebugLnExit(['<< Current Instruction: ']);
|
||||
ReleaseRefAndNil(FRunningInstruction);
|
||||
RunQueue;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.RunInstruction(AnInstruction: TDBGInstruction);
|
||||
begin
|
||||
DebugLnEnter(['>> Running Instruction: ', AnInstruction.Command]);
|
||||
FRunningInstruction := AnInstruction;
|
||||
FRunningInstruction.AddReference;
|
||||
FRunningInstruction.SendCommandDataToDBG;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.RemoveInstruction(AnInstruction: TDBGInstruction
|
||||
);
|
||||
begin
|
||||
If AnInstruction.FPrevQueuedInstruction <> nil then
|
||||
AnInstruction.FPrevQueuedInstruction.FNextQueuedInstruction := AnInstruction.FNextQueuedInstruction
|
||||
else begin
|
||||
assert(FFirstQueuedInstruction = AnInstruction, 'not on queue');
|
||||
FFirstQueuedInstruction := AnInstruction.FNextQueuedInstruction;
|
||||
end;
|
||||
|
||||
If AnInstruction.FNextQueuedInstruction <> nil then
|
||||
AnInstruction.FNextQueuedInstruction.FPrevQueuedInstruction := AnInstruction.FPrevQueuedInstruction
|
||||
else begin
|
||||
assert(FLastQueuedInstruction = AnInstruction, 'not on queue');
|
||||
FLastQueuedInstruction := AnInstruction.FPrevQueuedInstruction;
|
||||
end;
|
||||
|
||||
AnInstruction.FPrevQueuedInstruction := nil;
|
||||
AnInstruction.FNextQueuedInstruction := nil;
|
||||
AnInstruction.ReleaseReference;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.SendDataToDBG(ASender: TDBGInstruction;
|
||||
AData: String);
|
||||
begin
|
||||
FDebugProcess.SendCmdLn(AData);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.SendDataToDBG(ASender: TDBGInstruction;
|
||||
AData: String; const AValues: array of const);
|
||||
begin
|
||||
SendDataToDBG(ASender, Format(AData, AValues));
|
||||
end;
|
||||
|
||||
constructor TDBGInstructionQueue.Create(ADebugProcess: TDebugProcess);
|
||||
begin
|
||||
FDebugProcess := ADebugProcess;
|
||||
FDebugProcess.OnLineReceived := @DoDbgLineReceived;
|
||||
FDebugProcess.OnBeginLinesReceived := @DoBeginLinesReceived;
|
||||
FDebugProcess.OnEndLinesReceived := @DoEndLinesReceived;
|
||||
FDebugProcess.OnSendError := @DoDbgSendError;
|
||||
FDebugProcess.OnTerminate := @DoDbgTerminated;
|
||||
end;
|
||||
|
||||
destructor TDBGInstructionQueue.Destroy;
|
||||
begin
|
||||
while FFirstQueuedInstruction <> nil do
|
||||
RemoveInstruction(FFirstQueuedInstruction);
|
||||
if FRunningInstruction <> nil then
|
||||
DoInstructionFinished(FRunningInstruction); // TODO: maybe cancel?
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.LockQueueRun;
|
||||
begin
|
||||
inc(FLockQueueRun);
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.UnLockQueueRun;
|
||||
begin
|
||||
dec(FLockQueueRun);
|
||||
if FLockQueueRun = 0 then
|
||||
RunQueue;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.InvalidateThredAndFrame(AStackFrameOnly: Boolean);
|
||||
begin
|
||||
if AStackFrameOnly then begin
|
||||
DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Invalidating queue''s stack only. Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]);
|
||||
FFlags := FFlags - [iqfValidStackFrame];
|
||||
end
|
||||
else begin
|
||||
DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Invalidating queue''s current thread and stack. Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]);
|
||||
FFlags := FFlags - [iqfValidThread, iqfValidStackFrame];
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.SetKnownThread(AThread: Integer);
|
||||
begin
|
||||
DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Setting queue''s current thread and stack. New: Thr=', AThread, ' Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]);
|
||||
FCurrentThreadId := AThread;
|
||||
FFlags := FFlags + [iqfValidThread] - [iqfValidStackFrame];
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.SetKnownThreadAndFrame(AThread, AFrame: Integer);
|
||||
begin
|
||||
DebugLn(DBG_THREAD_AND_FRAME, ['TGDB_IQ: Setting queue''s current thread and stack. New: Thr=', AThread, ' Frm=', AFrame,' Was: ', dbgs(FFlags), ' Thr=', FCurrentThreadId, ' Frm=', FCurrentStackFrame]);
|
||||
FCurrentThreadId := AThread;
|
||||
FCurrentStackFrame := AFrame;
|
||||
FFlags := FFlags + [iqfValidThread, iqfValidStackFrame];
|
||||
end;
|
||||
|
||||
procedure TDBGInstructionQueue.QueueInstruction(AnInstruction: TDBGInstruction);
|
||||
begin
|
||||
debugln(['TDBGInstructionQueue.QueueInstruction ', AnInstruction.DebugText]);
|
||||
Assert(AnInstruction.State = disNew, 'queue only new instr');
|
||||
AnInstruction.AddReference;
|
||||
AnInstruction.FNextQueuedInstruction := nil;
|
||||
AnInstruction.FPrevQueuedInstruction := FLastQueuedInstruction;
|
||||
if FLastQueuedInstruction <> nil then
|
||||
FLastQueuedInstruction.FNextQueuedInstruction := AnInstruction
|
||||
else
|
||||
FFirstQueuedInstruction := AnInstruction;
|
||||
FLastQueuedInstruction := AnInstruction;
|
||||
AnInstruction.SetQueued(Self);
|
||||
RunQueue;
|
||||
end;
|
||||
|
||||
initialization
|
||||
DBGMI_TIMEOUT_DEBUG := DebugLogger.FindOrRegisterLogGroup('DBGMI_TIMEOUT_DEBUG' {$IFDEF DBGMI_TIMEOUT_DEBUG} , True {$ENDIF} );
|
||||
DBG_THREAD_AND_FRAME := DebugLogger.FindOrRegisterLogGroup('DBG_THREAD_AND_FRAME' {$IFDEF DBG_THREAD_AND_FRAME} , True {$ENDIF} );
|
||||
DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} );
|
||||
|
||||
end.
|
||||
|
||||
579
components/lazdebuggers/cmdlinedebuggerbase/debugprocess.pas
Normal file
579
components/lazdebuggers/cmdlinedebuggerbase/debugprocess.pas
Normal file
@ -0,0 +1,579 @@
|
||||
{
|
||||
This unit contains the Commandline debugger class for external commandline
|
||||
debuggers.
|
||||
|
||||
***************************************************************************
|
||||
* *
|
||||
* This source is free software; you can redistribute it and/or modify *
|
||||
* it under the terms of the GNU General Public License as published by *
|
||||
* the Free Software Foundation; either version 2 of the License, or *
|
||||
* (at your option) any later version. *
|
||||
* *
|
||||
* This code is distributed in the hope that it will be useful, but *
|
||||
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
||||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
||||
* General Public License for more details. *
|
||||
* *
|
||||
* A copy of the GNU General Public License is available on the World *
|
||||
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
||||
* obtain it by writing to the Free Software Foundation, *
|
||||
* Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
|
||||
* *
|
||||
***************************************************************************
|
||||
}
|
||||
unit DebugProcess;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{$DEFINE DBG_VERBOSE}
|
||||
{$DEFINE DBG_VERBOSE_FULL_DATA}
|
||||
|
||||
{$IFDEF MSWindows} // optional gtk
|
||||
{$DEFINE NATIVE_ASYNC_PROCESS}
|
||||
{$ELSE}
|
||||
{$UNDEF NATIVE_ASYNC_PROCESS}
|
||||
{$ENDIF}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, sysutils, AsyncProcess, LCLIntf, InterfaceBase, process,
|
||||
Pipes, LazLoggerBase, UTF8Process;
|
||||
|
||||
type
|
||||
|
||||
TDebugProcessNotification = procedure(Sender: TObject; ALine: String) of object;
|
||||
|
||||
{ TDebugProcessReadThread }
|
||||
|
||||
{$IFnDEF NATIVE_ASYNC_PROCESS}
|
||||
TDebugProcessReadThread = class(TThread)
|
||||
private
|
||||
FAsyncLoopWaitEvent: PRTLEvent;
|
||||
protected
|
||||
FStream: TInputPipeStream;
|
||||
FOnDataAvail: TThreadMethod;
|
||||
FOnPipeError: TThreadMethod;
|
||||
procedure Execute; override;
|
||||
public
|
||||
constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt =
|
||||
DefaultStackSize);
|
||||
destructor Destroy; override;
|
||||
property AsyncLoopWaitEvent: PRTLEvent read FAsyncLoopWaitEvent;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{ TDebugAsyncProcess }
|
||||
|
||||
TDebugAsyncProcess = class(TProcessUTF8) // TAsyncProcess
|
||||
private
|
||||
{$IFdef NATIVE_ASYNC_PROCESS}
|
||||
FPipeHandler: PPipeEventHandler;
|
||||
FProcessHandler: PProcessEventHandler;
|
||||
{$ELSE}
|
||||
FReadThread: TDebugProcessReadThread;
|
||||
{$ENDIF}
|
||||
FOnReadData: TNotifyEvent;
|
||||
FOnTerminate: TNotifyEvent;
|
||||
{$ifNdef NATIVE_ASYNC_PROCESS}
|
||||
procedure ThreadDataAvail;
|
||||
procedure ThreadPipeError;
|
||||
{$ENDIF}
|
||||
procedure FinishedReadingOutput;
|
||||
protected
|
||||
procedure HandlePipeInput(AData: PtrInt; AReasons: TPipeReasons);
|
||||
procedure HandleProcessTermination(AData: PtrInt; AReason: TChildExitReason; AInfo: dword);
|
||||
procedure UnhookPipeHandle;
|
||||
procedure UnhookProcessHandle;
|
||||
public
|
||||
procedure Execute; override;
|
||||
destructor Destroy; override;
|
||||
function Terminate(AExitCode: Integer): Boolean; override;
|
||||
published
|
||||
property OnReadData: TNotifyEvent read FOnReadData write FOnReadData;// You must read all the data in this event. Otherwise it is called again.
|
||||
property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
|
||||
end;
|
||||
|
||||
{ TDebugProcess }
|
||||
|
||||
TDebugProcess = class
|
||||
private const
|
||||
DBG_STREAM_READ_LEN = 8192;
|
||||
private
|
||||
FExternalDebugger: String;
|
||||
FDbgProcess: TDebugAsyncProcess;
|
||||
FOnLineReceived: TDebugProcessNotification;
|
||||
FOnBeginLinesReceived: TNotifyEvent;
|
||||
FOnEndLinesReceived: TNotifyEvent;
|
||||
FOnLineSent: TDebugProcessNotification;
|
||||
FOnSendError: TDebugProcessNotification;
|
||||
FOnTerminate: TNotifyEvent;
|
||||
FTmpBuffer: String;
|
||||
FOutputBuf: String;
|
||||
FLockReadData: Boolean;
|
||||
procedure DoReadData(Sender: TObject);
|
||||
procedure DoTerminate(Sender: TObject);
|
||||
function GetDbgProcess: TProcessUTF8;
|
||||
function HandleHasData(const AHandle: Integer): Boolean;
|
||||
protected
|
||||
function GetDebugProcessRunning: Boolean;
|
||||
public
|
||||
constructor Create(const AExternalDebugger: String);
|
||||
destructor Destroy; override;
|
||||
function CreateDebugProcess(const AOptions: String; AnEnvironment: TStrings): Boolean;
|
||||
procedure StopDebugProcess;
|
||||
procedure SendCmdLn(const ACommand: String); overload;
|
||||
procedure SendCmdLn(const ACommand: String; Values: array of const); overload;
|
||||
public
|
||||
property DebugProcess: TProcessUTF8 read GetDbgProcess;
|
||||
property DebugProcessRunning: Boolean read GetDebugProcessRunning;
|
||||
property OnLineReceived: TDebugProcessNotification read FOnLineReceived write FOnLineReceived;
|
||||
property OnBeginLinesReceived: TNotifyEvent read FOnBeginLinesReceived write FOnBeginLinesReceived;
|
||||
property OnEndLinesReceived: TNotifyEvent read FOnEndLinesReceived write FOnEndLinesReceived;
|
||||
property OnLineSent: TDebugProcessNotification read FOnLineSent write FOnLineSent;
|
||||
property OnSendError: TDebugProcessNotification read FOnSendError write FOnSendError;
|
||||
// property OnTimeOut: TDebugProcessNotification read FOnTimeOut write FOnTimeOut;
|
||||
property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
{$IFdef MSWindows} Windows {$ENDIF}
|
||||
{$IFDEF UNIX} Unix, BaseUnix {$ENDIF}
|
||||
;
|
||||
|
||||
var
|
||||
DBG_CMD_ECHO, DBG_CMD_ECHO_FULL, DBG_VERBOSE, DBG_WARNINGS: PLazLoggerLogGroup;
|
||||
|
||||
{ TDebugProcessReadThread }
|
||||
|
||||
{$IFnDEF NATIVE_ASYNC_PROCESS}
|
||||
procedure TDebugProcessReadThread.Execute;
|
||||
var
|
||||
R: Integer;
|
||||
FDS: TFDSet;
|
||||
begin
|
||||
while (not Terminated) and (FStream.Handle >= 0) do begin
|
||||
FpFD_ZERO(FDS);
|
||||
FpFD_Set(FStream.Handle, FDS);
|
||||
// R = -1 on error, 0 on timeout, >0 on success and is number of handles
|
||||
// FDS is changed, and indicates what descriptors have changed
|
||||
R := FpSelect(FStream.Handle + 1, @FDS, nil, nil, 50);
|
||||
|
||||
if Terminated then
|
||||
break;
|
||||
|
||||
if r < 0 then begin
|
||||
DebugLn('TTTTT pipe err');
|
||||
Queue(FOnPipeError);
|
||||
exit;
|
||||
end;
|
||||
|
||||
if (R > 0) and (FpFD_ISSET(FStream.Handle,FDS)=1) then begin
|
||||
DebugLn('TTTTT data avail');
|
||||
Queue(FOnDataAvail);
|
||||
RTLeventWaitFor(FAsyncLoopWaitEvent);
|
||||
DebugLn('TTTTT data avail continue');
|
||||
end;
|
||||
|
||||
end;
|
||||
DebugLn(['TTTTT loop end ', Terminated]);
|
||||
end;
|
||||
|
||||
constructor TDebugProcessReadThread.Create(CreateSuspended: Boolean;
|
||||
const StackSize: SizeUInt);
|
||||
begin
|
||||
FAsyncLoopWaitEvent := RTLEventCreate;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
destructor TDebugProcessReadThread.Destroy;
|
||||
begin
|
||||
inherited Destroy;
|
||||
RTLeventdestroy(FAsyncLoopWaitEvent);
|
||||
end;
|
||||
|
||||
{$ENDIF}
|
||||
|
||||
{ TDebugAsyncProcess }
|
||||
|
||||
procedure TDebugAsyncProcess.FinishedReadingOutput;
|
||||
begin
|
||||
{$ifNdef NATIVE_ASYNC_PROCESS}
|
||||
// Either finished reading, or TThread.Terminate was called
|
||||
if FReadThread <> nil then
|
||||
RTLeventSetEvent(FReadThread.AsyncLoopWaitEvent);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
{$ifNdef NATIVE_ASYNC_PROCESS}
|
||||
procedure TDebugAsyncProcess.ThreadDataAvail;
|
||||
begin
|
||||
if not Running then begin
|
||||
//HandlePipeInput(0, [prBroken]);
|
||||
HandleProcessTermination(0, cerExit, 0);
|
||||
exit;
|
||||
end;
|
||||
|
||||
HandlePipeInput(0, [prDataAvailable]);
|
||||
// SELF may have been destroyed, during read or handle-termination
|
||||
end;
|
||||
|
||||
procedure TDebugAsyncProcess.ThreadPipeError;
|
||||
begin
|
||||
DebugLn(['got pipe err / is running ', Running]);
|
||||
Terminate(0);
|
||||
HandleProcessTermination(0, cerExit, 0);
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure TDebugAsyncProcess.HandlePipeInput(AData: PtrInt;
|
||||
AReasons: TPipeReasons);
|
||||
begin
|
||||
if prBroken in AReasons then
|
||||
UnhookPipeHandle;
|
||||
if prDataAvailable in AReasons then
|
||||
if FOnReadData <> nil then
|
||||
FOnReadData(Self);
|
||||
end;
|
||||
|
||||
procedure TDebugAsyncProcess.HandleProcessTermination(AData: PtrInt;
|
||||
AReason: TChildExitReason; AInfo: dword);
|
||||
begin
|
||||
DebugLn('HandleProcessTermination');
|
||||
UnhookProcessHandle;
|
||||
UnhookPipeHandle;
|
||||
if FOnTerminate <> nil then
|
||||
FOnTerminate(Self);
|
||||
end;
|
||||
|
||||
procedure TDebugAsyncProcess.UnhookPipeHandle;
|
||||
begin
|
||||
{$IFdef NATIVE_ASYNC_PROCESS}
|
||||
if FPipeHandler <> nil then
|
||||
RemovePipeEventHandler(FPipeHandler);
|
||||
{$ELSE}
|
||||
if FReadThread <> nil then begin
|
||||
FReadThread.Terminate;
|
||||
FinishedReadingOutput;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TDebugAsyncProcess.UnhookProcessHandle;
|
||||
begin
|
||||
{$IFdef NATIVE_ASYNC_PROCESS}
|
||||
if FProcessHandler <> nil then
|
||||
RemoveProcessEventHandler(FProcessHandler);
|
||||
{$ELSE} // should be enough in UnhookPipeHandle;
|
||||
if FReadThread <> nil then begin
|
||||
FReadThread.Terminate;
|
||||
FinishedReadingOutput;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
procedure TDebugAsyncProcess.Execute;
|
||||
begin
|
||||
inherited Execute;
|
||||
|
||||
{$IFdef NATIVE_ASYNC_PROCESS}
|
||||
if poUsePipes in Options then
|
||||
FPipeHandler := AddPipeEventHandler(Output.Handle, @HandlePipeInput, 0);
|
||||
FProcessHandler := AddProcessEventHandler(ProcessHandle, @HandleProcessTermination, 0);
|
||||
{$ELSE}
|
||||
if FReadThread = nil then
|
||||
FReadThread := TDebugProcessReadThread.Create(false);
|
||||
FReadThread.FStream := Output;
|
||||
FReadThread.FOnDataAvail := @ThreadDataAvail;
|
||||
FReadThread.FOnPipeError := @ThreadPipeError;
|
||||
FReadThread.Start;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
destructor TDebugAsyncProcess.Destroy;
|
||||
begin
|
||||
{$IFdef NATIVE_ASYNC_PROCESS}
|
||||
UnhookProcessHandle;
|
||||
UnhookPipeHandle;
|
||||
{$ELSE}
|
||||
if FReadThread <> nil then begin
|
||||
FReadThread.Terminate;
|
||||
FinishedReadingOutput; // make sure destroy will not wait forever
|
||||
debugln(['DESTROY thread destroying']);
|
||||
FreeAndNil(FReadThread);
|
||||
debugln(['DESTROY thread destroyed']);
|
||||
end;
|
||||
{$ENDIF}
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TDebugAsyncProcess.Terminate(AExitCode: Integer): Boolean;
|
||||
begin
|
||||
{$ifdef NATIVE_ASYNC_PROCESS}
|
||||
UnhookProcessHandle;
|
||||
UnhookPipeHandle;
|
||||
{$ELSE}
|
||||
if FReadThread <> nil then begin
|
||||
FReadThread.Terminate;
|
||||
FinishedReadingOutput;
|
||||
end;
|
||||
{$ENDIF}
|
||||
Result := inherited Terminate(AExitCode);
|
||||
end;
|
||||
|
||||
{ TDebugProcess }
|
||||
|
||||
procedure TDebugProcess.DoReadData(Sender: TObject);
|
||||
function ReadData(const AStream: TInputPipeStream; var ABuffer: String): Integer;
|
||||
var
|
||||
c: LongInt;
|
||||
begin
|
||||
Result := 0;
|
||||
c := AStream.Read(FTmpBuffer[1], DBG_STREAM_READ_LEN);
|
||||
while c > 0 do begin
|
||||
SetLength(ABuffer, Length(ABuffer)+c);
|
||||
Move(FTmpBuffer[1], ABuffer[1 + Result], c);
|
||||
Result := Result + c;
|
||||
if (c = DBG_STREAM_READ_LEN) and HandleHasData(AStream.Handle) then begin
|
||||
c := AStream.Read(FTmpBuffer[1], DBG_STREAM_READ_LEN);
|
||||
end
|
||||
else
|
||||
c := 0;
|
||||
end;
|
||||
end;
|
||||
function LineEndPos(const s: string; out LineEndLen: integer): integer;
|
||||
var
|
||||
n, idx: Integer;
|
||||
begin
|
||||
LineEndLen := 0;
|
||||
Result := pos(#10, s);
|
||||
n := pos(#13, s);
|
||||
if (n > 0) and (n < Result) then
|
||||
Result := n;
|
||||
|
||||
if Result = 0 then exit;
|
||||
LineEndLen := 1;
|
||||
if Result < Length(s) then begin
|
||||
if (s[Result+1] in [#10,#13]) and (s[Result+1] <> s[Result]) then
|
||||
LineEndLen := 2;
|
||||
end;
|
||||
end;
|
||||
|
||||
var
|
||||
LineEndIdx, LineEndLen: Integer;
|
||||
Line: String;
|
||||
begin
|
||||
if not DebugProcessRunning then begin
|
||||
StopDebugProcess;
|
||||
exit;
|
||||
end;
|
||||
|
||||
if (FDbgProcess.Output <> nil) then
|
||||
ReadData(FDbgProcess.Output, Line);
|
||||
FOutputBuf := FOutputBuf + Line;
|
||||
|
||||
FDbgProcess.FinishedReadingOutput; // Allow new reads, while we are processing
|
||||
|
||||
if FLockReadData or (FOutputBuf = '') then
|
||||
exit;
|
||||
|
||||
try
|
||||
FLockReadData := True;
|
||||
if FOnBeginLinesReceived <> nil then // use to UnlockRelease
|
||||
FOnBeginLinesReceived(Self);
|
||||
|
||||
LineEndIdx := LineEndPos(FOutputBuf, LineEndLen);
|
||||
while (LineEndIdx > 0) do begin
|
||||
Dec(LineEndIdx);
|
||||
Line := Copy(FOutputBuf, 1, LineEndIdx);
|
||||
Delete(FOutputBuf, 1, LineEndIdx + LineEndLen);
|
||||
|
||||
if ((DBG_CMD_ECHO_FULL <> nil) and (DBG_CMD_ECHO_FULL^. Enabled))
|
||||
then debugln(DBG_CMD_ECHO_FULL, '<< << TCmdLineDebugger.ReadLn "',Line,'"')
|
||||
else if (length(Line) < 300)
|
||||
then debugln(DBG_CMD_ECHO, '<< << TCmdLineDebugger.ReadLn "',Line,'"')
|
||||
else debugln(DBG_CMD_ECHO, ['<< << TCmdLineDebugger.ReadLn "',copy(Line, 1, 200), '" ..(',length(Line)-300,').. "',copy(Line, length(Line)-99, 100),'"']);
|
||||
|
||||
if FOnLineReceived <> nil then
|
||||
FOnLineReceived(Self, Line);
|
||||
|
||||
LineEndIdx := LineEndPos(FOutputBuf, LineEndLen);
|
||||
end;
|
||||
|
||||
finally
|
||||
FLockReadData := False;
|
||||
if FOnEndLinesReceived <> nil then // use to LockRelease
|
||||
FOnEndLinesReceived(Self);
|
||||
// Debugger and Self may get destroyed at this point
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDebugProcess.DoTerminate(Sender: TObject);
|
||||
begin
|
||||
if FOnTerminate <> nil then
|
||||
FOnTerminate(Self);
|
||||
end;
|
||||
|
||||
function TDebugProcess.GetDbgProcess: TProcessUTF8;
|
||||
begin
|
||||
Result := FDbgProcess;
|
||||
end;
|
||||
|
||||
function TDebugProcess.HandleHasData(const AHandle: Integer): Boolean;
|
||||
{$IFDEF UNIX}
|
||||
var
|
||||
R: Integer;
|
||||
FDS: TFDSet;
|
||||
begin
|
||||
Result := False;
|
||||
if AHandle < 0 then
|
||||
exit;
|
||||
|
||||
FpFD_ZERO(FDS);
|
||||
FpFD_Set(AHandle, FDS);
|
||||
// R = -1 on error, 0 on timeout, >0 on success and is number of handles
|
||||
// FDS is changed, and indicates what descriptors have changed
|
||||
R := FpSelect(AHandle + 1, @FDS, nil, nil, 1);
|
||||
|
||||
Result := (R > 0) and (FpFD_ISSET(AHandle,FDS)=1);
|
||||
end;
|
||||
{$ELSE linux}
|
||||
{$IFdef MSWindows}
|
||||
var
|
||||
TotalBytesAvailable: dword;
|
||||
R: LongBool;
|
||||
begin
|
||||
R := Windows.PeekNamedPipe(AHandle, nil, 0, nil, @TotalBytesAvailable, nil);
|
||||
if not R then begin
|
||||
// PeekNamedPipe failed
|
||||
DebugLn(DBG_WARNINGS, ['PeekNamedPipe failed, GetLastError is ', GetLastError]);
|
||||
Exit;
|
||||
end;
|
||||
Result := TotalBytesAvailable > 0;
|
||||
end;
|
||||
{$ELSE win32}
|
||||
begin
|
||||
DebugLn('ToDo: implement WaitForHandles for this OS');
|
||||
Result := 0;
|
||||
end;
|
||||
{$ENDIF win32}
|
||||
{$ENDIF linux}
|
||||
|
||||
|
||||
function TDebugProcess.GetDebugProcessRunning: Boolean;
|
||||
begin
|
||||
Result := (FDbgProcess <> nil) and FDbgProcess.Running;
|
||||
end;
|
||||
|
||||
constructor TDebugProcess.Create(const AExternalDebugger: String);
|
||||
begin
|
||||
FDbgProcess := nil;
|
||||
FExternalDebugger := AExternalDebugger;
|
||||
SetLength(FTmpBuffer, DBG_STREAM_READ_LEN);
|
||||
inherited Create;
|
||||
end;
|
||||
|
||||
destructor TDebugProcess.Destroy;
|
||||
begin
|
||||
if DebugProcessRunning then
|
||||
StopDebugProcess; // calls FDbgProcess.Release;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TDebugProcess.CreateDebugProcess(const AOptions: String;
|
||||
AnEnvironment: TStrings): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if FDbgProcess = nil
|
||||
then begin
|
||||
FDbgProcess := TDebugAsyncProcess.Create(nil);
|
||||
try
|
||||
FDbgProcess.ParseCmdLine(FExternalDebugger + ' ' + AOptions);
|
||||
FDbgProcess.Options:= [poUsePipes, poNoConsole, poStdErrToOutPut, poNewProcessGroup];
|
||||
{$if defined(windows) and not defined(wince)}
|
||||
// under win9x and winMe should be created with console,
|
||||
// otherwise no break can be send.
|
||||
if Win32MajorVersion <= 4 then
|
||||
FDbgProcess.Options:= [poUsePipes, poNewConsole, poStdErrToOutPut, poNewProcessGroup];
|
||||
{$endif windows}
|
||||
FDbgProcess.ShowWindow := swoNone;
|
||||
FDbgProcess.Environment:= AnEnvironment;
|
||||
except
|
||||
FreeAndNil(FDbgProcess);
|
||||
end;
|
||||
end;
|
||||
if FDbgProcess = nil then exit;
|
||||
|
||||
FDbgProcess.OnReadData := @DoReadData;
|
||||
FDbgProcess.OnTerminate := @DoTerminate;
|
||||
|
||||
if not FDbgProcess.Running
|
||||
then begin
|
||||
try
|
||||
FDbgProcess.Execute;
|
||||
DebugLn(DBG_VERBOSE, '[TDebugProcess] Debug PID: ', IntToStr(FDbgProcess.Handle));
|
||||
Result := FDbgProcess.Running;
|
||||
except
|
||||
on E: Exception do begin
|
||||
FOutputBuf := E.Message;
|
||||
DebugLn(DBG_WARNINGS, 'Exception while executing debugger: ', FOutputBuf);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TDebugProcess.StopDebugProcess;
|
||||
begin
|
||||
debugln(['TDebugProcess.StopDebugProcess FDbgProcess = nil ',FDbgProcess = nil]);
|
||||
if FDbgProcess = nil then exit;
|
||||
|
||||
FDbgProcess.Terminate(0);
|
||||
try
|
||||
FDbgProcess.Destroy;
|
||||
except
|
||||
on E: Exception do DebugLn(DBG_WARNINGS, 'Exception while freeing debugger: ', E.Message);
|
||||
end;
|
||||
FDbgProcess := nil;
|
||||
end;
|
||||
|
||||
procedure TDebugProcess.SendCmdLn(const ACommand: String);
|
||||
const
|
||||
LE: string = LineEnding;
|
||||
begin
|
||||
if (DBG_CMD_ECHO_FULL <> nil) and (DBG_CMD_ECHO_FULL^.Enabled)
|
||||
then debugln(DBG_CMD_ECHO_FULL, '>> >> TDebugProcess.SendCmdLn "',ACommand,'"')
|
||||
else debugln(DBG_CMD_ECHO, '>> >> TDebugProcess.SendCmdLn "',ACommand,'"');
|
||||
|
||||
if DebugProcessRunning
|
||||
then begin
|
||||
if FOnLineSent <> nil then
|
||||
FOnLineSent(Self, ACommand);
|
||||
|
||||
if ACommand <> ''
|
||||
then FDbgProcess.Input.Write(ACommand[1], Length(ACommand));
|
||||
FDbgProcess.Input.Write(LE[1], Length(LE));
|
||||
end
|
||||
else begin
|
||||
DebugLn(DBG_WARNINGS, '[TDebugProcess.SendCmdLn] Unable to send <', ACommand, '>. No process running.');
|
||||
if FOnSendError <> nil then
|
||||
FOnSendError(Self, ACommand);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TDebugProcess.SendCmdLn(const ACommand: String;
|
||||
Values: array of const);
|
||||
begin
|
||||
SendCmdLn(Format(ACommand, Values));
|
||||
end;
|
||||
|
||||
initialization
|
||||
DBG_CMD_ECHO := DebugLogger.FindOrRegisterLogGroup('DBG_CMD_ECHO' {$IF defined(DBG_VERBOSE) or defined(DBG_CMD_ECHO)} , True {$ENDIF} );
|
||||
DBG_CMD_ECHO_FULL := DebugLogger.FindOrRegisterLogGroup('DBG_CMD_ECHO_FULL' {$IF defined(DBG_VERBOSE_FULL_DATA) or defined(DBG_CMD_ECHO_FULL)} , True {$ENDIF} );
|
||||
DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} );
|
||||
DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} );
|
||||
|
||||
end.
|
||||
|
||||
50
components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.lpk
Normal file
50
components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.lpk
Normal file
@ -0,0 +1,50 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="4">
|
||||
<PathDelim Value="\"/>
|
||||
<Name Value="LazDebuggerLldb"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<SearchPaths>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Other>
|
||||
<CustomOptions Value="$(IDEBuildOptions)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Files Count="3">
|
||||
<Item1>
|
||||
<Filename Value="lldbdebugger.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="LldbDebugger"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="lldbinstructions.pas"/>
|
||||
<UnitName Value="LldbInstructions"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Filename Value="lldbhelper.pas"/>
|
||||
<UnitName Value="LldbHelper"/>
|
||||
</Item3>
|
||||
</Files>
|
||||
<RequiredPkgs Count="3">
|
||||
<Item1>
|
||||
<PackageName Value="CmdLineDebuggerBase"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="DebuggerIntf"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<PackageName Value="FCL"/>
|
||||
</Item3>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
||||
22
components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.pas
Normal file
22
components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.pas
Normal file
@ -0,0 +1,22 @@
|
||||
{ This file was automatically created by Lazarus. Do not edit!
|
||||
This source is only used to compile and install the package.
|
||||
}
|
||||
|
||||
unit LazDebuggerLldb;
|
||||
|
||||
{$warn 5023 off : no warning about unused units}
|
||||
interface
|
||||
|
||||
uses
|
||||
LldbDebugger, LldbInstructions, LldbHelper, LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterUnit('LldbDebugger', @LldbDebugger.Register);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterPackage('LazDebuggerLldb', @Register);
|
||||
end.
|
||||
946
components/lazdebuggers/lazdebuggerlldb/lldbdebugger.pas
Normal file
946
components/lazdebuggers/lazdebuggerlldb/lldbdebugger.pas
Normal file
@ -0,0 +1,946 @@
|
||||
(*
|
||||
settings set prompt ((lldb)) \r\n
|
||||
settings set target.output-path /tmp/out.txt
|
||||
*)
|
||||
unit LldbDebugger;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, math, DbgIntfDebuggerBase, LazLoggerBase, LazClasses,
|
||||
LazFileUtils, Maps, strutils, DebugProcess, LldbInstructions, LldbHelper;
|
||||
|
||||
type
|
||||
|
||||
(*
|
||||
* Commands
|
||||
*)
|
||||
|
||||
TLldbDebugger = class;
|
||||
TLldbDebuggerCommand = class;
|
||||
|
||||
{ TLldbDebuggerCommandQueue }
|
||||
|
||||
TLldbDebuggerCommandQueue = class(TRefCntObjList)
|
||||
private
|
||||
FDebugger: TLldbDebugger;
|
||||
function Get(Index: Integer): TLldbDebuggerCommand;
|
||||
procedure Put(Index: Integer; const AValue: TLldbDebuggerCommand);
|
||||
private
|
||||
FRunningCommand: TLldbDebuggerCommand;
|
||||
procedure Run;
|
||||
protected
|
||||
procedure CommandFinished(ACommand: TLldbDebuggerCommand);
|
||||
public
|
||||
constructor Create(ADebugger: TLldbDebugger);
|
||||
destructor Destroy; override;
|
||||
property Items[Index: Integer]: TLldbDebuggerCommand read Get write Put; default;
|
||||
procedure QueueCommand(AValue: TLldbDebuggerCommand);
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommand }
|
||||
|
||||
TLldbDebuggerCommand = class(TRefCountedObject)
|
||||
private
|
||||
FOwner: TLldbDebugger;
|
||||
function GetDebuggerState: TDBGState;
|
||||
procedure Finished;
|
||||
function GetCommandQueue: TLldbDebuggerCommandQueue;
|
||||
function GetInstructionQueue: TLldbInstructionQueue;
|
||||
protected
|
||||
procedure DoExecute; virtual; abstract;
|
||||
|
||||
procedure InstructionSucceeded(AnInstruction: TObject);
|
||||
procedure InstructionFailed(AnInstruction: TObject);
|
||||
|
||||
procedure QueueInstruction(AnInstruction: TLldbInstruction);
|
||||
procedure SetDebuggerState(const AValue: TDBGState);
|
||||
property Debugger: TLldbDebugger read FOwner;
|
||||
property CommandQueue: TLldbDebuggerCommandQueue read GetCommandQueue;
|
||||
property InstructionQueue: TLldbInstructionQueue read GetInstructionQueue;
|
||||
property DebuggerState: TDBGState read GetDebuggerState;
|
||||
public
|
||||
constructor Create(AOwner: TLldbDebugger);
|
||||
procedure Execute;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandInit }
|
||||
|
||||
TLldbDebuggerCommandInit = class(TLldbDebuggerCommand)
|
||||
protected
|
||||
procedure DoExecute; override;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandRun }
|
||||
|
||||
TLldbDebuggerCommandRun = class(TLldbDebuggerCommand)
|
||||
private
|
||||
FRunInstr: TLldbInstruction;
|
||||
procedure TargetCreated(Sender: TObject);
|
||||
protected
|
||||
procedure DoExecute; override;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandStop }
|
||||
|
||||
TLldbDebuggerCommandStop = class(TLldbDebuggerCommand)
|
||||
private
|
||||
procedure StopInstructionSucceeded(Sender: TObject);
|
||||
protected
|
||||
procedure DoExecute; override;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandEvaluate }
|
||||
|
||||
TLldbDebuggerCommandEvaluate = class(TLldbDebuggerCommand)
|
||||
private
|
||||
FInstr: TLldbInstructionExpression;
|
||||
FWatchValue: TWatchValue;
|
||||
FExpr: String;
|
||||
FFlags: TDBGEvaluateFlags;
|
||||
FCallback: TDBGEvaluateResultCallback;
|
||||
procedure EvalInstructionFailed(Sender: TObject);
|
||||
procedure EvalInstructionSucceeded(Sender: TObject);
|
||||
protected
|
||||
procedure DoExecute; override;
|
||||
public
|
||||
// TODO: Pass FCurrentStackFrame to create
|
||||
constructor Create(AOwner: TLldbDebugger; AWatchValue: TWatchValue);
|
||||
constructor Create(AOwner: TLldbDebugger; AnExpr: String; AFlags: TDBGEvaluateFlags;
|
||||
ACallback: TDBGEvaluateResultCallback);
|
||||
end;
|
||||
|
||||
(*
|
||||
* Debugger
|
||||
*)
|
||||
{ TLldbDebugger }
|
||||
|
||||
TLldbDebugger = class(TDebuggerIntf)
|
||||
private
|
||||
FDebugProcess: TDebugProcess;
|
||||
FDebugInstructionQueue: TLldbInstructionQueue;
|
||||
FCommandQueue: TLldbDebuggerCommandQueue;
|
||||
FCurrentLocation: TDBGLocationRec;
|
||||
FCurrentStackFrame: Integer;
|
||||
FCurrentThreadId: Integer;
|
||||
|
||||
procedure DoAfterLineReceived(var ALine: String);
|
||||
procedure DoBeforeLineReceived(var ALine: String);
|
||||
procedure DoBeginReceivingLines(Sender: TObject);
|
||||
procedure DoCmdLineDebuggerTerminated(Sender: TObject);
|
||||
procedure DoEndReceivingLines(Sender: TObject);
|
||||
function LldbRun: Boolean;
|
||||
function LldbStep(AStepAction: TLldbInstructionProcessStepAction): Boolean;
|
||||
function LldbStop: Boolean;
|
||||
function LldbEvaluate(const AExpression: String; EvalFlags: TDBGEvaluateFlags; ACallback: TDBGEvaluateResultCallback): Boolean;
|
||||
protected
|
||||
procedure LockRelease; override;
|
||||
procedure UnlockRelease; override;
|
||||
procedure SetState(const AValue: TDBGState);
|
||||
//procedure DoState(const OldState: TDBGState); override;
|
||||
//procedure DoBeforeState(const OldState: TDBGState); override;
|
||||
protected
|
||||
function CreateBreakPoints: TDBGBreakPoints; override;
|
||||
//function CreateLocals: TLocalsSupplier; override;
|
||||
//function CreateLineInfo: TDBGLineInfo; override;
|
||||
//function CreateRegisters: TRegisterSupplier; override;
|
||||
function CreateCallStack: TCallStackSupplier; override;
|
||||
//function CreateDisassembler: TDBGDisassembler; override;
|
||||
function CreateWatches: TWatchesSupplier; override;
|
||||
//function CreateThreads: TThreadsSupplier; override;
|
||||
|
||||
function GetSupportedCommands: TDBGCommands; override;
|
||||
//function GetCommands: TDBGCommands; override;
|
||||
function RequestCommand(const ACommand: TDBGCommand;
|
||||
const AParams: array of const;
|
||||
const ACallback: TMethod): Boolean; override;
|
||||
public
|
||||
// class function CreateProperties: TDebuggerProperties; override; // Creates debuggerproperties
|
||||
class function Caption: String; override;
|
||||
// class function ExePaths: String; override;
|
||||
|
||||
constructor Create(const AExternalDebugger: String); override;
|
||||
destructor Destroy; override;
|
||||
procedure Init; override; // Initializes external debugger
|
||||
procedure Done; override; // Kills external debugger
|
||||
|
||||
function GetLocation: TDBGLocationRec; override;
|
||||
// function GetProcessList({%H-}AList: TRunningProcessInfoList): boolean; override;
|
||||
|
||||
// //LockCommandProcessing is more than just QueueExecuteLock
|
||||
// //LockCommandProcessing also takes care to run the queue, if unlocked and not already running
|
||||
// procedure LockCommandProcessing; override;
|
||||
// procedure UnLockCommandProcessing; override;
|
||||
|
||||
|
||||
// function NeedReset: Boolean; override;
|
||||
end;
|
||||
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
type
|
||||
|
||||
{ TLldbCallStack }
|
||||
|
||||
TLldbCallStack = class(TCallStackSupplier)
|
||||
private
|
||||
procedure StackInstructionFinished(Sender: TObject);
|
||||
protected
|
||||
//procedure Clear;
|
||||
//procedure DoThreadChanged;
|
||||
public
|
||||
procedure RequestAtLeastCount(ACallstack: TCallStackBase;
|
||||
ARequiredMinCount: Integer); override;
|
||||
procedure UpdateCurrentIndex; override;
|
||||
procedure RequestCurrent(ACallstack: TCallStackBase); override;
|
||||
procedure RequestEntries(ACallstack: TCallStackBase); override;
|
||||
end;
|
||||
|
||||
{ TLldbWatches }
|
||||
|
||||
TLldbWatches = class(TWatchesSupplier)
|
||||
private
|
||||
protected
|
||||
procedure InternalRequestData(AWatchValue: TWatchValue); override;
|
||||
public
|
||||
end;
|
||||
|
||||
{ TLldbBreakPoint }
|
||||
|
||||
TLldbBreakPoint = class(TDBGBreakPoint)
|
||||
private
|
||||
FBreakID: Integer;
|
||||
procedure BreakInstructionFinished(Sender: TObject);
|
||||
procedure SetBreakPoint;
|
||||
procedure ReleaseBreakPoint;
|
||||
protected
|
||||
procedure DoStateChange(const AOldState: TDBGState); override;
|
||||
public
|
||||
// constructor Create(ACollection: TCollection); override;
|
||||
// destructor Destroy; override;
|
||||
// procedure DoLogExpression(const AnExpression: String); override;
|
||||
procedure SetLocation(const ASource: String; const ALine: Integer); override;
|
||||
// procedure SetWatch(const AData: String; const AScope: TDBGWatchPointScope;
|
||||
// const AKind: TDBGWatchPointKind); override;
|
||||
end;
|
||||
|
||||
TLldbBreakPoints = class(TDBGBreakPoints)
|
||||
protected
|
||||
// function FindById(AnId: Integer): TGDBMIBreakPoint;
|
||||
end;
|
||||
|
||||
{ TLldbCallStack }
|
||||
|
||||
procedure TLldbCallStack.StackInstructionFinished(Sender: TObject);
|
||||
var
|
||||
Instr: TLldbInstructionStackTrace absolute Sender;
|
||||
i: Integer;
|
||||
e: TCallStackEntry;
|
||||
found, foundArg: TStringArray;
|
||||
Arguments: TStringList;
|
||||
It: TMapIterator;
|
||||
s: String;
|
||||
frame: LongInt;
|
||||
begin
|
||||
It := TMapIterator.Create(Instr.Callstack.RawEntries);
|
||||
|
||||
for i := 0 to Length(Instr.Res) - 1 do begin
|
||||
s := Instr.Res[i];
|
||||
if (Length(s) > 3) and (s[3] = '*') then s[3] := ' ';
|
||||
if StrMatches(s, [' frame #'{id}, ': '{addr}, ' '{exe}, '`'{func}, '',' at '{file}, ':'{line}, ''], found) then begin
|
||||
frame := StrToIntDef(found[0], -1);
|
||||
if It.Locate(frame) then begin
|
||||
Arguments := TStringList.Create;
|
||||
if StrMatches(found[3], ['', '(', '',')'], foundArg) then begin
|
||||
Arguments.CommaText := foundArg[1];
|
||||
found[3] := foundArg[0];
|
||||
end;
|
||||
|
||||
e := TCallStackEntry(It.DataPtr^);
|
||||
e.Init(StrToInt64Def(found[1],0), Arguments, found[3], found[4], '', StrToIntDef(found[5], -1));
|
||||
Arguments.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
It.Free;
|
||||
|
||||
|
||||
{
|
||||
<< << TCmdLineDebugger.ReadLn " * frame #0: 0x00429258 project1.exe`
|
||||
FORMCREATE(this=0x04a91060, SENDER=0x04a91060) at unit1.pas:39"
|
||||
<< << TCmdLineDebugger.ReadLn " frame #1: 0x0041ab6f project1.exe`DOCREATE(this=0x04a91060) at customform.inc:939"
|
||||
<< << TCmdLineDebugger.ReadLn " frame #2: 0x00418bd8 project1.exe`AFTERCONSTRUCTION(this=0x04a91060) at customform.inc:149"
|
||||
<< << TCmdLineDebugger.ReadLn " frame #3: 0x0042023a project1.exe`CREATE(this=0x000000c7, vmt=0x04a91060, THEOWNER=0x04a91060) at customform.inc:3184"
|
||||
<< << TCmdLineDebugger.ReadLn " frame #4: 0x0042746e project1.exe`CREATEFORM(this=0x000000c7, INSTANCECLASS=0x04a91060, REFERENCE=<unavailable>) at application.inc:2241"
|
||||
<< << TCmdLineDebugger.ReadLn " frame #5: 0x00402a42 project1.exe`main at project1.lpr:19"
|
||||
procedure Init(const AnAddress: TDbgPtr;
|
||||
const AnArguments: TStrings; const AFunctionName: String;
|
||||
const {%H-}FileName, {%H-}FullName: String;
|
||||
const ALine: Integer; AState: TDebuggerDataState = ddsValid); virtual;
|
||||
}
|
||||
|
||||
inherited RequestEntries(Instr.Callstack);
|
||||
end;
|
||||
|
||||
procedure TLldbCallStack.RequestAtLeastCount(ACallstack: TCallStackBase;
|
||||
ARequiredMinCount: Integer);
|
||||
begin
|
||||
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
|
||||
ACallstack.SetCurrentValidity(ddsInvalid);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
ACallstack.Count := ARequiredMinCount + 1;
|
||||
ACallstack.SetCountValidity(ddsValid);
|
||||
end;
|
||||
|
||||
procedure TLldbCallStack.UpdateCurrentIndex;
|
||||
var
|
||||
tid, idx: Integer;
|
||||
cs: TCallStackBase;
|
||||
begin
|
||||
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
|
||||
exit;
|
||||
end;
|
||||
|
||||
tid := 0; // Debugger.Threads.CurrentThreads.CurrentThreadId; // FCurrentThreadId ?
|
||||
cs := TCallStackBase(CurrentCallStackList.EntriesForThreads[tid]);
|
||||
idx := cs.NewCurrentIndex; // NEW-CURRENT
|
||||
|
||||
if TLldbDebugger(Debugger).FCurrentStackFrame = idx then Exit;
|
||||
|
||||
TLldbDebugger(Debugger).FCurrentStackFrame := idx;
|
||||
|
||||
if cs <> nil then begin
|
||||
cs.CurrentIndex := idx;
|
||||
cs.SetCurrentValidity(ddsValid);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TLldbCallStack.RequestCurrent(ACallstack: TCallStackBase);
|
||||
begin
|
||||
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
|
||||
ACallstack.SetCurrentValidity(ddsInvalid);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
ACallstack.CurrentIndex := 0; // will be used, if thread is changed
|
||||
ACallstack.SetCurrentValidity(ddsValid);
|
||||
end;
|
||||
|
||||
procedure TLldbCallStack.RequestEntries(ACallstack: TCallStackBase);
|
||||
var
|
||||
StartIdx, EndIdx: Integer;
|
||||
Instr: TLldbInstructionStackTrace;
|
||||
begin
|
||||
StartIdx := Max(ACallstack.LowestUnknown, 0);
|
||||
EndIdx := ACallstack.HighestUnknown;
|
||||
|
||||
Instr := TLldbInstructionStackTrace.Create(EndIdx, ACallstack);
|
||||
Instr.OnFinish := @StackInstructionFinished;
|
||||
TLldbDebugger(Debugger).FDebugInstructionQueue.QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
end;
|
||||
|
||||
{ TLldbWatches }
|
||||
|
||||
procedure TLldbWatches.InternalRequestData(AWatchValue: TWatchValue);
|
||||
var
|
||||
Cmd: TLldbDebuggerCommandEvaluate;
|
||||
begin
|
||||
Cmd := TLldbDebuggerCommandEvaluate.Create(TLldbDebugger(Debugger), AWatchValue);
|
||||
TLldbDebugger(Debugger).FCommandQueue.QueueCommand(Cmd);
|
||||
Cmd.ReleaseReference;
|
||||
end;
|
||||
|
||||
{ TLldbBreakPoint }
|
||||
|
||||
procedure TLldbBreakPoint.SetBreakPoint;
|
||||
var
|
||||
i: Integer;
|
||||
s: String;
|
||||
Instr: TLldbInstructionBreakSet;
|
||||
begin
|
||||
debugln(['TLldbBreakPoint.SetBreakPoint ']);
|
||||
i := LastPos(PathDelim, Source);
|
||||
if i > 0 then
|
||||
s := Copy(Source, i+1, Length(Source))
|
||||
else
|
||||
s := Source;
|
||||
Instr := TLldbInstructionBreakSet.Create(s, Line);
|
||||
Instr.OnFinish := @BreakInstructionFinished;
|
||||
// TLldbDebugger(Debugger).FCommandQueue.QueueCommand();
|
||||
TLldbDebugger(Debugger).FDebugInstructionQueue.QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
end;
|
||||
|
||||
procedure TLldbBreakPoint.BreakInstructionFinished(Sender: TObject);
|
||||
begin
|
||||
if TLldbInstructionBreakSet(Sender).IsSuccess then begin
|
||||
FBreakID := TLldbInstructionBreakSet(Sender).BreakId;
|
||||
SetValid(TLldbInstructionBreakSet(Sender).State);
|
||||
end
|
||||
else
|
||||
SetValid(vsInvalid);
|
||||
end;
|
||||
|
||||
procedure TLldbBreakPoint.ReleaseBreakPoint;
|
||||
var
|
||||
Instr: TLldbInstructionBreakDelete;
|
||||
begin
|
||||
SetHitCount(0);
|
||||
if FBreakID <= 0 then exit;
|
||||
|
||||
Instr := TLldbInstructionBreakDelete.Create(FBreakID);
|
||||
// Instr.OnFinish := @BreakInstructionFinished;
|
||||
TLldbDebugger(Debugger).FDebugInstructionQueue.QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
end;
|
||||
|
||||
procedure TLldbBreakPoint.DoStateChange(const AOldState: TDBGState);
|
||||
begin
|
||||
inherited DoStateChange(AOldState);
|
||||
case Debugger.State of
|
||||
dsRun: if AOldState = dsInit then begin
|
||||
// Disabled data breakpoints: wait until enabled
|
||||
// Disabled other breakpoints: Give to LLDB to see if they are valid
|
||||
if (Kind <> bpkData) or Enabled then
|
||||
SetBreakpoint;
|
||||
end;
|
||||
dsStop: begin
|
||||
if FBreakID > 0
|
||||
then ReleaseBreakpoint;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TLldbBreakPoint.SetLocation(const ASource: String;
|
||||
const ALine: Integer);
|
||||
begin
|
||||
inherited SetLocation(ASource, ALine);
|
||||
if Debugger.State in [dsPause, dsInternalPause, dsRun] then
|
||||
SetBreakPoint;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandQueue }
|
||||
|
||||
function TLldbDebuggerCommandQueue.Get(Index: Integer): TLldbDebuggerCommand;
|
||||
begin
|
||||
Result := TLldbDebuggerCommand(inherited Get(Index));
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandQueue.Put(Index: Integer;
|
||||
const AValue: TLldbDebuggerCommand);
|
||||
begin
|
||||
inherited Put(Index, AValue);
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandQueue.QueueCommand(AValue: TLldbDebuggerCommand);
|
||||
begin
|
||||
Insert(Count, AValue);
|
||||
Run;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandQueue.Run;
|
||||
begin
|
||||
if FRunningCommand <> nil then
|
||||
exit;
|
||||
if Count = 0 then
|
||||
exit;
|
||||
|
||||
FRunningCommand := Items[0];
|
||||
FRunningCommand.AddReference;
|
||||
Delete(0);
|
||||
DebugLnEnter(['>>> CommandQueue.Run ', FRunningCommand.ClassName, ', ', fDebugger.State]);
|
||||
FRunningCommand.Execute;
|
||||
// debugger and queue may get destroyed at the end of execute
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandQueue.CommandFinished(
|
||||
ACommand: TLldbDebuggerCommand);
|
||||
begin
|
||||
if FRunningCommand = ACommand then begin
|
||||
DebugLnExit(['<<< CommandQueue.Run ', FRunningCommand.ClassName, ', ', fDebugger.State]);
|
||||
ReleaseRefAndNil(FRunningCommand);
|
||||
end//;
|
||||
else DebugLn('TLldbDebuggerCommandQueue.CommandFinished >> unknown ???');
|
||||
if not(FDebugger.State in [dsError, dsDestroying, dsNone]) then
|
||||
Run;
|
||||
end;
|
||||
|
||||
constructor TLldbDebuggerCommandQueue.Create(ADebugger: TLldbDebugger);
|
||||
begin
|
||||
FDebugger := ADebugger;
|
||||
inherited Create;
|
||||
end;
|
||||
|
||||
destructor TLldbDebuggerCommandQueue.Destroy;
|
||||
begin
|
||||
while Count > 0 do
|
||||
Delete(0);
|
||||
if FRunningCommand <> nil then begin
|
||||
DebugLnExit(['<<< CommandQueue.Run (Destroy)', FRunningCommand.ClassName, ', ', fDebugger.State]);
|
||||
ReleaseRefAndNil(FRunningCommand);
|
||||
end;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommand }
|
||||
|
||||
function TLldbDebuggerCommand.GetDebuggerState: TDBGState;
|
||||
begin
|
||||
Result := Debugger.State;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommand.InstructionSucceeded(AnInstruction: TObject);
|
||||
begin
|
||||
Finished;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommand.InstructionFailed(AnInstruction: TObject);
|
||||
begin
|
||||
SetDebuggerState(dsError);
|
||||
Finished;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommand.Finished;
|
||||
begin
|
||||
InstructionQueue.CancelAllForCommand(Self); // in case there still are any
|
||||
CommandQueue.CommandFinished(Self);
|
||||
end;
|
||||
|
||||
function TLldbDebuggerCommand.GetCommandQueue: TLldbDebuggerCommandQueue;
|
||||
begin
|
||||
Result := Debugger.FCommandQueue;
|
||||
end;
|
||||
|
||||
function TLldbDebuggerCommand.GetInstructionQueue: TLldbInstructionQueue;
|
||||
begin
|
||||
Result := Debugger.FDebugInstructionQueue;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommand.QueueInstruction(AnInstruction: TLldbInstruction);
|
||||
begin
|
||||
AnInstruction.OwningCommand := Self;
|
||||
InstructionQueue.QueueInstruction(AnInstruction);
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommand.SetDebuggerState(const AValue: TDBGState);
|
||||
begin
|
||||
Debugger.SetState(AValue);
|
||||
end;
|
||||
|
||||
constructor TLldbDebuggerCommand.Create(AOwner: TLldbDebugger);
|
||||
begin
|
||||
FOwner := AOwner;
|
||||
inherited Create;
|
||||
AddReference;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommand.Execute;
|
||||
begin
|
||||
try
|
||||
Debugger.LockRelease;
|
||||
DoExecute;
|
||||
finally
|
||||
Debugger.UnlockRelease;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandInit }
|
||||
|
||||
procedure TLldbDebuggerCommandInit.DoExecute;
|
||||
var
|
||||
Instr: TLldbInstructionSettingSet;
|
||||
begin
|
||||
Instr := TLldbInstructionSettingSet.Create('stop-line-count-after', '0');
|
||||
QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
|
||||
Instr := TLldbInstructionSettingSet.Create('stop-line-count-before', '0');
|
||||
Instr.OnFinish := @InstructionSucceeded;
|
||||
QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandRun }
|
||||
|
||||
procedure TLldbDebuggerCommandRun.TargetCreated(Sender: TObject);
|
||||
begin
|
||||
SetDebuggerState(dsRun);
|
||||
// the state change allows breakpoints to be set, before the run command is issued.
|
||||
|
||||
FRunInstr := TLldbInstructionProcessLaunch.Create();
|
||||
FRunInstr.OnSuccess := @InstructionSucceeded;
|
||||
FRunInstr.OnFailure := @InstructionFailed;
|
||||
QueueInstruction(FRunInstr);
|
||||
FRunInstr.ReleaseReference;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandRun.DoExecute;
|
||||
var
|
||||
Instr: TLldbInstruction;
|
||||
begin
|
||||
Instr := TLldbInstructionTargetCreate.Create(Debugger.FileName);
|
||||
Instr.OnSuccess := @TargetCreated;
|
||||
Instr.OnFailure := @InstructionFailed;
|
||||
QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandStop }
|
||||
|
||||
procedure TLldbDebuggerCommandStop.StopInstructionSucceeded(Sender: TObject);
|
||||
begin
|
||||
if DebuggerState <> dsIdle then
|
||||
SetDebuggerState(dsStop);
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandStop.DoExecute;
|
||||
var
|
||||
Instr: TLldbInstruction;
|
||||
begin
|
||||
Instr := TLldbInstructionProcessKill.Create();
|
||||
Instr.OnSuccess := @StopInstructionSucceeded;
|
||||
Instr.OnFailure := @InstructionFailed;
|
||||
QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
|
||||
Instr := TLldbInstructionTargetDelete.Create();
|
||||
Instr.OnFailure := @InstructionFailed;
|
||||
QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
|
||||
Instr := TLldbInstructionTargetDelete.Create();
|
||||
Instr.OnSuccess := @InstructionSucceeded;
|
||||
Instr.OnFailure := @InstructionFailed;
|
||||
QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
end;
|
||||
|
||||
{ TLldbDebuggerCommandEvaluate }
|
||||
|
||||
procedure TLldbDebuggerCommandEvaluate.EvalInstructionSucceeded(Sender: TObject
|
||||
);
|
||||
begin
|
||||
if FWatchValue <> nil then begin
|
||||
FWatchValue.Value := FInstr.Res;
|
||||
//FWatchValue.TypeInfo := TypeInfo;
|
||||
FWatchValue.Validity := ddsValid;
|
||||
end
|
||||
else
|
||||
if FCallback <> nil then
|
||||
FCallback(Debugger, True, FInstr.Res, nil);
|
||||
|
||||
FInstr.ReleaseReference;
|
||||
Finished;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandEvaluate.EvalInstructionFailed(Sender: TObject);
|
||||
begin
|
||||
if FWatchValue <> nil then
|
||||
FWatchValue.Validity := ddsError
|
||||
else
|
||||
if FCallback <> nil then
|
||||
FCallback(Debugger, False, '', nil);
|
||||
FInstr.ReleaseReference;
|
||||
Finished;
|
||||
end;
|
||||
|
||||
procedure TLldbDebuggerCommandEvaluate.DoExecute;
|
||||
begin
|
||||
if FWatchValue <> nil then
|
||||
FInstr := TLldbInstructionExpression.Create(FWatchValue.Expression, Debugger.FCurrentThreadId, Debugger.FCurrentStackFrame)
|
||||
else
|
||||
FInstr := TLldbInstructionExpression.Create(FExpr, Debugger.FCurrentThreadId, Debugger.FCurrentStackFrame);
|
||||
FInstr.OnSuccess := @EvalInstructionSucceeded;
|
||||
FInstr.OnFailure := @EvalInstructionFailed;
|
||||
QueueInstruction(FInstr);
|
||||
end;
|
||||
|
||||
constructor TLldbDebuggerCommandEvaluate.Create(AOwner: TLldbDebugger;
|
||||
AWatchValue: TWatchValue);
|
||||
begin
|
||||
FWatchValue := AWatchValue;
|
||||
inherited Create(AOwner);
|
||||
end;
|
||||
|
||||
constructor TLldbDebuggerCommandEvaluate.Create(AOwner: TLldbDebugger;
|
||||
AnExpr: String; AFlags: TDBGEvaluateFlags;
|
||||
ACallback: TDBGEvaluateResultCallback);
|
||||
begin
|
||||
FExpr := AnExpr;
|
||||
FFlags := AFlags;
|
||||
FCallback := ACallback;
|
||||
inherited Create(AOwner);
|
||||
end;
|
||||
|
||||
{ TLldbDebugger }
|
||||
|
||||
function TLldbDebugger.LldbRun: Boolean;
|
||||
var
|
||||
Cmd: TLldbDebuggerCommandRun;
|
||||
begin
|
||||
DebugLn('*** Run');
|
||||
Result := True;
|
||||
|
||||
if State in [dsPause, dsInternalPause] then begin
|
||||
LldbStep(saContinue);
|
||||
exit;
|
||||
end;
|
||||
|
||||
if State in [dsNone, dsIdle, dsStop] then
|
||||
SetState(dsInit);
|
||||
|
||||
Cmd := TLldbDebuggerCommandRun.Create(Self);
|
||||
FCommandQueue.QueueCommand(Cmd);
|
||||
Cmd.ReleaseReference;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.DoAfterLineReceived(var ALine: String);
|
||||
var
|
||||
Instr: TLldbInstructionTargetDelete;
|
||||
found: TStringArray;
|
||||
begin
|
||||
if ALine = '' then
|
||||
exit;
|
||||
|
||||
// Process 8888 exited with status = 0 (0x00000000)
|
||||
if (LeftStr(ALine, 8) = 'Process ') and (pos('exited with status = ', ALine) > 0) then begin
|
||||
// todo: target delete
|
||||
if State <> dsIdle then
|
||||
SetState(dsStop);
|
||||
ALine := '';
|
||||
|
||||
Instr := TLldbInstructionTargetDelete.Create();
|
||||
FDebugInstructionQueue.QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
end;
|
||||
|
||||
if StrMatches(ALine, [' frame #0: ' {addr}, ' ' {}, '`' {fname}, '(', '',' at ', ':', ''], found) then begin
|
||||
FCurrentLocation.Address := StrToInt64Def(found[0], 0);
|
||||
FCurrentLocation.FuncName := found[2];
|
||||
FCurrentLocation.SrcFile := found[4];
|
||||
FCurrentLocation.SrcLine := StrToIntDef(found[5], -1);
|
||||
DoCurrent(FCurrentLocation);
|
||||
ALine := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.DoBeforeLineReceived(var ALine: String);
|
||||
var
|
||||
found: TStringArray;
|
||||
begin
|
||||
if StrMatches(ALine, ['Process ', ' stopped']) then begin
|
||||
ALine := '';
|
||||
end;
|
||||
|
||||
if StrMatches(ALine, ['* thread #', ', stop reason = ', ''], found) then begin
|
||||
FCurrentThreadId := StrToIntDef(found[0], 0);
|
||||
FCurrentStackFrame := 0;
|
||||
FDebugInstructionQueue.SetKnownThreadAndFrame(FCurrentThreadId, 0);
|
||||
SetState(dsPause);
|
||||
ALine := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.DoBeginReceivingLines(Sender: TObject);
|
||||
begin
|
||||
LockRelease;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.DoCmdLineDebuggerTerminated(Sender: TObject);
|
||||
begin
|
||||
SetState(dsError);
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.DoEndReceivingLines(Sender: TObject);
|
||||
begin
|
||||
UnlockRelease;
|
||||
end;
|
||||
|
||||
function TLldbDebugger.LldbStep(AStepAction: TLldbInstructionProcessStepAction
|
||||
): Boolean;
|
||||
var
|
||||
Instr: TLldbInstructionProcessStep;
|
||||
begin
|
||||
// TODO
|
||||
Result := True;
|
||||
Instr := TLldbInstructionProcessStep.Create(AStepAction);
|
||||
FDebugInstructionQueue.QueueInstruction(Instr);
|
||||
Instr.ReleaseReference;
|
||||
SetState(dsRun);
|
||||
end;
|
||||
|
||||
function TLldbDebugger.LldbStop: Boolean;
|
||||
var
|
||||
Cmd: TLldbDebuggerCommandStop;
|
||||
begin
|
||||
DebugLn('*** Stop');
|
||||
Result := True;
|
||||
|
||||
Cmd := TLldbDebuggerCommandStop.Create(Self);
|
||||
FCommandQueue.QueueCommand(Cmd);
|
||||
Cmd.ReleaseReference;
|
||||
end;
|
||||
|
||||
function TLldbDebugger.LldbEvaluate(const AExpression: String;
|
||||
EvalFlags: TDBGEvaluateFlags; ACallback: TDBGEvaluateResultCallback): Boolean;
|
||||
var
|
||||
Cmd: TLldbDebuggerCommandEvaluate;
|
||||
begin
|
||||
Cmd := TLldbDebuggerCommandEvaluate.Create(Self, AExpression, EvalFlags, ACallback);
|
||||
FCommandQueue.QueueCommand(Cmd);
|
||||
Cmd.ReleaseReference;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.LockRelease;
|
||||
begin
|
||||
inherited LockRelease;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.UnlockRelease;
|
||||
begin
|
||||
inherited UnlockRelease;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.SetState(const AValue: TDBGState);
|
||||
begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TLldbDebugger.CreateBreakPoints: TDBGBreakPoints;
|
||||
begin
|
||||
Result := TLldbBreakPoints.Create(Self, TLldbBreakPoint);
|
||||
end;
|
||||
|
||||
function TLldbDebugger.CreateCallStack: TCallStackSupplier;
|
||||
begin
|
||||
Result := TLldbCallStack.Create(Self);
|
||||
end;
|
||||
|
||||
function TLldbDebugger.CreateWatches: TWatchesSupplier;
|
||||
begin
|
||||
Result := TLldbWatches.Create(Self);
|
||||
end;
|
||||
|
||||
function TLldbDebugger.GetSupportedCommands: TDBGCommands;
|
||||
begin
|
||||
Result := [dcRun, dcStop, dcStepOver, dcStepInto, dcStepOut, dcEvaluate];
|
||||
// Result := [dcPause, dcStepOverInstr, dcStepIntoInstr, dcRunTo, dcAttach, dcDetach, dcJumpto,
|
||||
// dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment,
|
||||
// dcSetStackFrame, dcDisassemble
|
||||
// ];
|
||||
end;
|
||||
|
||||
function TLldbDebugger.RequestCommand(const ACommand: TDBGCommand;
|
||||
const AParams: array of const; const ACallback: TMethod): Boolean;
|
||||
var
|
||||
EvalFlags: TDBGEvaluateFlags;
|
||||
begin
|
||||
LockRelease;
|
||||
try
|
||||
case ACommand of
|
||||
dcRun: Result := LldbRun;
|
||||
//dcPause: Result := ;
|
||||
dcStop: Result := LldbStop;
|
||||
dcStepOver: Result := LldbStep(saOver);
|
||||
dcStepInto: Result := LldbStep(saInto);
|
||||
dcStepOut: Result := LldbStep(saOut);
|
||||
dcEvaluate: begin
|
||||
EvalFlags := [];
|
||||
if high(AParams) >= 1 then
|
||||
EvalFlags := TDBGEvaluateFlags(AParams[1].VInteger);
|
||||
Result := LldbEvaluate(String(AParams[0].VAnsiString),
|
||||
EvalFlags, TDBGEvaluateResultCallback(ACallback));
|
||||
end;
|
||||
// dcRunTo: Result := GDBRunTo(String(AParams[0].VAnsiString), AParams[1].VInteger);
|
||||
// dcJumpto: Result := GDBJumpTo(String(AParams[0].VAnsiString), AParams[1].VInteger);
|
||||
// dcAttach: Result := GDBAttach(String(AParams[0].VAnsiString));
|
||||
// dcDetach: Result := GDBDetach;
|
||||
// dcModify: Result := GDBModify(String(AParams[0].VAnsiString), String(AParams[1].VAnsiString));
|
||||
// dcEnvironment: Result := GDBEnvironment(String(AParams[0].VAnsiString), AParams[1].VBoolean);
|
||||
// dcDisassemble: Result := GDBDisassemble(AParams[0].VQWord^, AParams[1].VBoolean, TDbgPtr(AParams[2].VPointer^),
|
||||
// String(AParams[3].VPointer^), String(AParams[4].VPointer^),
|
||||
// String(AParams[5].VPointer^), Integer(AParams[6].VPointer^))
|
||||
// {%H-};
|
||||
// dcStepOverInstr: Result := GDBStepOverInstr;
|
||||
// dcStepIntoInstr: Result := GDBStepIntoInstr;
|
||||
end;
|
||||
finally
|
||||
UnlockRelease;
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TLldbDebugger.Caption: String;
|
||||
begin
|
||||
Result := 'LLDB Debugger (Alpha)';
|
||||
end;
|
||||
|
||||
constructor TLldbDebugger.Create(const AExternalDebugger: String);
|
||||
begin
|
||||
inherited Create(AExternalDebugger);
|
||||
FDebugProcess := TDebugProcess.Create(AExternalDebugger);
|
||||
|
||||
FDebugInstructionQueue := TLldbInstructionQueue.Create(FDebugProcess);
|
||||
FDebugInstructionQueue.OnBeginLinesReceived := @DoBeginReceivingLines;
|
||||
FDebugInstructionQueue.OnEndLinesReceived := @DoEndReceivingLines;
|
||||
FDebugInstructionQueue.OnBeforeHandleLineReceived := @DoBeforeLineReceived;
|
||||
FDebugInstructionQueue.OnAfterHandleLineReceived := @DoAfterLineReceived;
|
||||
FDebugInstructionQueue.OnDebuggerTerminated := @DoCmdLineDebuggerTerminated;
|
||||
|
||||
FCommandQueue := TLldbDebuggerCommandQueue.Create(Self);
|
||||
end;
|
||||
|
||||
destructor TLldbDebugger.Destroy;
|
||||
begin
|
||||
debugln(['!!!!!!!!!!!!!!! TLldbDebugger.Destroy ']);
|
||||
FDebugInstructionQueue.LockQueueRun;
|
||||
inherited Destroy;
|
||||
FCommandQueue.Destroy;
|
||||
FDebugInstructionQueue.Destroy;
|
||||
FDebugProcess.Destroy;
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.Init;
|
||||
var
|
||||
Cmd: TLldbDebuggerCommandInit;
|
||||
begin
|
||||
DebugLnEnter('*** Init');
|
||||
FDebugProcess.CreateDebugProcess('', Environment);
|
||||
inherited Init;
|
||||
|
||||
Cmd := TLldbDebuggerCommandInit.Create(Self);
|
||||
FCommandQueue.QueueCommand(Cmd);
|
||||
Cmd.ReleaseReference;
|
||||
DebugLnExit('*** Init');
|
||||
end;
|
||||
|
||||
procedure TLldbDebugger.Done;
|
||||
begin
|
||||
DebugLnEnter('!!! TLldbDebugger.Done;');
|
||||
// TODO: cancel all commands
|
||||
FDebugInstructionQueue.OnDebuggerTerminated := nil;
|
||||
FDebugProcess.StopDebugProcess;
|
||||
inherited Done;
|
||||
DebugLnExit('!!! TLldbDebugger.Done;');
|
||||
end;
|
||||
|
||||
function TLldbDebugger.GetLocation: TDBGLocationRec;
|
||||
begin
|
||||
Result := FCurrentLocation;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterDebugger(TLldbDebugger);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
99
components/lazdebuggers/lazdebuggerlldb/lldbhelper.pas
Normal file
99
components/lazdebuggers/lazdebuggerlldb/lldbhelper.pas
Normal file
@ -0,0 +1,99 @@
|
||||
unit LldbHelper;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, strutils;
|
||||
|
||||
function LastPos(ASearch, AString: string): Integer;
|
||||
|
||||
function StrStartsWith(AString, AStart: string): Boolean;
|
||||
function StrContains(AString, AFind: string): Boolean;
|
||||
function StrMatches(AString: string; AFind: array of string): Boolean;
|
||||
function StrMatches(AString: string; AFind: array of string; out AGapsContent: TStringArray): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
function LastPos(ASearch, AString: string): Integer;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
i := pos(ASearch, AString);
|
||||
Result := i;
|
||||
while i > 0 do begin
|
||||
Result := i;
|
||||
i := PosEx(ASearch, AString, i + 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
function StrStartsWith(AString, AStart: string): Boolean;
|
||||
begin
|
||||
Result := LeftStr(AString, Length(AStart)) = AStart;
|
||||
end;
|
||||
|
||||
function StrContains(AString, AFind: string): Boolean;
|
||||
begin
|
||||
Result := pos(AFind, AString) > 0;
|
||||
end;
|
||||
|
||||
function StrMatches(AString: string; AFind: array of string): Boolean;
|
||||
var
|
||||
Dummy: TStringArray;
|
||||
begin
|
||||
Result := StrMatches(AString, AFind, Dummy);
|
||||
end;
|
||||
|
||||
function StrMatches(AString: string; AFind: array of string; out
|
||||
AGapsContent: TStringArray): Boolean;
|
||||
var
|
||||
FindIdx, FindLen, j, j2, ResIdx: Integer;
|
||||
OpenEnd: Boolean;
|
||||
begin
|
||||
FindLen := Length(AFind);
|
||||
if FindLen = 0 then begin
|
||||
Result := False;
|
||||
AGapsContent := nil;
|
||||
exit;
|
||||
end;
|
||||
|
||||
SetLength(AGapsContent, FindLen - 1);
|
||||
Result := StrStartsWith(AString, AFind[0]);
|
||||
if not Result then
|
||||
exit;
|
||||
Delete(AString, 1, Length(AFind[0]));
|
||||
|
||||
OpenEnd := AFind[FindLen - 1] = '';
|
||||
if OpenEnd then
|
||||
dec(FindLen);
|
||||
|
||||
FindIdx := 1;
|
||||
ResIdx := 0;
|
||||
while (FindIdx < FindLen) do begin
|
||||
if AFind[FindIdx] = '' then begin
|
||||
// empty string, match as far ahead as possible
|
||||
inc(FindIdx);
|
||||
j := LastPos(AFind[FindIdx], AString) - 1;
|
||||
end
|
||||
else
|
||||
j := pos(AFind[FindIdx], AString) - 1;
|
||||
Result := j >= 0;
|
||||
if not Result then
|
||||
exit;
|
||||
AGapsContent[ResIdx] := copy(AString, 1, j);
|
||||
Delete(AString, 1, j + Length(AFind[FindIdx]));
|
||||
inc(FindIdx);
|
||||
inc(ResIdx);
|
||||
end;
|
||||
if OpenEnd then begin
|
||||
AGapsContent[ResIdx] := AString;
|
||||
inc(ResIdx);
|
||||
end
|
||||
else
|
||||
Result := AString = '';
|
||||
SetLength(AGapsContent, ResIdx);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
555
components/lazdebuggers/lazdebuggerlldb/lldbinstructions.pas
Normal file
555
components/lazdebuggers/lazdebuggerlldb/lldbinstructions.pas
Normal file
@ -0,0 +1,555 @@
|
||||
unit LldbInstructions;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, math, LazLoggerBase, DbgIntfDebuggerBase, DebugInstructions,
|
||||
LldbHelper;
|
||||
|
||||
type
|
||||
|
||||
(*
|
||||
* Instructions
|
||||
*)
|
||||
|
||||
TLldbInstruction = class;
|
||||
|
||||
{ TLldbInstructionQueue }
|
||||
|
||||
TLldbInstructionQueue = class(TDBGInstructionQueue)
|
||||
private
|
||||
protected
|
||||
procedure DoBeforeHandleLineReceived(var ALine: String); override;
|
||||
|
||||
function GetSelectFrameInstruction(AFrame: Integer): TDBGInstruction; override;
|
||||
//function GetSelectThreadInstruction(AThreadId: Integer): TDBGInstruction; override;
|
||||
public
|
||||
procedure CancelAllForCommand(ACommand: TObject); // Does NOT include the current or running instruction
|
||||
end;
|
||||
|
||||
{ TLldbInstruction }
|
||||
|
||||
TLldbInstruction = class(TDBGInstruction)
|
||||
private
|
||||
FOwningCommand: TObject;
|
||||
function GetQueue: TLldbInstructionQueue;
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
function CheckForIgnoredError(const AData: String): Boolean;
|
||||
procedure SetContentReceieved; reintroduce;
|
||||
|
||||
property Queue: TLldbInstructionQueue read GetQueue;
|
||||
property NextInstruction;
|
||||
public
|
||||
property OwningCommand: TObject read FOwningCommand write FOwningCommand;
|
||||
end;
|
||||
|
||||
{ TLldbInstructionSettingSet }
|
||||
|
||||
TLldbInstructionSettingSet = class(TLldbInstruction)
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(AName, AValue: String; AGlobal: Boolean = False);
|
||||
end;
|
||||
|
||||
{ TLldbInstructionTargetCreate }
|
||||
|
||||
TLldbInstructionTargetCreate = class(TLldbInstruction)
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(AFile: String);
|
||||
end;
|
||||
|
||||
{ TLldbInstructionTargetDelete }
|
||||
|
||||
TLldbInstructionTargetDelete = class(TLldbInstruction)
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create;
|
||||
end;
|
||||
|
||||
{ TLldbInstructionProcessLaunch }
|
||||
|
||||
TLldbInstructionProcessLaunch = class(TLldbInstruction)
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create();
|
||||
end;
|
||||
|
||||
{ TLldbInstructionProcessStep }
|
||||
|
||||
TLldbInstructionProcessStepAction = (saContinue, saOver, saInto, saOut);
|
||||
|
||||
TLldbInstructionProcessStep = class(TLldbInstruction)
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(AStepAction: TLldbInstructionProcessStepAction);
|
||||
end;
|
||||
|
||||
{ TLldbInstructionProcessKill }
|
||||
|
||||
TLldbInstructionProcessKill = class(TLldbInstruction)
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create();
|
||||
end;
|
||||
|
||||
{ TLldbInstructionBreakSet }
|
||||
|
||||
TLldbInstructionBreakSet = class(TLldbInstruction)
|
||||
private
|
||||
FBreakId: Integer;
|
||||
FState: TValidState;
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(AFileName: String; ALine: Integer);
|
||||
property BreakId: Integer read FBreakId;
|
||||
property State: TValidState read FState;
|
||||
end;
|
||||
|
||||
{ TLldbInstructionBreakDelete }
|
||||
|
||||
TLldbInstructionBreakDelete = class(TLldbInstruction)
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(AnId: Integer);
|
||||
end;
|
||||
|
||||
{ TLldbInstructionFrameSelect }
|
||||
|
||||
TLldbInstructionFrameSelect = class(TLldbInstruction)
|
||||
private
|
||||
FIndex: Integer;
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(AnIndex: Integer);
|
||||
end;
|
||||
|
||||
{ TLldbInstructionExpression }
|
||||
|
||||
TLldbInstructionExpression = class(TLldbInstruction)
|
||||
private
|
||||
FRes: String;
|
||||
FCurly: Integer;
|
||||
protected
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(AnExpression: String; AThread, AFrame: Integer);
|
||||
property Res: String read FRes;
|
||||
end;
|
||||
|
||||
{ TLldbInstructionStackTrace }
|
||||
|
||||
TLldbInstructionStackTrace = class(TLldbInstruction)
|
||||
private
|
||||
FCallstack: TCallStackBase;
|
||||
FRes: TStringArray;
|
||||
FReading: Boolean;
|
||||
protected
|
||||
procedure SendCommandDataToDbg(); override;
|
||||
function ProcessInputFromDbg(const AData: String): Boolean; override;
|
||||
public
|
||||
constructor Create(FrameCount: Integer; ACallstack: TCallStackBase);
|
||||
property Res: TStringArray read FRes;
|
||||
property Callstack: TCallStackBase read FCallstack;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TLldbInstructionQueue }
|
||||
|
||||
procedure TLldbInstructionQueue.DoBeforeHandleLineReceived(var ALine: String);
|
||||
begin
|
||||
while LeftStr(ALine, 7) = '(lldb) ' do begin
|
||||
Delete(ALine, 1, 7);
|
||||
end;
|
||||
|
||||
inherited DoBeforeHandleLineReceived(ALine);
|
||||
|
||||
// TODO: detect the echo, and flag if data is for RunningInstruction;
|
||||
|
||||
// if LeftStr(ALine, 7) = 'error: ' then begin
|
||||
// // TODO: late error for previous instruction
|
||||
// ALine := '';
|
||||
// end;
|
||||
//
|
||||
// ALine := '';
|
||||
end;
|
||||
|
||||
function TLldbInstructionQueue.GetSelectFrameInstruction(AFrame: Integer
|
||||
): TDBGInstruction;
|
||||
begin
|
||||
Result := TLldbInstructionFrameSelect.Create(AFrame);
|
||||
end;
|
||||
|
||||
procedure TLldbInstructionQueue.CancelAllForCommand(ACommand: TObject);
|
||||
var
|
||||
Instr, NextInstr: TLldbInstruction;
|
||||
begin
|
||||
NextInstr := TLldbInstruction(FirstInstruction);
|
||||
while NextInstr <> nil do begin
|
||||
Instr := NextInstr;
|
||||
NextInstr := TLldbInstruction(Instr.NextInstruction);
|
||||
if Instr.OwningCommand = ACommand then begin
|
||||
Instr.Cancel;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TLldbInstruction }
|
||||
|
||||
function TLldbInstruction.GetQueue: TLldbInstructionQueue;
|
||||
begin
|
||||
Result := TLldbInstructionQueue(inherited Queue);
|
||||
end;
|
||||
|
||||
function TLldbInstruction.ProcessInputFromDbg(const AData: String): Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if LeftStr(AData, 7) = 'error: ' then begin
|
||||
Result := True;
|
||||
if CheckForIgnoredError(AData) then
|
||||
exit;
|
||||
|
||||
HandleError(ifeContentError);
|
||||
exit;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TLldbInstruction.CheckForIgnoredError(const AData: String): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if StrStartsWith(AData, 'error: ') then begin // ignore dwarf warnings
|
||||
if StrMatches(AData, ['error', 'unhandled type tag', 'DW_TAG_', '']) then // ignore dwarf warnings
|
||||
exit;
|
||||
if StrStartsWith(AData, 'error: need to add support for DW_TAG_') then // ignore dwarf warnings
|
||||
exit;
|
||||
end;
|
||||
Result := False;
|
||||
end;
|
||||
|
||||
procedure TLldbInstruction.SetContentReceieved;
|
||||
begin
|
||||
inherited;
|
||||
MarkAsSuccess;
|
||||
end;
|
||||
|
||||
{ TLldbInstructionSettingSet }
|
||||
|
||||
function TLldbInstructionSettingSet.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := inherited ProcessInputFromDbg(AData);
|
||||
|
||||
if not Result then // if Result=true then self is destroyed;
|
||||
MarkAsSuccess;
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionSettingSet.Create(AName, AValue: String;
|
||||
AGlobal: Boolean);
|
||||
begin
|
||||
if AGlobal then
|
||||
inherited Create(Format('settings set -g -- %s %s', [AName, AValue]))
|
||||
else
|
||||
inherited Create(Format('settings set -- %s %s', [AName, AValue]));
|
||||
end;
|
||||
|
||||
{ TLldbInstructionTargetCreate }
|
||||
|
||||
function TLldbInstructionTargetCreate.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if LeftStr(AData, 25) = 'Current executable set to' then begin
|
||||
SetContentReceieved;
|
||||
end
|
||||
else
|
||||
Result := inherited;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionTargetCreate.Create(AFile: String);
|
||||
begin
|
||||
if pos(' ', AFile) > 0 then
|
||||
AFile := ''''+AFile+'''';
|
||||
inherited Create('target create '+AFile);
|
||||
end;
|
||||
|
||||
{ TLldbInstructionTargetDelete }
|
||||
|
||||
function TLldbInstructionTargetDelete.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if (LeftStr(AData, 27) = 'error: no targets to delete') or
|
||||
(LeftStr(AData, 17) = '1 targets deleted')
|
||||
then begin
|
||||
SetContentReceieved;
|
||||
end
|
||||
else
|
||||
Result := inherited;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionTargetDelete.Create;
|
||||
begin
|
||||
inherited Create('target delete 0');
|
||||
end;
|
||||
|
||||
{ TLldbInstructionProcessLaunch }
|
||||
|
||||
function TLldbInstructionProcessLaunch.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if (LeftStr(AData, 8) = 'Process ') and (pos(' launched:', AData) > 8) then begin
|
||||
SetContentReceieved;
|
||||
end
|
||||
else
|
||||
Result := inherited;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionProcessLaunch.Create();
|
||||
begin
|
||||
inherited Create('process launch -n');
|
||||
end;
|
||||
|
||||
{ TLldbInstructionProcessStep }
|
||||
|
||||
function TLldbInstructionProcessStep.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := inherited ProcessInputFromDbg(AData);
|
||||
SetContentReceieved;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionProcessStep.Create(
|
||||
AStepAction: TLldbInstructionProcessStepAction);
|
||||
begin
|
||||
case AStepAction of
|
||||
saContinue: inherited Create('thread continue');
|
||||
saOver: inherited Create('thread step-over');
|
||||
saInto: inherited Create('thread step-in');
|
||||
saOut: inherited Create('thread step-out');
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TLldbInstructionProcessKill }
|
||||
|
||||
function TLldbInstructionProcessKill.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if (LeftStr(AData, 8) = 'Process ') and (pos(' exited with status = ', AData) > 7) then begin
|
||||
SetContentReceieved;
|
||||
end
|
||||
else
|
||||
Result := inherited;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionProcessKill.Create();
|
||||
begin
|
||||
inherited Create('process kill');
|
||||
end;
|
||||
|
||||
{ TLldbInstructionBreakSet }
|
||||
|
||||
function TLldbInstructionBreakSet.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
var
|
||||
i: Integer;
|
||||
found, found2: TStringArray;
|
||||
begin
|
||||
Result := True;
|
||||
if StrMatches(AData, ['Breakpoint ',': ', ''], found) then begin
|
||||
i := StrToIntDef(found[0], -1);
|
||||
if i = -1 then begin
|
||||
MarkAsFailed;
|
||||
exit;
|
||||
end;
|
||||
FBreakId:= i;
|
||||
|
||||
if StrContains(found[1], 'pending') then
|
||||
FState := vsPending
|
||||
else
|
||||
if StrMatches(found[1], ['', ' locations'], found2) then begin
|
||||
if StrToIntDef(found2[0], 0) > 0 then
|
||||
FState := vsValid;
|
||||
end
|
||||
else
|
||||
if StrStartsWith(found[1], 'where = ') then
|
||||
FState := vsValid;
|
||||
|
||||
MarkAsSuccess;
|
||||
end
|
||||
//Breakpoint 41: where = lazarus.exe`CREATE + 2029 at synedit.pp:2123, address = 0x00764d2d
|
||||
//Breakpoint 38: no locations (pending).
|
||||
//Breakpoint 34: 3 locations.
|
||||
else
|
||||
Result := inherited;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionBreakSet.Create(AFileName: String; ALine: Integer);
|
||||
begin
|
||||
FState := vsInvalid;
|
||||
if pos(' ', AFileName) > 0 then
|
||||
AFileName := ''''+AFileName+'''';
|
||||
inherited Create(Format('breakpoint set --file %s --line %d', [AFileName, ALine]));
|
||||
end;
|
||||
|
||||
{ TLldbInstructionBreakDelete }
|
||||
|
||||
function TLldbInstructionBreakDelete.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := inherited ProcessInputFromDbg(AData);
|
||||
|
||||
if not Result then // if Result=true then self is destroyed;
|
||||
MarkAsSuccess;
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionBreakDelete.Create(AnId: Integer);
|
||||
begin
|
||||
inherited Create(Format('breakpoint delete %d', [AnId]));
|
||||
end;
|
||||
|
||||
{ TLldbInstructionFrameSelect }
|
||||
|
||||
function TLldbInstructionFrameSelect.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
begin
|
||||
Result := inherited ProcessInputFromDbg(AData);
|
||||
|
||||
if not Result then begin // if Result=true then self is destroyed;
|
||||
Queue.SetKnownThreadAndFrame(Queue.CurrentThreadId, FIndex);
|
||||
MarkAsSuccess;
|
||||
end;
|
||||
Result := true;
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionFrameSelect.Create(AnIndex: Integer);
|
||||
begin
|
||||
FIndex := AnIndex;
|
||||
inherited Create(Format('frame select %d', [AnIndex]));
|
||||
end;
|
||||
|
||||
{ TLldbInstructionExpression }
|
||||
|
||||
function TLldbInstructionExpression.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
function ParseStruct(ALine: string): Boolean;
|
||||
var
|
||||
i: Integer;
|
||||
begin
|
||||
i := 1;
|
||||
while i <= Length(ALine) do begin
|
||||
case ALine[i] of
|
||||
'"': break; // string always goes to end of line
|
||||
'{': inc(FCurly);
|
||||
'}': dec(FCurly);
|
||||
end;
|
||||
inc(i);
|
||||
if FCurly<0 then debugln(['ParseStruct curly too low ', FCurly]);
|
||||
end;
|
||||
Result := FCurly = 0;
|
||||
end;
|
||||
var
|
||||
found: TStringArray;
|
||||
begin
|
||||
Result := True;
|
||||
|
||||
if CheckForIgnoredError(AData) then
|
||||
exit;
|
||||
|
||||
if FRes <> '' then begin
|
||||
FRes := FRes + AData;
|
||||
if ParseStruct(AData) then
|
||||
SetContentReceieved;
|
||||
exit;
|
||||
end;
|
||||
|
||||
if StrMatches(AData, ['(', ')', ' = ', ''], found) then begin
|
||||
FRes := AData;
|
||||
FCurly := 0;
|
||||
if ParseStruct(found[2]) then
|
||||
SetContentReceieved;
|
||||
exit;
|
||||
end;
|
||||
// error: use of undeclared identifier 'i'
|
||||
// (int) $0 = 133
|
||||
// (LONGINT) I = 99
|
||||
// (ANSISTRING) $1 = 0x005aac80
|
||||
Result := inherited ProcessInputFromDbg(AData);
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionExpression.Create(AnExpression: String; AThread,
|
||||
AFrame: Integer);
|
||||
begin
|
||||
// inherited Create(Format('expression -R -- %s', [UpperCase(AnExpression)]));
|
||||
inherited Create(Format('expression -T -- %s', [UpperCase(AnExpression)]), AThread, AFrame);
|
||||
end;
|
||||
|
||||
{ TLldbInstructionStackTrace }
|
||||
|
||||
procedure TLldbInstructionStackTrace.SendCommandDataToDbg();
|
||||
begin
|
||||
inherited SendCommandDataToDbg();
|
||||
Queue.SendDataToDBG(Self, 'p 112233'); // end marker // do not sent before new prompt
|
||||
end;
|
||||
|
||||
function TLldbInstructionStackTrace.ProcessInputFromDbg(const AData: String
|
||||
): Boolean;
|
||||
var
|
||||
l: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
if StrStartsWith(AData, Command) then begin
|
||||
FReading := True;
|
||||
end;
|
||||
|
||||
if not FReading then
|
||||
exit;
|
||||
|
||||
Result := True;
|
||||
if CheckForIgnoredError(AData) then
|
||||
exit;
|
||||
|
||||
if StrStartsWith(AData, '* thread ') then
|
||||
exit;
|
||||
|
||||
|
||||
if StrStartsWith(AData, ' * frame ') or StrStartsWith(AData, ' frame ') then begin
|
||||
l := Length(FRes);
|
||||
SetLength(FRes, l+1);
|
||||
FRes[l] := AData;
|
||||
exit;
|
||||
end;
|
||||
|
||||
if StrMatches(AData, ['(', ')', ' = ', '112233', '']) then begin
|
||||
MarkAsSuccess;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
Result := inherited ProcessInputFromDbg(AData);
|
||||
end;
|
||||
|
||||
constructor TLldbInstructionStackTrace.Create(FrameCount: Integer;
|
||||
ACallstack: TCallStackBase);
|
||||
begin
|
||||
FCallstack := ACallstack;
|
||||
inherited Create(Format('bt %d', [FrameCount]));
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user