From fa3981c22e6e52419cc71f6a6b5e071f129a2bde Mon Sep 17 00:00:00 2001 From: martin Date: Wed, 13 Jun 2018 23:08:34 +0000 Subject: [PATCH] LLDB Debugger: New debugger based on lldb / early alpha git-svn-id: trunk@58253 - --- .gitattributes | 9 + .../cmdlinedebuggerbase.lpk | 42 + .../cmdlinedebuggerbase.pas | 21 + .../cmdlinedebuggerbase/debuginstructions.pas | 665 ++++++++++++ .../cmdlinedebuggerbase/debugprocess.pas | 579 +++++++++++ .../lazdebuggerlldb/lazdebuggerlldb.lpk | 50 + .../lazdebuggerlldb/lazdebuggerlldb.pas | 22 + .../lazdebuggerlldb/lldbdebugger.pas | 946 ++++++++++++++++++ .../lazdebuggerlldb/lldbhelper.pas | 99 ++ .../lazdebuggerlldb/lldbinstructions.pas | 555 ++++++++++ 10 files changed, 2988 insertions(+) create mode 100644 components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.lpk create mode 100644 components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.pas create mode 100644 components/lazdebuggers/cmdlinedebuggerbase/debuginstructions.pas create mode 100644 components/lazdebuggers/cmdlinedebuggerbase/debugprocess.pas create mode 100644 components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.lpk create mode 100644 components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.pas create mode 100644 components/lazdebuggers/lazdebuggerlldb/lldbdebugger.pas create mode 100644 components/lazdebuggers/lazdebuggerlldb/lldbhelper.pas create mode 100644 components/lazdebuggers/lazdebuggerlldb/lldbinstructions.pas diff --git a/.gitattributes b/.gitattributes index 1a90f3066b..6ab8b3de2b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.lpk b/components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.lpk new file mode 100644 index 0000000000..58bb36d8ba --- /dev/null +++ b/components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.lpk @@ -0,0 +1,42 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.pas b/components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.pas new file mode 100644 index 0000000000..611083948d --- /dev/null +++ b/components/lazdebuggers/cmdlinedebuggerbase/cmdlinedebuggerbase.pas @@ -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. diff --git a/components/lazdebuggers/cmdlinedebuggerbase/debuginstructions.pas b/components/lazdebuggers/cmdlinedebuggerbase/debuginstructions.pas new file mode 100644 index 0000000000..781f521838 --- /dev/null +++ b/components/lazdebuggers/cmdlinedebuggerbase/debuginstructions.pas @@ -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. + diff --git a/components/lazdebuggers/cmdlinedebuggerbase/debugprocess.pas b/components/lazdebuggers/cmdlinedebuggerbase/debugprocess.pas new file mode 100644 index 0000000000..db8e80c596 --- /dev/null +++ b/components/lazdebuggers/cmdlinedebuggerbase/debugprocess.pas @@ -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 . 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. + diff --git a/components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.lpk b/components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.lpk new file mode 100644 index 0000000000..702c88e44e --- /dev/null +++ b/components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.lpk @@ -0,0 +1,50 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.pas b/components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.pas new file mode 100644 index 0000000000..0ed5177a98 --- /dev/null +++ b/components/lazdebuggers/lazdebuggerlldb/lazdebuggerlldb.pas @@ -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. diff --git a/components/lazdebuggers/lazdebuggerlldb/lldbdebugger.pas b/components/lazdebuggers/lazdebuggerlldb/lldbdebugger.pas new file mode 100644 index 0000000000..08dc05861e --- /dev/null +++ b/components/lazdebuggers/lazdebuggerlldb/lldbdebugger.pas @@ -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=) 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. + diff --git a/components/lazdebuggers/lazdebuggerlldb/lldbhelper.pas b/components/lazdebuggers/lazdebuggerlldb/lldbhelper.pas new file mode 100644 index 0000000000..2d9befeeab --- /dev/null +++ b/components/lazdebuggers/lazdebuggerlldb/lldbhelper.pas @@ -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. + diff --git a/components/lazdebuggers/lazdebuggerlldb/lldbinstructions.pas b/components/lazdebuggers/lazdebuggerlldb/lldbinstructions.pas new file mode 100644 index 0000000000..c1bd4147fa --- /dev/null +++ b/components/lazdebuggers/lazdebuggerlldb/lldbinstructions.pas @@ -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. +