mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-06 22:38:14 +02:00
c9cd3c3901
GDBMiDebugger: fix range check / used wrong variable ........ git-svn-id: branches/fixes_1_8@57939 -
12902 lines
409 KiB
ObjectPascal
12902 lines
409 KiB
ObjectPascal
{ $Id$ }
|
|
{ ----------------------------------------------
|
|
GDBDebugger.pp - Debugger class forGDB
|
|
----------------------------------------------
|
|
|
|
@created(Wed Feb 23rd WET 2002)
|
|
@lastmod($Date$)
|
|
@author(Marc Weustink <marc@@lazarus.dommelstein.net>)
|
|
|
|
This unit contains debugger class for the GDB/MI debugger.
|
|
|
|
|
|
***************************************************************************
|
|
* *
|
|
* 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 GDBMIDebugger;
|
|
|
|
{$mode objfpc}
|
|
{$H+}
|
|
|
|
{$ifndef VER2}
|
|
{$define disassemblernestedproc}
|
|
{$endif VER2}
|
|
|
|
{$ifdef disassemblernestedproc}
|
|
{$modeswitch nestedprocvars}
|
|
{$endif disassemblernestedproc}
|
|
|
|
{$IFDEF linux} {$DEFINE DBG_ENABLE_TERMINAL} {$ENDIF}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFdef MSWindows}
|
|
Windows,
|
|
{$ENDIF}
|
|
{$IFDEF UNIX}
|
|
Unix,BaseUnix,termio,
|
|
{$ENDIF}
|
|
Classes, SysUtils, strutils, math, Variants,
|
|
// LCL
|
|
Controls, Dialogs, Forms,
|
|
LCLProc,
|
|
// LazUtils
|
|
FileUtil, LazUTF8, LazClasses, LazLoggerBase, Maps,
|
|
// IdeIntf
|
|
BaseIDEIntf,
|
|
{$IFDEF Darwin}
|
|
LazFileUtils,
|
|
{$ENDIF}
|
|
DebugUtils, GDBTypeInfo, GDBMIDebugInstructions, GDBMIMiscClasses,
|
|
DbgIntfBaseTypes, DbgIntfDebuggerBase, GdbmiStringConstants;
|
|
|
|
type
|
|
TGDBMIProgramInfo = record
|
|
State: TDBGState;
|
|
BreakPoint: Integer; // ID of Breakpoint hit
|
|
Signal: Integer; // Signal no if we hit one
|
|
SignalText: String; // Signal text if we hit one
|
|
end;
|
|
|
|
// The internal ExecCommand of the new Commands (object queue)
|
|
TGDBMICommandFlag = (
|
|
cfCheckState, // Copy CmdResult to DebuggerState, EXCEPT dsError,dsNone (e.g copy dsRun, dsPause, dsStop, dsIdle)
|
|
cfCheckError, // Copy CmdResult to DebuggerState, ONLY if dsError
|
|
cfTryAsync, // try with " &"
|
|
cfNoThreadContext,
|
|
cfNoStackContext,
|
|
//used for old commands, TGDBMIDebuggerSimpleCommand.Create
|
|
cfscIgnoreState, // ignore the result state of the command
|
|
cfscIgnoreError // ignore errors
|
|
);
|
|
TGDBMICommandFlags = set of TGDBMICommandFlag;
|
|
|
|
|
|
TGDBMICallback = procedure(const AResult: TGDBMIExecResult; const ATag: PtrInt) of object;
|
|
TGDBMIPauseWaitState = (pwsNone, pwsInternal, pwsExternal);
|
|
|
|
TGDBMITargetFlag = (
|
|
tfHasSymbols, // Debug symbols are present
|
|
tfRTLUsesRegCall, // the RTL is compiled with RegCall calling convention
|
|
tfClassIsPointer, // with dwarf class names are pointer. with stabs they are not
|
|
tfExceptionIsPointer, // Can happen, if stabs and dwarf are mixed
|
|
tfFlagHasTypeObject,
|
|
tfFlagHasTypeException,
|
|
tfFlagHasTypeShortstring,
|
|
//tfFlagHasTypePShortString,
|
|
tfFlagHasTypePointer,
|
|
tfFlagHasTypeByte
|
|
//tfFlagHasTypeChar
|
|
);
|
|
TGDBMITargetFlags = set of TGDBMITargetFlag;
|
|
|
|
TGDBMIDebuggerFlags = set of (
|
|
dfImplicidTypes, // Debugger supports implicit types (^Type)
|
|
dfForceBreak, // Debugger supports insertion of not yet known brekpoints
|
|
dfForceBreakDetected,
|
|
dfSetBreakFailed,
|
|
dfSetBreakPending
|
|
);
|
|
|
|
// Target info
|
|
TGDBMITargetInfo = record
|
|
TargetPID: Integer;
|
|
TargetFlags: TGDBMITargetFlags;
|
|
TargetCPU: String;
|
|
TargetOS: String;
|
|
TargetRegisters: array[0..2] of String;
|
|
TargetPtrSize: Byte; // size in bytes
|
|
TargetIsBE: Boolean;
|
|
end;
|
|
PGDBMITargetInfo = ^TGDBMITargetInfo;
|
|
|
|
TConvertToGDBPathType = (cgptNone, cgptCurDir, cgptExeName);
|
|
|
|
TGDBMIDebuggerFilenameEncoding = (
|
|
gdfeNone, gdfeDefault, gdfeEscSpace, gdfeQuote
|
|
);
|
|
TGDBMIDebuggerStartBreak = (
|
|
gdsbDefault, gdsbEntry, gdsbMainAddr, gdsbMain, gdsbAddZero
|
|
);
|
|
TGDBMIUseNoneMiRunCmdsState = (
|
|
gdnmNever, gdnmAlways, gdnmFallback
|
|
);
|
|
TGDBMIWarnOnSetBreakpointError = (
|
|
gdbwNone, gdbwAll, gdbwUserBreakPoint, gdbwExceptionsAndRunError
|
|
);
|
|
|
|
{ TGDBMIDebuggerPropertiesBase }
|
|
|
|
TGDBMIDebuggerPropertiesBase = class(TDebuggerProperties)
|
|
private
|
|
FDisableForcedBreakpoint: Boolean;
|
|
FDisableLoadSymbolsForLibraries: Boolean;
|
|
FEncodeCurrentDirPath: TGDBMIDebuggerFilenameEncoding;
|
|
FEncodeExeFileName: TGDBMIDebuggerFilenameEncoding;
|
|
{$IFDEF UNIX}
|
|
FConsoleTty: String;
|
|
{$ENDIF}
|
|
FGDBOptions: String;
|
|
FInternalStartBreak: TGDBMIDebuggerStartBreak;
|
|
FMaxDisplayLengthForString: Integer;
|
|
FTimeoutForEval: Integer;
|
|
FUseAsyncCommandMode: Boolean;
|
|
FUseNoneMiRunCommands: TGDBMIUseNoneMiRunCmdsState;
|
|
FWarnOnSetBreakpointError: TGDBMIWarnOnSetBreakpointError;
|
|
FWarnOnInternalError: Boolean;
|
|
FWarnOnTimeOut: Boolean;
|
|
procedure SetMaxDisplayLengthForString(AValue: Integer);
|
|
procedure SetTimeoutForEval(const AValue: Integer);
|
|
procedure SetWarnOnTimeOut(const AValue: Boolean);
|
|
public
|
|
constructor Create; override;
|
|
procedure Assign(Source: TPersistent); override;
|
|
public
|
|
property Debugger_Startup_Options: String read FGDBOptions write FGDBOptions;
|
|
{$IFDEF UNIX}
|
|
property ConsoleTty: String read FConsoleTty write FConsoleTty;
|
|
{$ENDIF}
|
|
property MaxDisplayLengthForString: Integer read FMaxDisplayLengthForString write SetMaxDisplayLengthForString;
|
|
property TimeoutForEval: Integer read FTimeoutForEval write SetTimeoutForEval;
|
|
property WarnOnTimeOut: Boolean read FWarnOnTimeOut write SetWarnOnTimeOut;
|
|
property WarnOnInternalError: Boolean read FWarnOnInternalError write FWarnOnInternalError;
|
|
property EncodeCurrentDirPath: TGDBMIDebuggerFilenameEncoding
|
|
read FEncodeCurrentDirPath write FEncodeCurrentDirPath default gdfeDefault;
|
|
property EncodeExeFileName: TGDBMIDebuggerFilenameEncoding
|
|
read FEncodeExeFileName write FEncodeExeFileName default gdfeDefault;
|
|
property InternalStartBreak: TGDBMIDebuggerStartBreak
|
|
read FInternalStartBreak write FInternalStartBreak default gdsbDefault;
|
|
property UseAsyncCommandMode: Boolean read FUseAsyncCommandMode write FUseAsyncCommandMode;
|
|
property UseNoneMiRunCommands: TGDBMIUseNoneMiRunCmdsState
|
|
read FUseNoneMiRunCommands write FUseNoneMiRunCommands default gdnmFallback;
|
|
property DisableLoadSymbolsForLibraries: Boolean read FDisableLoadSymbolsForLibraries
|
|
write FDisableLoadSymbolsForLibraries default False;
|
|
property DisableForcedBreakpoint: Boolean read FDisableForcedBreakpoint
|
|
write FDisableForcedBreakpoint default False;
|
|
property WarnOnSetBreakpointError: TGDBMIWarnOnSetBreakpointError read FWarnOnSetBreakpointError
|
|
write FWarnOnSetBreakpointError default gdbwAll;
|
|
end;
|
|
|
|
TGDBMIDebuggerProperties = class(TGDBMIDebuggerPropertiesBase)
|
|
published
|
|
property Debugger_Startup_Options;
|
|
{$IFDEF UNIX}
|
|
property ConsoleTty;
|
|
{$ENDIF}
|
|
property MaxDisplayLengthForString;
|
|
property TimeoutForEval;
|
|
property WarnOnTimeOut;
|
|
property WarnOnInternalError;
|
|
property EncodeCurrentDirPath;
|
|
property EncodeExeFileName;
|
|
property InternalStartBreak;
|
|
property UseAsyncCommandMode;
|
|
property UseNoneMiRunCommands;
|
|
property DisableLoadSymbolsForLibraries;
|
|
property DisableForcedBreakpoint;
|
|
//property WarnOnSetBreakpointError;
|
|
end;
|
|
|
|
TGDBMIDebugger = class;
|
|
TGDBMIDebuggerCommand = class;
|
|
|
|
{ TGDBMIDebuggerInstruction }
|
|
|
|
TGDBMIDebuggerInstruction = class(TGDBInstruction)
|
|
private
|
|
FCmd: TGDBMIDebuggerCommand;
|
|
FFullCmdReply: String;
|
|
FHasResult: Boolean;
|
|
FInLogWarning: Boolean;
|
|
FLogWarnings: String;
|
|
FResultData: TGDBMIExecResult;
|
|
protected
|
|
function ProcessInputFromGdb(const AData: String): Boolean; override;
|
|
function GetTimeOutVerifier: TGDBInstruction; override;
|
|
procedure Init; override;
|
|
public
|
|
procedure HandleNoGdbRunning; override;
|
|
procedure HandleReadError; override;
|
|
procedure HandleTimeOut; override;
|
|
property ResultData: TGDBMIExecResult read FResultData;
|
|
property HasResult: Boolean read FHasResult; // seen a "^foo" msg from gdb
|
|
property FullCmdReply: String read FFullCmdReply;
|
|
property LogWarnings: String read FLogWarnings;
|
|
property Cmd: TGDBMIDebuggerCommand read FCmd write FCmd;
|
|
end;
|
|
|
|
{ TGDBMIDbgInstructionQueue }
|
|
|
|
TGDBMIDbgInstructionQueue = class(TGDBInstructionQueue)
|
|
protected
|
|
procedure HandleGdbDataBeforeInstruction(var AData: String; var SkipData: Boolean;
|
|
const TheInstruction: TGDBInstruction); override;
|
|
function Debugger: TGDBMIDebugger; reintroduce;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommand }
|
|
|
|
TGDBMIDebuggerCommandState =
|
|
( dcsNone, // Initial State
|
|
dcsQueued, // [None] => Queued behind other commands
|
|
dcsExecuting, // [None, Queued] => currently running
|
|
// Final States, those lead to the object being freed, unless it still is referenced (Add/Release-Reference)
|
|
dcsFinished, // [Executing] => Finished Execution
|
|
dcsCanceled, // [Queued] => Never Executed
|
|
// Flags, for Seenstates
|
|
dcsInternalRefReleased // The internal reference has been released
|
|
);
|
|
TGDBMIDebuggerCommandStates = set of TGDBMIDebuggerCommandState;
|
|
|
|
TGDBMIDebuggerCommandProperty = (dcpCancelOnRun);
|
|
TGDBMIDebuggerCommandProperts = set of TGDBMIDebuggerCommandProperty;
|
|
|
|
TGDBMIExecCommandType =
|
|
( ectNone,
|
|
ectContinue, // -exec-continue
|
|
ectRun, // -exec-run
|
|
ectRunTo, // -exec-until [Source, Line]
|
|
ectStepOver, // -exec-next
|
|
ectStepOut, // -exec-finish
|
|
ectStepInto, // -exec-step
|
|
// not yet used
|
|
ectStepOverInstruction, // -exec-next-instruction
|
|
ectStepIntoInstruction, // -exec-step-instruction
|
|
ectReturn // -exec-return (step out immediately, skip execution)
|
|
);
|
|
|
|
TGDBMIBreakpointReason = (gbrBreak, gbrWatchTrigger, gbrWatchScope);
|
|
|
|
TGDBMIProcessResultOpt = (
|
|
prNoLeadingTab, // Do not require/strip the leading #9
|
|
prKeepBackSlash, // Workaround, backslash may have been removed already
|
|
|
|
// for structures
|
|
prStripAddressFromString,
|
|
prMakePrintAble
|
|
);
|
|
TGDBMIProcessResultOpts = set of TGDBMIProcessResultOpt;
|
|
|
|
TGDBMICommandContextKind = (ccNotRequired, ccUseGlobal, ccUseLocal);
|
|
TGDBMICommandContext = record
|
|
ThreadContext: TGDBMICommandContextKind;
|
|
ThreadId: Integer;
|
|
StackContext: TGDBMICommandContextKind;
|
|
StackFrame: Integer;
|
|
end;
|
|
|
|
TGDBMIDebuggerCommand = class(TRefCountedObject)
|
|
private
|
|
FDefaultTimeOut: Integer;
|
|
FLastExecwasTimeOut: Boolean;
|
|
FOnCancel: TNotifyEvent;
|
|
FOnDestroy: TNotifyEvent;
|
|
FOnExecuted: TNotifyEvent;
|
|
FPriority: Integer;
|
|
FProcessResultTimedOut: Boolean;
|
|
FProperties: TGDBMIDebuggerCommandProperts;
|
|
FQueueRunLevel: Integer;
|
|
FState : TGDBMIDebuggerCommandState;
|
|
FSeenStates: TGDBMIDebuggerCommandStates;
|
|
FLastExecCommand: String;
|
|
FLastExecResult: TGDBMIExecResult;
|
|
FLogWarnings, FFullCmdReply: String;
|
|
FGotStopped: Boolean; // used in ProcessRunning
|
|
function GetDebuggerProperties: TGDBMIDebuggerPropertiesBase;
|
|
function GetDebuggerState: TDBGState;
|
|
function GetTargetInfo: PGDBMITargetInfo;
|
|
protected
|
|
FTheDebugger: TGDBMIDebugger; // Set during Execute
|
|
FContext: TGDBMICommandContext;
|
|
function ContextThreadId: Integer; // does not check validy, only ccUseGlobal or ccUseLocal
|
|
function ContextStackFrame: Integer; // does not check validy, only ccUseGlobal or ccUseLocal
|
|
procedure CopyGlobalContextToLocal;
|
|
|
|
procedure SetDebuggerState(const AValue: TDBGState);
|
|
procedure SetDebuggerErrorState(const AMsg: String; const AInfo: String = '');
|
|
function ErrorStateMessage: String; virtual;
|
|
function ErrorStateInfo: String; virtual;
|
|
property DebuggerState: TDBGState read GetDebuggerState;
|
|
property DebuggerProperties: TGDBMIDebuggerPropertiesBase read GetDebuggerProperties;
|
|
property TargetInfo: PGDBMITargetInfo read GetTargetInfo;
|
|
protected
|
|
procedure SetCommandState(NewState: TGDBMIDebuggerCommandState);
|
|
procedure DoStateChanged({%H-}OldState: TGDBMIDebuggerCommandState); virtual;
|
|
procedure DoLockQueueExecute; virtual;
|
|
procedure DoUnLockQueueExecute; virtual;
|
|
procedure DoLockQueueExecuteForInstr; virtual;
|
|
procedure DoUnLockQueueExecuteForInstr; virtual;
|
|
function DoExecute: Boolean; virtual; abstract;
|
|
procedure DoOnExecuted;
|
|
procedure DoCancel; virtual;
|
|
procedure DoOnCanceled;
|
|
property SeenStates: TGDBMIDebuggerCommandStates read FSeenStates;
|
|
property QueueRunLevel: Integer read FQueueRunLevel write FQueueRunLevel; // if queue is nested
|
|
protected
|
|
// ExecuteCommand does execute direct. It does not use the queue
|
|
function ExecuteCommand(const ACommand: String;
|
|
AFlags: TGDBMICommandFlags = [];
|
|
ATimeOut: Integer = -1
|
|
): Boolean; overload;
|
|
function ExecuteCommand(const ACommand: String;
|
|
out AResult: TGDBMIExecResult;
|
|
AFlags: TGDBMICommandFlags = [];
|
|
ATimeOut: Integer = -1
|
|
): Boolean; overload;
|
|
function ExecuteCommand(const ACommand: String; const AValues: array of const;
|
|
AFlags: TGDBMICommandFlags;
|
|
ATimeOut: Integer = -1
|
|
): Boolean; overload;
|
|
function ExecuteCommand(const ACommand: String; const AValues: array of const;
|
|
out AResult: TGDBMIExecResult;
|
|
AFlags: TGDBMICommandFlags = [];
|
|
ATimeOut: Integer = -1
|
|
): Boolean; overload;
|
|
procedure DoTimeoutFeedback;
|
|
function ProcessGDBResultStruct(S: String; Opts: TGDBMIProcessResultOpts = []): String; // Must have at least one flag for structs
|
|
function ProcessGDBResultText(S: String; Opts: TGDBMIProcessResultOpts = []): String;
|
|
function GetStackDepth(MaxDepth: integer): Integer;
|
|
function FindStackFrame(FP: TDBGPtr; StartAt, MaxDepth: Integer): Integer;
|
|
function GetFrame(const AIndex: Integer): String;
|
|
function GetText(const ALocation: TDBGPtr): String; overload;
|
|
function GetText(const AExpression: String; const AValues: array of const): String; overload;
|
|
function GetChar(const AExpression: String; const AValues: array of const): String; overload;
|
|
function GetFloat(const AExpression: String; const AValues: array of const): String;
|
|
function GetWideText(const ALocation: TDBGPtr): String;
|
|
function GetGDBTypeInfo(const AExpression: String; FullTypeInfo: Boolean = False;
|
|
AFlags: TGDBTypeCreationFlags = [];
|
|
{%H-}AFormat: TWatchDisplayFormat = wdfDefault;
|
|
ARepeatCount: Integer = 0): TGDBType;
|
|
function GetClassName(const AClass: TDBGPtr): String; overload;
|
|
function GetClassName(const AExpression: String; const AValues: array of const): String; overload;
|
|
function GetInstanceClassName(const AInstance: TDBGPtr): String; overload;
|
|
function GetInstanceClassName(const AExpression: String; const AValues: array of const): String; overload;
|
|
function GetData(const ALocation: TDbgPtr): TDbgPtr; overload;
|
|
function GetData(const AExpression: String; const AValues: array of const): TDbgPtr; overload;
|
|
function GetStrValue(const AExpression: String; const AValues: array of const): String;
|
|
function GetIntValue(const AExpression: String; const AValues: array of const): Integer;
|
|
function GetPtrValue(const AExpression: String; const AValues: array of const; {%H-}ConvertNegative: Boolean = False): TDbgPtr;
|
|
function CheckHasType(TypeName: String; TypeFlag: TGDBMITargetFlag): TGDBMIExecResult;
|
|
function PointerTypeCast: string;
|
|
function FrameToLocation(const AFrame: String = ''): TDBGLocationRec;
|
|
procedure ProcessFrame(ALocation: TDBGLocationRec; ASeachStackForSource: Boolean = True); overload;
|
|
procedure ProcessFrame(const AFrame: String = ''; ASeachStackForSource: Boolean = True); overload;
|
|
procedure DoDbgEvent(const ACategory: TDBGEventCategory; const AEventType: TDBGEventType; const AText: String);
|
|
property LastExecResult: TGDBMIExecResult read FLastExecResult;
|
|
property DefaultTimeOut: Integer read FDefaultTimeOut write FDefaultTimeOut;
|
|
property ProcessResultTimedOut: Boolean read FProcessResultTimedOut; // single gdb command, took to long.Used to trigger timeout detection
|
|
property LastExecwasTimeOut: Boolean read FLastExecwasTimeOut; // timeout, was confirmed (additional commands send and returned)
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger);
|
|
destructor Destroy; override;
|
|
// DoQueued: Called if queued *behind* others
|
|
procedure DoQueued;
|
|
// DoFinished: Called after processing is done
|
|
// defaults to Destroy the object
|
|
procedure DoFinished;
|
|
function Execute: Boolean;
|
|
procedure Cancel;
|
|
function KillNow: Boolean; virtual;
|
|
|
|
function DebugText: String; virtual;
|
|
property State: TGDBMIDebuggerCommandState read FState;
|
|
property OnExecuted: TNotifyEvent read FOnExecuted write FOnExecuted;
|
|
property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;
|
|
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
|
|
property Priority: Integer read FPriority write FPriority;
|
|
property Properties: TGDBMIDebuggerCommandProperts read FProperties write FProperties;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandList }
|
|
|
|
TGDBMIDebuggerCommandList = class(TRefCntObjList)
|
|
private
|
|
function Get(Index: Integer): TGDBMIDebuggerCommand;
|
|
procedure Put(Index: Integer; const AValue: TGDBMIDebuggerCommand);
|
|
public
|
|
property Items[Index: Integer]: TGDBMIDebuggerCommand read Get write Put; default;
|
|
end;
|
|
|
|
{%region ***** TGDBMIDebuggerCommands ***** }
|
|
|
|
{ TGDBMIDebuggerSimpleCommand }
|
|
|
|
// not to be used for anything that runs/steps the app
|
|
TGDBMIDebuggerSimpleCommand = class(TGDBMIDebuggerCommand)
|
|
private
|
|
FCommand: String;
|
|
FFlags: TGDBMICommandFlags;
|
|
FCallback: TGDBMICallback;
|
|
FTag: PtrInt;
|
|
FResult: TGDBMIExecResult;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger;
|
|
const ACommand: String;
|
|
const AValues: array of const;
|
|
const AFlags: TGDBMICommandFlags;
|
|
const ACallback: TGDBMICallback;
|
|
const ATag: PtrInt);
|
|
function DebugText: String; override;
|
|
property Result: TGDBMIExecResult read FResult;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandInitDebugger }
|
|
|
|
TGDBMIDebuggerCommandInitDebugger = class(TGDBMIDebuggerCommand)
|
|
protected
|
|
FSuccess: Boolean;
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
property Success: Boolean read FSuccess;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerChangeFilenameBase }
|
|
|
|
TGDBMIDebuggerChangeFilenameBase = class(TGDBMIDebuggerCommand)
|
|
protected
|
|
FErrorMsg: String;
|
|
function DoChangeFilename: Boolean;
|
|
function DoSetPascal: Boolean;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandChangeFilename }
|
|
|
|
TGDBMIDebuggerCommandChangeFilename = class(TGDBMIDebuggerChangeFilenameBase)
|
|
private
|
|
FSuccess: Boolean;
|
|
FFileName: String;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; AFileName: String);
|
|
property Success: Boolean read FSuccess;
|
|
property ErrorMsg: String read FErrorMsg;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandExecuteBase }
|
|
|
|
TGDBMIDebuggerCommandExecuteBase = class(TGDBMIDebuggerChangeFilenameBase)
|
|
private
|
|
FCanKillNow, FDidKillNow: Boolean;
|
|
protected
|
|
function ProcessRunning(out AStoppedParams: String; out AResult: TGDBMIExecResult; ATimeOut: Integer = 0): Boolean;
|
|
function ParseBreakInsertError(var AText: String; out AnId: Integer): Boolean;
|
|
function ProcessStopped(const {%H-}AParams: String; const {%H-}AIgnoreSigIntState: Boolean): Boolean; virtual;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger);
|
|
function KillNow: Boolean; override;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStartBase }
|
|
|
|
TGDBMIDebuggerCommandStartBase = class(TGDBMIDebuggerCommandExecuteBase)
|
|
protected
|
|
procedure SetTargetInfo(const AFileType: String);
|
|
function CheckFunction(const AFunction: String): Boolean;
|
|
procedure RetrieveRegcall;
|
|
procedure CheckAvailableTypes;
|
|
procedure DetectForceableBreaks;
|
|
procedure CommonInit; // Before any run/exec
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStartDebugging }
|
|
|
|
TGDBMIDebuggerCommandStartDebugging = class(TGDBMIDebuggerCommandStartBase)
|
|
private
|
|
FContinueCommand: TGDBMIDebuggerCommand;
|
|
FSuccess: Boolean;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
function GdbRunCommand: String; virtual;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; AContinueCommand: TGDBMIDebuggerCommand);
|
|
destructor Destroy; override;
|
|
function DebugText: String; override;
|
|
property ContinueCommand: TGDBMIDebuggerCommand read FContinueCommand;
|
|
property Success: Boolean read FSuccess;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandAttach }
|
|
|
|
TGDBMIDebuggerCommandAttach = class(TGDBMIDebuggerCommandStartBase)
|
|
private
|
|
FProcessID: String;
|
|
FSuccess: Boolean;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; AProcessID: String);
|
|
function DebugText: String; override;
|
|
property Success: Boolean read FSuccess;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandDetach }
|
|
|
|
TGDBMIDebuggerCommandDetach = class(TGDBMIDebuggerCommand)
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandExecute }
|
|
|
|
TGDBMIDebuggerCommandExecute = class(TGDBMIDebuggerCommandExecuteBase)
|
|
private
|
|
FNextExecQueued: Boolean;
|
|
FResult: TGDBMIExecResult;
|
|
FExecType: TGDBMIExecCommandType;
|
|
FCurrentExecCmd: TGDBMIExecCommandType;
|
|
FCurrentExecArg: String;
|
|
FRunToSrc: String;
|
|
FRunToLine: Integer;
|
|
FStepBreakPoint: Integer;
|
|
protected
|
|
procedure DoLockQueueExecute; override;
|
|
procedure DoUnLockQueueExecute; override;
|
|
function ProcessStopped(const AParams: String; const AIgnoreSigIntState: Boolean): Boolean; override;
|
|
{$IFDEF MSWindows}
|
|
function FixThreadForSigTrap: Boolean;
|
|
{$ENDIF}
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; const ExecType: TGDBMIExecCommandType);
|
|
constructor Create(AOwner: TGDBMIDebugger; const ExecType: TGDBMIExecCommandType; Args: array of const);
|
|
function DebugText: String; override;
|
|
property Result: TGDBMIExecResult read FResult;
|
|
property NextExecQueued: Boolean read FNextExecQueued;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandKill }
|
|
|
|
TGDBMIDebuggerCommandKill = class(TGDBMIDebuggerCommand)
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
end;
|
|
|
|
{%endregion}
|
|
|
|
{ TGDBMIInternalBreakPoint }
|
|
|
|
TGDBMIInternalBreakPoint = class
|
|
private type
|
|
TClearOpt = (coClearIfSet, coKeepIfSet);
|
|
TBlockOpt = (boNone, boBlock, boUnblock);
|
|
TInternalBreakLocation = (iblNamed, iblAddrOfNamed, iblCustomAddr,
|
|
iblAddOffset, iblFileLine);
|
|
TInternalBreakData = record
|
|
BreakGdbId: Integer;
|
|
BreakAddr: TDBGPtr;
|
|
BreakFunction: String;
|
|
BreakFile: String;
|
|
BreakLine: String;
|
|
end;
|
|
private
|
|
FBreaks: array[TInternalBreakLocation] of TInternalBreakData;
|
|
(* F...ID: -1 not set, -2 blocked
|
|
*)
|
|
FEnabled: Boolean;
|
|
FName: string; // The (function) name of the location "main" or "FPC_RAISE"
|
|
FMainAddrFound: TDBGPtr; // The address found for this named location
|
|
FUseForceFlag: Boolean;
|
|
function BreakSet(ACmd: TGDBMIDebuggerCommand; ABreakLoc: String;
|
|
ALoc: TInternalBreakLocation;
|
|
AClearIfSet: TClearOpt): Boolean;
|
|
function GetBreakAddr(ALoc: TInternalBreakLocation): TDBGPtr;
|
|
function GetBreakFile(ALoc: TInternalBreakLocation): String;
|
|
function GetBreakId(ALoc: TInternalBreakLocation): Integer;
|
|
function GetBreakLine(ALoc: TInternalBreakLocation): String;
|
|
function GetInfoAddr(ACmd: TGDBMIDebuggerCommand): TDBGPtr;
|
|
function HasBreakAtAddr(AnAddr: TDBGPtr): Boolean;
|
|
function HasBreakWithId(AnId: Integer): Boolean;
|
|
procedure InternalSetAddr(ACmd: TGDBMIDebuggerCommand; ALoc: TInternalBreakLocation;
|
|
AnAddr: TDBGPtr);
|
|
protected
|
|
procedure Clear(ACmd: TGDBMIDebuggerCommand; ALoc: TInternalBreakLocation;
|
|
ABlock: TBlockOpt = boNone);
|
|
property BreakId[ALoc: TInternalBreakLocation]: Integer read GetBreakId;
|
|
property BreakAddr[ALoc: TInternalBreakLocation]: TDBGPtr read GetBreakAddr;
|
|
property BreakFile[ALoc: TInternalBreakLocation]: String read GetBreakFile;
|
|
property BreakLine[ALoc: TInternalBreakLocation]: String read GetBreakLine;
|
|
public
|
|
constructor Create(AName: string);
|
|
|
|
procedure SetBoth(ACmd: TGDBMIDebuggerCommand);
|
|
procedure SetByName(ACmd: TGDBMIDebuggerCommand);
|
|
procedure SetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
|
|
procedure SetAtCustomAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
|
|
procedure SetAtLineOffs(ACmd: TGDBMIDebuggerCommand; AnOffset: integer);
|
|
procedure SetAtFileLine(ACmd: TGDBMIDebuggerCommand; AFile, ALine: String);
|
|
|
|
procedure Clear(ACmd: TGDBMIDebuggerCommand);
|
|
function ClearId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
|
|
// a blocked id can not be set, until after the next clear (clear all)
|
|
function ClearAndBlockId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
|
|
function MatchAddr(AnAddr: TDBGPtr): boolean;
|
|
function MatchId(AnId: Integer): boolean;
|
|
function IsBreakSet: boolean;
|
|
function BreakSetCount: Integer;
|
|
procedure EnableOrSetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
|
|
procedure Enable(ACmd: TGDBMIDebuggerCommand);
|
|
procedure Disable(ACmd: TGDBMIDebuggerCommand);
|
|
property MainAddrFound: TDBGPtr read FMainAddrFound;
|
|
property UseForceFlag: Boolean read FUseForceFlag write FUseForceFlag;
|
|
property Enabled: Boolean read FEnabled;
|
|
end;
|
|
|
|
{ TGDBMIWatches }
|
|
|
|
TGDBMIDebuggerParentFrameCache = record
|
|
ThreadId: Integer;
|
|
ParentFPList: Array of
|
|
record
|
|
fp, parentfp: string; // empty=unknown / '-'=evaluated-no-data
|
|
end;
|
|
end;
|
|
PGDBMIDebuggerParentFrameCache = ^TGDBMIDebuggerParentFrameCache;
|
|
|
|
TGDBMIWatches = class(TWatchesSupplier)
|
|
private
|
|
FCommandList: TList;
|
|
FParentFPList: Array of TGDBMIDebuggerParentFrameCache;
|
|
FParentFPListChangeStamp: Integer;
|
|
procedure DoEvaluationDestroyed(Sender: TObject);
|
|
protected
|
|
function GetParentFPList(AThreadId: Integer): PGDBMIDebuggerParentFrameCache;
|
|
procedure DoStateChange(const AOldState: TDBGState); override;
|
|
procedure Changed;
|
|
procedure Clear;
|
|
function ForceQueuing: Boolean;
|
|
procedure InternalRequestData(AWatchValue: TWatchValue); override;
|
|
property ParentFPListChangeStamp: Integer read FParentFPListChangeStamp;
|
|
public
|
|
constructor Create(const ADebugger: TDebuggerIntf);
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
{ TGDBMILocals }
|
|
|
|
TGDBMILocals = class(TLocalsSupplier)
|
|
private
|
|
FCommandList: TList;
|
|
procedure CancelEvaluation; deprecated;
|
|
procedure DoEvaluationDestroyed(Sender: TObject);
|
|
protected
|
|
procedure CancelAllCommands;
|
|
function ForceQueuing: Boolean;
|
|
public
|
|
procedure Changed;
|
|
constructor Create(const ADebugger: TDebuggerIntf);
|
|
destructor Destroy; override;
|
|
procedure RequestData(ALocals: TLocals); override;
|
|
end;
|
|
|
|
{ TGDBMIDebugger }
|
|
|
|
TGDBMIDebugger = class(TGDBMICmdLineDebugger) // TODO: inherit from TDebugger direct
|
|
private
|
|
FInstructionQueue: TGDBMIDbgInstructionQueue;
|
|
FCommandQueue: TGDBMIDebuggerCommandList;
|
|
FCurrentCommand: TGDBMIDebuggerCommand;
|
|
FCommandQueueExecLock: Integer;
|
|
FCommandProcessingLock: Integer;
|
|
|
|
FMainAddrBreak: TGDBMIInternalBreakPoint;
|
|
FBreakAtMain: TDBGBreakPoint;
|
|
FBreakErrorBreak: TGDBMIInternalBreakPoint;
|
|
FRunErrorBreak: TGDBMIInternalBreakPoint;
|
|
FExceptionBreak: TGDBMIInternalBreakPoint;
|
|
FPopExceptStack, FCatchesBreak, FReRaiseBreak: TGDBMIInternalBreakPoint;
|
|
FPauseWaitState: TGDBMIPauseWaitState;
|
|
FStoppedReason: (srNone, srRaiseExcept, srReRaiseExcept, srPopExceptStack, srCatches);
|
|
FInExecuteCount: Integer;
|
|
FInIdle: Boolean;
|
|
FRunQueueOnUnlock: Boolean;
|
|
FDebuggerFlags: TGDBMIDebuggerFlags;
|
|
FSourceNames: TStringList; // Objects[] -> TMap[Integer|Integer] -> TDbgPtr
|
|
FReleaseLock: Integer;
|
|
FInProcessStopped: Boolean; // paused, but maybe state run
|
|
FCommandNoneMiState: Array [TGDBMIExecCommandType] of Boolean;
|
|
FCommandAsyncState: Array [TGDBMIExecCommandType] of Boolean;
|
|
FCurrentCmdIsAsync: Boolean;
|
|
FAsyncModeEnabled: Boolean;
|
|
FWasDisableLoadSymbolsForLibraries: Boolean;
|
|
|
|
// Internal Current values
|
|
FCurrentStackFrame, FCurrentThreadId: Integer; // User set values
|
|
FCurrentStackFrameValid, FCurrentThreadIdValid: Boolean; // Internal (update for every temporary change)
|
|
FCurrentLocation: TDBGLocationRec;
|
|
|
|
// GDB info (move to ?)
|
|
FGDBVersion: String;
|
|
FGDBVersionMajor, FGDBVersionMinor, FGDBVersionRev: Integer;
|
|
FGDBCPU: String;
|
|
FGDBPtrSize: integer; // PointerSize of the GDB-cpu
|
|
FGDBOS: String;
|
|
|
|
// Target info (move to record ?)
|
|
FTargetInfo: TGDBMITargetInfo;
|
|
|
|
FThreadGroups: TStringList;
|
|
FTypeRequestCache: TGDBPTypeRequestCache;
|
|
FMaxLineForUnitCache: TStringList;
|
|
|
|
procedure DoPseudoTerminalRead(Sender: TObject);
|
|
// Implementation of external functions
|
|
function GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
|
|
function GDBEvaluate(const AExpression: String; var AResult: String;
|
|
out ATypeInfo: TGDBType; EvalFlags: TDBGEvaluateFlags): Boolean;
|
|
function GDBModify(const AExpression, ANewValue: String): Boolean;
|
|
procedure GDBModifyDone(const {%H-}AResult: TGDBMIExecResult; const {%H-}ATag: PtrInt);
|
|
function GDBRun: Boolean;
|
|
function GDBPause(const AInternal: Boolean): Boolean;
|
|
function GDBStop: Boolean;
|
|
function GDBStepOver: Boolean;
|
|
function GDBStepInto: Boolean;
|
|
function GDBStepOverInstr: Boolean;
|
|
function GDBStepIntoInstr: Boolean;
|
|
function GDBStepOut: Boolean;
|
|
function GDBRunTo(const ASource: String; const ALine: Integer): Boolean;
|
|
function GDBJumpTo(const {%H-}ASource: String; const {%H-}ALine: Integer): Boolean;
|
|
function GDBAttach(AProcessID: String): Boolean;
|
|
function GDBDetach: Boolean;
|
|
function GDBDisassemble(AAddr: TDbgPtr; ABackward: Boolean; out ANextAddr: TDbgPtr;
|
|
out ADump, AStatement, AFile: String; out ALine: Integer): Boolean;
|
|
deprecated;
|
|
function GDBSourceAdress(const ASource: String; ALine, {%H-}AColumn: Integer; out AAddr: TDbgPtr): Boolean;
|
|
|
|
// prevent destruction while nested in any call
|
|
procedure LockRelease;
|
|
procedure UnlockRelease;
|
|
|
|
// ---
|
|
procedure ClearSourceInfo;
|
|
function FindBreakpoint(const ABreakpoint: Integer): TDBGBreakPoint;
|
|
|
|
// All ExecuteCommand functions are wrappers for the real (full) implementation
|
|
// ExecuteCommandFull is never called directly
|
|
function ExecuteCommand(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags): Boolean; overload;
|
|
function ExecuteCommand(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags; var AResult: TGDBMIExecResult): Boolean; overload;
|
|
function ExecuteCommandFull(const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags; const ACallback: TGDBMICallback; const ATag: PtrInt; var AResult: TGDBMIExecResult): Boolean; overload;
|
|
procedure RunQueue;
|
|
procedure CancelAllQueued;
|
|
procedure CancelBeforeRun;
|
|
procedure CancelAfterStop;
|
|
procedure RunQueueASync;
|
|
procedure RemoveRunQueueASync;
|
|
procedure DoRunQueueFromASync({%H-}Data: PtrInt);
|
|
function StartDebugging(AContinueCommand: TGDBMIExecCommandType): Boolean;
|
|
function StartDebugging(AContinueCommand: TGDBMIExecCommandType; AValues: array of const): Boolean;
|
|
function StartDebugging(AContinueCommand: TGDBMIDebuggerCommand = nil): Boolean;
|
|
procedure TerminateGDB;
|
|
protected
|
|
FNeedStateToIdle, FNeedReset: Boolean;
|
|
{$IFDEF MSWindows}
|
|
FPauseRequestInThreadID: Cardinal;
|
|
{$ENDIF}
|
|
{$IFDEF DBG_ENABLE_TERMINAL}
|
|
FPseudoTerminal: TPseudoTerminal;
|
|
procedure ProcessWhileWaitForHandles; override;
|
|
{$ENDIF}
|
|
procedure QueueExecuteLock;
|
|
procedure QueueExecuteUnlock;
|
|
procedure QueueCommand(const ACommand: TGDBMIDebuggerCommand; ForceQueue: Boolean = False);
|
|
procedure UnQueueCommand(const ACommand: TGDBMIDebuggerCommand);
|
|
|
|
function ConvertToGDBPath(APath: string; ConvType: TConvertToGDBPathType = cgptNone): string;
|
|
function ChangeFileName: Boolean; override;
|
|
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 GetTargetWidth: Byte; override;
|
|
procedure InterruptTarget; virtual;
|
|
function ParseInitialization: Boolean; virtual;
|
|
function CreateCommandInit: TGDBMIDebuggerCommandInitDebugger; virtual;
|
|
function CreateCommandStartDebugging(AContinueCommand: TGDBMIDebuggerCommand): TGDBMIDebuggerCommandStartDebugging; virtual;
|
|
function RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean; override;
|
|
property CurrentCmdIsAsync: Boolean read FCurrentCmdIsAsync;
|
|
property CurrentCommand: TGDBMIDebuggerCommand read FCurrentCommand;
|
|
|
|
procedure ClearCommandQueue;
|
|
function GetIsIdle: Boolean; override;
|
|
procedure ResetStateToIdle; override;
|
|
procedure DoState(const OldState: TDBGState); override;
|
|
procedure DoBeforeState(const OldState: TDBGState); override;
|
|
function LineEndPos(const s: string; out LineEndLen: integer): integer; override;
|
|
procedure DoThreadChanged;
|
|
property TargetPID: Integer read FTargetInfo.TargetPID;
|
|
property TargetPtrSize: Byte read FTargetInfo.TargetPtrSize;
|
|
property TargetFlags: TGDBMITargetFlags read FTargetInfo.TargetFlags write FTargetInfo.TargetFlags;
|
|
property PauseWaitState: TGDBMIPauseWaitState read FPauseWaitState;
|
|
property DebuggerFlags: TGDBMIDebuggerFlags read FDebuggerFlags;
|
|
procedure DoRelease; override; // Destroy self (or schedule)
|
|
procedure DoUnknownException(Sender: TObject; AnException: Exception);
|
|
|
|
procedure DoNotifyAsync(Line: String);
|
|
procedure DoDbgBreakpointEvent(ABreakpoint: TDBGBreakPoint; Location: TDBGLocationRec;
|
|
AReason: TGDBMIBreakpointReason;
|
|
AOldVal: String = ''; ANewVal: String = '');
|
|
procedure AddThreadGroup(const S: String);
|
|
procedure RemoveThreadGroup(const {%H-}S: String);
|
|
function ParseLibraryLoaded(const S: String): String;
|
|
function ParseLibraryUnLoaded(const S: String): String;
|
|
function ParseThread(const S, EventText: String): String;
|
|
|
|
property CurrentStackFrame: Integer read FCurrentStackFrame;
|
|
property CurrentThreadId: Integer read FCurrentThreadId;
|
|
property CurrentStackFrameValid: Boolean read FCurrentStackFrameValid;
|
|
property CurrentThreadIdValid: Boolean read FCurrentThreadIdValid;
|
|
|
|
function CreateTypeRequestCache: TGDBPTypeRequestCache; virtual;
|
|
property TypeRequestCache: TGDBPTypeRequestCache read FTypeRequestCache;
|
|
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;
|
|
|
|
property AsyncModeEnabled: Boolean read FAsyncModeEnabled;
|
|
|
|
// internal testing
|
|
procedure TestCmd(const ACommand: String); override;
|
|
function NeedReset: Boolean; override;
|
|
end;
|
|
|
|
{%region ***** TGDBMINameValueList and Parsers ***** }
|
|
|
|
{ TGDBMINameValueBasedList }
|
|
|
|
TGDBMINameValueBasedList = class
|
|
protected
|
|
FNameValueList: TGDBMINameValueList;
|
|
procedure PreParse; virtual; abstract;
|
|
public
|
|
constructor Create;
|
|
constructor Create(const AResultValues: String);
|
|
constructor Create(AResult: TGDBMIExecResult);
|
|
destructor Destroy; override;
|
|
procedure Init(AResultValues: string);
|
|
procedure Init(AResult: TGDBMIExecResult);
|
|
end;
|
|
|
|
{ TGDBMIMemoryDumpResultList }
|
|
|
|
TGDBMIMemoryDumpResultList = class(TGDBMINameValueBasedList)
|
|
private
|
|
FAddr: TDBGPtr;
|
|
function GetItem(Index: Integer): TPCharWithLen;
|
|
function GetItemNum(Index: Integer): Integer;
|
|
function GetItemTxt(Index: Integer): string;
|
|
protected
|
|
procedure PreParse; override;
|
|
public
|
|
// Expected input format: 1 row with hex values
|
|
function Count: Integer;
|
|
property Item[Index: Integer]: TPCharWithLen read GetItem;
|
|
property ItemTxt[Index: Integer]: string read GetItemTxt;
|
|
property ItemNum[Index: Integer]: Integer read GetItemNum;
|
|
property Addr: TDBGPtr read FAddr;
|
|
function AsText(AStartOffs, ACount: Integer; AAddrWidth: Integer): string;
|
|
end;
|
|
|
|
{%endregion *^^^* TGDBMINameValueList and Parsers *^^^* }
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
var
|
|
DBGMI_QUEUE_DEBUG, DBGMI_STRUCT_PARSER, DBG_VERBOSE, DBG_WARNINGS,
|
|
DBG_DISASSEMBLER, DBG_THREAD_AND_FRAME: PLazLoggerLogGroup;
|
|
|
|
|
|
const
|
|
GDBMIBreakPointReasonNames: Array[TGDBMIBreakpointReason] of string =
|
|
('Breakpoint', 'Watchpoint', 'Watchpoint (scope)');
|
|
|
|
GDBMIExecCommandMap: array [TGDBMIExecCommandType] of string =
|
|
( '', // ectNone
|
|
'-exec-continue', // ectContinue,
|
|
'-exec-run', // ectRun,
|
|
'-exec-until', // ectRunTo, // [Source, Line]
|
|
'-exec-next', // ectStepOver,
|
|
'-exec-finish', // ectStepOut,
|
|
'-exec-step', // ectStepInto,
|
|
'-exec-next-instruction', // ectStepOverInstruction,
|
|
'-exec-step-instruction', // ectStepIntoInstruction,
|
|
'-exec-return' // ectReturn // (step out immediately, skip execution)
|
|
);
|
|
GDBMIExecCommandMapNoneMI: array [TGDBMIExecCommandType] of string =
|
|
( '', // ectNone
|
|
'continue', // ectContinue,
|
|
'run', // ectRun,
|
|
'until', // ectRunTo, // [Source, Line]
|
|
'next', // ectStepOver,
|
|
'finish', // ectStepOut,
|
|
'step', // ectStepInto,
|
|
'nexti', // ectStepOverInstruction,
|
|
'stepi', // ectStepIntoInstruction,
|
|
'return' // ectReturn // (step out immediately, skip execution)
|
|
);
|
|
|
|
type
|
|
THackDBGType = class(TGDBType) end;
|
|
|
|
const
|
|
// priorities for commands
|
|
GDCMD_PRIOR_IMMEDIATE = 999; // run immediate (request without callback)
|
|
GDCMD_PRIOR_LINE_INFO = 100; // Line info should run asap
|
|
GDCMD_PRIOR_DISASS = 30; // Run before watches
|
|
GDCMD_PRIOR_USER_ACT = 10; // set/change/remove brkpoint
|
|
GDCMD_PRIOR_THREAD = 5; // Run before watches, stack or locals
|
|
GDCMD_PRIOR_STACK = 2; // Run before watches
|
|
GDCMD_PRIOR_LOCALS = 1; // Run before watches (also registers etc)
|
|
|
|
type
|
|
|
|
{%region ***** Locals ***** }
|
|
|
|
{ TGDBMIDebuggerCommandLocals }
|
|
|
|
TGDBMIDebuggerCommandLocals = class(TGDBMIDebuggerCommand)
|
|
private
|
|
FLocals: TLocals;
|
|
protected
|
|
procedure DoLockQueueExecute; override;
|
|
procedure DoUnLockQueueExecute; override;
|
|
procedure DoLockQueueExecuteForInstr; override;
|
|
procedure DoUnLockQueueExecuteForInstr; override;
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; ALocals: TLocals);
|
|
destructor Destroy; override;
|
|
function DebugText: String; override;
|
|
end;
|
|
|
|
{%endregion ^^^^^ Locals ^^^^^ }
|
|
|
|
{%region ***** LineSymbolInfo ***** }
|
|
|
|
{ TGDBMIDebuggerCommandLineSymbolInfo }
|
|
|
|
TGDBMIDebuggerCommandLineSymbolInfo = class(TGDBMIDebuggerCommand)
|
|
private
|
|
FResult: TGDBMIExecResult;
|
|
FSource: string;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; Source: string);
|
|
function DebugText: String; override;
|
|
property Result: TGDBMIExecResult read FResult;
|
|
property Source: string read FSource;
|
|
end;
|
|
|
|
{ TGDBMILineInfo }
|
|
|
|
TGDBMILineInfo = class(TDBGLineInfo)
|
|
private
|
|
FSourceIndex: TStringList;
|
|
FRequestedSources: TStringList;
|
|
FSourceMaps: array of record
|
|
Source: String;
|
|
Map: TMap;
|
|
end;
|
|
FGetLineSymbolsCmdObj: TGDBMIDebuggerCommandLineSymbolInfo;
|
|
procedure DoGetLineSymbolsDestroyed(Sender: TObject);
|
|
procedure ClearSources;
|
|
procedure AddInfo(const ASource: String; const AResult: TGDBMIExecResult);
|
|
procedure DoGetLineSymbolsFinished(Sender: TObject);
|
|
protected
|
|
function GetSource(const AIndex: integer): String; override;
|
|
procedure DoStateChange(const {%H-}AOldState: TDBGState); override;
|
|
public
|
|
constructor Create(const ADebugger: TDebuggerIntf);
|
|
destructor Destroy; override;
|
|
function Count: Integer; override;
|
|
function GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr; override;
|
|
function GetInfo({%H-}AAdress: TDbgPtr; out {%H-}ASource, {%H-}ALine, {%H-}AOffset: Integer): Boolean; override;
|
|
function IndexOf(const ASource: String): integer; override;
|
|
procedure Request(const ASource: String); override;
|
|
procedure Cancel(const ASource: String); override;
|
|
end;
|
|
|
|
{%endregion ^^^^^ LineSymbolInfo ^^^^^ }
|
|
|
|
{%region ***** BreakPoints ***** }
|
|
|
|
{ TGDBMIDebuggerCommandBreakPointBase }
|
|
|
|
TGDBMIDebuggerCommandBreakPointBase = class(TGDBMIDebuggerCommand)
|
|
protected
|
|
function ExecCheckLineInUnit(ASource: string; ALine: Integer): Boolean;
|
|
function ExecBreakDelete(ABreakId: Integer): Boolean;
|
|
function ExecBreakEnabled(ABreakId: Integer; AnEnabled: Boolean): Boolean;
|
|
function ExecBreakCondition(ABreakId: Integer; AnExpression: string): Boolean;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandBreakInsert }
|
|
|
|
TGDBMIDebuggerCommandBreakInsert = class(TGDBMIDebuggerCommandBreakPointBase)
|
|
private
|
|
FKind: TDBGBreakPointKind;
|
|
FAddress: TDBGPtr;
|
|
FSource: string;
|
|
FLine: Integer;
|
|
FEnabled: Boolean;
|
|
FExpression: string;
|
|
FReplaceId: Integer;
|
|
|
|
FAddr: TDBGPtr;
|
|
FBreakID: Integer;
|
|
FHitCnt: Integer;
|
|
FValid: Boolean;
|
|
FWatchData: String;
|
|
FWatchKind: TDBGWatchPointKind;
|
|
FWatchScope: TDBGWatchPointScope;
|
|
protected
|
|
function ExecBreakInsert(out ABreakId, AHitCnt: Integer; out AnAddr: TDBGPtr): Boolean;
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; ASource: string; ALine: Integer;
|
|
AEnabled: Boolean; AnExpression: string; AReplaceId: Integer); overload;
|
|
constructor Create(AOwner: TGDBMIDebugger; AAddress: TDBGPtr;
|
|
AEnabled: Boolean; AnExpression: string; AReplaceId: Integer); overload;
|
|
constructor Create(AOwner: TGDBMIDebugger; AData: string; AScope: TDBGWatchPointScope;
|
|
AKind: TDBGWatchPointKind; AEnabled: Boolean; AnExpression: string; AReplaceId: Integer); overload;
|
|
function DebugText: String; override;
|
|
property Kind: TDBGBreakPointKind read FKind write FKind;
|
|
property Address: TDBGPtr read FAddress write FAddress;
|
|
property Source: string read FSource write FSource;
|
|
property Line: Integer read FLine write FLine;
|
|
property WatchData: String read FWatchData write FWatchData;
|
|
property WatchScope: TDBGWatchPointScope read FWatchScope write FWatchScope;
|
|
property WatchKind: TDBGWatchPointKind read FWatchKind write FWatchKind;
|
|
property Enabled: Boolean read FEnabled write FEnabled;
|
|
property Expression: string read FExpression write FExpression;
|
|
property ReplaceId: Integer read FReplaceId write FReplaceId;
|
|
// result values
|
|
property Addr: TDBGPtr read FAddr;
|
|
property BreakID: Integer read FBreakID;
|
|
property HitCnt: Integer read FHitCnt;
|
|
property Valid: Boolean read FValid;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandBreakRemove }
|
|
|
|
TGDBMIDebuggerCommandBreakRemove = class(TGDBMIDebuggerCommandBreakPointBase)
|
|
private
|
|
FBreakId: Integer;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer);
|
|
function DebugText: String; override;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandBreakUpdate }
|
|
|
|
TGDBMIDebuggerCommandBreakUpdate = class(TGDBMIDebuggerCommandBreakPointBase)
|
|
private
|
|
FBreakID: Integer;
|
|
FEnabled: Boolean;
|
|
FExpression: string;
|
|
FUpdateEnabled: Boolean;
|
|
FUpdateExpression: Boolean;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer);
|
|
constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer; AnEnabled: Boolean);
|
|
constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer; AnExpression: string);
|
|
constructor Create(AOwner: TGDBMIDebugger; ABreakId: Integer; AnEnabled: Boolean; AnExpression: string);
|
|
function DebugText: String; override;
|
|
property UpdateEnabled: Boolean read FUpdateEnabled write FUpdateEnabled;
|
|
property UpdateExpression: Boolean read FUpdateExpression write FUpdateExpression;
|
|
property Enabled: Boolean read FEnabled write FEnabled;
|
|
property Expression: string read FExpression write FExpression;
|
|
end;
|
|
|
|
{ TGDBMIBreakPoint ***** BreakPoints ***** }
|
|
|
|
TGDBMIBreakPointUpdateFlag = (bufSetBreakPoint, bufEnabled, bufCondition);
|
|
TGDBMIBreakPointUpdateFlags = set of TGDBMIBreakPointUpdateFlag;
|
|
|
|
TGDBMIBreakPoint = class(TDBGBreakPoint)
|
|
private
|
|
FParsedExpression: String;
|
|
FCurrentCmd: TGDBMIDebuggerCommandBreakPointBase;
|
|
FUpdateFlags: TGDBMIBreakPointUpdateFlags;
|
|
procedure SetBreakPoint;
|
|
procedure ReleaseBreakPoint;
|
|
procedure UpdateProperties(AFlags: TGDBMIBreakPointUpdateFlags);
|
|
procedure DoCommandDestroyed(Sender: TObject);
|
|
procedure DoCommandExecuted(Sender: TObject);
|
|
protected
|
|
FBreakID: Integer;
|
|
procedure DoEndUpdate; override;
|
|
procedure DoEnableChange; override;
|
|
procedure DoExpressionChange; override;
|
|
procedure DoStateChange(const AOldState: TDBGState); override;
|
|
procedure MakeInvalid;
|
|
procedure SetAddress(const AValue: TDBGPtr); 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;
|
|
|
|
{ TGDBMIBreakPoints }
|
|
|
|
TGDBMIBreakPoints = class(TDBGBreakPoints)
|
|
protected
|
|
function FindById(AnId: Integer): TGDBMIBreakPoint;
|
|
end;
|
|
{%endregion ^^^^^ BreakPoints ^^^^^ }
|
|
|
|
{%region ***** Register ***** }
|
|
|
|
TStringArray = Array of string;
|
|
|
|
TGDBMIRegisterSupplier = class;
|
|
|
|
{ TGDBMIDebuggerCommandRegisterUpdate }
|
|
|
|
TGDBMIDebuggerCommandRegisterUpdate = class(TGDBMIDebuggerCommand)
|
|
private
|
|
FRegisters: TRegisters;
|
|
FGDBMIRegSupplier: TGDBMIRegisterSupplier;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
procedure DoCancel; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; AGDBMIRegSupplier: TGDBMIRegisterSupplier; ARegisters: TRegisters);
|
|
destructor Destroy; override;
|
|
//function DebugText: String; override;
|
|
end;
|
|
|
|
{ TGDBMIRegisterSupplier }
|
|
|
|
TGDBMIRegisterSupplier = class(TRegisterSupplier)
|
|
private
|
|
FRegNamesCache: TStringArray;
|
|
protected
|
|
procedure DoStateChange(const AOldState: TDBGState); override;
|
|
public
|
|
procedure Changed;
|
|
procedure RequestData(ARegisters: TRegisters); override;
|
|
end;
|
|
|
|
{%endregion ^^^^^ Register ^^^^^ }
|
|
|
|
{%region ***** Watches ***** }
|
|
|
|
{ TGDBMIDebuggerCommandEvaluate }
|
|
|
|
TGDBMIDebuggerCommandEvaluate = class(TGDBMIDebuggerCommand)
|
|
private
|
|
FEvalFlags: TDBGEvaluateFlags;
|
|
FExpression: String;
|
|
FDisplayFormat: TWatchDisplayFormat;
|
|
FWatchValue: TWatchValue;
|
|
FTextValue: String;
|
|
FTypeInfo: TGDBType;
|
|
FValidity: TDebuggerDataState;
|
|
FTypeInfoAutoDestroy: Boolean;
|
|
FLockFlag: Boolean;
|
|
function GetTypeInfo: TGDBType;
|
|
procedure DoWatchFreed(Sender: TObject);
|
|
protected
|
|
procedure DoLockQueueExecute; override;
|
|
procedure DoUnLockQueueExecute; override;
|
|
procedure DoLockQueueExecuteForInstr; override;
|
|
procedure DoUnLockQueueExecuteForInstr; override;
|
|
function DoExecute: Boolean; override;
|
|
function SelectContext: Boolean;
|
|
procedure UnSelectContext;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; AExpression: String; ADisplayFormat: TWatchDisplayFormat);
|
|
constructor Create(AOwner: TGDBMIDebugger; AWatchValue: TWatchValue);
|
|
destructor Destroy; override;
|
|
function DebugText: String; override;
|
|
property Expression: String read FExpression;
|
|
property EvalFlags: TDBGEvaluateFlags read FEvalFlags write FEvalFlags;
|
|
property DisplayFormat: TWatchDisplayFormat read FDisplayFormat;
|
|
property TextValue: String read FTextValue;
|
|
property TypeInfo: TGDBType read GetTypeInfo;
|
|
property TypeInfoAutoDestroy: Boolean read FTypeInfoAutoDestroy write FTypeInfoAutoDestroy;
|
|
end;
|
|
|
|
{%endregion ^^^^^ Watches ^^^^^ }
|
|
|
|
{%region ***** Stack ***** }
|
|
|
|
TGDBMINameValueListArray = array of TGDBMINameValueList;
|
|
|
|
{ TGDBMIDebuggerCommandStack }
|
|
|
|
TGDBMIDebuggerCommandStack = class(TGDBMIDebuggerCommand)
|
|
private
|
|
procedure DoCallstackFreed(Sender: TObject);
|
|
protected
|
|
FCallstack: TCallStackBase;
|
|
procedure DoLockQueueExecute; override;
|
|
procedure DoUnLockQueueExecute; override;
|
|
procedure DoLockQueueExecuteForInstr; override;
|
|
procedure DoUnLockQueueExecuteForInstr; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; ACallstack: TCallStackBase);
|
|
destructor Destroy; override;
|
|
property Callstack: TCallStackBase read FCallstack;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStackFrames }
|
|
|
|
TGDBMIDebuggerCommandStackFrames = class(TGDBMIDebuggerCommandStack)
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStackDepth }
|
|
|
|
TGDBMIDebuggerCommandStackDepth = class(TGDBMIDebuggerCommandStack)
|
|
private
|
|
FDepth: Integer;
|
|
FLimit: Integer;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; ACallstack: TCallStackBase);
|
|
function DebugText: String; override;
|
|
property Depth: Integer read FDepth;
|
|
property Limit: Integer read FLimit write FLimit;
|
|
end;
|
|
|
|
{ TGDBMICallStack }
|
|
|
|
TGDBMICallStack = class(TCallStackSupplier)
|
|
private
|
|
FCommandList: TList;
|
|
FDepthEvalCmdObj: TGDBMIDebuggerCommandStackDepth;
|
|
FLimitSeen: Integer;
|
|
procedure DoDepthCommandExecuted(Sender: TObject);
|
|
//procedure DoFramesCommandExecuted(Sender: TObject);
|
|
procedure DoCommandDestroyed(Sender: TObject);
|
|
protected
|
|
procedure Clear;
|
|
procedure DoThreadChanged;
|
|
public
|
|
constructor Create(const ADebugger: TDebuggerIntf);
|
|
destructor Destroy; override;
|
|
procedure RequestCount(ACallstack: TCallStackBase); override;
|
|
procedure RequestAtLeastCount(ACallstack: TCallStackBase; ARequiredMinCount: Integer); override;
|
|
procedure RequestCurrent(ACallstack: TCallStackBase); override;
|
|
procedure RequestEntries(ACallstack: TCallStackBase); override;
|
|
procedure UpdateCurrentIndex; override;
|
|
end;
|
|
|
|
{%endregion ^^^^^ Stack ^^^^^ }
|
|
|
|
{%region ***** Disassembler ***** }
|
|
|
|
const
|
|
(* Some values to calculate how many bytes to disassemble for a given amount of lines
|
|
Those values are only guesses *)
|
|
// Max possible len of a statement in byte. Only used for up to 5 lines
|
|
DAssBytesPerCommandMax = 24;
|
|
// Maximum alignment between to procedures (for detecion of gaps, after dis-ass with source)
|
|
DAssBytesPerCommandAlign = 16;
|
|
|
|
type
|
|
|
|
{ TGDBMIDisassembleResultList }
|
|
|
|
TGDBMIDisassembleResultList = class(TGDBMINameValueBasedList)
|
|
private
|
|
FCount: Integer;
|
|
FHasSourceInfo: Boolean;
|
|
FItems: array of record
|
|
AsmEntry: TPCharWithLen;
|
|
SrcFile: TPCharWithLen;
|
|
SrcLine: TPCharWithLen;
|
|
ParsedInfo: TDisassemblerEntry;
|
|
end;
|
|
HasItemPointerList: Boolean;
|
|
ItemPointerList: Array of PDisassemblerEntry;
|
|
function GetItem(Index: Integer): PDisassemblerEntry;
|
|
function GetLastItem: PDisassemblerEntry;
|
|
procedure ParseItem(Index: Integer);
|
|
procedure SetCount(const AValue: Integer);
|
|
procedure SetItem(Index: Integer; const AValue: PDisassemblerEntry);
|
|
procedure SetLastItem(const AValue: PDisassemblerEntry);
|
|
protected
|
|
procedure PreParse; override;
|
|
public
|
|
property Count: Integer read FCount write SetCount;
|
|
property HasSourceInfo: Boolean read FHasSourceInfo;
|
|
property Item[Index: Integer]: PDisassemblerEntry read GetItem write SetItem;
|
|
property LastItem: PDisassemblerEntry read GetLastItem write SetLastItem;
|
|
function SortByAddress: Boolean;
|
|
public
|
|
// only valid as long a src object exists, and not modified
|
|
constructor CreateSubList(ASource: TGDBMIDisassembleResultList; AStartIdx, ACount: Integer);
|
|
procedure InitSubList(ASource: TGDBMIDisassembleResultList; AStartIdx, ACount: Integer);
|
|
end;
|
|
|
|
{ TGDBMIDisassembleResultFunctionIterator }
|
|
|
|
TGDBMIDisassembleResultFunctionIterator = class
|
|
private
|
|
FCurIdx: Integer;
|
|
FIndexOfLocateAddress: Integer;
|
|
FOffsetOfLocateAddress: Integer;
|
|
FIndexOfCounterAddress: Integer;
|
|
FList: TGDBMIDisassembleResultList;
|
|
FStartedAtIndex: Integer;
|
|
FStartIdx, FMaxIdx: Integer;
|
|
FLastSubListEndAddr: TDBGPtr;
|
|
FAddressToLocate, FAddForLineAfterCounter: TDBGPtr;
|
|
FSublistNumber: Integer;
|
|
public
|
|
constructor Create(AList: TGDBMIDisassembleResultList; AStartIdx: Integer;
|
|
ALastSubListEndAddr: TDBGPtr;
|
|
AnAddressToLocate, AnAddForLineAfterCounter: TDBGPtr);
|
|
function EOL: Boolean;
|
|
function NextSubList(var AResultList: TGDBMIDisassembleResultList): Boolean;
|
|
|
|
// Current SubList
|
|
function IsFirstSubList: Boolean;
|
|
function CurrentFixedAddr(AOffsLimit: Integer): TDBGPtr; // Addr[0] - Offs[0]
|
|
// About the next SubList
|
|
function NextStartAddr: TDBGPtr;
|
|
function NextStartOffs: Integer;
|
|
// Overall
|
|
function CountLinesAfterCounterAddr: Integer; // count up to Start of Current SubList
|
|
|
|
property CurrentIndex: Integer read FCurIdx;
|
|
property NextIndex: Integer read FStartIdx;
|
|
property SublistNumber: Integer read FSublistNumber; // running count of sublists found
|
|
|
|
property StartedAtIndex: Integer read FStartedAtIndex;
|
|
property IndexOfLocateAddress: Integer read FIndexOfLocateAddress;
|
|
property OffsetOfLocateAddress: Integer read FOffsetOfLocateAddress;
|
|
property IndexOfCounterAddress: Integer read FIndexOfCounterAddress;
|
|
property List: TGDBMIDisassembleResultList read FList;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandDisassemble }
|
|
|
|
TGDBMIDisAssAddrRange = record
|
|
FirstAddr, LastAddr: TDBGPtr;
|
|
end;
|
|
|
|
TGDBMIDebuggerCommandDisassemble = class(TGDBMIDebuggerCommand)
|
|
private
|
|
FEndAddr: TDbgPtr;
|
|
FLinesAfter: Integer;
|
|
FLinesBefore: Integer;
|
|
FOnProgress: TNotifyEvent;
|
|
FStartAddr: TDbgPtr;
|
|
FKnownRanges: TDBGDisassemblerEntryMap;
|
|
FRangeIterator: TDBGDisassemblerEntryMapIterator;
|
|
FMemDumpsNeeded: array of TGDBMIDisAssAddrRange;
|
|
procedure DoProgress;
|
|
{$ifndef disassemblernestedproc}
|
|
function AdjustToKnowFunctionStart(var AStartAddr: TDisassemblerAddress): Boolean;
|
|
function DoDisassembleRange(AnEntryRanges: TDBGDisassemblerEntryMap; AFirstAddr, ALastAddr: TDisassemblerAddress; StopAfterAddress: TDBGPtr; StopAfterNumLines: Integer): Boolean;
|
|
function ExecDisassmble(AStartAddr, AnEndAddr: TDbgPtr; WithSrc: Boolean;
|
|
AResultList: TGDBMIDisassembleResultList = nil;
|
|
ACutBeforeEndAddr: Boolean = False): TGDBMIDisassembleResultList;
|
|
function OnCheckCancel: boolean;
|
|
{$endif}
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger; AKnownRanges: TDBGDisassemblerEntryMap;
|
|
AStartAddr, AEndAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer);
|
|
destructor Destroy; override;
|
|
function DebugText: String; override;
|
|
property StartAddr: TDbgPtr read FStartAddr write FStartAddr;
|
|
property EndAddr: TDbgPtr read FEndAddr write FEndAddr;
|
|
property LinesBefore: Integer read FLinesBefore write FLinesBefore;
|
|
property LinesAfter: Integer read FLinesAfter write FLinesAfter;
|
|
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
|
|
end;
|
|
|
|
TGDBMIDisassembler = class(TDBGDisassembler)
|
|
private
|
|
FDisassembleEvalCmdObj: TGDBMIDebuggerCommandDisassemble;
|
|
FLastExecAddr, FCancelledAddr: TDBGPtr;
|
|
FIsCancelled: Boolean;
|
|
procedure DoDisassembleExecuted(Sender: TObject);
|
|
procedure DoDisassembleProgress(Sender: TObject);
|
|
procedure DoDisassembleDestroyed(Sender: TObject);
|
|
protected
|
|
function PrepareEntries(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; override;
|
|
function HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange;AnAddr:
|
|
TDbgPtr; var ALinesBefore, ALinesAfter: Integer): boolean; override;
|
|
public
|
|
procedure Clear; override;
|
|
function PrepareRange(AnAddr: TDbgPtr; ALinesBefore, ALinesAfter: Integer): Boolean; override;
|
|
end;
|
|
|
|
{%endregion ^^^^^ Disassembler ^^^^^ }
|
|
|
|
{%region ***** Threads ***** }
|
|
|
|
{ TGDBMIDebuggerCommandThreads }
|
|
|
|
TGDBMIDebuggerCommandThreads = class(TGDBMIDebuggerCommand)
|
|
private
|
|
FCurrentThreadId: Integer;
|
|
FCurrentThreads: TThreads;
|
|
FSuccess: Boolean;
|
|
FThreads: Array of TThreadEntry;
|
|
function GetThread(AnIndex: Integer): TThreadEntry;
|
|
protected
|
|
function DoExecute: Boolean; override;
|
|
public
|
|
constructor Create(AOwner: TGDBMIDebugger);
|
|
destructor Destroy; override;
|
|
//function DebugText: String; override;
|
|
function Count: Integer;
|
|
property Threads[AnIndex: Integer]: TThreadEntry read GetThread;
|
|
property CurrentThreadId: Integer read FCurrentThreadId;
|
|
property Success: Boolean read FSuccess;
|
|
property CurrentThreads: TThreads read FCurrentThreads write FCurrentThreads;
|
|
end;
|
|
|
|
{ TGDBMIThreads }
|
|
|
|
TGDBMIThreads = class(TThreadsSupplier)
|
|
private
|
|
FGetThreadsCmdObj: TGDBMIDebuggerCommandThreads;
|
|
|
|
function GetDebugger: TGDBMIDebugger;
|
|
procedure ThreadsNeeded;
|
|
procedure CancelEvaluation;
|
|
procedure DoThreadsDestroyed(Sender: TObject);
|
|
procedure DoThreadsFinished(Sender: TObject);
|
|
protected
|
|
property Debugger: TGDBMIDebugger read GetDebugger;
|
|
procedure DoCleanAfterPause; override;
|
|
public
|
|
destructor Destroy; override;
|
|
procedure RequestMasterData; override;
|
|
procedure ChangeCurrentThread(ANewId: Integer); override;
|
|
end;
|
|
|
|
{%endregion ^^^^^ Threads ^^^^^ }
|
|
|
|
{ TGDBStringIterator }
|
|
|
|
TGDBStringIterator=class
|
|
protected
|
|
FDataSize: Integer;
|
|
FReadPointer: Integer;
|
|
FParsableData: String;
|
|
public
|
|
constructor Create(const AParsableData: String);
|
|
function ParseNext(out ADecomposable: Boolean; out APayload: String; out ACharStopper: Char): Boolean;
|
|
end;
|
|
|
|
TGDBMIExceptionInfo = record
|
|
ObjAddr: String;
|
|
Name: String;
|
|
end;
|
|
|
|
{ =========================================================================== }
|
|
{ Some win32 stuff }
|
|
{ =========================================================================== }
|
|
{$IFdef MSWindows}
|
|
var
|
|
DebugBreakAddr: Pointer = nil;
|
|
// use our own version. Win9x doesn't support this, so it is a nice check
|
|
_CreateRemoteThread: function(hProcess: THandle; lpThreadAttributes: Pointer; dwStackSize: DWORD; lpStartAddress: TFNThreadStartRoutine; lpParameter: Pointer; dwCreationFlags: DWORD; var lpThreadId: DWORD): THandle; stdcall = nil;
|
|
|
|
procedure InitWin32;
|
|
var
|
|
hMod: THandle;
|
|
begin
|
|
// Check if we already are initialized
|
|
if DebugBreakAddr <> nil then Exit;
|
|
|
|
// normally you would load a lib, but since kernel32 is
|
|
// always loaded we can use this (and we don't have to free it
|
|
hMod := GetModuleHandle(kernel32);
|
|
if hMod = 0 then Exit; //????
|
|
|
|
DebugBreakAddr := GetProcAddress(hMod, 'DebugBreak');
|
|
Pointer(_CreateRemoteThread) := GetProcAddress(hMod, 'CreateRemoteThread');
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{ =========================================================================== }
|
|
{ Helpers }
|
|
{ =========================================================================== }
|
|
|
|
function CpuNameToPtrSize(const CpuName: String): Integer;
|
|
begin
|
|
//'x86', 'i386', 'i486', 'i586', 'i686',
|
|
//'ia64', 'x86_64', 'powerpc', aarch64
|
|
//'sparc', 'arm'
|
|
Result := 4;
|
|
if (LowerCase(CpuName) = 'ia64') or (LowerCase(CpuName) = 'x86_64') or (LowerCase(CpuName) = 'aarch64')
|
|
then Result := 8;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandRegisterUpdate }
|
|
|
|
function TGDBMIDebuggerCommandRegisterUpdate.DoExecute: Boolean;
|
|
procedure UpdateFormat(AFormat: TRegisterDisplayFormat);
|
|
const
|
|
// rdDefault, rdHex, rdBinary, rdOctal, rdDecimal, rdRaw
|
|
FormatChar : array [TRegisterDisplayFormat] of string =
|
|
('N', 'x', 't', 'o', 'd', 'r');
|
|
var
|
|
i, idx: Integer;
|
|
Num: QWord;
|
|
List, ValList: TGDBMINameValueList;
|
|
Item: PGDBMINameValue;
|
|
RegVal: TRegisterValue;
|
|
RegValObj: TRegisterDisplayValue;
|
|
t: String;
|
|
NumErr: word;
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
if (not ExecuteCommand('-data-list-register-values %s', [FormatChar[AFormat]], R)) or
|
|
(R.State = dsError)
|
|
then begin
|
|
for i := 0 to FRegisters.Count - 1 do
|
|
if FRegisters[i].DataValidity in [ddsRequested, ddsEvaluating] then
|
|
FRegisters[i].DataValidity := ddsInvalid;
|
|
Exit;
|
|
end;
|
|
|
|
ValList := TGDBMINameValueList.Create('');
|
|
List := TGDBMINameValueList.Create(R, ['register-values']);
|
|
for i := 0 to List.Count - 1 do
|
|
begin
|
|
Item := List.Items[i];
|
|
ValList.Init(Item^.Name);
|
|
idx := StrToIntDef(Unquote(ValList.Values['number']), -1);
|
|
if (idx < 0) or (idx > High(FGDBMIRegSupplier.FRegNamesCache)) then Continue;
|
|
RegVal := FRegisters.EntriesByName[FGDBMIRegSupplier.FRegNamesCache[idx]];
|
|
if (RegVal.DataValidity = ddsValid) and (RegVal.HasValueFormat[AFormat]) then continue;
|
|
|
|
t := Unquote(ValList.Values['value']);
|
|
RegValObj := RegVal.ValueObjFormat[AFormat];
|
|
if (AFormat in [rdDefault, rdRaw]) or (RegValObj.SupportedDispFormats = [AFormat]) then
|
|
RegValObj.SetAsText(t);
|
|
Val(t, Num, NumErr);
|
|
if NumErr <> 0 then
|
|
RegValObj.SetAsText(t)
|
|
else
|
|
begin
|
|
RegValObj.SetAsNum(Num, FTheDebugger.TargetPtrSize);
|
|
RegValObj.AddFormats([rdBinary, rdDecimal, rdOctal, rdHex]);
|
|
end;
|
|
if AFormat = RegVal.DisplayFormat then
|
|
RegVal.DataValidity := ddsValid;
|
|
end;
|
|
FreeAndNil(List);
|
|
FreeAndNil(ValList);
|
|
|
|
end;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
i, idx: Integer;
|
|
ChangedRegList: TGDBMINameValueList;
|
|
begin
|
|
Result := True;
|
|
if FRegisters.DataValidity = ddsEvaluating then // in process
|
|
exit;
|
|
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.StackContext := ccUseLocal;
|
|
FContext.ThreadId := FRegisters.ThreadId;
|
|
FContext.StackFrame := FRegisters.StackFrame;
|
|
|
|
FGDBMIRegSupplier.BeginUpdate;
|
|
try
|
|
if length(FGDBMIRegSupplier.FRegNamesCache) = 0 then begin
|
|
if (not ExecuteCommand('-data-list-register-names', R, [cfNoThreadContext, cfNoStackContext])) or
|
|
(R.State = dsError)
|
|
then begin
|
|
if FRegisters.DataValidity in [ddsRequested, ddsEvaluating] then
|
|
FRegisters.DataValidity := ddsInvalid;
|
|
exit;
|
|
end;
|
|
|
|
List := TGDBMINameValueList.Create(R, ['register-names']);
|
|
SetLength(FGDBMIRegSupplier.FRegNamesCache, List.Count);
|
|
for i := 0 to List.Count - 1 do
|
|
FGDBMIRegSupplier.FRegNamesCache[i] := UnQuote(List.GetString(i));
|
|
FreeAndNil(List);
|
|
end;
|
|
|
|
|
|
if FRegisters.DataValidity = ddsRequested then begin
|
|
ChangedRegList := nil;
|
|
if (FRegisters.StackFrame = 0) and // need modified, run before all others
|
|
ExecuteCommand('-data-list-changed-registers', R, [cfscIgnoreError]) and
|
|
(R.State <> dsError)
|
|
then
|
|
ChangedRegList := TGDBMINameValueList.Create(R, ['changed-registers']);
|
|
|
|
// Need all registers
|
|
FRegisters.DataValidity := ddsEvaluating;
|
|
UpdateFormat(rdDefault);
|
|
FRegisters.DataValidity := ddsValid;
|
|
|
|
if ChangedRegList <> nil then begin
|
|
for i := 0 to ChangedRegList.Count - 1 do begin
|
|
idx := StrToIntDef(Unquote(ChangedRegList.GetString(i)), -1);
|
|
if (idx < 0) or (idx > High(FGDBMIRegSupplier.FRegNamesCache)) then Continue;
|
|
FRegisters.EntriesByName[FGDBMIRegSupplier.FRegNamesCache[idx]].Modified := True;
|
|
end;
|
|
FreeAndNil(ChangedRegList);
|
|
end;
|
|
end;
|
|
|
|
// check for individual updates / displayformat
|
|
for i := 0 to FRegisters.Count - 1 do begin
|
|
if not FRegisters[i].HasValue then
|
|
UpdateFormat(FRegisters[i].DisplayFormat);
|
|
end;
|
|
finally
|
|
FGDBMIRegSupplier.EndUpdate;
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandRegisterUpdate.DoCancel;
|
|
begin
|
|
if FRegisters.DataValidity in [ddsRequested, ddsEvaluating] then
|
|
FRegisters.DataValidity := ddsInvalid;
|
|
inherited DoCancel;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandRegisterUpdate.Create(AOwner: TGDBMIDebugger;
|
|
AGDBMIRegSupplier: TGDBMIRegisterSupplier; ARegisters: TRegisters);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FGDBMIRegSupplier := AGDBMIRegSupplier;
|
|
FRegisters := ARegisters;
|
|
FRegisters.AddReference;
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommandRegisterUpdate.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
FRegisters.ReleaseReference;
|
|
end;
|
|
|
|
{ TGDBMIRegisterSupplier }
|
|
|
|
procedure TGDBMIRegisterSupplier.DoStateChange(const AOldState: TDBGState);
|
|
begin
|
|
if not( (AOldState in [dsPause, dsInternalPause]) and (Debugger.State in [dsPause, dsInternalPause]) )
|
|
then
|
|
SetLength(FRegNamesCache, 0);
|
|
inherited DoStateChange(AOldState);
|
|
end;
|
|
|
|
procedure TGDBMIRegisterSupplier.Changed;
|
|
begin
|
|
if CurrentRegistersList <> nil
|
|
then CurrentRegistersList.Clear;
|
|
end;
|
|
|
|
procedure TGDBMIRegisterSupplier.RequestData(ARegisters: TRegisters);
|
|
var
|
|
ForceQueue: Boolean;
|
|
Cmd: TGDBMIDebuggerCommandRegisterUpdate;
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsStop]) then
|
|
exit;
|
|
|
|
Cmd := TGDBMIDebuggerCommandRegisterUpdate.Create(TGDBMIDebugger(Debugger), Self, ARegisters);
|
|
//Cmd.OnExecuted := @DoGetRegisterNamesFinished;
|
|
//Cmd.OnDestroy := @DoGetRegisterNamesDestroyed;
|
|
Cmd.Priority := GDCMD_PRIOR_LOCALS;
|
|
Cmd.Properties := [dcpCancelOnRun];
|
|
ForceQueue := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
|
|
and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
|
|
and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
|
|
and (Debugger.State <> dsInternalPause);
|
|
TGDBMIDebugger(Debugger).QueueCommand(Cmd, ForceQueue);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerChangeFilenameBase }
|
|
|
|
function TGDBMIDebuggerChangeFilenameBase.DoChangeFilename: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
S: String;
|
|
begin
|
|
Result := False;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
//Cleanup our own breakpoints
|
|
FTheDebugger.FExceptionBreak.Clear(Self);
|
|
FTheDebugger.FBreakErrorBreak.Clear(Self);
|
|
FTheDebugger.FRunErrorBreak.Clear(Self);
|
|
FTheDebugger.FPopExceptStack.Clear(Self);
|
|
FTheDebugger.FCatchesBreak.Clear(Self);
|
|
FTheDebugger.FReRaiseBreak.Clear(Self);
|
|
if DebuggerState = dsError then Exit;
|
|
|
|
S := FTheDebugger.ConvertToGDBPath(FTheDebugger.FileName, cgptExeName);
|
|
Result := ExecuteCommand('-file-exec-and-symbols %s', [S], R);
|
|
if not Result then exit;
|
|
{$IFDEF darwin}
|
|
if (R.State = dsError) and (FTheDebugger.FileName <> '')
|
|
then begin
|
|
S := FTheDebugger.FileName + '/Contents/MacOS/' + ExtractFileNameOnly(FTheDebugger.FileName);
|
|
S := FTheDebugger.ConvertToGDBPath(S, cgptExeName);
|
|
Result := ExecuteCommand('-file-exec-and-symbols %s', [S], R);
|
|
if not Result then exit;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
if (R.State = dsError) and (FTheDebugger.FileName <> '')
|
|
then begin
|
|
List := TGDBMINameValueList.Create(R);
|
|
FErrorMsg := DeleteEscapeChars((List.Values['msg']));
|
|
List.Free;
|
|
Result := False;
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerChangeFilenameBase.DoSetPascal: Boolean;
|
|
begin
|
|
Result := True;
|
|
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
// Force setting language
|
|
// Setting extensions dumps GDB (bug #508)
|
|
Result := ExecuteCommand('-gdb-set language pascal', [], [cfCheckError]);
|
|
Result := Result and (DebuggerState <> dsError);
|
|
(*
|
|
ExecuteCommand('-gdb-set extension-language .lpr pascal', False);
|
|
if not FHasSymbols then Exit; // file-exec-and-symbols not allways result in no symbols
|
|
ExecuteCommand('-gdb-set extension-language .lrs pascal', False);
|
|
ExecuteCommand('-gdb-set extension-language .dpr pascal', False);
|
|
ExecuteCommand('-gdb-set extension-language .pas pascal', False);
|
|
ExecuteCommand('-gdb-set extension-language .pp pascal', False);
|
|
ExecuteCommand('-gdb-set extension-language .inc pascal', False);
|
|
*)
|
|
end;
|
|
|
|
{ TGDBMIDbgInstructionQueue }
|
|
|
|
procedure TGDBMIDbgInstructionQueue.HandleGdbDataBeforeInstruction(var AData: String;
|
|
var SkipData: Boolean; const TheInstruction: TGDBInstruction);
|
|
|
|
procedure DoConsoleStream(Line: String);
|
|
begin
|
|
// check for symbol info
|
|
if Pos('no debugging symbols', Line) > 0
|
|
then begin
|
|
Debugger.TargetFlags := Debugger.TargetFlags - [tfHasSymbols];
|
|
Debugger.DoDbgEvent(ecDebugger, etDefault, Format(gdbmiEventLogNoSymbols, [Debugger.FileName]));
|
|
end;
|
|
end;
|
|
|
|
procedure DoLogStream(const Line: String);
|
|
begin
|
|
// check for symbol info
|
|
if Pos('No symbol table is loaded. Use the \"file\" command.', Line) > 0
|
|
then begin
|
|
Debugger.TargetFlags := Debugger.TargetFlags - [tfHasSymbols];
|
|
Debugger.DoDbgEvent(ecDebugger, etDefault,
|
|
Format(gdbmiEventLogNoSymbols, [Debugger.FileName]));
|
|
end;
|
|
|
|
// check internal error
|
|
if (Pos('internal-error:', LowerCase(Line)) > 0) or
|
|
(Pos('internal to gdb has been detected', LowerCase(Line)) > 0) or
|
|
(Pos('further debugging may prove unreliable', LowerCase(Line)) > 0)
|
|
then begin
|
|
Debugger.DoDbgEvent(ecDebugger, etDefault,
|
|
Format(gdbmiEventLogGDBInternalError, [AData]));
|
|
if TGDBMIDebuggerProperties(Debugger.GetProperties).WarnOnInternalError
|
|
then begin
|
|
if Debugger.OnFeedback(Debugger,
|
|
Format(gdbmiGDBInternalError, [LineEnding]),
|
|
Format(gdbmiGDBInternalErrorInfo, [LineEnding, Line, TheInstruction.DebugText]),
|
|
ftWarning, [frOk, frStop]
|
|
) = frStop
|
|
then begin
|
|
try
|
|
Debugger.CancelAllQueued;
|
|
finally
|
|
Debugger.FNeedReset := True;
|
|
Debugger.Stop;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
begin
|
|
if AData <> ''
|
|
then case AData[1] of
|
|
'~': DoConsoleStream(AData);
|
|
//'@': DoTargetStream(AData);
|
|
'&': DoLogStream(AData);
|
|
//'*': DoExecAsync(AData);
|
|
//'+': DoStatusAsync(AData);
|
|
//'=': DoMsgAsync(AData);
|
|
end;
|
|
|
|
inherited HandleGdbDataBeforeInstruction(AData, SkipData, TheInstruction);
|
|
end;
|
|
|
|
function TGDBMIDbgInstructionQueue.Debugger: TGDBMIDebugger;
|
|
begin
|
|
Result := TGDBMIDebugger(inherited Debugger);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerInstruction }
|
|
|
|
function TGDBMIDebuggerInstruction.ProcessInputFromGdb(const AData: String): Boolean;
|
|
|
|
function DoResultRecord(Line: String; CurRes: Boolean): Boolean;
|
|
var
|
|
ResultClass: String;
|
|
OldResult: Boolean;
|
|
begin
|
|
ResultClass := GetPart('^', ',', Line);
|
|
|
|
if Line = ''
|
|
then begin
|
|
if FResultData.Values <> ''
|
|
then Include(FResultData.Flags, rfNoMI);
|
|
end
|
|
else begin
|
|
FResultData.Values := Line;
|
|
end;
|
|
|
|
OldResult := CurRes;
|
|
Result := True;
|
|
case StringCase(ResultClass, ['done', 'running', 'exit', 'error', 'stopped']) of
|
|
0: begin // done
|
|
end;
|
|
1: begin // running
|
|
FResultData.State := dsRun;
|
|
end;
|
|
2: begin // exit
|
|
FResultData.State := dsIdle;
|
|
end;
|
|
3: begin // error
|
|
DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessResult Error: ', Line);
|
|
// todo: implement with values
|
|
if (pos('msg=', Line) > 0)
|
|
and (pos('not being run', Line) > 0)
|
|
then FResultData.State := dsStop
|
|
else FResultData.State := dsError;
|
|
end;
|
|
4: begin
|
|
FCmd.FGotStopped := True;
|
|
//AStoppedParams := Line;
|
|
end;
|
|
else
|
|
//TODO: should that better be dsError ?
|
|
if OldResult and (FResultData.State in [dsError, dsStop]) and
|
|
(copy(ResultClass,1,6) = 'error"')
|
|
then begin
|
|
// Gdb 6.3.5 on Mac, does sometime return a 2nd mis-formatted error line
|
|
// The line seems truncated, it simply is (note the misplaced quote): ^error"
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class (IGNORING): ', ResultClass);
|
|
end
|
|
else begin
|
|
Result := False;
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class: ', ResultClass);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure DoConsoleStream(Line: String);
|
|
var
|
|
len: Integer;
|
|
begin
|
|
// Strip surrounding ~" "
|
|
len := Length(Line) - 3;
|
|
if len < 0 then Exit;
|
|
Line := Copy(Line, 3, len);
|
|
// strip trailing \n (unless it is escaped \\n)
|
|
if (len >= 2) and (Line[len - 1] = '\') and (Line[len] = 'n')
|
|
then begin
|
|
if len = 2
|
|
then Line := LineEnding
|
|
else if Line[len - 2] <> '\'
|
|
then begin
|
|
SetLength(Line, len - 2);
|
|
Line := Line + LineEnding;
|
|
end;
|
|
end;
|
|
|
|
FResultData.Values := FResultData.Values + Line;
|
|
end;
|
|
|
|
procedure DoTargetStream(const Line: String);
|
|
begin
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Target output: ', Line);
|
|
end;
|
|
|
|
procedure DoLogStream(const Line: String);
|
|
//const
|
|
// LogWarning = '&"warning:"';
|
|
begin
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Log output: ', Line);
|
|
if Line = '&"kill\n"'
|
|
then FResultData.State := dsStop
|
|
else if LeftStr(Line, 8) = '&"Error '
|
|
then FResultData.State := dsError;
|
|
if LowerCase(copy(Line, 1, length(FLogWarnings))) = FLogWarnings
|
|
then FInLogWarning := True;
|
|
if FInLogWarning
|
|
then FLogWarnings := FLogWarnings + copy(Line, 3, length(Line)-5) + LineEnding;
|
|
if Line = '&"\n"' then
|
|
FInLogWarning := False;
|
|
end;
|
|
|
|
procedure DoExecAsync(Line: String);
|
|
var
|
|
S: String;
|
|
ct: TThreads;
|
|
i: Integer;
|
|
t: TThreadEntry;
|
|
begin
|
|
S := GetPart(['*'], [','], Line);
|
|
if S = 'running'
|
|
then begin
|
|
if (FCmd.FTheDebugger.Threads.CurrentThreads <> nil)
|
|
then begin
|
|
ct := FCmd.FTheDebugger.Threads.CurrentThreads;
|
|
S := GetPart('thread-id="', '"', Line);
|
|
if s = 'all' then begin
|
|
for i := 0 to ct.Count - 1 do
|
|
ct[i].ThreadState := 'running'; // TODO enum?
|
|
end
|
|
else begin
|
|
S := S + ',';
|
|
while s <> '' do begin
|
|
i := StrToIntDef(GetPart('', ',', s), -1);
|
|
if (s <> '') and (s[1] = ',') then delete(s, 1, 1)
|
|
else begin
|
|
debugln(DBG_WARNINGS, 'GDBMI: Error parsing threads');
|
|
break
|
|
end;
|
|
if i < 0 then Continue;
|
|
t := ct.EntryById[i];
|
|
if t <> nil then
|
|
t.ThreadState := 'running'; // TODO enum?
|
|
end;
|
|
end;
|
|
FCmd.FTheDebugger.Threads.Changed;
|
|
end;
|
|
|
|
FCmd.DoDbgEvent(ecProcess, etProcessStart,
|
|
Format(gdbmiEventLogProcessStart, [FCmd.FTheDebugger.FileName]));
|
|
end
|
|
else
|
|
if S = 'stopped' then begin
|
|
FCmd.FGotStopped := True;
|
|
// StoppedParam ??
|
|
end
|
|
else
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
|
|
end;
|
|
|
|
procedure DoMsgAsync(Line: String);
|
|
var
|
|
S: String;
|
|
i, x: Integer;
|
|
ct: TThreads;
|
|
t: TThreadEntry;
|
|
begin
|
|
S := GetPart('=', ',', Line, False, False);
|
|
x := StringCase(S, ['thread-created', 'thread-exited', 'thread-group-started']);
|
|
case x of // thread-group-exited // thread-group-added,id="i1"
|
|
0,1: begin
|
|
i := StrToIntDef(GetPart(',id="', '"', Line, False, False), -1);
|
|
if (i > 0) and (FCmd.FTheDebugger.Threads.CurrentThreads <> nil)
|
|
then begin
|
|
ct := FCmd.FTheDebugger.Threads.CurrentThreads;
|
|
t := ct.EntryById[i];
|
|
case x of
|
|
0: begin
|
|
if t = nil then begin
|
|
t := ct.CreateEntry(0, nil, '', '', '', 0, i, '', 'unknown');
|
|
ct.Add(t);
|
|
t.Free;
|
|
end
|
|
else
|
|
debugln(DBG_WARNINGS, 'GDBMI: Duplicate thread');
|
|
end;
|
|
1: begin
|
|
if t <> nil then begin
|
|
ct.Remove(t);
|
|
end
|
|
else
|
|
debugln(DBG_WARNINGS, 'GDBMI: Missing thread');
|
|
end;
|
|
end;
|
|
FCmd.FTheDebugger.Threads.Changed;
|
|
end;
|
|
end;
|
|
2: begin // thread-group-started // needed in RunToMain
|
|
// Todo, store in seperate field
|
|
if FCmd is TGDBMIDebuggerCommandStartDebugging then
|
|
FLogWarnings := FLogWarnings + Line + LineEnding;
|
|
end;
|
|
end;
|
|
|
|
FCmd.FTheDebugger.DoNotifyAsync(Line);
|
|
end;
|
|
|
|
procedure DoStatusAsync(const Line: String);
|
|
begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
|
|
end;
|
|
|
|
begin
|
|
Result := True;
|
|
FFullCmdReply := FFullCmdReply + AData + LineEnding;
|
|
if AData = '(gdb) ' then begin
|
|
MarkAsSuccess;
|
|
exit;
|
|
end;
|
|
//if (AData = '^exit') and (FCmd = '-gdb-exit') then begin
|
|
// // no (gdb) expected
|
|
// MarkAsSuccess;
|
|
//end;
|
|
|
|
if AData <> '' then begin
|
|
if AData[1] <> '&' then
|
|
FInLogWarning := False;
|
|
case AData[1] of
|
|
'^': FHasResult := DoResultRecord(AData, Result);
|
|
'~': DoConsoleStream(AData);
|
|
'@': DoTargetStream(AData);
|
|
'&': DoLogStream(AData);
|
|
'*': DoExecAsync(AData);
|
|
'+': DoStatusAsync(AData);
|
|
'=': DoMsgAsync(AData);
|
|
else
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown record: ', AData);
|
|
end;
|
|
end;
|
|
{$IFDEF VerboseIDEToDo}{$message warning condition should also check end-of-file reached for process output stream}{$ENDIF}
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerInstruction.HandleNoGdbRunning;
|
|
begin
|
|
if FHasResult and (Command = '-gdb-exit') then begin
|
|
// no (gdb) expected
|
|
MarkAsSuccess;
|
|
end
|
|
else
|
|
inherited HandleNoGdbRunning;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerInstruction.HandleReadError;
|
|
begin
|
|
if FHasResult and (Command = '-gdb-exit') then begin
|
|
// no (gdb) expected
|
|
MarkAsSuccess;
|
|
end
|
|
else
|
|
inherited HandleReadError;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerInstruction.HandleTimeOut;
|
|
begin
|
|
if FHasResult and (Command = '-gdb-exit') then begin
|
|
// no (gdb) expected
|
|
MarkAsSuccess;
|
|
end
|
|
else
|
|
inherited HandleTimeOut;
|
|
end;
|
|
|
|
function TGDBMIDebuggerInstruction.GetTimeOutVerifier: TGDBInstruction;
|
|
begin
|
|
if FHasResult and (Command = '-gdb-exit') then
|
|
Result := nil
|
|
else
|
|
Result := inherited GetTimeOutVerifier;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerInstruction.Init;
|
|
begin
|
|
inherited Init;
|
|
FHasResult := False;
|
|
FResultData.Values := '';
|
|
FResultData.Flags := [];
|
|
FResultData.State := dsNone;
|
|
FFullCmdReply := '';
|
|
FLogWarnings := '';
|
|
FInLogWarning := False;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStartBase }
|
|
|
|
procedure TGDBMIDebuggerCommandStartBase.SetTargetInfo(const AFileType: String);
|
|
var
|
|
FoundPtrSize, UseWin64ABI: Boolean;
|
|
begin
|
|
UseWin64ABI := False;
|
|
// assume some defaults
|
|
TargetInfo^.TargetPtrSize := GetIntValue('sizeof(%s)', [PointerTypeCast]);
|
|
FoundPtrSize := (FLastExecResult.State <> dsError) and (TargetInfo^.TargetPtrSize > 0);
|
|
if not FoundPtrSize
|
|
then TargetInfo^.TargetPtrSize := 4;
|
|
TargetInfo^.TargetIsBE := False;
|
|
|
|
case StringCase(AFileType, [
|
|
'efi-app-ia32', 'elf32-i386', 'pei-i386', 'elf32-i386-freebsd',
|
|
'elf64-x86-64', 'pei-x86-64',
|
|
'mach-o-be',
|
|
'mach-o-le',
|
|
'pei-arm-little',
|
|
'pei-arm-big',
|
|
'elf64-littleaarch64',
|
|
'elf64-bigaarch64'
|
|
], True, False) of
|
|
0..3: TargetInfo^.TargetCPU := 'x86';
|
|
4: TargetInfo^.TargetCPU := 'x86_64'; //TODO: should we check, PtrSize must be 8, but what if not?
|
|
5: begin
|
|
TargetInfo^.TargetCPU := 'x86_64'; //TODO: should we check, PtrSize must be 8, but what if not?
|
|
UseWin64ABI := True;
|
|
end;
|
|
6: begin
|
|
//mach-o-be
|
|
TargetInfo^.TargetIsBE := True;
|
|
if FTheDebugger.FGDBCPU <> ''
|
|
then TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU
|
|
else TargetInfo^.TargetCPU := 'powerpc'; // guess
|
|
end;
|
|
7: begin
|
|
//mach-o-le
|
|
if FoundPtrSize then begin
|
|
if FTheDebugger.FGDBPtrSize = TargetInfo^.TargetPtrSize
|
|
then TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU
|
|
else // guess
|
|
case TargetInfo^.TargetPtrSize of
|
|
4: TargetInfo^.TargetCPU := 'x86'; // guess
|
|
8: TargetInfo^.TargetCPU := 'x86_64'; // guess
|
|
else TargetInfo^.TargetCPU := 'x86'; // guess
|
|
end
|
|
end
|
|
else begin
|
|
if FTheDebugger.FGDBCPU <> ''
|
|
then TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU
|
|
else TargetInfo^.TargetCPU := 'x86'; // guess
|
|
end;
|
|
end;
|
|
8: begin
|
|
TargetInfo^.TargetCPU := 'arm';
|
|
end;
|
|
9: begin
|
|
TargetInfo^.TargetIsBE := True;
|
|
TargetInfo^.TargetCPU := 'arm';
|
|
end;
|
|
10: begin
|
|
TargetInfo^.TargetCPU := 'aarch64';
|
|
end;
|
|
11: begin
|
|
TargetInfo^.TargetIsBE := True;
|
|
TargetInfo^.TargetCPU := 'aarch64';
|
|
end;
|
|
else
|
|
// Unknown filetype, use GDB cpu
|
|
DebugLn(DBG_WARNINGS, '[WARNING] [Debugger.TargetInfo] Unknown FileType: %s, using GDB cpu', [AFileType]);
|
|
|
|
TargetInfo^.TargetCPU := FTheDebugger.FGDBCPU;
|
|
// Todo: check PtrSize and downgrade 64 bit cpu to 32 bit cpu, if required
|
|
end;
|
|
|
|
if not FoundPtrSize
|
|
then TargetInfo^.TargetPtrSize := CpuNameToPtrSize(TargetInfo^.TargetCPU);
|
|
|
|
case StringCase(TargetInfo^.TargetCPU, [
|
|
'x86', 'i386', 'i486', 'i586', 'i686',
|
|
'ia64', 'x86_64', 'powerpc',
|
|
'sparc', 'arm', 'aarch64'
|
|
], True, False) of
|
|
0..4: begin // x86
|
|
TargetInfo^.TargetRegisters[0] := '$eax';
|
|
TargetInfo^.TargetRegisters[1] := '$edx';
|
|
TargetInfo^.TargetRegisters[2] := '$ecx';
|
|
end;
|
|
5, 6: begin // ia64, x86_64
|
|
if TargetInfo^.TargetPtrSize = 4
|
|
then begin
|
|
TargetInfo^.TargetRegisters[0] := '$eax';
|
|
TargetInfo^.TargetRegisters[1] := '$edx';
|
|
TargetInfo^.TargetRegisters[2] := '$ecx';
|
|
end
|
|
else if UseWin64ABI
|
|
then begin
|
|
TargetInfo^.TargetRegisters[0] := '$rcx';
|
|
TargetInfo^.TargetRegisters[1] := '$rdx';
|
|
TargetInfo^.TargetRegisters[2] := '$r8';
|
|
end else
|
|
begin
|
|
TargetInfo^.TargetRegisters[0] := '$rdi';
|
|
TargetInfo^.TargetRegisters[1] := '$rsi';
|
|
TargetInfo^.TargetRegisters[2] := '$rdx';
|
|
end;
|
|
end;
|
|
7: begin // powerpc
|
|
TargetInfo^.TargetIsBE := True;
|
|
// alltough darwin can start with r2, it seems that all OS start with r3
|
|
// if UpperCase(FTargetInfo.TargetOS) = 'DARWIN'
|
|
// then begin
|
|
// FTargetInfo.TargetRegisters[0] := '$r2';
|
|
// FTargetInfo.TargetRegisters[1] := '$r3';
|
|
// FTargetInfo.TargetRegisters[2] := '$r4';
|
|
// end
|
|
// else begin
|
|
TargetInfo^.TargetRegisters[0] := '$r3';
|
|
TargetInfo^.TargetRegisters[1] := '$r4';
|
|
TargetInfo^.TargetRegisters[2] := '$r5';
|
|
// end;
|
|
end;
|
|
8: begin // sparc
|
|
TargetInfo^.TargetIsBE := True;
|
|
TargetInfo^.TargetRegisters[0] := '$g1';
|
|
TargetInfo^.TargetRegisters[1] := '$o0';
|
|
TargetInfo^.TargetRegisters[2] := '$o1';
|
|
end;
|
|
9: begin // arm
|
|
TargetInfo^.TargetRegisters[0] := '$r0';
|
|
TargetInfo^.TargetRegisters[1] := '$r1';
|
|
TargetInfo^.TargetRegisters[2] := '$r2';
|
|
end;
|
|
10: begin // aarch64
|
|
//TargetInfo^.TargetRegisters[0] := '$r0';
|
|
//TargetInfo^.TargetRegisters[1] := '$r1';
|
|
//TargetInfo^.TargetRegisters[2] := '$r2';
|
|
TargetInfo^.TargetRegisters[0] := '$x0';
|
|
TargetInfo^.TargetRegisters[1] := '$x1';
|
|
TargetInfo^.TargetRegisters[2] := '$x2';
|
|
end;
|
|
else
|
|
TargetInfo^.TargetRegisters[0] := '';
|
|
TargetInfo^.TargetRegisters[1] := '';
|
|
TargetInfo^.TargetRegisters[2] := '';
|
|
DebugLn(DBG_WARNINGS, '[WARNING] [Debugger] Unknown target CPU: ', TargetInfo^.TargetCPU);
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandStartBase.CheckFunction(const AFunction: String
|
|
): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
idx: Integer;
|
|
begin
|
|
ExecuteCommand('info functions %s', [AFunction], R, [cfCheckState]);
|
|
idx := Pos(AFunction, R.Values);
|
|
if idx <> 0
|
|
then begin
|
|
// Strip first
|
|
Delete(R.Values, 1, idx + Length(AFunction) - 1);
|
|
idx := Pos(AFunction, R.Values);
|
|
end;
|
|
Result := idx <> 0;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStartBase.RetrieveRegcall;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
// Assume it is
|
|
Include(TargetInfo^.TargetFlags, tfRTLUsesRegCall);
|
|
|
|
ExecuteCommand('-data-evaluate-expression FPC_THREADVAR_RELOCATE_PROC', R);
|
|
if R.State <> dsError then Exit; // guessed right
|
|
|
|
// next attempt, posibly no symbols, try functions
|
|
if CheckFunction('FPC_CPUINIT') then Exit; // function present --> not 1.0
|
|
|
|
// this runerror is only defined for < 1.1 ?
|
|
if not CheckFunction('$$_RUNERROR$') then Exit;
|
|
|
|
// We are here in 2 cases
|
|
// 1) there are no symbols at all
|
|
// We do not have to know the calling convention
|
|
// 2) target is compiled with an earlier version than 1.9.2
|
|
// params are passes by stack
|
|
Exclude(TargetInfo^.TargetFlags, tfRTLUsesRegCall);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStartBase.CheckAvailableTypes;
|
|
var
|
|
HadTimeout: Boolean;
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
// collect timeouts
|
|
HadTimeout := False;
|
|
// check whether we need class cast dereference
|
|
R := CheckHasType('TObject', tfFlagHasTypeObject);
|
|
HadTimeout := HadTimeout and LastExecwasTimeOut;
|
|
if R.State <> dsError
|
|
then begin
|
|
if UpperCase(LeftStr(R.Values, 15)) = UpperCase('type = ^TOBJECT')
|
|
then include(TargetInfo^.TargetFlags, tfClassIsPointer);
|
|
end;
|
|
R := CheckHasType('Exception', tfFlagHasTypeException);
|
|
HadTimeout := HadTimeout and LastExecwasTimeOut;
|
|
if R.State <> dsError
|
|
then begin
|
|
if UpperCase(LeftStr(R.Values, 17)) = UpperCase('type = ^EXCEPTION')
|
|
then include(TargetInfo^.TargetFlags, tfExceptionIsPointer);
|
|
end;
|
|
CheckHasType('Shortstring', tfFlagHasTypeShortstring);
|
|
HadTimeout := HadTimeout and LastExecwasTimeOut;
|
|
//CheckHasType('PShortstring', tfFlagHasTypePShortString);
|
|
//HadTimeout := HadTimeout and LastExecwasTimeOut;
|
|
CheckHasType('pointer', tfFlagHasTypePointer);
|
|
HadTimeout := HadTimeout and LastExecwasTimeOut;
|
|
CheckHasType('byte', tfFlagHasTypeByte);
|
|
HadTimeout := HadTimeout and LastExecwasTimeOut;
|
|
//CheckHasType('char', tfFlagHasTypeChar);
|
|
//HadTimeout := HadTimeout and LastExecwasTimeOut;
|
|
|
|
if HadTimeout then DoTimeoutFeedback;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStartBase.DetectForceableBreaks;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
if DebuggerProperties.DisableForcedBreakpoint then
|
|
exit;
|
|
|
|
if not (dfForceBreakDetected in FTheDebugger.FDebuggerFlags) then begin
|
|
// detect if we can insert a not yet known break
|
|
ExecuteCommand('-break-insert -f foo', R);
|
|
if R.State <> dsError
|
|
then begin
|
|
Include(FTheDebugger.FDebuggerFlags, dfForceBreak);
|
|
List := TGDBMINameValueList.Create(R, ['bkpt']);
|
|
ExecuteCommand('-break-delete ' + List.Values['number']);
|
|
List.Free;
|
|
end
|
|
else Exclude(FTheDebugger.FDebuggerFlags, dfForceBreak);
|
|
Include(FTheDebugger.FDebuggerFlags, dfForceBreakDetected);
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStartBase.CommonInit;
|
|
var
|
|
i: TGDBMIExecCommandType;
|
|
begin
|
|
for i := low(TGDBMIExecCommandType) to high(TGDBMIExecCommandType) do begin
|
|
FTheDebugger.FCommandAsyncState[i] := True;
|
|
FTheDebugger.FCommandNoneMiState[i] := DebuggerProperties.UseNoneMiRunCommands = gdnmAlways;
|
|
end;
|
|
FTheDebugger.FCurrentCmdIsAsync := False;
|
|
ExecuteCommand('set print elements %d',
|
|
[TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties).MaxDisplayLengthForString],
|
|
[]);
|
|
|
|
if DebuggerProperties.DisableLoadSymbolsForLibraries then begin
|
|
ExecuteCommand('set auto-solib-add off', [cfscIgnoreState, cfscIgnoreError]);
|
|
FTheDebugger.FWasDisableLoadSymbolsForLibraries := True;
|
|
end
|
|
else begin
|
|
// Only unset, if it was set due to this property
|
|
if FTheDebugger.FWasDisableLoadSymbolsForLibraries then
|
|
ExecuteCommand('set auto-solib-add on', [cfscIgnoreState, cfscIgnoreError]);
|
|
FTheDebugger.FWasDisableLoadSymbolsForLibraries := False;
|
|
end;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandExecuteBase }
|
|
|
|
function TGDBMIDebuggerCommandExecuteBase.ProcessRunning(out AStoppedParams: String; out
|
|
AResult: TGDBMIExecResult; ATimeOut: Integer): Boolean;
|
|
var
|
|
InLogWarning: Boolean;
|
|
|
|
function DoExecAsync(var Line: String): Boolean;
|
|
var
|
|
S: String;
|
|
i: Integer;
|
|
ct: TThreads;
|
|
t: TThreadEntry;
|
|
begin
|
|
Result := False;
|
|
S := GetPart('*', ',', Line);
|
|
case StringCase(S, ['stopped', 'started', 'disappeared', 'running']) of
|
|
0: begin // stopped
|
|
AStoppedParams := Line;
|
|
FGotStopped := True;
|
|
end;
|
|
1: ; // Known, but undocumented classes
|
|
2: FGotStopped := True;
|
|
3: begin // running,thread-id="1" // running,thread-id="all"
|
|
if (FTheDebugger.Threads.CurrentThreads <> nil)
|
|
then begin
|
|
ct := FTheDebugger.Threads.CurrentThreads;
|
|
S := GetPart('thread-id="', '"', Line);
|
|
if s = 'all' then begin
|
|
for i := 0 to ct.Count - 1 do
|
|
ct[i].ThreadState := 'running'; // TODO enum?
|
|
end
|
|
else begin
|
|
S := S + ',';
|
|
while s <> '' do begin
|
|
i := StrToIntDef(GetPart('', ',', s), -1);
|
|
if (s <> '') and (s[1] = ',') then delete(s, 1, 1)
|
|
else begin
|
|
debugln(DBG_WARNINGS, 'GDBMI: Error parsing threads');
|
|
break
|
|
end;
|
|
if i < 0 then Continue;
|
|
t := ct.EntryById[i];
|
|
if t <> nil then
|
|
t.ThreadState := 'running'; // TODO enum?
|
|
end;
|
|
end;
|
|
FTheDebugger.Threads.Changed;
|
|
end;
|
|
end;
|
|
else
|
|
// Assume targetoutput, strip char and continue
|
|
DebugLn(DBG_VERBOSE, '[DBGTGT] *');
|
|
Line := S + Line;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
procedure DoMsgAsync(var Line: String);
|
|
var
|
|
S: String;
|
|
i, x: Integer;
|
|
ct: TThreads;
|
|
t: TThreadEntry;
|
|
begin
|
|
S := GetPart('=', ',', Line, False, False);
|
|
x := StringCase(S, ['thread-created', 'thread-exited']);
|
|
case x of // thread-group-exited // thread-group-added,id="i1"
|
|
0,1: begin
|
|
i := StrToIntDef(GetPart(',id="', '"', Line, False, False), -1);
|
|
if (i > 0) and (FTheDebugger.Threads.CurrentThreads <> nil)
|
|
then begin
|
|
ct := FTheDebugger.Threads.CurrentThreads;
|
|
t := ct.EntryById[i];
|
|
case x of
|
|
0: begin
|
|
if t = nil then begin
|
|
t := FTheDebugger.Threads.CurrentThreads.CreateEntry(0, nil, '', '', '', 0, i, '', 'unknown');
|
|
ct.Add(t);
|
|
t.Free;
|
|
end
|
|
else
|
|
debugln(DBG_WARNINGS, 'GDBMI: Duplicate thread');
|
|
end;
|
|
1: begin
|
|
if t <> nil then begin
|
|
ct.Remove(t);
|
|
end
|
|
else
|
|
debugln(DBG_WARNINGS, 'GDBMI: Missing thread');
|
|
end;
|
|
end;
|
|
FTheDebugger.Threads.Changed;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
FTheDebugger.DoNotifyAsync(Line);
|
|
end;
|
|
|
|
procedure DoStatusAsync(const Line: String);
|
|
begin
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Status output: ', Line);
|
|
end;
|
|
|
|
procedure DoResultRecord(Line: String);
|
|
var
|
|
ResultClass: String;
|
|
begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: unexpected result-record: ', Line);
|
|
|
|
ResultClass := GetPart('^', ',', Line);
|
|
if Line = ''
|
|
then begin
|
|
if AResult.Values <> ''
|
|
then Include(AResult.Flags, rfNoMI);
|
|
end
|
|
else begin
|
|
AResult.Values := Line;
|
|
end;
|
|
|
|
//Result := True;
|
|
case StringCase(ResultClass, ['done', 'running', 'exit', 'error']) of
|
|
0: begin // done
|
|
AResult.State := dsIdle; // just indicate a ressult <> dsNone
|
|
end;
|
|
1: begin // running
|
|
AResult.State := dsRun;
|
|
end;
|
|
2: begin // exit
|
|
AResult.State := dsIdle;
|
|
end;
|
|
3: begin // error
|
|
DebugLn(DBG_WARNINGS, 'TGDBMIDebugger.ProcessRunning Error: ', Line);
|
|
// todo: implement with values
|
|
if (pos('msg=', Line) > 0)
|
|
and (pos('not being run', Line) > 0)
|
|
then AResult.State := dsStop
|
|
else AResult.State := dsError;
|
|
end;
|
|
else
|
|
//TODO: should that better be dsError ?
|
|
//Result := False;
|
|
AResult.State := dsIdle; // just indicate a ressult <> dsNone
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown result class: ', ResultClass);
|
|
end;
|
|
end;
|
|
|
|
procedure DoConsoleStream(const Line: String);
|
|
begin
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Console output: ', Line);
|
|
end;
|
|
|
|
procedure DoTargetStream(const Line: String);
|
|
begin
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Target output: ', Line);
|
|
end;
|
|
|
|
procedure DoLogStream(const Line: String);
|
|
const
|
|
LogWarning = 'warning:';
|
|
var
|
|
Warning: String;
|
|
begin
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Log output: ', Line);
|
|
Warning := Line;
|
|
if Copy(Warning, 1, 2) = '&"' then
|
|
Delete(Warning, 1, 2);
|
|
if Copy(Warning, Length(Warning) - 2, 3) = '\n"' then
|
|
Delete(Warning, Length(Warning) - 2, 3);
|
|
if LowerCase(Copy(Warning, 1, Length(LogWarning))) = LogWarning then
|
|
begin
|
|
InLogWarning := True;
|
|
Delete(Warning, 1, Length(LogWarning));
|
|
Warning := MakePrintable(UnEscapeBackslashed(Trim(Warning), [uefOctal, uefTab, uefNewLine]));
|
|
DoDbgEvent(ecOutput, etOutputDebugString, Format(gdbmiEventLogDebugOutput, [Warning]));
|
|
end;
|
|
if InLogWarning then
|
|
FLogWarnings := FLogWarnings + Warning + LineEnding;
|
|
if Line = '&"\n"' then
|
|
InLogWarning := False;
|
|
(*
|
|
<< TCmdLineDebugger.ReadLn "&"Warning:\n""
|
|
<< TCmdLineDebugger.ReadLn "&"Cannot insert breakpoint 11.\n""
|
|
<< TCmdLineDebugger.ReadLn "&"Error accessing memory address 0x760: Input/output error.\n""
|
|
<< TCmdLineDebugger.ReadLn "&"\n""
|
|
|
|
|
|
<< TCmdLineDebugger.ReadLn "&"warning: Bad debug information detected: Attempt to read 592 bytes from registers.\n""
|
|
<< TCmdLineDebugger.ReadLn "^done,stack-args=[frame={level="5",args=[{name="ADDR",value="131"},{name="FUNC",value="']A'#0#131#0#0#0'l'#248#202#7#156#248#202#7#132#245#202#7#140#245#202#7'2kA'#0#6#2#0#0#27#0#0#0'#'#0#0#0'#'#0#0#0" ..(493).. ",{name="PTEXT",value="<value optimized out>"}]},frame={level="8",args=[]},frame={level="9",args=[]}]"
|
|
|
|
*)
|
|
end;
|
|
|
|
var
|
|
S: String;
|
|
idx: Integer;
|
|
begin
|
|
Result := True;
|
|
AResult.State := dsNone;
|
|
InLogWarning := False;
|
|
FGotStopped := False;
|
|
FLogWarnings := '';
|
|
AStoppedParams := '';
|
|
while FTheDebugger.DebugProcessRunning and not(FTheDebugger.State in [dsError, dsDestroying]) do
|
|
begin
|
|
if ATimeOut > 0 then begin
|
|
S := FTheDebugger.ReadLine(ATimeOut);
|
|
if FTheDebugger.ReadLineTimedOut then begin
|
|
FProcessResultTimedOut := True;
|
|
break;
|
|
end;
|
|
end
|
|
else
|
|
S := FTheDebugger.ReadLine(50);
|
|
|
|
if (S = '(gdb) ') or
|
|
( (S = '') and FDidKillNow )
|
|
then
|
|
Break;
|
|
|
|
while S <> '' do
|
|
begin
|
|
if S[1] <> '&' then
|
|
InLogWarning := False;
|
|
case S[1] of
|
|
'^': DoResultRecord(S);
|
|
'~': DoConsoleStream(S);
|
|
'@': DoTargetStream(S);
|
|
'&': DoLogStream(S);
|
|
'*': if DoExecAsync(S) then Continue;
|
|
'+': DoStatusAsync(S);
|
|
'=': DoMsgAsync(S);
|
|
else
|
|
// since target output isn't prefixed (yet?)
|
|
// one of our known commands could be part of it.
|
|
idx := Pos('*stopped', S);
|
|
if idx > 0
|
|
then begin
|
|
DebugLn(DBG_VERBOSE, '[DBGTGT] ', Copy(S, 1, idx - 1));
|
|
Delete(S, 1, idx - 1);
|
|
FGotStopped := True;
|
|
Continue;
|
|
end
|
|
else begin
|
|
// normal target output
|
|
DebugLn(DBG_VERBOSE, '[DBGTGT] ', S);
|
|
end;
|
|
end;
|
|
Break;
|
|
end;
|
|
|
|
if FTheDebugger.FAsyncModeEnabled and FGotStopped then begin
|
|
// There should not be a "(gdb) ",
|
|
// but some versions print it, as they run none async, after accepting "run &"
|
|
S := FTheDebugger.ReadLine(True, 50);
|
|
if FTheDebugger.ReadLineTimedOut then break;
|
|
if (S = '(gdb) ') then begin
|
|
FTheDebugger.ReadLine(50); // read the extra "(gdb) "
|
|
break;
|
|
end;
|
|
// since no command was sent, we can loop
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandExecuteBase.ParseBreakInsertError(var AText: String; out
|
|
AnId: Integer): Boolean;
|
|
const
|
|
BreaKErrMsg = 'not insert breakpoint ';
|
|
WatchErrMsg = 'not insert hardware watchpoint ';
|
|
var
|
|
i, i2, j: Integer;
|
|
begin
|
|
Result := False;
|
|
AnId := -1;
|
|
|
|
i := pos(BreaKErrMsg, AText);
|
|
if i > 0
|
|
then j := i + length(BreaKErrMsg);
|
|
i2 := pos(WatchErrMsg, AText);
|
|
if (i2 > 0) and ( (i2 < i) or (i < 1) )
|
|
then begin
|
|
i := i2;
|
|
j := i + length(WatchErrMsg);
|
|
end;
|
|
|
|
if i <= 0 then exit;
|
|
|
|
i2 := j;
|
|
while (i2 <= length(AText)) and (AText[i2] in ['0'..'9']) do inc(i2);
|
|
if i2 > j then
|
|
AnId := StrToIntDef(copy(AText, j, i2-j), -1);
|
|
|
|
Delete(AText, i, i2 - i);
|
|
Result := True;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandExecuteBase.ProcessStopped(const AParams: String;
|
|
const AIgnoreSigIntState: Boolean): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandExecuteBase.Create(AOwner: TGDBMIDebugger);
|
|
begin
|
|
FCanKillNow := False;
|
|
inherited Create(AOwner);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandExecuteBase.KillNow: Boolean;
|
|
var
|
|
StoppedParams: String;
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Result := False;
|
|
if not FCanKillNow then exit;
|
|
// only here, if we are in ProcessRunning
|
|
FDidKillNow := True; // interrupt current ProcessRunning
|
|
FCanKillNow := False; // Do not allow to re-enter
|
|
|
|
FTheDebugger.GDBPause(True);
|
|
FTheDebugger.CancelAllQueued; // before ProcessStopped
|
|
FDidKillNow := False; // allow ProcessRunning
|
|
Result := ProcessRunning(StoppedParams, R, 1500);
|
|
if ProcessResultTimedOut then begin
|
|
// the outer Processrunning should stop, due to process no longer running
|
|
FDidKillNow := True;
|
|
FTheDebugger.TerminateGDB;
|
|
FTheDebugger.FNeedReset:= True;
|
|
SetDebuggerState(dsStop);
|
|
//FTheDebugger.CancelAllQueued; // stop queued new cmd
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
FDidKillNow := True;
|
|
if StoppedParams <> ''
|
|
then ProcessStopped(StoppedParams, FTheDebugger.PauseWaitState = pwsInternal);
|
|
FTheDebugger.FPauseWaitState := pwsNone;
|
|
|
|
ExecuteCommand('kill', [cfNoThreadContext], 1500);
|
|
FTheDebugger.FCurrentStackFrameValid := False;
|
|
FTheDebugger.FCurrentThreadIdValid := False;
|
|
Result := ExecuteCommand('info program', R, [cfNoThreadContext], 1500);
|
|
Result := Result and (Pos('not being run', R.Values) > 0);
|
|
if Result
|
|
then SetDebuggerState(dsStop);
|
|
|
|
// Now give the ProcessRunning in the current DoExecute something
|
|
//FTheDebugger.SendCmdLn('print 1');
|
|
end;
|
|
|
|
|
|
function TGDBMIDebugger.ConvertToGDBPath(APath: string; ConvType: TConvertToGDBPathType = cgptNone): string;
|
|
// GDB wants forward slashes in its filenames, even on win32.
|
|
var
|
|
esc: TGDBMIDebuggerFilenameEncoding;
|
|
begin
|
|
Result := UTF8ToWinCP(APath);
|
|
// no need to process empty filename
|
|
if Result = '' then exit;
|
|
|
|
case ConvType of
|
|
cgptNone: esc := gdfeNone;
|
|
cgptCurDir:
|
|
begin
|
|
esc := TGDBMIDebuggerPropertiesBase(GetProperties).FEncodeCurrentDirPath;
|
|
//TODO: check FGDBOS
|
|
//Unix/Windows can use gdfeEscSpace, but work without too;
|
|
{$IFDEF darwin}
|
|
if esc = gdfeDefault then
|
|
if (FGDBVersionMajor >= 7) and (FGDBVersionMinor >= 0)
|
|
then esc := gdfeNone
|
|
else esc := gdfeQuote;
|
|
{$ELSE}
|
|
if esc = gdfeDefault then esc := gdfeNone;
|
|
{$ENDIF}
|
|
end;
|
|
cgptExeName:
|
|
begin
|
|
esc := TGDBMIDebuggerPropertiesBase(GetProperties).FEncodeExeFileName;
|
|
//Unix/Windows can use gdfeEscSpace, but work without too;
|
|
{$IFDEF darwin}
|
|
if esc = gdfeDefault then
|
|
if (FGDBVersionMajor >= 7) and (FGDBVersionMinor >= 0)
|
|
then esc := gdfeNone
|
|
else esc := gdfeEscSpace;
|
|
{$ELSE}
|
|
if esc = gdfeDefault then esc := gdfeNone;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
{$WARNINGS off}
|
|
if DirectorySeparator <> '/' then
|
|
Result := StringReplace(Result, DirectorySeparator, '/', [rfReplaceAll]);
|
|
{$WARNINGS on}
|
|
if esc = gdfeEscSpace
|
|
then Result := StringReplace(Result, ' ', '\ ', [rfReplaceAll]);
|
|
if esc = gdfeQuote
|
|
then Result := '\"' + Result + '\"';
|
|
Result := '"' + Result + '"';
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandChangeFilename }
|
|
|
|
function TGDBMIDebuggerCommandChangeFilename.DoExecute: Boolean;
|
|
begin
|
|
Result := True;
|
|
FSuccess := DoChangeFilename;
|
|
if not FSuccess then exit;
|
|
|
|
if FFileName = '' then exit;
|
|
FSuccess := DoSetPascal;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandChangeFilename.Create(AOwner: TGDBMIDebugger;
|
|
AFileName: String);
|
|
begin
|
|
FFileName := AFileName;
|
|
inherited Create(AOwner);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandInitDebugger }
|
|
|
|
function TGDBMIDebuggerCommandInitDebugger.DoExecute: Boolean;
|
|
function StoreGdbVersionAsNumber: Boolean;
|
|
var
|
|
i: Integer;
|
|
s: String;
|
|
begin
|
|
FTheDebugger.FGDBVersionMajor := -1;
|
|
FTheDebugger.FGDBVersionMinor := -1;
|
|
FTheDebugger.FGDBVersionRev := -1;
|
|
s := FTheDebugger.FGDBVersion;
|
|
Result := False;
|
|
// remove none leading digits
|
|
i := 1;
|
|
while (i <= Length(s)) and not (s[i] in ['0'..'9']) do inc(i);
|
|
Delete(s,1,i-1);
|
|
if s = '' then exit;
|
|
FTheDebugger.FGDBVersion := s;
|
|
// Major
|
|
i := 1;
|
|
while (i <= Length(s)) and (s[i] in ['0'..'9']) do inc(i);
|
|
if (i = 1) or (i > Length(s)) or (s[i] <> '.') then exit;
|
|
FTheDebugger.FGDBVersionMajor := StrToIntDef(copy(s,1,i-1), -1);
|
|
if i < 0 then exit;
|
|
Delete(s,1,i);
|
|
// Minor
|
|
i := 1;
|
|
while (i <= Length(s)) and (s[i] in ['0'..'9']) do inc(i);
|
|
if (i = 1) then exit;
|
|
FTheDebugger.FGDBVersionMinor := StrToIntDef(copy(s,1,i-1), -1);
|
|
Result := True;
|
|
if (i > Length(s)) or (s[i] <> '.') then exit;
|
|
Delete(s,1,i);
|
|
// Rev
|
|
i := 1;
|
|
while (i <= Length(s)) and (s[i] in ['0'..'9']) do inc(i);
|
|
if (i = 1) then exit;
|
|
FTheDebugger.FGDBVersionRev := StrToIntDef(copy(s,1,i-1), -1);
|
|
end;
|
|
|
|
function ParseGDBVersionMI: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
S: String;
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
Result := ExecuteCommand('-gdb-version', R);
|
|
Result := Result and (R.Values <> '');
|
|
if (not Result) then exit;
|
|
|
|
List := TGDBMINameValueList.Create(R);
|
|
|
|
FTheDebugger.FGDBVersion := List.Values['version'];
|
|
S := List.Values['target'];
|
|
|
|
FTheDebugger.FGDBCPU := GetPart('', '-', S);
|
|
GetPart('-', '-', S); // strip vendor
|
|
FTheDebugger.FGDBOS := GetPart(['-'], ['-', ''], S);
|
|
|
|
List.Free;
|
|
|
|
if StoreGdbVersionAsNumber
|
|
then exit;
|
|
|
|
// maybe a none MI result
|
|
S := GetPart(['configured as \"'], ['\"'], R.Values, False, False);
|
|
if Pos('--target=', S) <> 0 then
|
|
S := GetPart('--target=', '', S);
|
|
FTheDebugger.FGDBCPU := GetPart('', '-', S);
|
|
GetPart('-', '-', S); // strip vendor
|
|
FTheDebugger.FGDBOS := GetPart('-', '-', S);
|
|
|
|
FTheDebugger.FGDBVersion := GetPart(['('], [')'], R.Values, False, False);
|
|
if StoreGdbVersionAsNumber then Exit;
|
|
|
|
FTheDebugger.FGDBVersion := GetPart(['gdb '], [#10, #13], R.Values, True, False);
|
|
if StoreGdbVersionAsNumber then Exit;
|
|
|
|
// Retry, but do not check for format (old behaviour)
|
|
FTheDebugger.FGDBVersion := GetPart(['('], [')'], R.Values, False, False);
|
|
StoreGdbVersionAsNumber;
|
|
if FTheDebugger.FGDBVersion <> '' then Exit;
|
|
|
|
FTheDebugger.FGDBVersion := GetPart(['gdb '], [#10, #13], R.Values, True, False);
|
|
StoreGdbVersionAsNumber;
|
|
|
|
Result := False;
|
|
end;
|
|
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
FSuccess := ExecuteCommand('-gdb-set confirm off', R);
|
|
FSuccess := FSuccess and (r.State <> dsError);
|
|
if (not FSuccess) then exit;
|
|
// for win32, turn off a new console otherwise breaking gdb will fail
|
|
// ignore the error on other platforms
|
|
FSuccess := ExecuteCommand('-gdb-set new-console off', R);
|
|
if (not FSuccess) then exit;
|
|
|
|
// set the output width to a great value to avoid unexpected
|
|
// new lines like in large functions or procedures
|
|
ExecuteCommand('set width 50000', []);
|
|
|
|
FTheDebugger.FAsyncModeEnabled := False;
|
|
if TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties).UseAsyncCommandMode then begin
|
|
if ExecuteCommand('set target-async on', R, []) and (R.State <> dsError) then begin
|
|
ExecuteCommand('show target-async', R, []);
|
|
FTheDebugger.FAsyncModeEnabled := (R.State <> dsError) and
|
|
(pos('mode is on', LowerCase(R.Values)) > 0);
|
|
end;
|
|
if not FTheDebugger.FAsyncModeEnabled then
|
|
ExecuteCommand('set target-async off', R, []);
|
|
end;
|
|
|
|
ParseGDBVersionMI;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStack.DoCallstackFreed(Sender: TObject);
|
|
begin
|
|
debugln(DBGMI_QUEUE_DEBUG, ['DoCallstackFreed: ', DebugText]);
|
|
FCallstack := nil;
|
|
Cancel;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStack.DoLockQueueExecute;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStack.DoUnLockQueueExecute;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStack.DoLockQueueExecuteForInstr;
|
|
begin
|
|
///
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandStack.DoUnLockQueueExecuteForInstr;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandStack.Create(AOwner: TGDBMIDebugger;
|
|
ACallstack: TCallStackBase);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FCallstack := ACallstack;
|
|
FCallstack.AddFreeNotification(@DoCallstackFreed);
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommandStack.Destroy;
|
|
begin
|
|
if FCallstack <> nil
|
|
then FCallstack.RemoveFreeNotification(@DoCallstackFreed);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
{ TGDBMIBreakPoints }
|
|
|
|
function TGDBMIBreakPoints.FindById(AnId: Integer): TGDBMIBreakPoint;
|
|
var
|
|
n: Integer;
|
|
begin
|
|
for n := 0 to Count - 1 do
|
|
begin
|
|
Result := TGDBMIBreakPoint(Items[n]);
|
|
if (Result.FBreakID = AnId)
|
|
then Exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandKill }
|
|
|
|
function TGDBMIDebuggerCommandKill.DoExecute: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
CmdRes: Boolean;
|
|
begin
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
// not supported yet
|
|
// ExecuteCommand('-exec-abort');
|
|
CmdRes := ExecuteCommand('kill', [], [], 1500); // Hardcoded timeout
|
|
FTheDebugger.FCurrentStackFrameValid := False;
|
|
FTheDebugger.FCurrentThreadIdValid := False;
|
|
if CmdRes
|
|
then CmdRes := ExecuteCommand('info program', R, [cfNoThreadContext], 1500); // Hardcoded timeout
|
|
if (not CmdRes)
|
|
or (Pos('not being run', R.Values) <= 0)
|
|
then begin
|
|
FTheDebugger.TerminateGDB;
|
|
SetDebuggerState(dsError); // failed to stop
|
|
exit;
|
|
end;
|
|
SetDebuggerState(dsStop);
|
|
end;
|
|
|
|
{ TGDBMIThreads }
|
|
|
|
procedure TGDBMIThreads.DoThreadsDestroyed(Sender: TObject);
|
|
begin
|
|
if FGetThreadsCmdObj = Sender
|
|
then FGetThreadsCmdObj:= nil;
|
|
end;
|
|
|
|
procedure TGDBMIThreads.DoThreadsFinished(Sender: TObject);
|
|
var
|
|
Cmd: TGDBMIDebuggerCommandThreads;
|
|
i: Integer;
|
|
begin
|
|
if Monitor = nil then exit;
|
|
Cmd := TGDBMIDebuggerCommandThreads(Sender);
|
|
if CurrentThreads = nil then exit;
|
|
|
|
if not Cmd.Success then begin
|
|
CurrentThreads.SetValidity(ddsInvalid);
|
|
CurrentThreads.CurrentThreadId := Debugger.FCurrentThreadId;
|
|
exit;
|
|
end;
|
|
|
|
CurrentThreads.Clear;
|
|
for i := 0 to Cmd.Count - 1 do
|
|
CurrentThreads.Add(Cmd.Threads[i]);
|
|
|
|
CurrentThreads.CurrentThreadId := Cmd.CurrentThreadId;
|
|
CurrentThreads.SetValidity(ddsValid);
|
|
Debugger.FCurrentThreadId := CurrentThreads.CurrentThreadId;
|
|
Debugger.FCurrentThreadIdValid := True;
|
|
end;
|
|
|
|
function TGDBMIThreads.GetDebugger: TGDBMIDebugger;
|
|
begin
|
|
Result := TGDBMIDebugger(inherited Debugger);
|
|
end;
|
|
|
|
procedure TGDBMIThreads.ThreadsNeeded;
|
|
var
|
|
ForceQueue: Boolean;
|
|
begin
|
|
if Debugger = nil then Exit;
|
|
|
|
if (Debugger.State in [dsPause, dsInternalPause])
|
|
then begin
|
|
FGetThreadsCmdObj := TGDBMIDebuggerCommandThreads.Create(Debugger);
|
|
FGetThreadsCmdObj.OnExecuted := @DoThreadsFinished;
|
|
FGetThreadsCmdObj.OnDestroy := @DoThreadsDestroyed;
|
|
FGetThreadsCmdObj.Properties := [dcpCancelOnRun];
|
|
FGetThreadsCmdObj.Priority := GDCMD_PRIOR_THREAD;
|
|
FGetThreadsCmdObj.CurrentThreads := CurrentThreads;
|
|
// If a ExecCmd is running, then defer exec until the exec cmd is done
|
|
ForceQueue := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
|
|
and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
|
|
and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
|
|
and (Debugger.State <> dsInternalPause);
|
|
TGDBMIDebugger(Debugger).QueueCommand(FGetThreadsCmdObj, ForceQueue);
|
|
(* DoEvaluationFinished may be called immediately at this point *)
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIThreads.CancelEvaluation;
|
|
begin
|
|
if FGetThreadsCmdObj <> nil
|
|
then begin
|
|
FGetThreadsCmdObj.OnExecuted := nil;
|
|
FGetThreadsCmdObj.OnDestroy := nil;
|
|
FGetThreadsCmdObj.Cancel;
|
|
end;
|
|
FGetThreadsCmdObj := nil;
|
|
end;
|
|
|
|
destructor TGDBMIThreads.Destroy;
|
|
begin
|
|
CancelEvaluation;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TGDBMIThreads.RequestMasterData;
|
|
begin
|
|
ThreadsNeeded;
|
|
end;
|
|
|
|
procedure TGDBMIThreads.ChangeCurrentThread(ANewId: Integer);
|
|
begin
|
|
if Debugger = nil then Exit;
|
|
if not(Debugger.State in [dsPause, dsInternalPause]) then exit;
|
|
|
|
Debugger.FCurrentThreadId := ANewId;
|
|
Debugger.FCurrentThreadIdValid := True;
|
|
|
|
Debugger.DoThreadChanged;
|
|
if CurrentThreads <> nil
|
|
then CurrentThreads.CurrentThreadId := ANewId;
|
|
|
|
DebugLn(DBG_THREAD_AND_FRAME, ['TGDBMIThreads THREAD wanted ', Debugger.FCurrentThreadId]);
|
|
end;
|
|
|
|
procedure TGDBMIThreads.DoCleanAfterPause;
|
|
begin
|
|
if (Debugger.State <> dsRun) or (Monitor = nil) then begin
|
|
inherited DoCleanAfterPause;
|
|
exit;
|
|
end;
|
|
|
|
//for i := 0 to Monitor.CurrentThreads.Count - 1 do
|
|
// Monitor.CurrentThreads[i].ClearLocation; // TODO enum?
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandThreads }
|
|
|
|
function TGDBMIDebuggerCommandThreads.GetThread(AnIndex: Integer): TThreadEntry;
|
|
begin
|
|
Result := FThreads[AnIndex];
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandThreads.DoExecute: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List, EList, ArgList: TGDBMINameValueList;
|
|
i, j: Integer;
|
|
line, ThrId: Integer;
|
|
func, filename, fullname: String;
|
|
ThrName, ThrState: string;
|
|
addr: TDBGPtr;
|
|
Arguments: TStringList;
|
|
begin
|
|
(* TODO: none MI command
|
|
<info threads>
|
|
&"info threads\n"
|
|
~" 5 thread 4928.0x1f50 0x77755ca4 in ntdll!LdrAccessResource () from C:\\Windows\\system32\\ntdll.dll\n"
|
|
~" 4 thread 4928.0x12c8 0x77755ca4 in ntdll!LdrAccessResource () from C:\\Windows\\system32\\ntdll.dll\n"
|
|
~"* 1 thread 4928.0x1d18 TFORM1__BUTTON1CLICK (SENDER=0x209ef0, this=0x209a20) at unit1.pas:65\n"
|
|
^done
|
|
(gdb)
|
|
|
|
*)
|
|
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
if not ExecuteCommand('-thread-info', R)
|
|
then exit;
|
|
if r.State = dsError then exit;;
|
|
List := TGDBMINameValueList.Create(R);
|
|
EList := TGDBMINameValueList.Create;
|
|
ArgList := TGDBMINameValueList.Create;
|
|
try
|
|
FCurrentThreadId := StrToIntDef(List.Values['current-thread-id'], -1);
|
|
if FCurrentThreadId < 0 then exit;
|
|
FSuccess := True;
|
|
|
|
// update queue if needed // clear current stackframe
|
|
if FTheDebugger.FInstructionQueue.CurrentThreadId <> FCurrentThreadId then
|
|
FTheDebugger.FInstructionQueue.SetKnownThread(FCurrentThreadId);
|
|
|
|
|
|
List.SetPath('threads');
|
|
SetLength(FThreads, List.Count);
|
|
for i := 0 to List.Count - 1 do begin
|
|
EList.Init(List.Items[i]^.Name);
|
|
ThrId := StrToIntDef(EList.Values['id'], -2);
|
|
ThrName := EList.Values['target-id'];
|
|
ThrState := EList.Values['state'];
|
|
EList.SetPath('frame');
|
|
addr := StrToQWordDef(EList.Values['addr'], 0);
|
|
func := EList.Values['func'];
|
|
filename := ConvertGdbPathAndFile(EList.Values['file']);
|
|
fullname := ConvertGdbPathAndFile(EList.Values['fullname']);
|
|
line := StrToIntDef(EList.Values['line'], 0);
|
|
|
|
EList.SetPath('args');
|
|
Arguments := TStringList.Create;
|
|
for j := 0 to EList.Count - 1 do begin
|
|
ArgList.Init(EList.Items[j]^.Name);
|
|
Arguments.Add(ArgList.Values['name'] + '=' + DeleteEscapeChars(ArgList.Values['value']));
|
|
end;
|
|
|
|
|
|
FThreads[i] := CurrentThreads.CreateEntry(
|
|
addr,
|
|
Arguments,
|
|
func,
|
|
filename, fullname,
|
|
line,
|
|
ThrId,ThrName, ThrState
|
|
);
|
|
|
|
Arguments.Free;
|
|
end;
|
|
|
|
finally
|
|
FreeAndNil(ArgList);
|
|
FreeAndNil(EList);
|
|
FreeAndNil(List);
|
|
end;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandThreads.Create(AOwner: TGDBMIDebugger);
|
|
begin
|
|
inherited;
|
|
FSuccess := False;
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommandThreads.Destroy;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to length(FThreads) - 1 do FreeAndNil(FThreads[i]);
|
|
FThreads := nil;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandThreads.Count: Integer;
|
|
begin
|
|
Result := length(FThreads);
|
|
end;
|
|
|
|
{ TGDBMINameValueBasedList }
|
|
|
|
constructor TGDBMINameValueBasedList.Create;
|
|
begin
|
|
FNameValueList := TGDBMINameValueList.Create;
|
|
end;
|
|
|
|
constructor TGDBMINameValueBasedList.Create(const AResultValues: String);
|
|
begin
|
|
FNameValueList := TGDBMINameValueList.Create(AResultValues);
|
|
PreParse;
|
|
end;
|
|
|
|
constructor TGDBMINameValueBasedList.Create(AResult: TGDBMIExecResult);
|
|
begin
|
|
Create(AResult.Values);
|
|
end;
|
|
|
|
destructor TGDBMINameValueBasedList.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
FreeAndNil(FNameValueList);
|
|
end;
|
|
|
|
procedure TGDBMINameValueBasedList.Init(AResultValues: string);
|
|
begin
|
|
FNameValueList.Init(AResultValues);
|
|
PreParse;
|
|
end;
|
|
|
|
procedure TGDBMINameValueBasedList.Init(AResult: TGDBMIExecResult);
|
|
begin
|
|
Init(AResult.Values);
|
|
end;
|
|
|
|
{ TGDBMIDisassembleResultList }
|
|
|
|
procedure TGDBMIDisassembleResultList.PreParse;
|
|
const
|
|
SrcAndAsm = 'src_and_asm_line';
|
|
SrcAndAsmLen = length(SrcAndAsm);
|
|
var
|
|
Itm: PGDBMINameValue;
|
|
SrcList: TGDBMINameValueList;
|
|
i, j: Integer;
|
|
SFile, SLine: TPCharWithLen;
|
|
begin
|
|
// The "^done" is stripped already
|
|
if (FNameValueList.Count <> 1) or(FNameValueList.IndexOf('asm_insns') < 0)
|
|
then debugln(DBG_DISASSEMBLER, ['WARNING: TGDBMIDisassembleResultList: Unexpected Entries']);
|
|
HasItemPointerList := False;
|
|
FNameValueList.SetPath('asm_insns');
|
|
FCount := 0;
|
|
SetLength(FItems, FNameValueList.Count * 4);
|
|
FHasSourceInfo := False;
|
|
SrcList := nil;
|
|
for i := 0 to FNameValueList.Count - 1 do begin
|
|
Itm := FNameValueList.Items[i];
|
|
if (Itm^.Name.Len = SrcAndAsmLen)
|
|
and (strlcomp(Itm^.Name.Ptr, PChar(SrcAndAsm), SrcAndAsmLen) = 0)
|
|
then begin
|
|
// Source and asm
|
|
FHasSourceInfo := True;
|
|
if SrcList = nil
|
|
then SrcList := TGDBMINameValueList.Create(Itm^.Value)
|
|
else SrcList.Init(Itm^.Value);
|
|
SFile := SrcList.ValuesPtr['file'];
|
|
SLine := SrcList.ValuesPtr['line'];
|
|
SrcList.SetPath('line_asm_insn');
|
|
|
|
if FCount + SrcList.Count >= length(FItems)
|
|
then SetLength(FItems, FCount + SrcList.Count + 20);
|
|
for j := 0 to SrcList.Count - 1 do begin
|
|
FItems[FCount].AsmEntry := SrcList.Items[j]^.Name;
|
|
FItems[FCount].SrcFile := SFile;
|
|
FItems[FCount].SrcLine := SLine;
|
|
FItems[FCount].ParsedInfo.SrcStatementIndex := j;
|
|
FItems[FCount].ParsedInfo.SrcStatementCount := SrcList.Count;
|
|
inc(FCount);
|
|
end;
|
|
end
|
|
else
|
|
if (Itm^.Name.Len > 1)
|
|
and (Itm^.Name.Ptr[0] = '{')
|
|
and (Itm^.Value.Len = 0)
|
|
then begin
|
|
// Asm only
|
|
if FCount + 1 >= length(FItems)
|
|
then SetLength(FItems, FCount + 20);
|
|
FItems[FCount].AsmEntry := Itm^.Name;
|
|
FItems[FCount].SrcFile.Ptr := nil;
|
|
FItems[FCount].SrcFile.Len := 0;
|
|
FItems[FCount].SrcLine.Ptr := nil;
|
|
FItems[FCount].SrcLine.Len := 0;
|
|
FItems[FCount].ParsedInfo.SrcStatementIndex := 0;
|
|
FItems[FCount].ParsedInfo.SrcStatementCount := 0;
|
|
inc(FCount);
|
|
end
|
|
else
|
|
begin
|
|
// unknown
|
|
debugln(['WARNING: TGDBMIDisassembleResultList.Parse: unknown disass entry',
|
|
DbgsPCLen(Itm^.Name),': ',DbgsPCLen(Itm^.Value)]);
|
|
end;
|
|
end;
|
|
FreeAndNil(SrcList);
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultList.GetLastItem: PDisassemblerEntry;
|
|
begin
|
|
if HasItemPointerList
|
|
then begin
|
|
Result := ItemPointerList[Count - 1];
|
|
exit;
|
|
end;
|
|
ParseItem(Count - 1);
|
|
Result := @FItems[Count - 1].ParsedInfo;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultList.SortByAddress: Boolean;
|
|
var
|
|
i, j: Integer;
|
|
Itm1: PDisassemblerEntry;
|
|
begin
|
|
Result := True;
|
|
SetLength(ItemPointerList, FCount);
|
|
for i := 0 to Count - 1 do begin
|
|
Itm1 := Item[i];
|
|
j := i - 1;
|
|
while j >= 0 do begin
|
|
if ItemPointerList[j]^.Addr > Itm1^.Addr
|
|
then ItemPointerList[j+1] := ItemPointerList[j]
|
|
else break;
|
|
dec(j);
|
|
end;
|
|
ItemPointerList[j+1] := Itm1;
|
|
end;
|
|
HasItemPointerList := True;
|
|
end;
|
|
|
|
constructor TGDBMIDisassembleResultList.CreateSubList(ASource: TGDBMIDisassembleResultList;
|
|
AStartIdx, ACount: Integer);
|
|
begin
|
|
Create;
|
|
InitSubList(ASource, AStartIdx, ACount);
|
|
end;
|
|
|
|
procedure TGDBMIDisassembleResultList.InitSubList(ASource: TGDBMIDisassembleResultList;
|
|
AStartIdx, ACount: Integer);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
SetLength(ItemPointerList, ACount);
|
|
FCount := ACount;
|
|
for i := 0 to ACount - 1 do
|
|
ItemPointerList[i] := ASource.Item[AStartIdx + i];
|
|
HasItemPointerList := True;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultList.GetItem(Index: Integer): PDisassemblerEntry;
|
|
begin
|
|
if HasItemPointerList
|
|
then begin
|
|
Result := ItemPointerList[Index];
|
|
exit;
|
|
end;
|
|
ParseItem(Index);
|
|
Result := @FItems[Index].ParsedInfo;
|
|
end;
|
|
|
|
procedure TGDBMIDisassembleResultList.ParseItem(Index: Integer);
|
|
var
|
|
AsmList: TGDBMINameValueList;
|
|
begin
|
|
if FItems[Index].AsmEntry.Ptr = nil
|
|
then exit;
|
|
AsmList := TGDBMINameValueList.Create(FItems[Index].AsmEntry);
|
|
|
|
FItems[Index].ParsedInfo.SrcFileName := ConvertGdbPathAndFile(PCLenToString(FItems[Index].SrcFile, True));
|
|
FItems[Index].ParsedInfo.SrcFileLine := PCLenToInt(FItems[Index].SrcLine, 0);
|
|
// SrcStatementIndex, SrcStatementCount are already set
|
|
|
|
FItems[Index].ParsedInfo.Addr := PCLenToQWord(AsmList.ValuesPtr['address'], 0);
|
|
FItems[Index].ParsedInfo.Statement :=
|
|
UnEscapeBackslashed(PCLenToString(AsmList.ValuesPtr['inst'], True), [uefTab], 16);
|
|
FItems[Index].ParsedInfo.FuncName := PCLenToString(AsmList.ValuesPtr['func-name'], True);
|
|
FItems[Index].ParsedInfo.Offset := PCLenToInt(AsmList.ValuesPtr['offset'], 0);
|
|
|
|
FItems[Index].AsmEntry.Ptr := nil;
|
|
FreeAndNil(AsmList);
|
|
end;
|
|
|
|
procedure TGDBMIDisassembleResultList.SetCount(const AValue: Integer);
|
|
begin
|
|
if FCount = AValue then exit;
|
|
if FCount > length(FItems)
|
|
then raise Exception.Create('Invalid Count');
|
|
FCount := AValue;
|
|
end;
|
|
|
|
procedure TGDBMIDisassembleResultList.SetItem(Index: Integer;
|
|
const AValue: PDisassemblerEntry);
|
|
begin
|
|
if HasItemPointerList
|
|
then begin
|
|
ItemPointerList[Index]^ := AValue^;
|
|
exit;
|
|
end;
|
|
FItems[Index].ParsedInfo := AValue^;
|
|
FItems[Index].AsmEntry.Ptr := nil;
|
|
end;
|
|
|
|
procedure TGDBMIDisassembleResultList.SetLastItem(const AValue: PDisassemblerEntry);
|
|
begin
|
|
if HasItemPointerList
|
|
then begin
|
|
ItemPointerList[Count - 1]^ := AValue^;
|
|
exit;
|
|
end;
|
|
FItems[Count - 1].ParsedInfo := AValue^;
|
|
FItems[Count - 1].AsmEntry.Ptr := nil;
|
|
end;
|
|
|
|
{ TGDBMIDisassembleResultFunctionIterator }
|
|
|
|
constructor TGDBMIDisassembleResultFunctionIterator.Create(AList: TGDBMIDisassembleResultList;
|
|
AStartIdx: Integer; ALastSubListEndAddr: TDBGPtr;
|
|
AnAddressToLocate, AnAddForLineAfterCounter: TDBGPtr);
|
|
begin
|
|
FList := AList;
|
|
FStartedAtIndex := AStartIdx;
|
|
FStartIdx := AStartIdx;
|
|
FLastSubListEndAddr := ALastSubListEndAddr;
|
|
FAddressToLocate := AnAddressToLocate;
|
|
FAddForLineAfterCounter := AnAddForLineAfterCounter;
|
|
FMaxIdx := FList.Count - 1;
|
|
if FStartIdx > FMaxIdx
|
|
then raise Exception.Create('internal error');
|
|
FIndexOfLocateAddress := 1;
|
|
FOffsetOfLocateAddress := -1;
|
|
FIndexOfCounterAddress := -1;
|
|
FSublistNumber := -1;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultFunctionIterator.EOL: Boolean;
|
|
begin
|
|
Result := FStartIdx > FMaxIdx ;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultFunctionIterator.NextSubList
|
|
(var AResultList: TGDBMIDisassembleResultList): Boolean;
|
|
var
|
|
WasBeforeStart: Boolean;
|
|
HasPrcName: Boolean;
|
|
PrcBaseAddr: TDBGPtr;
|
|
Itm: PDisassemblerEntry;
|
|
NextIdx: Integer;
|
|
HasLocate: Boolean;
|
|
begin
|
|
FCurIdx := FStartIdx;
|
|
if FStartIdx > FMaxIdx
|
|
then raise Exception.Create('internal error');
|
|
inc(FSublistNumber);
|
|
|
|
(* The name may change in the middle of a function. Check for either:
|
|
- change between no-name and has-name
|
|
- change of the base-address (addr-offset), if the offset is valid (if has-name)
|
|
*)
|
|
HasPrcName := FList.Item[FStartIdx]^.FuncName <> ''; // can use offsets
|
|
{$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$ENDIF} // Overflow is allowed to occur
|
|
PrcBaseAddr := FList.Item[FStartIdx]^.Addr - FList.Item[FStartIdx]^.Offset;
|
|
{$POP}
|
|
|
|
WasBeforeStart := FList.Item[FStartIdx]^.Addr < FAddressToLocate;
|
|
HasLocate := False;
|
|
|
|
NextIdx := FStartIdx + 1;
|
|
while NextIdx <= FMaxIdx do
|
|
begin
|
|
Itm := FList.Item[NextIdx];
|
|
{$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$ENDIF} // Overflow is allowed to occur
|
|
// Also check the next statement after PrcName.
|
|
// If it has FOffsetOfLocateAddress > 0, then FAddressToLocate is in current block, but not matched
|
|
if (Itm^.Addr = FAddressToLocate)
|
|
then begin
|
|
FIndexOfLocateAddress := NextIdx;
|
|
FOffsetOfLocateAddress := 0;
|
|
WasBeforeStart := False;
|
|
HasLocate := True;
|
|
end
|
|
else if WasBeforeStart and (Itm^.Addr > FAddressToLocate)
|
|
then begin
|
|
FIndexOfLocateAddress := NextIdx - 1;
|
|
FOffsetOfLocateAddress := FAddressToLocate - FList.Item[NextIdx-1]^.Addr;
|
|
WasBeforeStart := False;
|
|
HasLocate := True;
|
|
end;
|
|
if (FAddForLineAfterCounter > 0)
|
|
and ( (Itm^.Addr = FAddForLineAfterCounter)
|
|
or ((Itm^.Addr > FAddForLineAfterCounter) and (FIndexOfCounterAddress < 0)) )
|
|
then FIndexOfCounterAddress := NextIdx;
|
|
|
|
if (HasPrcName <> (Itm^.FuncName <> ''))
|
|
or (HasPrcName and (PrcBaseAddr <> Itm^.Addr - Itm^.Offset))
|
|
then break;
|
|
{$POP}
|
|
|
|
inc(NextIdx);
|
|
end;
|
|
|
|
if AResultList = nil
|
|
then AResultList := TGDBMIDisassembleResultList.CreateSubList(FList, FStartIdx, NextIdx - FStartIdx)
|
|
else AResultList.InitSubList(FList, FStartIdx, NextIdx - FStartIdx);
|
|
FStartIdx := NextIdx;
|
|
|
|
// Does the next address look good?
|
|
// And is AStartAddrHit ok
|
|
//Result := ((NextIdx > FMaxIdx) or (FList.Item[NextIdx]^.Offset = 0))
|
|
// and
|
|
Result := ( (not HasLocate) or ((FIndexOfLocateAddress < 0) or (FOffsetOfLocateAddress = 0)) );
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultFunctionIterator.IsFirstSubList: Boolean;
|
|
begin
|
|
Result := FSublistNumber = 0;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultFunctionIterator.CountLinesAfterCounterAddr: Integer;
|
|
begin
|
|
Result := -1;
|
|
if FIndexOfCounterAddress >= 0 then
|
|
Result := CurrentIndex - IndexOfCounterAddress - 1;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultFunctionIterator.CurrentFixedAddr(AOffsLimit: Integer): TDBGPtr;
|
|
begin
|
|
Result := FList.Item[CurrentIndex]^.Addr - Min(FList.Item[CurrentIndex]^.Offset, AOffsLimit);
|
|
// Offset may increase to a point BEFORE the previous address (e.g. neseted proc, maybe inline?)
|
|
if CurrentIndex > 0 then
|
|
if Result <= FList.Item[CurrentIndex-1]^.Addr then
|
|
Result := FList.Item[CurrentIndex]^.Addr;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultFunctionIterator.NextStartAddr: TDBGPtr;
|
|
begin
|
|
if NextIndex <= FMaxIdx
|
|
then begin
|
|
Result := FList.Item[NextIndex]^.Addr - FList.Item[NextIndex]^.Offset;
|
|
// Offset may increase to a point BEFORE the previous address (e.g. neseted proc, maybe inline?)
|
|
if NextIndex > 0 then
|
|
if Result <= FList.Item[NextIndex-1]^.Addr then
|
|
Result := FList.Item[NextIndex]^.Addr;
|
|
end
|
|
else
|
|
Result := FLastSubListEndAddr;
|
|
end;
|
|
|
|
function TGDBMIDisassembleResultFunctionIterator.NextStartOffs: Integer;
|
|
begin
|
|
if NextIndex <= FMaxIdx
|
|
then Result := FList.Item[NextIndex]^.Offset
|
|
else Result := 0;
|
|
end;
|
|
|
|
{ TGDBMIMemoryDumpResultList }
|
|
|
|
function TGDBMIMemoryDumpResultList.GetItemNum(Index: Integer): Integer;
|
|
begin
|
|
Result := PCLenToInt(FNameValueList.Items[Index]^.Name, 0);
|
|
end;
|
|
|
|
function TGDBMIMemoryDumpResultList.GetItem(Index: Integer): TPCharWithLen;
|
|
begin
|
|
Result := FNameValueList.Items[Index]^.Name;
|
|
end;
|
|
|
|
function TGDBMIMemoryDumpResultList.GetItemTxt(Index: Integer): string;
|
|
var
|
|
itm: PGDBMINameValue;
|
|
begin
|
|
itm := FNameValueList.Items[Index];
|
|
if itm <> nil
|
|
then Result := PCLenToString(itm^.Name, True)
|
|
else Result := '';
|
|
end;
|
|
|
|
procedure TGDBMIMemoryDumpResultList.PreParse;
|
|
begin
|
|
FNameValueList.SetPath('memory');
|
|
if FNameValueList.Count = 0 then exit;
|
|
FNameValueList.Init(FNameValueList.Items[0]^.Name);
|
|
FAddr := PCLenToQWord(FNameValueList.ValuesPtr['addr'], 0);
|
|
FNameValueList.SetPath('data');
|
|
end;
|
|
|
|
function TGDBMIMemoryDumpResultList.Count: Integer;
|
|
begin
|
|
Result := FNameValueList.Count;
|
|
end;
|
|
|
|
function TGDBMIMemoryDumpResultList.AsText(AStartOffs, ACount: Integer;
|
|
AAddrWidth: Integer): string;
|
|
var
|
|
i: LongInt;
|
|
begin
|
|
if AAddrWidth > 0
|
|
then Result := IntToHex(addr + AStartOffs, AAddrWidth) + ':'
|
|
else Result := '';
|
|
for i := AStartOffs to AStartOffs + ACount do begin
|
|
if i >= ACount then exit;
|
|
Result := Result + ' ' + PCLenPartToString(Item[i], 3, 2);
|
|
end;
|
|
end;
|
|
|
|
{ TGDBMIDisassembler }
|
|
|
|
procedure TGDBMIDisassembler.DoDisassembleDestroyed(Sender: TObject);
|
|
begin
|
|
if FDisassembleEvalCmdObj = Sender
|
|
then FDisassembleEvalCmdObj := nil;
|
|
end;
|
|
|
|
procedure TGDBMIDisassembler.DoDisassembleProgress(Sender: TObject);
|
|
begin
|
|
Changed;
|
|
end;
|
|
|
|
procedure TGDBMIDisassembler.DoDisassembleExecuted(Sender: TObject);
|
|
begin
|
|
// Results were added from inside the TGDBMIDebuggerCommandDisassemble object
|
|
FLastExecAddr := TGDBMIDebuggerCommandDisassemble(Sender).StartAddr;
|
|
if dcsCanceled in TGDBMIDebuggerCommandDisassemble(Sender).SeenStates then begin
|
|
// TODO: fill a block of data with "canceled" info
|
|
FIsCancelled := True;
|
|
FCancelledAddr := TGDBMIDebuggerCommandDisassemble(Sender).StartAddr;
|
|
end;
|
|
FDisassembleEvalCmdObj := nil;
|
|
Changed;
|
|
end;
|
|
|
|
function TGDBMIDisassembler.PrepareEntries(AnAddr: TDbgPtr; ALinesBefore,
|
|
ALinesAfter: Integer): Boolean;
|
|
var
|
|
ForceQueue: Boolean;
|
|
begin
|
|
Result := False;
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause])
|
|
then exit;
|
|
if FIsCancelled and (FCancelledAddr = AnAddr) then
|
|
exit;
|
|
|
|
|
|
if (FDisassembleEvalCmdObj <> nil)
|
|
then begin
|
|
if FDisassembleEvalCmdObj.State <> dcsQueued
|
|
then exit; // the request will be done again, after the next "Changed" (which should be the edn of the current command)
|
|
|
|
if (AnAddr < FDisassembleEvalCmdObj.StartAddr)
|
|
and (AnAddr >= FDisassembleEvalCmdObj.StartAddr
|
|
- (ALinesAfter + FDisassembleEvalCmdObj.LinesBefore) * DAssBytesPerCommandAvg)
|
|
then begin
|
|
// merge before
|
|
debugln(DBG_DISASSEMBLER, ['INFO: TGDBMIDisassembler.PrepareEntries MERGE request at START: NewStartAddr=', AnAddr,
|
|
' NewLinesBefore=', Max(ALinesBefore, FDisassembleEvalCmdObj.LinesBefore), ' OldStartAddr=', FDisassembleEvalCmdObj.StartAddr,
|
|
' OldLinesBefore=', FDisassembleEvalCmdObj.LinesBefore ]);
|
|
FDisassembleEvalCmdObj.StartAddr := AnAddr;
|
|
FDisassembleEvalCmdObj.LinesBefore := Max(ALinesBefore, FDisassembleEvalCmdObj.LinesBefore);
|
|
exit;
|
|
end;
|
|
|
|
if (AnAddr > FDisassembleEvalCmdObj.EndAddr)
|
|
and (AnAddr <= FDisassembleEvalCmdObj.EndAddr
|
|
+ (ALinesBefore + FDisassembleEvalCmdObj.LinesAfter) * DAssBytesPerCommandAvg)
|
|
then begin
|
|
// merge after
|
|
debugln(DBG_DISASSEMBLER, ['INFO: TGDBMIDisassembler.PrepareEntries MERGE request at END: NewEndAddr=', AnAddr,
|
|
' NewLinesAfter=', Max(ALinesAfter, FDisassembleEvalCmdObj.LinesAfter), ' OldEndAddr=', FDisassembleEvalCmdObj.EndAddr,
|
|
' OldLinesAfter=', FDisassembleEvalCmdObj.LinesAfter ]);
|
|
FDisassembleEvalCmdObj.EndAddr := AnAddr;
|
|
FDisassembleEvalCmdObj.LinesAfter := Max(ALinesAfter, FDisassembleEvalCmdObj.LinesAfter);
|
|
exit;
|
|
end;
|
|
|
|
exit;
|
|
end;
|
|
|
|
FDisassembleEvalCmdObj := TGDBMIDebuggerCommandDisassemble.Create
|
|
(TGDBMIDebugger(Debugger), EntryRanges, AnAddr, AnAddr, ALinesBefore, ALinesAfter);
|
|
FDisassembleEvalCmdObj.OnExecuted := @DoDisassembleExecuted;
|
|
FDisassembleEvalCmdObj.OnProgress := @DoDisassembleProgress;
|
|
FDisassembleEvalCmdObj.OnDestroy := @DoDisassembleDestroyed;
|
|
FDisassembleEvalCmdObj.Priority := GDCMD_PRIOR_DISASS;
|
|
FDisassembleEvalCmdObj.Properties := [dcpCancelOnRun];
|
|
ForceQueue := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
|
|
and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
|
|
and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
|
|
and (Debugger.State <> dsInternalPause);
|
|
TGDBMIDebugger(Debugger).QueueCommand(FDisassembleEvalCmdObj, ForceQueue);
|
|
(* DoDepthCommandExecuted may be called immediately at this point *)
|
|
Result := FDisassembleEvalCmdObj = nil; // already executed
|
|
end;
|
|
|
|
function TGDBMIDisassembler.HandleRangeWithInvalidAddr(ARange: TDBGDisassemblerEntryRange;
|
|
AnAddr: TDbgPtr; var ALinesBefore, ALinesAfter: Integer): boolean;
|
|
var
|
|
i, c: Integer;
|
|
begin
|
|
if AnAddr = FLastExecAddr
|
|
then begin
|
|
i := 0;
|
|
c := ARange.Count;
|
|
while i < c do
|
|
begin
|
|
if ARange.EntriesPtr[i]^.Addr > AnAddr
|
|
then break;
|
|
inc(i);
|
|
end;
|
|
if i > 0
|
|
then dec(i);
|
|
ALinesBefore := i;
|
|
ALinesAfter := ARange.Count - 1 - i;
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
Result := inherited HandleRangeWithInvalidAddr(ARange, AnAddr, ALinesBefore, ALinesAfter);
|
|
end;
|
|
|
|
procedure TGDBMIDisassembler.Clear;
|
|
begin
|
|
FIsCancelled := False;
|
|
inherited Clear;
|
|
if FDisassembleEvalCmdObj <> nil
|
|
then begin
|
|
FDisassembleEvalCmdObj.OnExecuted := nil;
|
|
FDisassembleEvalCmdObj.OnDestroy := nil;
|
|
FDisassembleEvalCmdObj.Cancel;
|
|
end;
|
|
FDisassembleEvalCmdObj := nil;
|
|
end;
|
|
|
|
function TGDBMIDisassembler.PrepareRange(AnAddr: TDbgPtr; ALinesBefore,
|
|
ALinesAfter: Integer): Boolean;
|
|
begin
|
|
if AnAddr <> FLastExecAddr
|
|
then FLastExecAddr := 0;
|
|
Result := inherited PrepareRange(AnAddr, ALinesBefore, ALinesAfter);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandDisassembe }
|
|
|
|
procedure TGDBMIDebuggerCommandDisassemble.DoProgress;
|
|
begin
|
|
if assigned(FOnProgress)
|
|
then FOnProgress(Self);
|
|
end;
|
|
|
|
{$ifdef disassemblernestedproc}
|
|
function TGDBMIDebuggerCommandDisassemble.DoExecute: Boolean;
|
|
{$endif}
|
|
const
|
|
TrustedValidity = [avFoundFunction, avFoundRange, avFoundStatement];
|
|
|
|
procedure PadAddress(var AnAddr: TDisassemblerAddress; APad: Integer);
|
|
begin
|
|
{$PUSH}{$Q-}{$R-}// APad can be negative, but will be expanded to TDbgPtr (QWord)
|
|
AnAddr.Value := AnAddr.Value + APad;
|
|
{$POP}
|
|
AnAddr.Validity := avPadded;
|
|
AnAddr.Offset := -1;
|
|
end;
|
|
|
|
function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}ExecDisassmble(AStartAddr, AnEndAddr: TDbgPtr; WithSrc: Boolean;
|
|
AResultList: TGDBMIDisassembleResultList = nil;
|
|
ACutBeforeEndAddr: Boolean = False): TGDBMIDisassembleResultList;
|
|
var
|
|
WS: Integer;
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
WS := 0;
|
|
if WithSrc
|
|
then WS := 1;;
|
|
Result := AResultList;
|
|
ExecuteCommand('-data-disassemble -s %u -e %u -- %d', [AStartAddr, AnEndAddr, WS], R);
|
|
if Result <> nil
|
|
then Result.Init(R)
|
|
else Result := TGDBMIDisassembleResultList.Create(R);
|
|
if ACutBeforeEndAddr and Result.HasSourceInfo
|
|
then Result.SortByAddress;
|
|
while ACutBeforeEndAddr and (Result.Count > 0) and (Result.LastItem^.Addr >= AnEndAddr)
|
|
do Result.Count := Result.Count - 1;
|
|
end;
|
|
|
|
// Set Value, based on GuessedValue
|
|
function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}AdjustToKnowFunctionStart(var AStartAddr: TDisassemblerAddress): Boolean;
|
|
var
|
|
DisAssList: TGDBMIDisassembleResultList;
|
|
DisAssItm: PDisassemblerEntry;
|
|
s: TDBGPtr;
|
|
begin
|
|
Result := False;
|
|
// TODO: maybe try "info symbol <addr>
|
|
s := (AStartAddr.GuessedValue -1) div 4 * 4; // 4 byte boundary
|
|
DisAssList := ExecDisassmble(s, s+1, False);
|
|
if DisAssList.Count > 0 then begin
|
|
DisAssItm := DisAssList.Item[0];
|
|
if (DisAssItm^.FuncName <> '') and (DisAssItm^.Addr <> 0) and (DisAssItm^.Offset >= 0)
|
|
then begin
|
|
AStartAddr.Value := DisAssItm^.Addr - DisAssItm^.Offset; // This should always be good
|
|
AStartAddr.Offset := 0;
|
|
AStartAddr.Validity := avFoundFunction;
|
|
Result := True;
|
|
end;
|
|
end;
|
|
FreeAndNil(DisAssList);
|
|
end;
|
|
|
|
procedure AdjustLastEntryEndAddr(const ARange: TDBGDisassemblerEntryRange;
|
|
const ADisAssList: TGDBMIDisassembleResultList);
|
|
var
|
|
i: Integer;
|
|
TmpAddr: TDBGPtr;
|
|
begin
|
|
if ARange.Count = 0 then exit;
|
|
TmpAddr := ARange.LastAddr;
|
|
i := 0;
|
|
while (i < ADisAssList.Count) and (ADisAssList.Item[i]^.Addr <= TmpAddr) do inc(i);
|
|
if i < ADisAssList.Count
|
|
then ARange.LastEntryEndAddr := ADisAssList.Item[i]^.Addr
|
|
else if ARange.LastEntryEndAddr <= ARange.RangeEndAddr
|
|
then ARange.LastEntryEndAddr := ARange.RangeEndAddr + 1;
|
|
end;
|
|
|
|
procedure CopyToRange(const ADisAssList: TGDBMIDisassembleResultList;
|
|
const ADestRange: TDBGDisassemblerEntryRange; AFromIndex, ACount: Integer;
|
|
ASrcInfoDisAssList: TGDBMIDisassembleResultList = nil);
|
|
var
|
|
i, j, MinInSrc, MaxInSrc: Integer;
|
|
ItmPtr, ItmPtr2, LastItem: PDisassemblerEntry;
|
|
begin
|
|
if ASrcInfoDisAssList = ADisAssList
|
|
then ASrcInfoDisAssList := nil;
|
|
if ADisAssList.Count = 0 then
|
|
exit;
|
|
// Clean end of range
|
|
ItmPtr := ADisAssList.Item[AFromIndex];
|
|
i := ADestRange.Count;
|
|
while (i > 0) and (ADestRange.EntriesPtr[i-1]^.Addr >= ItmPtr^.Addr) do dec(i);
|
|
if ADestRange.Count <> i then debugln(DBG_DISASSEMBLER, ['NOTICE, CopyToRange: Removing ',i,' entries from the end of Range. AFromIndex=',AFromIndex, ' ACount=', ACount, ' Range=',dbgs(ADestRange)]);
|
|
ADestRange.Count := i;
|
|
if i > 0 then begin
|
|
ItmPtr2 := ADestRange.EntriesPtr[i-1];
|
|
if ItmPtr2^.Dump <> '' then begin
|
|
{$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur
|
|
j := (ItmPtr^.Addr - ItmPtr2^.Addr) * 2;
|
|
{$POP}
|
|
if length(ItmPtr2^.Dump) > j then debugln(DBG_DISASSEMBLER, ['NOTICE, CopyToRange: Shortening Dump at the end of Range. AFromIndex=',AFromIndex, ' ACount=', ACount, ' Range=',dbgs(ADestRange)]);
|
|
if length(ItmPtr2^.Dump) > j then ItmPtr2^.Dump := copy(ItmPtr2^.Dump, 1, j);
|
|
end;
|
|
end;
|
|
|
|
if ADestRange.Count = 0
|
|
then ADestRange.RangeStartAddr := ADisAssList.Item[AFromIndex]^.Addr;
|
|
|
|
if ADestRange.RangeEndAddr < ADisAssList.Item[AFromIndex+ACount-1]^.Addr
|
|
then ADestRange.RangeEndAddr := ADisAssList.Item[AFromIndex+ACount-1]^.Addr;
|
|
|
|
if ADisAssList.Count > AFromIndex + ACount
|
|
then begin
|
|
if ADestRange.LastEntryEndAddr < ADisAssList.Item[AFromIndex+ACount]^.Addr
|
|
then ADestRange.LastEntryEndAddr := ADisAssList.Item[AFromIndex+ACount]^.Addr;
|
|
end
|
|
else
|
|
if ADestRange.LastEntryEndAddr <= ADestRange.RangeEndAddr
|
|
then ADestRange.LastEntryEndAddr := ADestRange.RangeEndAddr + 1;
|
|
|
|
|
|
// Append new items
|
|
LastItem := nil;
|
|
MinInSrc := 0;
|
|
if ASrcInfoDisAssList <> nil
|
|
then MaxInSrc := ASrcInfoDisAssList.Count - 1;
|
|
for i := AFromIndex to AFromIndex + ACount - 1 do begin
|
|
ItmPtr := ADisAssList.Item[i];
|
|
ItmPtr2 := nil;
|
|
if ASrcInfoDisAssList <> nil
|
|
then begin
|
|
j := MinInSrc;
|
|
while j <= MaxInSrc do begin
|
|
ItmPtr2 := ASrcInfoDisAssList.Item[j];
|
|
if ItmPtr2^.Addr = itmPtr^.Addr
|
|
then break;
|
|
inc(j);
|
|
end;
|
|
if j <= MaxInSrc
|
|
then begin
|
|
ItmPtr2^.Dump := ItmPtr^.Dump;
|
|
ItmPtr := ItmPtr2;
|
|
end
|
|
else ItmPtr2 := nil;
|
|
end;
|
|
if (LastItem <> nil) then begin
|
|
// unify strings, to keep only one instance
|
|
if (ItmPtr^.SrcFileName = LastItem^.SrcFileName)
|
|
then ItmPtr^.SrcFileName := LastItem^.SrcFileName;
|
|
if (ItmPtr^.FuncName = LastItem^.FuncName)
|
|
then ItmPtr^.FuncName:= LastItem^.FuncName;
|
|
end;
|
|
ADestRange.Append(ItmPtr);
|
|
// now we can move the data, pointed to by ItmPtr // reduce search range
|
|
if ItmPtr2 <> nil
|
|
then begin
|
|
// j is valid
|
|
if j = MaxInSrc
|
|
then dec(MaxInSrc)
|
|
else if j = MinInSrc
|
|
then inc(MinInSrc)
|
|
else begin
|
|
ASrcInfoDisAssList.Item[j] := ASrcInfoDisAssList.Item[MaxInSrc];
|
|
dec(MaxInSrc);
|
|
end;
|
|
end;;
|
|
LastItem := ItmPtr;
|
|
end;
|
|
// Src list may be reused for other addresses, so discard used entries
|
|
if ASrcInfoDisAssList <> nil
|
|
then begin
|
|
for i := 0 to Min(MinInSrc - 1, MaxInSrc - MinInSrc) do
|
|
ASrcInfoDisAssList.Item[i] := ASrcInfoDisAssList.Item[i + MinInSrc];
|
|
ASrcInfoDisAssList.Count := MaxInSrc + 1 - MinInSrc;
|
|
end;
|
|
end;
|
|
|
|
procedure AddMemDumpToRange(const ARange: TDBGDisassemblerEntryRange;
|
|
AMemDump: TGDBMIMemoryDumpResultList; AFirstAddr, ALastAddr: TDBGPtr);
|
|
var
|
|
i, Cnt, FromIndex: Integer;
|
|
Itm, NextItm: PDisassemblerEntry;
|
|
Addr, Offs, Len: TDBGPtr;
|
|
s: String;
|
|
begin
|
|
Cnt := ARange.Count;
|
|
if ARange.FirstAddr > AFirstAddr
|
|
then FromIndex := -1
|
|
else FromIndex := ARange.IndexOfAddrWithOffs(AFirstAddr)-1;
|
|
if FromIndex < -1
|
|
then exit;
|
|
|
|
NextItm := ARange.EntriesPtr[FromIndex + 1];
|
|
while NextItm <> nil do
|
|
begin
|
|
inc(FromIndex);
|
|
Itm := NextItm;
|
|
if Itm^.Addr > ALastAddr
|
|
then break;
|
|
|
|
if FromIndex < Cnt - 1
|
|
then NextItm := ARange.EntriesPtr[FromIndex + 1]
|
|
else NextItm := nil;
|
|
|
|
if (Itm^.Dump <> '')
|
|
then Continue;
|
|
Itm^.Dump := ' ';
|
|
|
|
{$PUSH}{$IFnDEF DBGMI_WITH_DISASS_OVERFLOW}{$Q-}{$R-}{$ENDIF} // Overflow is allowed to occur
|
|
Addr := Itm^.Addr;
|
|
Offs := TDBGPtr(Addr - AMemDump.Addr);
|
|
if (Offs >= AMemDump.Count)
|
|
then Continue;
|
|
|
|
if (NextItm <> nil) //and (NextItm^.Addr > Addr)
|
|
then Len := NextItm^.Addr - Addr
|
|
else Len := AMemDump.Count - 1 - Offs;
|
|
if Offs + Len >= AMemDump.Count
|
|
then Len := AMemDump.Count - 1 - Offs;
|
|
if Len = 0
|
|
then Continue;
|
|
if Len > 32
|
|
then Len := 32;
|
|
{$POP}
|
|
s := '';
|
|
for i := Offs to Offs + Len - 1 do
|
|
s := s + Copy(AMemDump.ItemTxt[i],3,2);
|
|
Itm^.Dump := s;
|
|
end;
|
|
end;
|
|
|
|
(* Known issues with GDB's disassembler results:
|
|
** "-data-disassemble -s ### -e ### -- 1" with source
|
|
* Result may not be sorted by addresses
|
|
=>
|
|
* Result may be empty, even where "-- 0" (no src info) does return data
|
|
=> Remedy: disassemble those secions without src-info
|
|
If function-offset is available, this can be done per function
|
|
* Result may be missing src-info, even if src-info is available for parts of the result
|
|
This seems to be the case, if no src info is available for the start address,
|
|
then src-info for later addresses will be ignored.
|
|
=> Remedy: if function offset is available, disassembl;e per function
|
|
* Contains address gaps, as it does not show fillbytes, between functions
|
|
** "-data-disassemble -s ### -e ### -- 0" without source (probably both (with/without src)
|
|
* "func-name" may change, while "offset" keeps increasing
|
|
This was seen after the end of a procedure, with 0x00 bytes filling up to the next proc
|
|
=> Remedy: None, can be ignored
|
|
* In contineous disassemble a function may not be started at offset=0.
|
|
This seems to happen after 0x00 fill bytes.
|
|
The func-name changes and the offset restarts at a lower value (but not 0)
|
|
=> Remedy: discard data, and re-disassemble
|
|
*)
|
|
// Returns True: If some data was added
|
|
// False: if failed to add anything
|
|
function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}DoDisassembleRange(AnEntryRanges: TDBGDisassemblerEntryMap;AFirstAddr,
|
|
ALastAddr: TDisassemblerAddress; StopAfterAddress: TDBGPtr;
|
|
StopAfterNumLines: Integer): Boolean;
|
|
|
|
procedure AddRangetoMemDumpsNeeded(NewRange: TDBGDisassemblerEntryRange);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := length(FMemDumpsNeeded);
|
|
if (i > 0)
|
|
then begin
|
|
if (NewRange.RangeStartAddr <= FMemDumpsNeeded[0].FirstAddr)
|
|
and (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[0].FirstAddr)
|
|
then FMemDumpsNeeded[0].FirstAddr := NewRange.RangeStartAddr
|
|
else
|
|
if (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[0].LastAddr)
|
|
and (NewRange.RangeStartAddr <= FMemDumpsNeeded[0].LastAddr)
|
|
then FMemDumpsNeeded[0].LastAddr := NewRange.LastEntryEndAddr + 1
|
|
else
|
|
if (NewRange.RangeStartAddr <= FMemDumpsNeeded[i-1].FirstAddr)
|
|
and (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[i-1].FirstAddr)
|
|
then FMemDumpsNeeded[i-1].FirstAddr := NewRange.RangeStartAddr
|
|
else
|
|
if (NewRange.LastEntryEndAddr + 1 >= FMemDumpsNeeded[i-1].LastAddr)
|
|
and (NewRange.RangeStartAddr <= FMemDumpsNeeded[i-1].LastAddr)
|
|
then FMemDumpsNeeded[i-1].LastAddr := NewRange.LastEntryEndAddr + 1
|
|
else begin
|
|
SetLength(FMemDumpsNeeded, i + 1);
|
|
FMemDumpsNeeded[i].FirstAddr := NewRange.RangeStartAddr;
|
|
FMemDumpsNeeded[i].LastAddr := NewRange.LastEntryEndAddr + 1;
|
|
end;
|
|
end
|
|
else begin
|
|
SetLength(FMemDumpsNeeded, i + 1);
|
|
FMemDumpsNeeded[i].FirstAddr := NewRange.RangeStartAddr;
|
|
FMemDumpsNeeded[i].LastAddr := NewRange.LastEntryEndAddr + 1;
|
|
end;
|
|
end;
|
|
|
|
procedure DoDisassembleSourceless(ASubFirstAddr, ASubLastAddr: TDBGPtr;
|
|
ARange: TDBGDisassemblerEntryRange; SkipFirstAddresses: Boolean = False);
|
|
var
|
|
DisAssList, DisAssListCurrentSub: TGDBMIDisassembleResultList;
|
|
DisAssIterator: TGDBMIDisassembleResultFunctionIterator;
|
|
i: Integer;
|
|
begin
|
|
DisAssListCurrentSub := nil;
|
|
DisAssList := ExecDisassmble(ASubFirstAddr, ASubLastAddr, False, nil, True);
|
|
if DisAssList.Count > 0 then begin
|
|
i := 0;
|
|
if SkipFirstAddresses
|
|
then i := 1; // skip the instruction exactly at ASubFirstAddr;
|
|
DisAssIterator := TGDBMIDisassembleResultFunctionIterator.Create
|
|
(DisAssList, i, ASubLastAddr, FStartAddr, 0);
|
|
ARange.Capacity := Max(ARange.Capacity, ARange.Count + DisAssList.Count);
|
|
// add without source
|
|
while not DisAssIterator.EOL
|
|
do begin
|
|
DisAssIterator.NextSubList(DisAssListCurrentSub);
|
|
// ignore StopAfterNumLines, until we have at least the source;
|
|
|
|
if (not DisAssIterator.IsFirstSubList) and (DisAssListCurrentSub.Item[0]^.Offset <> 0)
|
|
then begin
|
|
// Current block starts with offset. Adjust and disassemble again
|
|
debugln(DBG_DISASSEMBLER, ['WARNING: Sublist not at offset 0 (filling gap in/before Src-Info): FromIdx=', DisAssIterator.CurrentIndex, ' NextIdx=', DisAssIterator.NextIndex,
|
|
' SequenceNo=', DisAssIterator.SublistNumber, ' StartIdx=', DisAssIterator.IndexOfLocateAddress, ' StartOffs=', DisAssIterator.OffsetOfLocateAddress]);
|
|
DisAssListCurrentSub := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
|
|
DisAssIterator.NextStartAddr, False, DisAssListCurrentSub, True);
|
|
end;
|
|
|
|
CopyToRange(DisAssListCurrentSub, ARange, 0, DisAssListCurrentSub.Count);
|
|
end;
|
|
|
|
FreeAndNil(DisAssIterator);
|
|
end;
|
|
FreeAndNil(DisAssList);
|
|
FreeAndNil(DisAssListCurrentSub);
|
|
end;
|
|
|
|
var
|
|
DisAssIterator: TGDBMIDisassembleResultFunctionIterator;
|
|
DisAssList, DisAssListCurrentSub, DisAssListWithSrc: TGDBMIDisassembleResultList;
|
|
i, Cnt, DisAssStartIdx: Integer;
|
|
NewRange: TDBGDisassemblerEntryRange;
|
|
OrigLastAddress, OrigFirstAddress: TDisassemblerAddress;
|
|
TmpAddr: TDBGPtr;
|
|
BlockOk, SkipDisAssInFirstLoop, ContinueAfterSource: Boolean;
|
|
Itm: TDisassemblerEntry;
|
|
begin
|
|
Result := False;
|
|
DisAssList := nil;
|
|
DisAssListCurrentSub := nil;
|
|
DisAssListWithSrc := nil;
|
|
DisAssIterator := nil;
|
|
OrigFirstAddress := AFirstAddr;
|
|
OrigLastAddress := ALastAddr;
|
|
SkipDisAssInFirstLoop := False;
|
|
|
|
NewRange := TDBGDisassemblerEntryRange.Create;
|
|
// set some values, wil be adjusted later (in CopyToRange
|
|
NewRange.RangeStartAddr := AFirstAddr.Value;
|
|
NewRange.RangeEndAddr := ALastAddr.Value;
|
|
NewRange.LastEntryEndAddr := ALastAddr.Value;
|
|
|
|
// No nice startingpoint found, just start to disassemble aprox 5 instructions before it
|
|
// and hope that when we started in the middle of an instruction it get sorted out.
|
|
// If so, the 4st for lines from the result must be discarded
|
|
if not (AFirstAddr.Validity in TrustedValidity)
|
|
then PadAddress(AFirstAddr, - 5 * DAssBytesPerCommandMax);
|
|
|
|
// Adjust ALastAddr
|
|
if ALastAddr.Value <= AFirstAddr.Value
|
|
then begin
|
|
ALastAddr.Value := AFirstAddr.Value;
|
|
PadAddress(ALastAddr, 2 * DAssBytesPerCommandMax);
|
|
end
|
|
else
|
|
if not (ALastAddr.Validity in TrustedValidity)
|
|
then PadAddress(ALastAddr, 2 * DAssBytesPerCommandMax);
|
|
|
|
DebugLnEnter(DBG_DISASSEMBLER, ['INFO: DoDisassembleRange for AFirstAddr =', Dbgs(AFirstAddr),
|
|
' ALastAddr=', Dbgs(ALastAddr), ' OrigFirst=', Dbgs(OrigFirstAddress), ' OrigLastAddress=', Dbgs(OrigLastAddress),
|
|
' StopAffterAddr=', StopAfterAddress, ' StopAfterLines=', StopAfterNumLines ]);
|
|
try // only needed for debugln DBG_DISASSEMBLER,
|
|
|
|
// check if we have an overall source-info
|
|
// we can only do that, if we know the offset of firstaddr (limit to DAssRangeOverFuncTreshold avg lines, should be enough)
|
|
// TODO: limit offset ONLY, if previous range known (already have disass)
|
|
if (AFirstAddr.Offset >= 0)
|
|
then begin
|
|
TmpAddr := AFirstAddr.Value - Min(AFirstAddr.Offset, DAssRangeOverFuncTreshold * DAssBytesPerCommandAvg);
|
|
DisAssListWithSrc := ExecDisassmble(TmpAddr, ALastAddr.Value, True);
|
|
end;
|
|
|
|
if (DisAssListWithSrc <> nil) and (DisAssListWithSrc.Count > 0) and DisAssListWithSrc.HasSourceInfo
|
|
then begin
|
|
DisAssListWithSrc.SortByAddress;
|
|
// gdb may return data far out of range.
|
|
if (DisAssListWithSrc.LastItem^.Addr < TmpAddr) and
|
|
(TmpAddr - DisAssListWithSrc.LastItem^.Addr > DAssMaxRangeSize)
|
|
then FreeAndNil(DisAssListWithSrc);
|
|
end;
|
|
|
|
if (DisAssListWithSrc <> nil) and (DisAssListWithSrc.Count > 0) and DisAssListWithSrc.HasSourceInfo
|
|
then begin
|
|
(* ***
|
|
*** Add the full source info
|
|
***
|
|
*)
|
|
Result := True;
|
|
//DisAssListWithSrc.SortByAddress;
|
|
if DisAssListWithSrc.Item[0]^.Addr > AFirstAddr.Value
|
|
then begin
|
|
// fill in gap at start
|
|
DoDisassembleSourceless(AFirstAddr.Value, DisAssListWithSrc.Item[0]^.Addr, NewRange);
|
|
end;
|
|
|
|
// Find out what comes after the disassembled source (need at least one statemnet, to determine end-add of last src-stmnt)
|
|
TmpAddr := DisAssListWithSrc.LastItem^.Addr;
|
|
ContinueAfterSource := OrigLastAddress.Value > TmpAddr;
|
|
if ContinueAfterSource
|
|
then TmpAddr := ALastAddr.Value;
|
|
DisAssList := ExecDisassmble(DisAssListWithSrc.LastItem^.Addr,
|
|
TmpAddr + 2 * DAssBytesPerCommandAlign, False);
|
|
|
|
// Add the known source list
|
|
if DisAssList.Count < 2
|
|
then TmpAddr := ALastAddr.Value
|
|
else TmpAddr := DisAssList.Item[1]^.Addr;
|
|
|
|
DisAssIterator := TGDBMIDisassembleResultFunctionIterator.Create
|
|
(DisAssListWithSrc, 0, TmpAddr , FStartAddr, StopAfterAddress);
|
|
NewRange.Capacity := Max(NewRange.Capacity, NewRange.Count + DisAssListWithSrc.Count);
|
|
while not DisAssIterator.EOL
|
|
do begin
|
|
if (dcsCanceled in SeenStates) then break;
|
|
DisAssIterator.NextSubList(DisAssListCurrentSub);
|
|
CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count); // Do not add the Sourcelist as last param, or it will get re-sorted
|
|
|
|
// check for gap
|
|
if DisAssListCurrentSub.LastItem^.Addr < DisAssIterator.NextStartAddr - DAssBytesPerCommandAlign
|
|
then begin
|
|
debugln(DBG_DISASSEMBLER, ['Info: Filling GAP in the middle of Source: Src-FromIdx=', DisAssIterator.CurrentIndex, ' Src-NextIdx=', DisAssIterator.NextIndex,
|
|
' Src-SequenceNo=', DisAssIterator.SublistNumber, ' Last Address in Src-Block=', DisAssListCurrentSub.LastItem^.Addr ]);
|
|
DoDisassembleSourceless(DisAssListCurrentSub.LastItem^.Addr, DisAssIterator.NextStartAddr, NewRange, True);
|
|
end;
|
|
end;
|
|
i := DisAssIterator.CountLinesAfterCounterAddr;
|
|
|
|
FreeAndNil(DisAssIterator);
|
|
FreeAndNil(DisAssListWithSrc);
|
|
FreeAndNil(DisAssListCurrentSub);
|
|
// Source Completly Added
|
|
|
|
if not ContinueAfterSource
|
|
then begin
|
|
AdjustLastEntryEndAddr(NewRange, DisAssList);
|
|
AddRangetoMemDumpsNeeded(NewRange);
|
|
AnEntryRanges.AddRange(NewRange); // NewRange is now owned by AnEntryRanges
|
|
NewRange := nil;
|
|
FreeAndNil(DisAssList);
|
|
exit;
|
|
end;
|
|
|
|
// continue with the DisAsslist for the remainder
|
|
AFirstAddr.Validity := avFoundFunction; // if we got source, then start is ok (original start is kept)
|
|
DisAssStartIdx := 1;
|
|
SkipDisAssInFirstLoop := True;
|
|
if i > 0
|
|
then StopAfterNumLines := StopAfterNumLines - i;
|
|
(* ***
|
|
*** Finished adding the full source info
|
|
***
|
|
*)
|
|
end
|
|
else begin
|
|
(* ***
|
|
*** Full Source was not available
|
|
***
|
|
*)
|
|
if (DisAssListWithSrc <> nil) and (DisAssListWithSrc.Count > 0)
|
|
then begin
|
|
DisAssList := DisAssListWithSrc; // got data already
|
|
DisAssListWithSrc := nil;
|
|
end
|
|
else begin
|
|
DisAssList := ExecDisassmble(AFirstAddr.Value, ALastAddr.Value, False);
|
|
end;
|
|
|
|
if DisAssList.Count < 2
|
|
then begin
|
|
debugln('Error failed to get enough data for dsassemble');
|
|
// create a dummy range, so we will not retry
|
|
NewRange.Capacity := 1;
|
|
NewRange.RangeStartAddr := AFirstAddr.Value;
|
|
if OrigLastAddress.Value > AFirstAddr.Value+1
|
|
then NewRange.RangeEndAddr := OrigLastAddress.Value
|
|
else NewRange.RangeEndAddr := AFirstAddr.Value+1;
|
|
NewRange.LastEntryEndAddr := AFirstAddr.Value+1;
|
|
Itm.Addr := AFirstAddr.Value;
|
|
Itm.Dump := ' ';
|
|
Itm.SrcFileLine := 0;
|
|
Itm.Offset := 0;
|
|
itm.Statement := '<error>';
|
|
NewRange.Append(@Itm);
|
|
AnEntryRanges.AddRange(NewRange); // NewRange is now owned by AnEntryRanges
|
|
NewRange := nil;
|
|
FreeAndNil(DisAssList);
|
|
exit;
|
|
end;
|
|
|
|
DisAssStartIdx := 0;
|
|
end;
|
|
|
|
// we may have gotten more lines than ask, and the last line we don't know the length
|
|
Cnt := DisAssList.Count;
|
|
if (ALastAddr.Validity = avPadded) or (DisAssList.LastItem^.Addr >= ALastAddr.Value)
|
|
then begin
|
|
ALastAddr.Value := DisAssList.LastItem^.Addr;
|
|
ALastAddr.Validity := avFoundStatement;
|
|
dec(Cnt);
|
|
DisAssList.Count := Cnt;
|
|
end;
|
|
// ALastAddr.Value is now the address after the last statement;
|
|
|
|
if (AFirstAddr.Validity = avPadded) // always False, if we had source-info
|
|
then begin
|
|
// drop up to 4 entries, if possible
|
|
while (DisAssStartIdx < 4) and (DisAssStartIdx + 1 < Cnt) and (DisAssList.Item[DisAssStartIdx+1]^.Addr <= OrigFirstAddress.Value)
|
|
do inc(DisAssStartIdx);
|
|
AFirstAddr.Value := DisAssList.Item[DisAssStartIdx]^.Addr;
|
|
AFirstAddr.Validity := avFoundStatement;
|
|
end;
|
|
|
|
|
|
NewRange.Capacity := Max(NewRange.Capacity, NewRange.Count + Cnt);
|
|
|
|
DisAssIterator := TGDBMIDisassembleResultFunctionIterator.Create
|
|
(DisAssList, DisAssStartIdx, ALastAddr.Value, FStartAddr, StopAfterAddress);
|
|
|
|
while not DisAssIterator.EOL
|
|
do begin
|
|
if (dcsCanceled in SeenStates) then break;
|
|
BlockOk := DisAssIterator.NextSubList(DisAssListCurrentSub);
|
|
|
|
// Do we have enough lines (without the current block)?
|
|
if (DisAssIterator.CountLinesAfterCounterAddr > StopAfterNumLines)
|
|
then begin
|
|
DebugLn(DBG_DISASSEMBLER, ['INFO: Got enough line in Iteration: CurrentIndex=', DisAssIterator.CurrentIndex]);
|
|
NewRange.LastEntryEndAddr := DisAssIterator.NextStartAddr;
|
|
//AdjustLastEntryEndAddr(NewRange, DisAssList);
|
|
break;
|
|
end;
|
|
|
|
if (not DisAssIterator.IsFirstSubList) and (DisAssListCurrentSub.Item[0]^.Offset <> 0)
|
|
then begin
|
|
// Got List with Offset at start
|
|
debugln(DBG_DISASSEMBLER, ['WARNING: Sublist not at offset 0 (offs=',DisAssListCurrentSub.Item[0]^.Offset,'): FromIdx=', DisAssIterator.CurrentIndex, ' NextIdx=', DisAssIterator.NextIndex,
|
|
' SequenceNo=', DisAssIterator.SublistNumber, ' StartIdx=', DisAssIterator.IndexOfLocateAddress, ' StartOffs=', DisAssIterator.OffsetOfLocateAddress]);
|
|
// Current block starts with offset. Adjust and disassemble again
|
|
// Try with source first, in case it returns dat without source
|
|
DisAssListWithSrc := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
|
|
DisAssIterator.NextStartAddr, True, DisAssListWithSrc, True);
|
|
if (DisAssListWithSrc.Count > 0)
|
|
then begin
|
|
if DisAssListWithSrc.HasSourceInfo
|
|
then DisAssListWithSrc.SortByAddress;
|
|
if (not DisAssListWithSrc.HasSourceInfo)
|
|
or (DisAssListWithSrc.LastItem^.Addr > DisAssIterator.NextStartAddr - DAssBytesPerCommandAlign)
|
|
then begin
|
|
// no source avail, but got data
|
|
// OR source and no gap
|
|
CopyToRange(DisAssListWithSrc, NewRange, 0, DisAssListWithSrc.Count);
|
|
Result := True;
|
|
continue;
|
|
end;
|
|
end;
|
|
|
|
//get the source-less code as reference
|
|
DisAssListCurrentSub := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
|
|
DisAssIterator.NextStartAddr, False, DisAssListCurrentSub, True);
|
|
CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count, DisAssListWithSrc);
|
|
Result := Result or (DisAssListCurrentSub.Count > 0);
|
|
continue;
|
|
end;
|
|
|
|
// Todo: Check for wrong start stmnt offset
|
|
if BlockOk
|
|
then begin
|
|
// Got a good block
|
|
if (DisAssListCurrentSub.Item[0]^.FuncName <> '')
|
|
then begin
|
|
// Try to get source-info (up to DisAssIterator.NextStartAddr)
|
|
// Subtract offset from StartAddress, in case this is the first block
|
|
// (we may continue existing data, but src info must be retrieved in full, or may be incomplete)
|
|
if not( DisAssIterator.IsFirstSubList and SkipDisAssInFirstLoop )
|
|
then begin
|
|
DisAssListWithSrc := ExecDisassmble(DisAssIterator.CurrentFixedAddr(DAssMaxRangeSize),
|
|
DisAssIterator.NextStartAddr, True, DisAssListWithSrc, True);
|
|
// We may have less lines with source, as we stripped padding at the end
|
|
if (DisAssListWithSrc <> nil) and DisAssListWithSrc.HasSourceInfo
|
|
then begin
|
|
CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count, DisAssListWithSrc);
|
|
Result := Result or (DisAssListCurrentSub.Count > 0);
|
|
continue;
|
|
end;
|
|
end;
|
|
end;
|
|
CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count);
|
|
Result := Result or (DisAssListCurrentSub.Count > 0);
|
|
continue;
|
|
end;
|
|
|
|
// Got a problematic block
|
|
debugln(DBG_DISASSEMBLER, ['WARNING: FindProcEnd reported an issue FromIdx=', DisAssIterator.CurrentIndex,' NextIdx=',
|
|
DisAssIterator.NextIndex, ' StartIdx=', DisAssIterator.IndexOfLocateAddress, ' StartOffs=', DisAssIterator.OffsetOfLocateAddress]);
|
|
//if DisAssIterator.IsFirstSubList and (not(AFirstAddr.Validity in TrustedValidity))
|
|
//and (DisAssIterator.IndexOfLocateAddress >= DisAssIterator.CurrentIndex) // in current list
|
|
//and (DisAssIterator.OffsetOfLocateAddress <> 0)
|
|
//then begin
|
|
// // FStartAddr is in the middle of a statement. Maybe move the Range?
|
|
//end;
|
|
|
|
CopyToRange(DisAssListCurrentSub, NewRange, 0, DisAssListCurrentSub.Count);
|
|
Result := Result or (DisAssListCurrentSub.Count > 0);
|
|
end;
|
|
|
|
if NewRange.LastEntryEndAddr > NewRange.RangeEndAddr
|
|
then NewRange.RangeEndAddr := NewRange.LastEntryEndAddr;
|
|
|
|
AddRangetoMemDumpsNeeded(NewRange);
|
|
AnEntryRanges.AddRange(NewRange); // NewRange is now owned by AnEntryRanges
|
|
NewRange := nil;
|
|
|
|
FreeAndNil(DisAssIterator);
|
|
FreeAndNil(DisAssList);
|
|
FreeAndNil(DisAssListCurrentSub);
|
|
FreeAndNil(DisAssListWithSrc);
|
|
finally
|
|
DebugLnExit(DBG_DISASSEMBLER, ['INFO: DoDisassembleRange finished' ]);
|
|
end;
|
|
end;
|
|
|
|
function {$ifndef disassemblernestedproc}TGDBMIDebuggerCommandDisassemble.{$endif}OnCheckCancel: boolean;
|
|
begin
|
|
result := dcsCanceled in SeenStates;
|
|
end;
|
|
|
|
{$ifndef disassemblernestedproc}
|
|
function TGDBMIDebuggerCommandDisassemble.DoExecute: Boolean;
|
|
{$endif disassemblernestedproc}
|
|
|
|
function ExecMemDump(AStartAddr: TDbgPtr; ACount: Cardinal;
|
|
AResultList: TGDBMIMemoryDumpResultList = nil): TGDBMIMemoryDumpResultList;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Result := AResultList;
|
|
ExecuteCommand('-data-read-memory %u x 1 1 %u', [AStartAddr, ACount], R);
|
|
if Result <> nil
|
|
then Result.Init(R)
|
|
else Result := TGDBMIMemoryDumpResultList.Create(R);
|
|
end;
|
|
|
|
procedure AddMemDumps;
|
|
var
|
|
i: Integer;
|
|
MemDump: TGDBMIMemoryDumpResultList;
|
|
Rng: TDBGDisassemblerEntryRange;
|
|
FirstAddr: TDBGPtr;
|
|
begin
|
|
MemDump := nil;
|
|
for i := 0 to length(FMemDumpsNeeded) - 1 do
|
|
begin
|
|
if (dcsCanceled in SeenStates) then break;
|
|
FirstAddr := FMemDumpsNeeded[i].FirstAddr;
|
|
Rng := FRangeIterator.GetRangeForAddr(FirstAddr, True);
|
|
if rng <> nil
|
|
then MemDump := ExecMemDump(FirstAddr, FMemDumpsNeeded[i].LastAddr - FirstAddr, MemDump);
|
|
if DebuggerState <> dsError
|
|
then begin
|
|
while (Rng <> nil) and (Rng.FirstAddr <= FMemDumpsNeeded[i].LastAddr) do
|
|
begin
|
|
AddMemDumpToRange(Rng, MemDump, FMemDumpsNeeded[i].FirstAddr, FMemDumpsNeeded[i].LastAddr);
|
|
Rng := FRangeIterator.NextRange;
|
|
end;
|
|
end;
|
|
end;
|
|
FreeAndNil(MemDump);
|
|
end;
|
|
|
|
var
|
|
DisassembleRangeExtender: TDBGDisassemblerRangeExtender;
|
|
begin
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
if FEndAddr < FStartAddr
|
|
then FEndAddr := FStartAddr;
|
|
|
|
DisassembleRangeExtender := TDBGDisassemblerRangeExtender.Create(FKnownRanges);
|
|
try
|
|
DisassembleRangeExtender.OnDoDisassembleRange:=@DoDisassembleRange;
|
|
DisassembleRangeExtender.OnCheckCancel:=@OnCheckCancel;
|
|
DisassembleRangeExtender.OnAdjustToKnowFunctionStart:=@AdjustToKnowFunctionStart;
|
|
result := DisassembleRangeExtender.DisassembleRange(FLinesBefore, FLinesAfter, FStartAddr, FStartAddr);
|
|
finally
|
|
DisassembleRangeExtender.Free;
|
|
end;
|
|
|
|
DoProgress;
|
|
AddMemDumps;
|
|
DoProgress;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandDisassemble.Create(AOwner: TGDBMIDebugger;
|
|
AKnownRanges: TDBGDisassemblerEntryMap; AStartAddr, AEndAddr: TDbgPtr; ALinesBefore,
|
|
ALinesAfter: Integer);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FKnownRanges := AKnownRanges;
|
|
FRangeIterator:= TDBGDisassemblerEntryMapIterator.Create(FKnownRanges);
|
|
FStartAddr := AStartAddr;
|
|
FEndAddr := AEndAddr;
|
|
FLinesBefore := ALinesBefore;
|
|
FLinesAfter := ALinesAfter;
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommandDisassemble.Destroy;
|
|
begin
|
|
FreeAndNil(FRangeIterator);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandDisassemble.DebugText: String;
|
|
begin
|
|
Result := Format('%s: FromAddr=%u ToAddr=%u LinesBefore=%d LinesAfter=%d',
|
|
[ClassName, FStartAddr, FEndAddr, FLinesBefore, FLinesAfter]);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStartDebugging }
|
|
|
|
function TGDBMIDebuggerCommandStartDebugging.DoExecute: Boolean;
|
|
|
|
{$IF defined(UNIX) or defined(DBG_ENABLE_TERMINAL)}
|
|
procedure InitConsole;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
s: String;
|
|
h: THandle;
|
|
isConsole: Boolean;
|
|
begin
|
|
isConsole := False;
|
|
// Make sure consule output will ot be mixed with gbd output
|
|
{$IFDEF DBG_ENABLE_TERMINAL}
|
|
{$IFDEF UNIX}
|
|
(* DBG_ENABLE_TERMINAL and UNIX *)
|
|
s := DebuggerProperties.ConsoleTty;
|
|
if s = '' then begin
|
|
FTheDebugger.FPseudoTerminal.Open;
|
|
s := FTheDebugger.FPseudoTerminal.Devicename;
|
|
isConsole := True;
|
|
end;
|
|
{$ELSE}
|
|
(* only DBG_ENABLE_TERMINAL *)
|
|
FTheDebugger.FPseudoTerminal.Open;
|
|
s := FTheDebugger.FPseudoTerminal.Devicename;
|
|
isConsole := True;
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
(* only UNIX *)
|
|
s := DebuggerProperties.ConsoleTty;
|
|
if s = '' then s := '/dev/null';
|
|
{$ENDIF}
|
|
|
|
if not isConsole then begin
|
|
h := fileopen(S, fmOpenWrite);
|
|
isConsole := IsATTY(h) = 1;
|
|
FileClose(h);
|
|
end;
|
|
|
|
if isConsole then
|
|
isConsole := ExecuteCommand('set inferior-tty %s', [s], R) and (r.State <> dsError);
|
|
if not isConsole then
|
|
ExecuteCommand('set inferior-tty /dev/null', []);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
var
|
|
FndOffsFile, FndOffsLine: String;
|
|
StoppedFile, StoppedLine: String;
|
|
StoppedAddr: TDBGPtr;
|
|
StoppedAtEntryPoint: Boolean;
|
|
const
|
|
MIN_RELOC_ADDRESS = $4000;
|
|
|
|
procedure RunToMain(EntryPoint: String);
|
|
type
|
|
TRunToMainType = (mtMain, mtMainAddr, mtEntry, mtAddZero);
|
|
var
|
|
EntryPointNum: TDBGPtr;
|
|
|
|
function SetMainBrk: boolean;
|
|
procedure MaybeAddMainBrk(AType: TRunToMainType; AnSkipIfCntGreater: Integer;
|
|
ACheckEntryPoinReloc: Boolean = false);
|
|
begin
|
|
// Check if the Entrypoint looks promising (if it looks like it matches the relocated address)
|
|
if ACheckEntryPoinReloc and not(EntryPointNum > MIN_RELOC_ADDRESS) then
|
|
exit;
|
|
// Check amount of already set breakpoints
|
|
if (AnSkipIfCntGreater >= 0) and (FTheDebugger.FMainAddrBreak.BreakSetCount > AnSkipIfCntGreater) then
|
|
exit;
|
|
case AType of
|
|
mtMain: FTheDebugger.FMainAddrBreak.SetByName(Self);
|
|
mtMainAddr: FTheDebugger.FMainAddrBreak.SetByAddr(Self);
|
|
mtEntry: FTheDebugger.FMainAddrBreak.SetAtCustomAddr(Self, StrToQWordDef(EntryPoint, 0));
|
|
mtAddZero: FTheDebugger.FMainAddrBreak.SetAtLineOffs(Self, 0);
|
|
end;
|
|
|
|
if (AType = mtAddZero) and (FndOffsFile = '') then begin
|
|
FndOffsLine := FTheDebugger.FMainAddrBreak.BreakLine[iblAddOffset];
|
|
if (FndOffsLine <> '') then
|
|
FndOffsFile := FTheDebugger.FMainAddrBreak.BreakFile[iblAddOffset];
|
|
end;
|
|
end;
|
|
var
|
|
bcnt: Integer;
|
|
begin
|
|
Result := False;
|
|
bcnt := FTheDebugger.FMainAddrBreak.BreakSetCount;
|
|
case DebuggerProperties.InternalStartBreak of
|
|
gdsbEntry: begin
|
|
MaybeAddMainBrk(mtEntry, -1, true);
|
|
if not FTheDebugger.FMainAddrBreak.IsBreakSet then begin
|
|
MaybeAddMainBrk(mtEntry, -1, false);
|
|
MaybeAddMainBrk(mtAddZero, -1);
|
|
// set only, if no other is set (e.g. 2nd attempt)
|
|
MaybeAddMainBrk(mtMainAddr, 0);
|
|
MaybeAddMainBrk(mtMain, 0);
|
|
end;
|
|
end;
|
|
gdsbMainAddr: begin
|
|
MaybeAddMainBrk(mtMainAddr, -1);
|
|
// set only, if no other is set (e.g. 2nd attempt)
|
|
if not FTheDebugger.FMainAddrBreak.IsBreakSet then begin
|
|
MaybeAddMainBrk(mtEntry, 0, true);
|
|
MaybeAddMainBrk(mtAddZero, 1);
|
|
MaybeAddMainBrk(mtEntry, 0, false);
|
|
MaybeAddMainBrk(mtMain, 0);
|
|
end;
|
|
end;
|
|
gdsbMain: begin
|
|
MaybeAddMainBrk(mtMain, -1);
|
|
// set only, if no other is set (e.g. 2nd attempt)
|
|
MaybeAddMainBrk(mtAddZero, 0);
|
|
MaybeAddMainBrk(mtMainAddr, 0);
|
|
MaybeAddMainBrk(mtEntry, 0, false);
|
|
end;
|
|
gdsbAddZero: begin
|
|
MaybeAddMainBrk(mtAddZero, -1);
|
|
// set only, if no other is set (e.g. 2nd attempt)
|
|
MaybeAddMainBrk(mtEntry, 0, true);
|
|
MaybeAddMainBrk(mtMain, 0);
|
|
MaybeAddMainBrk(mtEntry, 0, false);
|
|
MaybeAddMainBrk(mtMainAddr, 0);
|
|
end;
|
|
else begin // gdsbDefault
|
|
// SetByName: "main", this is the best aproach, unless any library also exports main.
|
|
MaybeAddMainBrk(mtMain, -1);
|
|
MaybeAddMainBrk(mtEntry, -1, true); // Previous versions used "+0" as 2nd in the list
|
|
MaybeAddMainBrk(mtAddZero, -1);
|
|
MaybeAddMainBrk(mtMainAddr, 2); // set only, if less than 2 are set
|
|
// set only, if no other is set (e.g. 2nd attempt)
|
|
MaybeAddMainBrk(mtEntry, 0, false);
|
|
end;
|
|
end;
|
|
Result := bcnt < FTheDebugger.FMainAddrBreak.BreakSetCount; // added new breaks
|
|
end;
|
|
|
|
function ParseLogForPid(ALogTxt: String): Integer;
|
|
var
|
|
s: String;
|
|
begin
|
|
s := GetPart(['=thread-group-started,'], [LineEnding], ALogTxt, True, False);
|
|
if s <> '' then
|
|
s := GetPart(['pid="'], ['"'], s, True, False);
|
|
if s <> '' then begin
|
|
Result := StrToIntDef(s, 0);
|
|
if Result <> 0 then exit;
|
|
end;
|
|
|
|
s := GetPart(['process '], [' local', ']'], ALogTxt, True);
|
|
Result := StrToIntDef(s, 0);
|
|
end;
|
|
|
|
function ParseStopped(AParam: String): Integer;
|
|
var
|
|
List: TGDBMINameValueList;
|
|
Reason: String;
|
|
begin
|
|
Result := -1; // no id found
|
|
List := nil;
|
|
try
|
|
List := TGDBMINameValueList.Create(AParam);
|
|
Reason := List.Values['reason'];
|
|
if (Reason = 'exited-normally') or (Reason = 'exited') or
|
|
(Reason = 'exited-signalled')
|
|
then
|
|
Result := -2;
|
|
// if Reason = 'signal-received' // Pause ?
|
|
if Reason = 'breakpoint-hit' then begin
|
|
Result := StrToIntDef(List.Values['bkptno'], -1);
|
|
StoppedAtEntryPoint := Result = FTheDebugger.FMainAddrBreak.BreakId[iblCustomAddr];
|
|
List.SetPath('frame');
|
|
StoppedAddr := StrToInt64Def(List.Values['addr'], -1);
|
|
StoppedFile := List.Values['fullname'];
|
|
if StoppedFile = '' then
|
|
StoppedFile := List.Values['file'];
|
|
StoppedLine := List.Values['line'];
|
|
end;
|
|
except
|
|
end;
|
|
List.Free;
|
|
end;
|
|
|
|
var
|
|
R: TGDBMIExecResult;
|
|
Cmd, s, s2, rval: String;
|
|
i, j, LoopCnt: integer;
|
|
List: TGDBMINameValueList;
|
|
BrkErr: Boolean;
|
|
begin
|
|
EntryPointNum := StrToQWordDef(EntryPoint, 0);
|
|
TargetInfo^.TargetPID := 0;
|
|
FDidKillNow := False;
|
|
|
|
// TODO: async
|
|
Cmd := GdbRunCommand;// '-exec-run';
|
|
rval := '';
|
|
R.State := dsError;
|
|
FTheDebugger.FMainAddrBreak.Clear(Self);
|
|
LoopCnt := 6; // max iterations
|
|
while (LoopCnt > 0) and not(DebuggerState = dsError) do begin
|
|
dec(LoopCnt);
|
|
SetMainBrk;
|
|
if not FTheDebugger.FMainAddrBreak.IsBreakSet
|
|
then begin
|
|
(* TODO:
|
|
If no main break can be set, it may still be possible (desirable) to run
|
|
the app, without debug-capacbilities
|
|
Or maybe even try to set all breakpoints.
|
|
*)
|
|
SetDebuggerErrorState(Format(gdbmiCommandStartMainBreakError, [LineEnding]),
|
|
ErrorStateInfo);
|
|
exit; // failed to find a main breakpoint
|
|
end;
|
|
|
|
// RUN
|
|
DefaultTimeOut := 0;
|
|
if not ExecuteCommand(Cmd, R, [cfTryAsync])
|
|
then begin
|
|
SetDebuggerErrorState(Format(gdbmiCommandStartMainRunError, [LineEnding]),
|
|
ErrorStateInfo);
|
|
exit;
|
|
end;
|
|
s := r.Values + FLogWarnings;
|
|
if TargetInfo^.TargetPID = 0 then
|
|
TargetInfo^.TargetPID := ParseLogForPid(s);
|
|
|
|
s2 := '';
|
|
if R.State = dsRun
|
|
then begin
|
|
if not (rfAsyncFailed in R.Flags) then begin
|
|
FCanKillNow := True;
|
|
FTheDebugger.FCurrentCmdIsAsync := True;
|
|
end;
|
|
if (TargetInfo^.TargetPID <> 0) then
|
|
FCanKillNow := True;
|
|
ProcessRunning(s2, R);
|
|
FCanKillNow := False;
|
|
FTheDebugger.FCurrentCmdIsAsync := False;
|
|
j := ParseStopped(s2);
|
|
if (j = -2) or (pos('reason="exited-normally"', s2) > 0) or FDidKillNow then begin
|
|
// app has already run
|
|
R.State := dsStop;
|
|
break;
|
|
end;
|
|
R.State := dsRun; // restore cmd state
|
|
s := s + s2 + R.Values;
|
|
Cmd := '-exec-continue'; // until we hit one of the breakpoints
|
|
end;
|
|
|
|
rval := rval + s;
|
|
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval; // Getting address for breakpoints may need timeout
|
|
BrkErr := ParseBreakInsertError(s, i);
|
|
if not BrkErr
|
|
then break;
|
|
|
|
j := FTheDebugger.FMainAddrBreak.BreakSetCount;
|
|
while BrkErr and not(DebuggerState = dsError) do begin
|
|
if not FTheDebugger.FMainAddrBreak.ClearAndBlockId(Self, i)
|
|
then begin
|
|
DebugLn(DBG_WARNINGS, ['TGDBMIDebugger.RunToMain: An unknown breakpoint id was reported as failing: ', i]);
|
|
if not ExecuteCommand('-break-delete %d', [i], [cfCheckError]) // wil set error state if it fails
|
|
then break;
|
|
inc(j);
|
|
end;
|
|
BrkErr := ParseBreakInsertError(s, i)
|
|
end;
|
|
// Break, if no breakpoint was removed
|
|
if j = FTheDebugger.FMainAddrBreak.BreakSetCount
|
|
then break;
|
|
end;
|
|
|
|
if DebuggerState = dsError then
|
|
exit;
|
|
|
|
if FDidKillNow then
|
|
exit;
|
|
if R.State = dsStop
|
|
then begin
|
|
debugln(DBG_WARNINGS, 'Debugger INIT failed. App has already run');
|
|
SetDebuggerErrorState(Format(gdbmiCommandStartMainRunToStopError, [LineEnding]),
|
|
ErrorStateInfo);
|
|
exit;
|
|
end;
|
|
|
|
if not(R.State = dsRun)
|
|
then begin
|
|
SetDebuggerErrorState(Format(gdbmiCommandStartMainRunError, [LineEnding]),
|
|
ErrorStateInfo);
|
|
exit;
|
|
end;
|
|
|
|
FTheDebugger.FMainAddrBreak.Clear(Self);
|
|
|
|
SetDebuggerState(dsRun); // TODO: should not be needed here
|
|
|
|
// and we should ave hit a breakpoint
|
|
//List := TGDBMINameValueList.Create(R.Values);
|
|
//Reason := List.Values['reason'];
|
|
//if Reason = 'breakpoint-hit'
|
|
|
|
|
|
(* *** Find the PID *** *)
|
|
|
|
(* Try GDB output. Some of output after the -exec-run.
|
|
|
|
Mac GDB 6.3.5
|
|
~"[Switching to process 12345 local thread 0x0123]\n"
|
|
|
|
FreeBSD 9.0 GDB 6.1 (modified ?, supplied by FreeBSD)
|
|
PID is not equal to LWP.
|
|
[New LWP 100229]
|
|
[New Thread 807407400 (LWP 100229/project1)]
|
|
[Switching to Thread 807407400 (LWP 100229/project1)]
|
|
|
|
Somme linux, GDB 7.1
|
|
Win GDB 7.0
|
|
=thread-group-created,id="2125"
|
|
=thread-created,id="1",group-id="2125"
|
|
~"[New Thread 9280.0x24e4]\n" // This line is Win only (or gdb 7.0?)
|
|
^running
|
|
*running,thread-id="all"
|
|
(gdb)
|
|
|
|
|
|
Win GDB 7.4
|
|
FreeBSD 9.0 GDB 7.3 (from ports)
|
|
=thread-group-started,id="i1",pid="8876"
|
|
=thread-created,id="1",group-id="i1"
|
|
~"[New Thread 8876.0x21c0]\n" // This line is Win only (or gdb 7.0?)
|
|
^running
|
|
*running,thread-id="all"
|
|
(gdb)
|
|
|
|
FreeBSD 9.0 GDB 7.3 (from ports) CONTINUED (LWP is not useable
|
|
=thread-created,id="1",group-id="i1"
|
|
~"[New LWP 100073]\n"
|
|
*running,thread-id="1"
|
|
=thread-created,id="2",group-id="i1"
|
|
~"[New Thread 807407400 (LWP 100073)]\n"
|
|
=thread-exited,id="1",group-id="i1"
|
|
~"[Switching to Thread 807407400 (LWP 100073)]\n"
|
|
|
|
*)
|
|
if TargetInfo^.TargetPID <> 0 then
|
|
exit;
|
|
|
|
TargetInfo^.TargetPID := ParseLogForPid(rval);
|
|
if TargetInfo^.TargetPID <> 0 then
|
|
exit;
|
|
|
|
(* PID via "info program"
|
|
|
|
Somme linux, gdb 7.1
|
|
~"\tUsing the running image of child Thread 0xb7fd8820 (LWP 2125).\n"
|
|
|
|
On FreeBSD LWP may differ from PID
|
|
FreeBSD 9.0 GDB 6.1 (modified ?, supplied by FreeBSD)
|
|
PID is not equal to LWP.
|
|
Using the running image of child Thread 807407400 (LWP 100229/project1).
|
|
|
|
Win GDB 7.4
|
|
~"\tUsing the running image of child Thread 8876.0x21c0.\n"
|
|
*)
|
|
if ExecuteCommand('info program', [], R, [cfCheckState])
|
|
then begin
|
|
s := GetPart(['child process ', 'child thread ', 'lwp '], [' ', '.', ')'],
|
|
R.Values, True);
|
|
TargetInfo^.TargetPID := StrToIntDef(s, 0);
|
|
if TargetInfo^.TargetPID <> 0 then exit;
|
|
end;
|
|
|
|
// apple
|
|
if ExecuteCommand('info pid', [], R, [cfCheckState]) and (R.State <> dsError)
|
|
then begin
|
|
List := TGDBMINameValueList.Create(R);
|
|
TargetInfo^.TargetPID := StrToIntDef(List.Values['process-id'], 0);
|
|
List.Free;
|
|
if TargetInfo^.TargetPID <> 0 then exit;
|
|
end;
|
|
|
|
// gdb server
|
|
if ExecuteCommand('info proc', [], R, [cfCheckState]) and (R.State <> dsError)
|
|
then begin
|
|
s := GetPart(['process '], [#10,#13#10], R.Values, True);
|
|
TargetInfo^.TargetPID := StrToIntDef(s, 0);
|
|
if TargetInfo^.TargetPID <> 0 then exit;
|
|
end;
|
|
|
|
// apple / MacPort 7.1 / 32 bit dwarf
|
|
if ExecuteCommand('info threads', [], R, [cfCheckState]) and (R.State <> dsError)
|
|
then begin
|
|
s := GetPart(['of process '], [' '], R.Values, True);
|
|
TargetInfo^.TargetPID := StrToIntDef(s, 0);
|
|
if TargetInfo^.TargetPID <> 0 then exit;
|
|
|
|
// returned by gdb server (maybe others)
|
|
s := GetPart(['Thread '], [' ', '.'], R.Values, True);
|
|
TargetInfo^.TargetPID := StrToIntDef(s, 0);
|
|
if TargetInfo^.TargetPID <> 0 then exit;
|
|
end;
|
|
|
|
// no PID found
|
|
SetDebuggerErrorState(Format(gdbmiCommandStartMainRunNoPIDError, [LineEnding]));
|
|
end;
|
|
|
|
var
|
|
R: TGDBMIExecResult;
|
|
FileType, EntryPoint: String;
|
|
List: TGDBMINameValueList;
|
|
CanContinue: Boolean;
|
|
StateStopped: Boolean;
|
|
begin
|
|
Result := True;
|
|
FSuccess := False;
|
|
StateStopped := False;
|
|
|
|
try
|
|
if not (DebuggerState in [dsStop])
|
|
then begin
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
|
|
if not DoChangeFilename then begin
|
|
SetDebuggerErrorState(synfFailedToLoadApplicationExecutable, FErrorMsg);
|
|
exit;
|
|
end;
|
|
if not DoSetPascal then begin
|
|
SetDebuggerErrorState(synfFailedToInitializeTheDebuggerSetPascalFailed,
|
|
FLastExecResult.Values);
|
|
exit;
|
|
end;
|
|
|
|
DebugLn(['TGDBMIDebugger.StartDebugging WorkingDir="', FTheDebugger.WorkingDir,'"']);
|
|
if FTheDebugger.WorkingDir <> ''
|
|
then begin
|
|
// to workaround a possible bug in gdb, first set the workingdir to .
|
|
// otherwise on second run within the same gdb session the workingdir
|
|
// is set to c:\windows
|
|
ExecuteCommand('-environment-cd %s', ['.'], []);
|
|
ExecuteCommand('-environment-cd %s', [FTheDebugger.ConvertToGDBPath(FTheDebugger.WorkingDir, cgptCurDir)], [cfCheckError]);
|
|
end;
|
|
|
|
TargetInfo^.TargetFlags := [tfHasSymbols]; // Set until proven otherwise
|
|
|
|
// check if the exe is compiled with FPC >= 1.9.2
|
|
// then the rtl is compiled with regcalls
|
|
RetrieveRegCall;
|
|
|
|
// also call execute -exec-arguments if there are no arguments in this run
|
|
// so the possible arguments of a previous run are cleared
|
|
ExecuteCommand('-exec-arguments %s', [UTF8ToWinCP(FTheDebugger.Arguments)], [cfCheckState]);
|
|
|
|
{$IF defined(UNIX) or defined(DBG_ENABLE_TERMINAL)}
|
|
InitConsole;
|
|
{$ENDIF}
|
|
|
|
ExecuteCommand('-gdb-set language pascal', [cfCheckError]);
|
|
|
|
CheckAvailableTypes;
|
|
CommonInit;
|
|
|
|
TargetInfo^.TargetCPU := '';
|
|
TargetInfo^.TargetOS := FTheDebugger.FGDBOS; // try to detect ??
|
|
|
|
// try to retrieve the filetype and program entry point
|
|
FileType := '';
|
|
EntryPoint := '';
|
|
if ExecuteCommand('info file', R)
|
|
then begin
|
|
if rfNoMI in R.Flags
|
|
then begin
|
|
FileType := GetPart('file type ', '.', R.Values);
|
|
EntryPoint := GetPart(['Entry point: '], [#10, #13, '\t'], R.Values);
|
|
end
|
|
else begin
|
|
// OS X gdb has mi output here
|
|
List := TGDBMINameValueList.Create(R, ['section-info']);
|
|
FileType := List.Values['filetype'];
|
|
EntryPoint := List.Values['entry-point'];
|
|
List.Free;
|
|
end;
|
|
DebugLn(DBG_VERBOSE, '[Debugger] File type: ', FileType);
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Entry point: ', EntryPoint);
|
|
end;
|
|
SetTargetInfo(FileType);
|
|
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval; // Getting address for breakpoints may need timeout
|
|
|
|
DetectForceableBreaks;
|
|
|
|
(* We need a breakpoint at entry-point or main, to continue initialization
|
|
"main" could map to more than one location, so we try entry point first
|
|
*)
|
|
RunToMain(EntryPoint);
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval; // Getting address for breakpoints may need timeout
|
|
|
|
if DebuggerState = dsStop
|
|
then begin
|
|
Result := False;
|
|
FSuccess := False;
|
|
Exit;
|
|
end;
|
|
|
|
if DebuggerState = dsError
|
|
then begin
|
|
Result := False;
|
|
FSuccess := False;
|
|
Exit;
|
|
end;
|
|
|
|
if TargetInfo^.TargetPID = 0
|
|
then begin
|
|
Result := False;
|
|
FSuccess := False;
|
|
SetDebuggerState(dsError);
|
|
Exit;
|
|
end;
|
|
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Target PID: %u', [TargetInfo^.TargetPID]);
|
|
|
|
Exclude(FTheDebugger.FDebuggerFlags, dfSetBreakFailed);
|
|
Exclude(FTheDebugger.FDebuggerFlags, dfSetBreakPending);
|
|
// they may still exist from prev run, addr will be checked
|
|
// TODO: defered setting of below beakpoint / e.g. if debugging a library
|
|
{$IFdef WITH_GDB_FORCE_EXCEPTBREAK}
|
|
FTheDebugger.FExceptionBreak.SetByAddr(Self, True);
|
|
FTheDebugger.FBreakErrorBreak.SetByAddr(Self, True);
|
|
FTheDebugger.FRunErrorBreak.SetByAddr(Self, True);
|
|
{$Else}
|
|
FTheDebugger.FExceptionBreak.SetByAddr(Self);
|
|
FTheDebugger.FBreakErrorBreak.SetByAddr(Self);
|
|
FTheDebugger.FRunErrorBreak.SetByAddr(Self);
|
|
{$ENDIF}
|
|
if (not (FTheDebugger.FExceptionBreak.IsBreakSet and
|
|
FTheDebugger.FBreakErrorBreak.IsBreakSet and
|
|
FTheDebugger.FRunErrorBreak.IsBreakSet)) and
|
|
(DebuggerProperties.WarnOnSetBreakpointError in [gdbwAll, gdbwExceptionsAndRunError])
|
|
then
|
|
Include(FTheDebugger.FDebuggerFlags, dfSetBreakFailed);
|
|
|
|
SetDebuggerState(dsInit); // triggers all breakpoints to be set.
|
|
FTheDebugger.RunQueue; // run all the breakpoints
|
|
Application.ProcessMessages; // workaround, allow source-editor to queue line info request (Async call)
|
|
|
|
if FTheDebugger.FBreakAtMain <> nil
|
|
then begin
|
|
CanContinue := False;
|
|
TGDBMIBreakPoint(FTheDebugger.FBreakAtMain).Hit(CanContinue);
|
|
end
|
|
else CanContinue := True;
|
|
|
|
//if FTheDebugger.DebuggerFlags * [dfSetBreakFailed, dfSetBreakPending] <> [] then begin
|
|
// if FTheDebugger.OnFeedback
|
|
// (self, Format(synfTheDebuggerWasUnableToSetAllBreakpointsDuringIniti,
|
|
// [LineEnding]), '', ftWarning, [frOk, frStop]) = frStop
|
|
// then begin
|
|
// StateStopped := True;
|
|
// SetDebuggerState(dsStop);
|
|
// exit;
|
|
// end;
|
|
//end;
|
|
|
|
if StoppedAtEntryPoint and CanContinue and (FContinueCommand = nil) then begin
|
|
// try to step to pascal code
|
|
if (FndOffsFile <> '') and (FndOffsLine <> '') and
|
|
( (FndOffsFile <> StoppedFile) or (FndOffsLine <> StoppedLine) )
|
|
then begin
|
|
FTheDebugger.FMainAddrBreak.SetAtFileLine(Self, FndOffsFile, FndOffsLine);
|
|
if (FTheDebugger.FMainAddrBreak.BreakAddr[iblFileLine] < MIN_RELOC_ADDRESS) or
|
|
(FTheDebugger.FMainAddrBreak.BreakAddr[iblFileLine] = StoppedAddr)
|
|
then
|
|
FTheDebugger.FMainAddrBreak.Clear(Self, iblFileLine);
|
|
end;
|
|
|
|
FTheDebugger.FMainAddrBreak.SetByName(Self);
|
|
if (FTheDebugger.FMainAddrBreak.BreakAddr[iblNamed] < MIN_RELOC_ADDRESS) or
|
|
(FTheDebugger.FMainAddrBreak.BreakAddr[iblNamed] = StoppedAddr) or
|
|
(FTheDebugger.FMainAddrBreak.BreakFile[iblNamed] = '') or
|
|
(FTheDebugger.FMainAddrBreak.BreakLine[iblNamed] = '') or
|
|
( (FTheDebugger.FMainAddrBreak.BreakFile[iblNamed] = StoppedFile) and
|
|
(FTheDebugger.FMainAddrBreak.BreakFile[iblNamed] = StoppedLine) )
|
|
then
|
|
FTheDebugger.FMainAddrBreak.Clear(Self, iblNamed);
|
|
|
|
if FTheDebugger.FMainAddrBreak.IsBreakSet then begin
|
|
FContinueCommand := TGDBMIDebuggerCommandExecute.Create(FTheDebugger, ectContinue);
|
|
end;
|
|
end;
|
|
|
|
if CanContinue and (FContinueCommand <> nil)
|
|
then begin
|
|
FTheDebugger.QueueCommand(FContinueCommand);
|
|
FContinueCommand := nil;
|
|
end
|
|
else begin
|
|
SetDebuggerState(dsPause);
|
|
end;
|
|
|
|
if DebuggerState = dsPause
|
|
then ProcessFrame;
|
|
finally
|
|
ReleaseRefAndNil(FContinueCommand);
|
|
if not(StateStopped or (DebuggerState in [dsInit, dsRun, dsPause])) then
|
|
SetDebuggerErrorState(synfFailedToInitializeDebugger);
|
|
end;
|
|
|
|
FSuccess := True;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandStartDebugging.GdbRunCommand: String;
|
|
begin
|
|
Result := '-exec-run';
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandStartDebugging.Create(AOwner: TGDBMIDebugger;
|
|
AContinueCommand: TGDBMIDebuggerCommand);
|
|
begin
|
|
inherited Create(AOwner);
|
|
// AContinueCommand, takes over the current reference.
|
|
// Caller will never Release it. So TGDBMIDebuggerCommandStartDebugging must do this
|
|
FContinueCommand := AContinueCommand;
|
|
FSuccess := False;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommandStartDebugging.Destroy;
|
|
begin
|
|
ReleaseRefAndNil(FContinueCommand);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandStartDebugging.DebugText: String;
|
|
var
|
|
s: String;
|
|
begin
|
|
s := '<none>';
|
|
if FContinueCommand <> nil
|
|
then s := FContinueCommand.DebugText;
|
|
Result := Format('%s: ContinueCommand= %s', [ClassName, s]);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandAttach }
|
|
|
|
function TGDBMIDebuggerCommandAttach.DoExecute: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
StoppedParams, FileType, CmdResp, s: String;
|
|
List: TGDBMINameValueList;
|
|
NewPID: Integer;
|
|
begin
|
|
Result := True;
|
|
FSuccess := False;
|
|
|
|
if not ExecuteCommand('-file-exec-and-symbols %s',
|
|
[FTheDebugger.ConvertToGDBPath('', cgptExeName)], R)
|
|
then
|
|
R.State := dsError;
|
|
if R.State = dsError then begin
|
|
SetDebuggerErrorState('Attach failed');
|
|
exit;
|
|
end;
|
|
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval;
|
|
|
|
// Tnit (StartDebugging)
|
|
TargetInfo^.TargetFlags := [tfHasSymbols]; // Set until proven otherwise
|
|
ExecuteCommand('-gdb-set language pascal', [cfCheckError]); // TODO: Maybe remove, must be done after attach
|
|
|
|
//{$IF defined(UNIX) or defined(DBG_ENABLE_TERMINAL)}
|
|
//InitConsole;
|
|
//{$ENDIF}
|
|
|
|
SetDebuggerState(dsInit); // triggers all breakpoints to be set.
|
|
Application.ProcessMessages; // workaround, allow source-editor to queue line info request (Async call)
|
|
|
|
|
|
// Attach
|
|
if not ExecuteCommand('attach %s', [FProcessID], R) then
|
|
R.State := dsError;
|
|
if R.State = dsError then begin
|
|
ExecuteCommand('detach', [], R);
|
|
SetDebuggerErrorState('Attach failed');
|
|
exit;
|
|
end;
|
|
CmdResp := FFullCmdReply;
|
|
|
|
if (R.State <> dsNone)
|
|
then SetDebuggerState(R.State);
|
|
|
|
if R.State = dsRun then begin
|
|
ProcessRunning(StoppedParams, R);;
|
|
if (R.State = dsError) then begin
|
|
ExecuteCommand('detach', [], R);
|
|
SetDebuggerErrorState('Attach failed');
|
|
exit;
|
|
end;
|
|
end;
|
|
CmdResp := CmdResp + StoppedParams + R.Values;
|
|
|
|
// Get PID
|
|
NewPID := 0;
|
|
|
|
s := GetPart(['Attaching to process '], [LineEnding, '.'], CmdResp, True, False);
|
|
if s <> '' then
|
|
NewPID := StrToIntDef(s, 0);
|
|
|
|
if NewPID = 0 then begin
|
|
s := GetPart(['=thread-group-started,'], [LineEnding], CmdResp, True, False);
|
|
if s <> '' then
|
|
s := GetPart(['pid="'], ['"'], s, True, False);
|
|
if s <> '' then
|
|
NewPID := StrToIntDef(s, 0);
|
|
end;
|
|
|
|
if NewPID = 0 then begin
|
|
NewPID := StrToIntDef(FProcessID, 0);
|
|
end;
|
|
|
|
// "info program" may crash after attach
|
|
if NewPID = 0 then begin
|
|
if ExecuteCommand('info pid', [], R, [cfCheckState]) and (R.State <> dsError)
|
|
then begin
|
|
List := TGDBMINameValueList.Create(R);
|
|
NewPID := StrToIntDef(List.Values['process-id'], 0);
|
|
List.Free;
|
|
end;
|
|
end;
|
|
|
|
if NewPID = 0 then begin
|
|
if ExecuteCommand('info threads', [], R, [cfCheckState]) and (R.State <> dsError)
|
|
then begin
|
|
s := GetPart(['of process '], [' '], R.Values, True);
|
|
NewPID := StrToIntDef(s, 0);
|
|
end;
|
|
end;
|
|
|
|
if NewPID = 0 then begin
|
|
ExecuteCommand('detach', [], R);
|
|
SetDebuggerErrorState(Format(gdbmiCommandStartMainRunNoPIDError, [LineEnding]));
|
|
exit;
|
|
end;
|
|
|
|
TargetInfo^.TargetPID := NewPID;
|
|
|
|
DoSetPascal;
|
|
|
|
if (FTheDebugger.FileName <> '') and (pos('READING SYMBOLS FROM', UpperCase(CmdResp)) < 1) then begin
|
|
ExecuteCommand('ptype TObject', [], R);
|
|
if pos('NO SYMBOL TABLE IS LOADED', UpperCase(FFullCmdReply)) > 0 then begin
|
|
ExecuteCommand('-file-exec-and-symbols %s',
|
|
[FTheDebugger.ConvertToGDBPath(FTheDebugger.FileName, cgptExeName)], R);
|
|
DoSetPascal;
|
|
end;
|
|
end;
|
|
|
|
// Tnit (StartDebugging)
|
|
// check if the exe is compiled with FPC >= 1.9.2
|
|
// then the rtl is compiled with regcalls
|
|
RetrieveRegCall;
|
|
CheckAvailableTypes;
|
|
CommonInit;
|
|
DetectForceableBreaks;
|
|
|
|
FileType := '';
|
|
if ExecuteCommand('info file', R)
|
|
then begin
|
|
if rfNoMI in R.Flags
|
|
then begin
|
|
FileType := GetPart('file type ', '.', R.Values);
|
|
end
|
|
else begin
|
|
// OS X gdb has mi output here
|
|
List := TGDBMINameValueList.Create(R, ['section-info']);
|
|
FileType := List.Values['filetype'];
|
|
List.Free;
|
|
end;
|
|
DebugLn(DBG_VERBOSE, '[Debugger] File type: ', FileType);
|
|
end;
|
|
SetTargetInfo(FileType);
|
|
|
|
FTheDebugger.FExceptionBreak.SetByAddr(Self);
|
|
FTheDebugger.FBreakErrorBreak.SetByAddr(Self);
|
|
FTheDebugger.FRunErrorBreak.SetByAddr(Self);
|
|
|
|
if not(DebuggerState in [dsPause]) then
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame; // Includes DoLocation
|
|
FSuccess := True;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandAttach.Create(AOwner: TGDBMIDebugger;
|
|
AProcessID: String);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FSuccess := False;
|
|
FProcessID := AProcessID;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandAttach.DebugText: String;
|
|
begin
|
|
Result := Format('%s: ProcessID= %s', [ClassName, FProcessID]);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandDetach }
|
|
|
|
function TGDBMIDebuggerCommandDetach.DoExecute: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
if not ExecuteCommand('detach', R) then
|
|
R.State := dsError;
|
|
if R.State = dsError then begin
|
|
SetDebuggerErrorState('Detach failed');
|
|
exit;
|
|
end;
|
|
|
|
SetDebuggerState(dsStop);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandExecute }
|
|
|
|
procedure TGDBMIDebuggerCommandExecute.DoLockQueueExecute;
|
|
begin
|
|
// prevent lock
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandExecute.DoUnLockQueueExecute;
|
|
begin
|
|
// prevent lock
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandExecute.ProcessStopped(const AParams: String;
|
|
const AIgnoreSigIntState: Boolean): Boolean;
|
|
|
|
function GetLocation: TDBGLocationRec; // update current location
|
|
var
|
|
R: TGDBMIExecResult;
|
|
S: String;
|
|
FP: TDBGPtr;
|
|
i, cnt: longint;
|
|
begin
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
Result.SrcLine := -1;
|
|
Result.SrcFile := '';
|
|
Result.FuncName := '';
|
|
// Get the frame and addr info from the call-params
|
|
if tfRTLUsesRegCall in TargetInfo^.TargetFlags
|
|
then begin
|
|
Result.Address := GetPtrValue(TargetInfo^.TargetRegisters[1], []);
|
|
FP := GetPtrValue(TargetInfo^.TargetRegisters[2], []);
|
|
end else begin
|
|
Result.Address := GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 3]);
|
|
FP := GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 4]);
|
|
end;
|
|
|
|
if FP <> 0 then begin
|
|
// try finding the stackframe
|
|
cnt := GetStackDepth(33); // do not search more than 32 deep, takes a lot of time
|
|
i := FindStackFrame(Fp, 0, cnt);
|
|
if i >= 0 then begin
|
|
FTheDebugger.FCurrentStackFrame := i;
|
|
DebugLn(DBG_THREAD_AND_FRAME, ['ProcessStopped GetLocation found fp Stack(Internal) = ', FTheDebugger.FCurrentStackFrame]);
|
|
end;
|
|
|
|
if FTheDebugger.FCurrentStackFrame <> 0
|
|
then begin
|
|
// This frame should have all the info we need
|
|
s := GetFrame(FTheDebugger.FCurrentStackFrame);
|
|
if s <> '' then
|
|
FTheDebugger.FCurrentLocation := FrameToLocation(S);
|
|
Result.SrcFile := FTheDebugger.FCurrentLocation.SrcFile;
|
|
Result.SrcFullName := FTheDebugger.FCurrentLocation.SrcFullName;
|
|
Result.FuncName := FTheDebugger.FCurrentLocation.FuncName;
|
|
Result.SrcLine := FTheDebugger.FCurrentLocation.SrcLine;
|
|
end;
|
|
end;
|
|
|
|
if (Result.SrcLine = -1) or (Result.SrcFile = '') then begin
|
|
Str(Result.Address, S);
|
|
if ExecuteCommand('info line *%s', [S], R)
|
|
then begin
|
|
Result.SrcLine := StrToIntDef(GetPart('Line ', ' of', R.Values), -1);
|
|
Result.SrcFile := ConvertGdbPathAndFile(GetPart('\"', '\"', R.Values));
|
|
end;
|
|
end;
|
|
|
|
FTheDebugger.FCurrentLocation := Result;
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
end;
|
|
|
|
function GetExceptionInfo: TGDBMIExceptionInfo;
|
|
begin
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
if tfRTLUsesRegCall in TargetInfo^.TargetFlags
|
|
then Result.ObjAddr := TargetInfo^.TargetRegisters[0]
|
|
else begin
|
|
if dfImplicidTypes in FTheDebugger.DebuggerFlags
|
|
then Result.ObjAddr := Format('^%s($fp+%d)^', [PointerTypeCast, TargetInfo^.TargetPtrSize * 2])
|
|
else Str(GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 2]), Result.ObjAddr);
|
|
end;
|
|
Result.Name := GetInstanceClassName(Result.ObjAddr, []);
|
|
if Result.Name = ''
|
|
then Result.Name := 'Unknown';
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
end;
|
|
|
|
procedure ProcessException;
|
|
var
|
|
ExceptionMessage: String;
|
|
CanContinue: Boolean;
|
|
Location: TDBGLocationRec;
|
|
ExceptInfo: TGDBMIExceptionInfo;
|
|
ExceptItem: TBaseException;
|
|
begin
|
|
FTheDebugger.FStoppedReason := srRaiseExcept;
|
|
if (FTheDebugger.Exceptions = nil) or FTheDebugger.Exceptions.IgnoreAll
|
|
then begin
|
|
Result := True; //ExecuteCommand('-exec-continue')
|
|
exit;
|
|
end;
|
|
|
|
ExceptInfo := GetExceptionInfo;
|
|
// check if we should ignore this exception
|
|
ExceptItem := FTheDebugger.Exceptions.Find(ExceptInfo.Name);
|
|
if (ExceptItem <> nil) and (ExceptItem.Enabled)
|
|
then begin
|
|
Result := True; //ExecuteCommand('-exec-continue')
|
|
exit;
|
|
end;
|
|
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
if (dfImplicidTypes in FTheDebugger.DebuggerFlags)
|
|
then begin
|
|
if (tfFlagHasTypeException in TargetInfo^.TargetFlags) then begin
|
|
if tfExceptionIsPointer in TargetInfo^.TargetFlags
|
|
then ExceptionMessage := GetText('Exception(%s).FMessage', [ExceptInfo.ObjAddr])
|
|
else ExceptionMessage := GetText('^Exception(%s)^.FMessage', [ExceptInfo.ObjAddr]);
|
|
if FLastExecResult.State = dsError then begin
|
|
if tfExceptionIsPointer in TargetInfo^.TargetFlags then begin
|
|
ExceptionMessage := GetText('^Exception(%s).FMessage', [ExceptInfo.ObjAddr]);
|
|
if FLastExecResult.State <> dsError then
|
|
Exclude(TargetInfo^.TargetFlags, tfExceptionIsPointer);
|
|
end;
|
|
if FLastExecResult.State = dsError then
|
|
ExceptionMessage := GetText('^^char(^%s(%s)+1)^', [PointerTypeCast, ExceptInfo.ObjAddr]);
|
|
end;
|
|
//ExceptionMessage := GetText('^^Exception($fp+8)^^.FMessage', []);
|
|
end else begin
|
|
// Only works if Exception class is not changed. FMessage must be first member
|
|
ExceptionMessage := GetText('^^char(^%s(%s)+1)^', [PointerTypeCast, ExceptInfo.ObjAddr]);
|
|
end;
|
|
end
|
|
else ExceptionMessage := '### Not supported on GDB < 5.3 ###';
|
|
|
|
Location := GetLocation;
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
|
|
FTheDebugger.DoException(deInternal, ExceptInfo.Name, Location, ExceptionMessage, CanContinue);
|
|
if CanContinue
|
|
then begin
|
|
//ExecuteCommand('-exec-continue')
|
|
Result := True; // outer funciton result
|
|
exit;
|
|
end;
|
|
|
|
SetDebuggerState(dsPause); // after GetLocation => dsPause may run stack, watches etc
|
|
FTheDebugger.DoCurrent(Location);
|
|
end;
|
|
|
|
procedure ProcessBreak;
|
|
var
|
|
ErrorNo: Integer;
|
|
CanContinue: Boolean;
|
|
Location: TDBGLocationRec;
|
|
ExceptName: String;
|
|
ExceptItem: TBaseException;
|
|
begin
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
if tfRTLUsesRegCall in TargetInfo^.TargetFlags
|
|
then ErrorNo := GetIntValue(TargetInfo^.TargetRegisters[0], [])
|
|
else ErrorNo := Integer(GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 2]));
|
|
ErrorNo := ErrorNo and $FFFF;
|
|
|
|
Location := GetLocation;
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
|
|
ExceptName := Format('RunError(%d)', [ErrorNo]);
|
|
ExceptItem := FTheDebugger.Exceptions.Find(ExceptName);
|
|
if (ExceptItem <> nil) and (ExceptItem.Enabled)
|
|
then begin
|
|
Result := True; //ExecuteCommand('-exec-continue')
|
|
exit;
|
|
end;
|
|
|
|
FTheDebugger.DoException(deRunError, ExceptName, Location, '', CanContinue);
|
|
if CanContinue
|
|
then begin
|
|
//ExecuteCommand('-exec-continue')
|
|
Result := True; // outer funciton result
|
|
exit;
|
|
end;
|
|
|
|
SetDebuggerState(dsPause); // after GetLocation => dsPause may run stack, watches etc
|
|
FTheDebugger.DoCurrent(Location);
|
|
end;
|
|
|
|
procedure ProcessRunError;
|
|
var
|
|
ErrorNo: Integer;
|
|
CanContinue: Boolean;
|
|
Location: TDBGLocationRec;
|
|
ExceptName: String;
|
|
ExceptItem: TBaseException;
|
|
begin
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
if tfRTLUsesRegCall in TargetInfo^.TargetFlags
|
|
then ErrorNo := GetIntValue(TargetInfo^.TargetRegisters[0], [])
|
|
else ErrorNo := Integer(GetData('$fp+%d', [TargetInfo^.TargetPtrSize * 2]));
|
|
ErrorNo := ErrorNo and $FFFF;
|
|
|
|
Location := GetLocation;
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
|
|
ExceptName := Format('RunError(%d)', [ErrorNo]);
|
|
ExceptItem := FTheDebugger.Exceptions.Find(ExceptName);
|
|
if (ExceptItem <> nil) and (ExceptItem.Enabled)
|
|
then begin
|
|
Result := True; //ExecuteCommand('-exec-continue')
|
|
exit;
|
|
end;
|
|
|
|
FTheDebugger.DoException(deRunError, ExceptName, Location, '', CanContinue);
|
|
if CanContinue
|
|
then begin
|
|
//ExecuteCommand('-exec-continue')
|
|
Result := True; // outer funciton result
|
|
exit;
|
|
end;
|
|
|
|
SetDebuggerState(dsPause); // after GetLocation => dsPause may run stack, watches etc
|
|
ProcessFrame(GetFrame(1));
|
|
end;
|
|
|
|
procedure ProcessSignalReceived(const AList: TGDBMINameValueList);
|
|
var
|
|
SigInt, CanContinue: Boolean;
|
|
S, F: String;
|
|
{$IFdef MSWindows}
|
|
fixed: Boolean;
|
|
{$ENDIF}
|
|
begin
|
|
// TODO: check to run (un)handled
|
|
|
|
S := AList.Values['signal-name'];
|
|
F := AList.Values['frame'];
|
|
{$IFdef MSWindows}
|
|
SigInt := S = 'SIGTRAP';
|
|
if FTheDebugger.FAsyncModeEnabled then
|
|
SigInt := SigInt or (S = 'SIGINT');
|
|
{$ELSE}
|
|
SigInt := S = 'SIGINT';
|
|
{$ENDIF}
|
|
|
|
{$IFdef MSWindows}
|
|
if SigInt and (FTheDebugger.PauseWaitState = pwsNone) and
|
|
(pos('DbgUiConvertStateChangeStructure', FTheDebugger.FCurrentLocation.FuncName) > 0)
|
|
then begin
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
if not AIgnoreSigIntState // not pwsInternal
|
|
or not SigInt
|
|
then begin
|
|
// user-requested pause OR other signal (not sigint)
|
|
// TODO: if SigInt, check that it was issued by IDE
|
|
{$IFdef MSWindows}
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
fixed := FixThreadForSigTrap;
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
// Before anything else goes => correct the thread
|
|
if fixed
|
|
then F := '';
|
|
{$ENDIF}
|
|
SetDebuggerState(dsPause);
|
|
end;
|
|
|
|
if not SigInt
|
|
then FTheDebugger.DoException(deExternal, 'External: ' + S, FTheDebugger.FCurrentLocation, '', CanContinue);
|
|
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
if not AIgnoreSigIntState
|
|
or not SigInt
|
|
then ProcessFrame(F);
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
end;
|
|
|
|
procedure ProcessBreakPoint(ABreakId: Integer; const List: TGDBMINameValueList;
|
|
AReason: TGDBMIBreakpointReason; AOldVal: String = ''; ANewVal: String = '');
|
|
var
|
|
BreakPoint: TGDBMIBreakPoint;
|
|
CanContinue: Boolean;
|
|
Location: TDBGLocationRec;
|
|
BrkSlave: TBaseBreakPoint;
|
|
begin
|
|
BreakPoint := nil;
|
|
if ABreakId >= 0 then
|
|
BreakPoint := TGDBMIBreakPoint(FTheDebugger.FindBreakpoint(ABreakID));
|
|
|
|
if (BreakPoint <> nil) and (BreakPoint.Kind <> bpkData) and
|
|
(AReason in [gbrWatchScope, gbrWatchTrigger])
|
|
then BreakPoint := nil;
|
|
|
|
if BreakPoint <> nil
|
|
then begin
|
|
try
|
|
(* - Breakpoint may not be destroyed, while in use
|
|
- And it may not be destroyed, before state is set (otherwhise an InterruptTarget is triggered)
|
|
*)
|
|
BreakPoint.AddReference;
|
|
BrkSlave := BreakPoint.Slave;
|
|
if BrkSlave <> nil then BrkSlave.AddReference;
|
|
|
|
CanContinue := False;
|
|
FTheDebugger.QueueExecuteLock;
|
|
try
|
|
Location := FrameToLocation(List.Values['frame']);
|
|
FTheDebugger.FCurrentLocation := Location;
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
FTheDebugger.DoDbgBreakpointEvent(BreakPoint, Location, AReason, AOldVal, ANewVal);
|
|
// Important: The Queue must be unlocked
|
|
// BreakPoint.Hit may evaluate stack and expressions
|
|
// SetDebuggerState may evaluate data for Snapshot
|
|
BreakPoint.Hit(CanContinue);
|
|
if CanContinue
|
|
then begin
|
|
// Important trigger State => as snapshot is taken in TDebugManager.DebuggerChangeState
|
|
SetDebuggerState(dsInternalPause);
|
|
Result := True;
|
|
end
|
|
else begin
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(Location);
|
|
// inform the user, why we stopped
|
|
// TODO: Add a dedicated callback
|
|
case AReason of
|
|
gbrWatchTrigger: FTheDebugger.OnFeedback
|
|
(self, Format('The Watchpoint for "%1:s" was triggered.%0:s%0:sOld value: %2:s%0:sNew value: %3:s',
|
|
[LineEnding, BreakPoint.WatchData, AOldVal, ANewVal]),
|
|
'', ftInformation, [frOk]);
|
|
gbrWatchScope: FTheDebugger.OnFeedback
|
|
(self, Format('The Watchpoint for "%s" went out of scope', [BreakPoint.WatchData]),
|
|
'', ftInformation, [frOk]);
|
|
end;
|
|
end;
|
|
|
|
if AReason = gbrWatchScope
|
|
then begin
|
|
BreakPoint.ReleaseBreakPoint; // gdb should have released already => ignore error
|
|
BreakPoint.Enabled := False;
|
|
BreakPoint.FBreakID := 0; // removed by debugger, ID no longer exists
|
|
end;
|
|
|
|
finally
|
|
if BrkSlave <> nil then BrkSlave.ReleaseReference;
|
|
BreakPoint.ReleaseReference;
|
|
end;
|
|
exit;
|
|
end;
|
|
|
|
if (DebuggerState = dsRun)
|
|
then begin
|
|
debugln(['********** WARNING: breakpoint hit, but nothing known about it ABreakId=', ABreakID, ' brbtno=', List.Values['bkptno'] ]);
|
|
{$IFDEF DBG_VERBOSE_BRKPOINT}
|
|
debugln(['-*- List of breakpoints Cnt=', FTheDebugger.Breakpoints.Count]);
|
|
for ABreakID := 0 to FTheDebugger.Breakpoints.Count - 1 do
|
|
debugln(['* ',Dbgs(FTheDebugger.Breakpoints[ABreakID]), ':', DbgsName(FTheDebugger.Breakpoints[ABreakID]), ' ABreakId=',TGDBMIBreakPoint(FTheDebugger.Breakpoints[ABreakID]).FBreakID, ' Source=', FTheDebugger.Breakpoints[ABreakID].Source, ' Line=', FTheDebugger.Breakpoints[ABreakID].Line ]);
|
|
debugln(['************************************************************************ ']);
|
|
debugln(['************************************************************************ ']);
|
|
debugln(['************************************************************************ ']);
|
|
{$ENDIF}
|
|
|
|
case FTheDebugger.OnFeedback
|
|
(self, Format(gdbmiWarningUnknowBreakPoint,
|
|
[LineEnding, GDBMIBreakPointReasonNames[AReason]]),
|
|
List.Text, ftWarning, [frOk, frStop]
|
|
)
|
|
of
|
|
frOk: begin
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(List.Values['frame']); // and jump to it
|
|
end;
|
|
frStop: begin
|
|
FTheDebugger.Stop;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
var
|
|
List, List2: TGDBMINameValueList;
|
|
Reason: String;
|
|
BreakID: Integer;
|
|
CanContinue: Boolean;
|
|
i: Integer;
|
|
s: String;
|
|
begin
|
|
(* The Queue is not locked / This code can be interupted
|
|
Therefore all calls to ExecuteCommand (gdb cmd) must be wrapped in QueueExecuteLock
|
|
*)
|
|
Result := False;
|
|
FTheDebugger.FInProcessStopped := True; // paused, but maybe state run
|
|
FTheDebugger.FStoppedReason := srNone;
|
|
|
|
List := TGDBMINameValueList.Create(AParams);
|
|
List2 := nil;
|
|
|
|
FTheDebugger.FCurrentStackFrame := 0;
|
|
FTheDebugger.FCurrentThreadId := StrToIntDef(List.Values['thread-id'], -1);
|
|
FTheDebugger.FCurrentThreadIdValid := True;
|
|
FTheDebugger.FCurrentStackFrameValid := True;
|
|
FTheDebugger.FInstructionQueue.SetKnownThreadAndFrame(FTheDebugger.FCurrentThreadId, 0);
|
|
FContext.ThreadContext := ccUseGlobal;
|
|
FContext.StackContext := ccUseGlobal;
|
|
|
|
FTheDebugger.FCurrentLocation.Address := 0;
|
|
FTheDebugger.FCurrentLocation.SrcFile := '';
|
|
FTheDebugger.FCurrentLocation.SrcFullName := '';
|
|
|
|
|
|
|
|
try
|
|
Reason := List.Values['reason'];
|
|
if (Reason = 'exited-normally')
|
|
then begin
|
|
DoDbgEvent(ecProcess, etProcessExit, gdbmiEventLogProcessExitNormally);
|
|
SetDebuggerState(dsStop);
|
|
Exit;
|
|
end;
|
|
|
|
if Reason = 'exited'
|
|
then begin
|
|
FTheDebugger.SetExitCode(StrToIntDef(List.Values['exit-code'], 0));
|
|
DoDbgEvent(ecProcess, etProcessExit, Format(gdbmiEventLogProcessExitCode, [List.Values['exi'
|
|
+'t-code']]));
|
|
SetDebuggerState(dsStop);
|
|
Exit;
|
|
end;
|
|
|
|
if Reason = 'exited-signalled'
|
|
then begin
|
|
SetDebuggerState(dsStop);
|
|
FTheDebugger.DoException(deExternal, 'External: ' + List.Values['signal-name'], FTheDebugger.FCurrentLocation, '', CanContinue);
|
|
// ProcessFrame(List.Values['frame']);
|
|
Exit;
|
|
end;
|
|
|
|
// not stopped? Then we should have a location
|
|
FTheDebugger.FCurrentLocation := FrameToLocation(List.Values['frame']);
|
|
|
|
if Reason = 'signal-received'
|
|
then begin
|
|
ProcessSignalReceived(List);
|
|
Exit;
|
|
end;
|
|
|
|
if (Reason = 'watchpoint-trigger') or (Reason = 'access-watchpoint-trigger') or
|
|
(Reason = 'read-watchpoint-trigger')
|
|
then begin
|
|
i := 0;
|
|
List2 := nil;
|
|
while i < List.Count do begin
|
|
s := PCLenToString(List.Items[i]^.Name);
|
|
if copy(s, Length(s) - 2, 3) = 'wpt' then
|
|
List2 := TGDBMINameValueList.Create(List.Values[s]);
|
|
inc(i);
|
|
end;
|
|
if List2 <> nil then begin
|
|
BreakID := StrToIntDef(List2.Values['number'], -1);
|
|
// Use List2.Values['exp'] ? It may contain globalized expression
|
|
List2.Init(List.Values['value']);
|
|
ProcessBreakPoint(BreakID, List, gbrWatchTrigger, List2.Values['old'], List2.Values['new']);
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
if Reason = 'watchpoint-scope'
|
|
then begin
|
|
BreakID := StrToIntDef(List.Values['wpnum'], -1);
|
|
ProcessBreakPoint(BreakID, List, gbrWatchScope);
|
|
exit;
|
|
end;
|
|
|
|
if Reason = 'breakpoint-hit'
|
|
then begin
|
|
BreakID := StrToIntDef(List.Values['bkptno'], -1);
|
|
if BreakID = -1
|
|
then begin
|
|
ProcessBreakPoint(BreakID, List, gbrBreak);
|
|
SetDebuggerState(dsError);
|
|
Exit;
|
|
end;
|
|
|
|
if FTheDebugger.FBreakErrorBreak.MatchId(BreakID)
|
|
then begin
|
|
ProcessBreak; // will set dsPause / unless CanContinue
|
|
Exit;
|
|
end;
|
|
|
|
if FTheDebugger.FRunErrorBreak.MatchId(BreakID)
|
|
then begin
|
|
ProcessRunError; // will set dsPause / unless CanCuntinue
|
|
Exit;
|
|
end;
|
|
|
|
if FTheDebugger.FExceptionBreak.MatchId(BreakID)
|
|
then begin
|
|
ProcessException; // will set dsPause / unless CanCuntinue
|
|
Exit;
|
|
end;
|
|
|
|
if FTheDebugger.FPopExceptStack.MatchId(BreakID)
|
|
then begin
|
|
FTheDebugger.FStoppedReason := srPopExceptStack;
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
|
|
if FTheDebugger.FCatchesBreak.MatchId(BreakID)
|
|
then begin
|
|
FTheDebugger.FStoppedReason := srCatches;
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
|
|
if FTheDebugger.FReRaiseBreak.MatchId(BreakID)
|
|
then begin
|
|
FTheDebugger.FStoppedReason := srReRaiseExcept;
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
|
|
if FTheDebugger.FMainAddrBreak.MatchId(BreakID)
|
|
then begin
|
|
FTheDebugger.FMainAddrBreak.Clear(Self); // done with launch
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(FTheDebugger.FCurrentLocation );
|
|
Exit;
|
|
end;
|
|
|
|
if (FStepBreakPoint > 0) and (BreakID = FStepBreakPoint)
|
|
then begin
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(FTheDebugger.FCurrentLocation );
|
|
exit;
|
|
end;
|
|
|
|
ProcessBreakPoint(BreakID, List, gbrBreak);
|
|
exit;
|
|
end;
|
|
|
|
if Reason = 'function-finished'
|
|
then begin
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(List.Values['frame'], False);
|
|
Exit;
|
|
end;
|
|
|
|
if Reason = 'end-stepping-range'
|
|
then begin
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(List.Values['frame'], False);
|
|
Exit;
|
|
end;
|
|
|
|
if Reason = 'location-reached'
|
|
then begin
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(List.Values['frame'], False);
|
|
Exit;
|
|
end;
|
|
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unknown stopped reason: ', Reason);
|
|
SetDebuggerState(dsPause);
|
|
ProcessFrame(List.Values['frame']);
|
|
finally
|
|
FTheDebugger.FInProcessStopped := False;
|
|
List.Free;
|
|
list2.Free;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF MSWindows}
|
|
function TGDBMIDebuggerCommandExecute.FixThreadForSigTrap: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
s: string;
|
|
n, ID1, ID2: Integer;
|
|
begin
|
|
Result := False;
|
|
if not ExecuteCommand('info program', R, [cfNoThreadContext])
|
|
then exit;
|
|
S := GetPart(['.0x'], ['.'], R.Values, True, False); // From the line "using child thread"
|
|
if PtrInt(StrToQWordDef('$'+S, 0)) <> FTheDebugger.FPauseRequestInThreadID
|
|
then Exit;
|
|
|
|
|
|
if not ExecuteCommand('-thread-list-ids', R, [cfNoThreadContext])
|
|
then Exit;
|
|
List := TGDBMINameValueList.Create(R);
|
|
try
|
|
n := StrToIntDef(List.Values['number-of-threads'], 0);
|
|
if n < 2 then Exit; //nothing to switch
|
|
List.SetPath(['thread-ids']);
|
|
if List.Count < 2 then Exit; // ???
|
|
ID1 := StrToIntDef(List.Values['thread-id'], 0);
|
|
List.Delete(0);
|
|
ID2 := StrToIntDef(List.Values['thread-id'], 0);
|
|
|
|
if ID1 = ID2 then Exit;
|
|
finally
|
|
List.Free;
|
|
end;
|
|
|
|
Result := True;
|
|
FTheDebugger.FCurrentThreadId := ID2;
|
|
FTheDebugger.FCurrentThreadIdValid := True;
|
|
DebugLn(DBG_THREAD_AND_FRAME, ['FixThreadForSigTrap Thread(Internal) = ', FTheDebugger.FCurrentThreadId]);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TGDBMIDebuggerCommandExecute.DoExecute: Boolean;
|
|
var
|
|
RunMode: (rmNormal, rmStepToFinally);
|
|
const
|
|
BreaKErrMsg = 'not insert breakpoint ';
|
|
WatchErrMsg = 'not insert hardware watchpoint ';
|
|
|
|
function HandleBreakPointError(var ARes: TGDBMIExecResult; AError: String): Boolean;
|
|
var
|
|
c, i: Integer;
|
|
bp: Array of Integer;
|
|
s, s2: string;
|
|
b: TGDBMIBreakPoint;
|
|
begin
|
|
Result := False;
|
|
s := AError;
|
|
c := 0;
|
|
while ParseBreakInsertError(s, i) do begin
|
|
if FTheDebugger.FMainAddrBreak.ClearId(Self, i) then begin
|
|
Result := True;
|
|
ARes.State := dsRun;
|
|
continue;
|
|
end;
|
|
SetLength(bp, c+1);
|
|
bp[c] := i;
|
|
if bp[c] >= 0 then inc(c);
|
|
end;
|
|
|
|
if Result and not FTheDebugger.FMainAddrBreak.IsBreakSet then
|
|
ARes.State := dsPause; // no break left
|
|
|
|
if c = 0 then exit;
|
|
|
|
Result := True;
|
|
|
|
if ARes.State = dsError
|
|
then begin
|
|
s := ARes.Values;
|
|
if FLogWarnings <> ''
|
|
then s2 := Format(gdbmiErrorOnRunCommandWithWarning, [LineEnding, FLogWarnings])
|
|
else s2 := '';
|
|
FLogWarnings := '';
|
|
end else begin
|
|
s := AError;
|
|
s2 := '';
|
|
end;
|
|
|
|
case FTheDebugger.OnFeedback(self,
|
|
Format(gdbmiBreakPointErrorOnRunCommand, [LineEnding, s]) + s2,
|
|
ARes.Values, ftError, [frOk, frStop]
|
|
) of
|
|
frOk: begin
|
|
ARes.State := dsPause;
|
|
ProcessFrame;
|
|
FTheDebugger.FInProcessStopped := True; // paused, but maybe state run
|
|
try
|
|
for i := 0 to length(bp)-1 do begin
|
|
b := TGDBMIBreakPoints(FTheDebugger.BreakPoints).FindById(bp[i]);
|
|
if b <> nil
|
|
then begin
|
|
if b.Kind = bpkData
|
|
then b.Enabled := False
|
|
else b.MakeInvalid;
|
|
end
|
|
else ExecuteCommand('-break-delete %d', [bp[i]], [cfNoThreadContext]);
|
|
end;
|
|
finally
|
|
FTheDebugger.FInProcessStopped := False; // paused, but maybe state run
|
|
end;
|
|
end;
|
|
frStop: begin
|
|
FTheDebugger.Stop;
|
|
ARes.State := dsStop;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
function HandleRunError(var ARes: TGDBMIExecResult): Boolean;
|
|
var
|
|
s, s2: String;
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
Result := False; // keep the error state
|
|
// check known errors
|
|
if (Pos('program is not being run', ARes.Values) > 0) then begin // Should lead to dsStop
|
|
SetDebuggerState(dsError);
|
|
exit;
|
|
end;
|
|
if (Pos(BreaKErrMsg, ARes.Values) > 0) or
|
|
(Pos(BreaKErrMsg, FLogWarnings) > 0) or
|
|
(Pos(WatchErrMsg, ARes.Values) > 0) or
|
|
(Pos(WatchErrMsg, FLogWarnings) > 0)
|
|
then begin
|
|
Result := HandleBreakPointError(ARes, ARes.Values + FLogWarnings);
|
|
if Result then exit;
|
|
end;
|
|
|
|
if assigned(FTheDebugger.OnFeedback) then begin
|
|
List := TGDBMINameValueList.Create(ARes);
|
|
s := List.Values['msg'];
|
|
FreeAndNil(List);
|
|
if FLogWarnings <> ''
|
|
then s2 := Format(gdbmiErrorOnRunCommandWithWarning, [LineEnding, FLogWarnings])
|
|
else s2 := '';
|
|
FLogWarnings := '';
|
|
if s <> '' then begin
|
|
case FTheDebugger.OnFeedback(self,
|
|
Format(gdbmiErrorOnRunCommand, [LineEnding, s]) + s2,
|
|
ARes.Values, ftError, [frOk, frStop]
|
|
) of
|
|
frOk: begin
|
|
ARes.State := dsPause;
|
|
ProcessFrame;
|
|
Result := True;
|
|
end;
|
|
frStop: begin
|
|
FTheDebugger.Stop;
|
|
ARes.State := dsStop;
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
end;
|
|
end
|
|
end;
|
|
end;
|
|
|
|
function CheckResultForError(var ARes: TGDBMIExecResult): Boolean;
|
|
begin
|
|
Result := False;
|
|
if (ARes.State = dsError) and (not HandleRunError(ARes)) then begin
|
|
DoDbgEvent(ecDebugger, etDefault, Format(gdbmiFatalErrorOccurred, [ARes.Values]));
|
|
SetDebuggerState(dsError);
|
|
Result := True;
|
|
end;
|
|
end;
|
|
|
|
function FindStackWithSymbols(StartAt,
|
|
MaxDepth: Integer): Integer;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
// Result;
|
|
// -1 : Not found
|
|
// -2 : FP is outside stack
|
|
Result := StartAt;
|
|
List := TGDBMINameValueList.Create('');
|
|
try
|
|
repeat
|
|
if not ExecuteCommand('-stack-list-frames %d %d', [Result, Result], R, [cfNoStackContext])
|
|
or (R.State = dsError)
|
|
then begin
|
|
Result := -1;
|
|
break;
|
|
end;
|
|
|
|
List.Init(R.Values);
|
|
List.SetPath('stack');
|
|
if List.Count > 0 then List.Init(List.GetString(0));
|
|
List.SetPath('frame');
|
|
if List.Values['file'] <> ''
|
|
then exit;
|
|
|
|
inc(Result);
|
|
until Result > MaxDepth;
|
|
|
|
Result := -1;
|
|
finally
|
|
List.Free;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
FP: TDBGPtr;
|
|
CurThreadId: Integer;
|
|
|
|
function DoContinueStepping: Boolean;
|
|
procedure DoEndStepping;
|
|
begin
|
|
Result := True;
|
|
FCurrentExecCmd := ectNone;
|
|
FCurrentExecArg := '';
|
|
SetDebuggerState(dsPause);
|
|
FTheDebugger.DoCurrent(FTheDebugger.FCurrentLocation);
|
|
end;
|
|
const
|
|
MaxStackDepth = 99;
|
|
var
|
|
cnt, i: Integer;
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
// TODO: an exception can skip the step-end breakpoint....
|
|
// TODO: the "break" breakpoint can stop on the current, instead of the next instruction
|
|
|
|
Result := False;
|
|
|
|
if RunMode = rmStepToFinally then begin
|
|
Result := FTheDebugger.FStoppedReason in [srPopExceptStack, srCatches];
|
|
if Result then
|
|
FCurrentExecCmd := ectStepOut;
|
|
exit;
|
|
end;
|
|
|
|
if FTheDebugger.FStoppedReason = srReRaiseExcept then begin
|
|
FTheDebugger.FPopExceptStack.EnableOrSetByAddr(Self, True);
|
|
FTheDebugger.FCatchesBreak.EnableOrSetByAddr(Self, True);
|
|
FCurrentExecCmd := ectContinue;
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
if FTheDebugger.FStoppedReason in [srPopExceptStack, srCatches] then begin
|
|
FTheDebugger.FPopExceptStack.Disable(Self);
|
|
FTheDebugger.FCatchesBreak.Disable(Self);
|
|
i := FindStackFrame(Fp, 0, 1);
|
|
if (i in [0, 1]) or (i = -2) // -2 already stepped out of the desired frame, enter dsPause
|
|
then begin
|
|
FCurrentExecCmd := ectStepOut; // ecStepOut will not offer a change to ContinueStepping
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
case FExecType of
|
|
ectContinue, ectRun:
|
|
begin
|
|
FCurrentExecCmd := ectContinue;
|
|
FCurrentExecArg := '';
|
|
Result := True;
|
|
end;
|
|
ectRunTo: // check if we are at correct location
|
|
begin
|
|
Result := not(
|
|
( (FTheDebugger.FCurrentLocation.SrcFile = FRunToSrc) or
|
|
(FTheDebugger.FCurrentLocation.SrcFullName = FRunToSrc) ) and
|
|
(FTheDebugger.FCurrentLocation.SrcLine = FRunToLine)
|
|
);
|
|
if not Result
|
|
then DoEndStepping; // location reached
|
|
end;
|
|
ectStepOver, ectStepOverInstruction, ectStepOut, ectStepInto:
|
|
begin
|
|
FTheDebugger.FPopExceptStack.EnableOrSetByAddr(Self, True);
|
|
FTheDebugger.FCatchesBreak.EnableOrSetByAddr(Self, True);
|
|
Result := FStepBreakPoint > 0;
|
|
if Result then
|
|
exit;
|
|
|
|
i := -1;
|
|
if FP <> 0 then begin
|
|
cnt := GetStackDepth(MaxStackDepth);
|
|
if FExecType = ectStepInto
|
|
then i := FindStackWithSymbols(0, cnt)
|
|
else i := FindStackFrame(Fp, 0, cnt);
|
|
if (FExecType = ectStepOut) and (i >= 0)
|
|
then inc(i);
|
|
end;
|
|
|
|
if (i = 0) or (i = -2) // -2 already stepped out of the desired frame, enter dsPause
|
|
then begin
|
|
DoEndStepping;
|
|
exit;
|
|
end;
|
|
|
|
if i > 0
|
|
then begin
|
|
// TODO: move to queue
|
|
// must use none gdbmi commands
|
|
FContext.ThreadContext := ccUseGlobal;
|
|
FTheDebugger.QueueExecuteLock; // force queue
|
|
try
|
|
// This messes up the Stack context of the queue.
|
|
FTheDebugger.FInstructionQueue.InvalidateThredAndFrame;
|
|
if (not ExecuteCommand('frame %d', [i], R, [cfNoStackContext])) or (R.State = dsError)
|
|
then i := -3; // error to user
|
|
if (i < 0) or (not ExecuteCommand('break', [i], R, [cfNoStackContext])) or (R.State = dsError)
|
|
then i := -3; // error to user
|
|
finally
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
|
|
FStepBreakPoint := StrToIntDef(GetPart(['Breakpoint '], [' at '], R.Values), -1);
|
|
if FStepBreakPoint < 0
|
|
then i := -3;
|
|
|
|
if i > 0 then begin
|
|
Result := True;
|
|
FCurrentExecCmd := ectContinue;
|
|
FCurrentExecArg := '';
|
|
end;
|
|
end;
|
|
if i < 0
|
|
then begin
|
|
DebugLn(['CommandExecute: exStepOver, frame not found: ', i]);
|
|
DoEndStepping; // TODO: User-error feedback
|
|
end;
|
|
end;
|
|
//ectStepOut:
|
|
// begin
|
|
// end;
|
|
//ectStepInto:
|
|
// begin
|
|
// end;
|
|
//ectStepOverInstruction:
|
|
// begin
|
|
// end;
|
|
ectStepIntoInstruction:
|
|
DoEndStepping;
|
|
ectReturn:
|
|
DoEndStepping;
|
|
end;
|
|
end;
|
|
|
|
function GetCurrentFp: TDBGPtr;
|
|
begin
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.StackContext := ccUseLocal;
|
|
FContext.StackFrame := 0;
|
|
FContext.ThreadId := CurThreadId;
|
|
Result := GetPtrValue('$fp', []);
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
end;
|
|
|
|
function DoExecCommand(AnExecCmd: TGDBMIExecCommandType; AnExecArg: String): Boolean;
|
|
var
|
|
UseMI: Boolean;
|
|
AFlags: TGDBMICommandFlags;
|
|
s: String;
|
|
begin
|
|
Result := False;
|
|
if AnExecCmd in [ectStepOut, ectReturn {, ectRunTo}] then begin
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.StackContext := ccUseLocal;
|
|
FContext.StackFrame := 0;
|
|
FContext.ThreadId := CurThreadId;
|
|
end
|
|
else begin
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
end;
|
|
|
|
UseMI := not FTheDebugger.FCommandNoneMiState[AnExecCmd];
|
|
if UseMI then
|
|
s := GDBMIExecCommandMap[AnExecCmd] + AnExecArg
|
|
else
|
|
s := GDBMIExecCommandMapNoneMI[AnExecCmd] + AnExecArg;
|
|
|
|
AFlags := [];
|
|
if FTheDebugger.FAsyncModeEnabled and FTheDebugger.FCommandAsyncState[AnExecCmd] then
|
|
AFlags := [cfTryAsync];
|
|
|
|
if (UseMI) and (cfTryAsync in AFlags) and (DebuggerProperties.UseNoneMiRunCommands = gdnmFallback)
|
|
then begin
|
|
if not ExecuteCommand(s + ' &', FResult, []) then // Try MI in async
|
|
exit;
|
|
if (FResult.State = dsError) then begin
|
|
// Retry none MI
|
|
FTheDebugger.FCommandNoneMiState[AnExecCmd] := True;
|
|
s := GDBMIExecCommandMapNoneMI[AnExecCmd] + AnExecArg;
|
|
if not ExecuteCommand(s, FResult, AFlags) then
|
|
exit;
|
|
end;
|
|
end
|
|
else begin
|
|
if not ExecuteCommand(s, FResult, AFlags) then
|
|
exit;
|
|
end;
|
|
|
|
if (cfTryAsync in AFlags) and (FResult.State <> dsError) then begin
|
|
if (rfAsyncFailed in FResult.Flags) then
|
|
FTheDebugger.FCommandAsyncState[AnExecCmd] := False
|
|
else
|
|
FTheDebugger.FCurrentCmdIsAsync := True;
|
|
end;
|
|
|
|
Result := True;
|
|
end;
|
|
|
|
var
|
|
StoppedParams, RunWarnings: String;
|
|
ContinueExecution, ContinueStep: Boolean;
|
|
NextExecCmdObj: TGDBMIDebuggerCommandExecute;
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Result := True;
|
|
FCanKillNow := False;
|
|
FDidKillNow := False;
|
|
FNextExecQueued := False;
|
|
FP := 0;
|
|
CurThreadId := FTheDebugger.FCurrentThreadId;
|
|
if not FTheDebugger.FCurrentThreadIdValid then CurThreadId := 1; // TODO, but we need something
|
|
ContinueStep := False; // A step command was interupted, and is continued on breakpoint
|
|
FStepBreakPoint := -1;
|
|
RunMode := rmNormal;
|
|
if (FExecType in [ectStepOver, ectStepInto, ectStepOut]) and
|
|
(FTheDebugger.FStoppedReason = srRaiseExcept)
|
|
then begin
|
|
RunMode := rmStepToFinally;
|
|
FCurrentExecCmd := ectContinue;
|
|
FTheDebugger.FPopExceptStack.EnableOrSetByAddr(Self, True);
|
|
FTheDebugger.FCatchesBreak.EnableOrSetByAddr(Self, True);
|
|
end;
|
|
if (FExecType in [ectRunTo, ectStepOver{, ectStepInto}, ectStepOut, ectStepOverInstruction {, ectStepIntoInstruction}]) then
|
|
FTheDebugger.FReRaiseBreak.EnableOrSetByAddr(Self, True)
|
|
else
|
|
FTheDebugger.FReRaiseBreak.Disable(Self);
|
|
|
|
try
|
|
repeat
|
|
FTheDebugger.CancelBeforeRun; // TODO: see comment on top of TGDBMIDebugger.QueueCommand
|
|
FTheDebugger.QueueExecuteLock; // prevent other commands from executing
|
|
try
|
|
if (not ContinueStep) and (not (RunMode in [rmStepToFinally])) and
|
|
(FExecType in [ectStepOver, ectStepInto, ectStepOut, ectStepOverInstruction, ectStepIntoInstruction])
|
|
then
|
|
FP := GetCurrentFp;
|
|
|
|
FTheDebugger.FCurrentStackFrameValid := False;
|
|
FTheDebugger.FCurrentThreadIdValid := False;
|
|
FTheDebugger.FCurrentCmdIsAsync := False;
|
|
|
|
if not DoExecCommand(FCurrentExecCmd, FCurrentExecArg) then
|
|
exit;
|
|
|
|
if CheckResultForError(FResult)
|
|
then exit;
|
|
RunWarnings := FLogWarnings;
|
|
|
|
if (FResult.State <> dsNone)
|
|
then SetDebuggerState(FResult.State);
|
|
|
|
// if ContinueExecution will be true, the we ignore dsError..
|
|
// TODO: check for cancelled
|
|
StoppedParams := '';
|
|
FCanKillNow := True;
|
|
R.State := dsNone;
|
|
if FResult.State = dsRun
|
|
then Result := ProcessRunning(StoppedParams, R);
|
|
finally
|
|
FCanKillNow := False;
|
|
// allow other commands to execute
|
|
// e.g. source-line-info, watches.. all triggered in ProcessStopped)
|
|
//TODO: prevent the next exec-command from running (or the order of SetLocation in Process Stopped is wrong)
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
|
|
if FDidKillNow or CheckResultForError(R)
|
|
then exit;
|
|
|
|
ContinueExecution := False;
|
|
if HandleBreakPointError(FResult, RunWarnings + LineEnding + FLogWarnings) then begin
|
|
if FResult.State = dsStop then exit;
|
|
ContinueExecution := FResult.State = dsRun; // no user interaction => FMainAddrBreak
|
|
end;
|
|
|
|
ContinueStep := False;
|
|
if StoppedParams <> ''
|
|
then ContinueExecution := ProcessStopped(StoppedParams, FTheDebugger.PauseWaitState = pwsInternal);
|
|
|
|
if ContinueExecution
|
|
then begin
|
|
ContinueStep := DoContinueStepping; // will set dsPause, if step has finished
|
|
|
|
if (not ContinueStep) and (FCurrentExecCmd <> ectNone) then begin
|
|
// - Fall back to "old" behaviour and queue a new exec-continue
|
|
// - Queue is unlocked, so nothing should be empty
|
|
// But make info available, if anything wants to queue
|
|
FNextExecQueued := True;
|
|
debugln(DBGMI_QUEUE_DEBUG, ['CommandExecute: Internal queuing -exec-continue (ContinueExecution = True)']);
|
|
FTheDebugger.FPauseWaitState := pwsNone;
|
|
NextExecCmdObj := TGDBMIDebuggerCommandExecute.Create(FTheDebugger, ectContinue);
|
|
FTheDebugger.QueueExecuteLock; // force queue
|
|
FTheDebugger.QueueCommand(NextExecCmdObj, DebuggerState = dsInternalPause); // TODO: ForceQueue, only until better means of queue control... (allow snapshot to run)
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
end;
|
|
|
|
until (not ContinueStep) or (FCurrentExecCmd = ectNone);
|
|
|
|
finally
|
|
if FStepBreakPoint > 0
|
|
then ExecuteCommand('-break-delete %d', [FStepBreakPoint], [cfNoThreadContext]);
|
|
FStepBreakPoint := -1;
|
|
FTheDebugger.FPopExceptStack.Disable(Self);
|
|
FTheDebugger.FCatchesBreak.Disable(Self);
|
|
FTheDebugger.FMainAddrBreak.Clear(Self);
|
|
end;
|
|
|
|
if (not ContinueExecution) and (DebuggerState = dsRun) and
|
|
(FTheDebugger.PauseWaitState <> pwsInternal)
|
|
then begin
|
|
// Handle the unforeseen
|
|
if (StoppedParams <> '')
|
|
then debugln(['ERROR: Got stop params, but did not change FTheDebugger.state: ', StoppedParams])
|
|
else debugln(['ERROR: Got NO stop params at all, but was running']);
|
|
SetDebuggerState(dsPause);
|
|
end;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandExecute.Create(AOwner: TGDBMIDebugger;
|
|
const ExecType: TGDBMIExecCommandType);
|
|
begin
|
|
Create(AOwner, ExecType, []);
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandExecute.Create(AOwner: TGDBMIDebugger;
|
|
const ExecType: TGDBMIExecCommandType; Args: array of const);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FQueueRunLevel := 0; // Execommands are only allowed at level 0
|
|
FCanKillNow := False;
|
|
FDidKillNow := False;;
|
|
FNextExecQueued := False;
|
|
FExecType := ExecType;
|
|
FCurrentExecCmd := ExecType;
|
|
FCurrentExecArg := '';
|
|
if FCurrentExecCmd = ectRunTo then begin
|
|
FRunToSrc := AnsiString(Args[0].VAnsiString);
|
|
FRunToLine := Args[1].VInteger;
|
|
FCurrentExecArg := Format(' %s:%d', [FRunToSrc, FRunToLine]);
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandExecute.DebugText: String;
|
|
begin
|
|
Result := Format('%s: %s', [ClassName, GDBMIExecCommandMap[FCurrentExecCmd]]);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandLineSymbolInfo }
|
|
|
|
function TGDBMIDebuggerCommandLineSymbolInfo.DoExecute: Boolean;
|
|
var
|
|
Src: String;
|
|
begin
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
Src := StringReplace(FSource, '\', '/', [rfReplaceAll]);
|
|
Src := StringReplace(Src, '"', '\"', [rfReplaceAll]);
|
|
ExecuteCommand('-symbol-list-lines "%s"', [Src], FResult);
|
|
|
|
if (FResult.State = dsError) and not(dcsCanceled in SeenStates)
|
|
then
|
|
ExecuteCommand('-symbol-list-lines %s', [FSource], FResult);
|
|
|
|
if (FResult.State = dsError) and not(dcsCanceled in SeenStates)
|
|
then begin
|
|
// the second trial: gdb can return info to file w/o path
|
|
Src := ExtractFileName(FSource);
|
|
if Src <> FSource
|
|
then ExecuteCommand('-symbol-list-lines %s', [Src], FResult);
|
|
end;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandLineSymbolInfo.Create(AOwner: TGDBMIDebugger;
|
|
Source: string);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FSource := Source;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandLineSymbolInfo.DebugText: String;
|
|
begin
|
|
Result := Format('%s: Source=%s', [ClassName, FSource]);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStackDepth }
|
|
|
|
function TGDBMIDebuggerCommandStackDepth.DoExecute: Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
i, cnt: longint;
|
|
begin
|
|
Result := True;
|
|
if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
|
|
|
|
FContext.StackContext := ccNotRequired;
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.ThreadId := FCallstack.ThreadId;
|
|
|
|
FDepth := -1;
|
|
|
|
if FLimit > 0 then
|
|
ExecuteCommand('-stack-info-depth %d', [FLimit], R)
|
|
else
|
|
ExecuteCommand('-stack-info-depth', R);
|
|
List := TGDBMINameValueList.Create(R);
|
|
cnt := StrToIntDef(List.Values['depth'], -1);
|
|
FreeAndNil(List);
|
|
if cnt = -1 then
|
|
begin
|
|
{ In case of error some stackframes still can be accessed.
|
|
Trying to find out how many...
|
|
We try maximum 40 frames, because sometimes a corrupt stack and a bug in
|
|
gdb may cooperate, so that -stack-info-depth X returns always X }
|
|
FLimit := 0; // this is a final result
|
|
i:=0;
|
|
repeat
|
|
inc(i);
|
|
ExecuteCommand('-stack-info-depth %d', [i], R);
|
|
List := TGDBMINameValueList.Create(R);
|
|
cnt := StrToIntDef(List.Values['depth'], -1);
|
|
FreeAndNil(List);
|
|
if (cnt = -1) then begin
|
|
// no valid stack-info-depth found, so the previous was the last valid one
|
|
cnt:=i - 1;
|
|
end;
|
|
until (cnt < i) or (i = 40);
|
|
end;
|
|
FDepth := cnt;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandStackDepth.Create(AOwner: TGDBMIDebugger;
|
|
ACallstack: TCallStackBase);
|
|
begin
|
|
inherited Create(AOwner, ACallstack);
|
|
FLimit := 0;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandStackDepth.DebugText: String;
|
|
begin
|
|
Result := Format('%s:', [ClassName]);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandStackFrames }
|
|
|
|
function TGDBMIDebuggerCommandStackFrames.DoExecute: Boolean;
|
|
var
|
|
CurStartIdx: Integer;
|
|
It: TMapIterator;
|
|
|
|
procedure FreeList(var AList: TGDBMINameValueListArray);
|
|
var
|
|
i : Integer;
|
|
begin
|
|
for i := low(AList) to high(AList) do
|
|
AList[i].Free;
|
|
end;
|
|
|
|
procedure UpdateEntry(AnEntry: TCallStackEntry; AArgInfo, AFrameInfo : TGDBMINameValueList);
|
|
var
|
|
i, j, n, e, NameEnd: Integer;
|
|
Arguments: TStringList;
|
|
List: TGDBMINameValueList;
|
|
Arg: PGDBMINameValue;
|
|
addr: TDbgPtr;
|
|
func, filename, fullname, line, cl, fn, fa, un: String;
|
|
begin
|
|
Arguments := TStringList.Create;
|
|
|
|
if (AArgInfo <> nil) and (AArgInfo.Count > 0)
|
|
then begin
|
|
List := TGDBMINameValueList.Create('');
|
|
for n := 0 to AArgInfo.Count - 1 do
|
|
begin
|
|
Arg := AArgInfo.Items[n];
|
|
List.Init(Arg^.Name);
|
|
Arguments.Add(List.Values['name'] + '=' + DeleteEscapeChars(List.Values['value']));
|
|
end;
|
|
FreeAndNil(List);
|
|
end;
|
|
|
|
addr := 0;
|
|
func := '';
|
|
filename := '';
|
|
fullname := '';
|
|
line := '';
|
|
if AFrameInfo <> nil
|
|
then begin
|
|
Val(AFrameInfo.Values['addr'], addr, e);
|
|
if e=0 then ;
|
|
func := AFrameInfo.Values['func'];
|
|
filename := ConvertGdbPathAndFile(AFrameInfo.Values['file']);
|
|
fullname := ConvertGdbPathAndFile(AFrameInfo.Values['fullname']);
|
|
line := AFrameInfo.Values['line'];
|
|
end;
|
|
|
|
(*
|
|
func="fpc_pushexceptaddr"
|
|
func="_$CODETEMPLATESDLG$_Ld98"
|
|
func="_$CODETEMPLATESDLG$_Ld98"
|
|
func="??"
|
|
*)
|
|
|
|
j := pos('$', func);
|
|
if j > 1 then begin
|
|
un := '';
|
|
cl := '';
|
|
fa := '';
|
|
i := pos('_$__', func);
|
|
if i > 1 then begin
|
|
// CLASSES$_$TREADER_$__$$_READINTEGER$$LONGINT
|
|
// SYSTEM_TOBJECT_$__DISPATCH$formal
|
|
// UNIT1_TFORM1_$__FORMCLOSE$TOBJECT$TCLOSEACTION
|
|
cl := copy(func, 1, i - 1); // unit and class
|
|
|
|
if copy(func, i + 4, 3) = '$$_' then
|
|
inc(i, 3);
|
|
NameEnd := PosEx('$', func, i + 4);
|
|
if NameEnd <= 0
|
|
then NameEnd := length(func) + 1;
|
|
fn := copy(func, i + 4, NameEnd - (i + 4)); // function
|
|
|
|
i := pos('$_$', cl);
|
|
if i > 1 then begin
|
|
un := copy(cl, 1, i - 1); // unit
|
|
delete(cl, 1, i + 2); // class
|
|
end
|
|
else begin
|
|
i := pos('_', cl);
|
|
if posex('_', cl, i + 1) < 1 then begin
|
|
// Only one _ => split unit and class
|
|
un := copy(cl, 1, i - 1); // unit
|
|
delete(cl, 1, i); // class
|
|
end;
|
|
end;
|
|
end
|
|
else begin
|
|
// SYSUTILS_COMPARETEXT$ANSISTRING$ANSISTRING$$LONGINT
|
|
NameEnd := j;
|
|
fn := copy(func, 1, NameEnd - 1);
|
|
i := pos('_', fn);
|
|
if posex('_', fn, i + 1) < 1 then begin
|
|
// Only one _ => split unit and class
|
|
un := copy(fn, 1, i - 1); // unit
|
|
delete(fn, 1, i); // class
|
|
end;
|
|
end;
|
|
|
|
inc(NameEnd, 1);
|
|
if copy(func, NameEnd, 1) = '$' then
|
|
inc(NameEnd, 1);
|
|
if (length(func) >= NameEnd) and (func[NameEnd] in ['a'..'z', 'A'..'Z']) then
|
|
fa := copy(func, NameEnd, MaxInt); // args
|
|
fa := AnsiReplaceText(fa, '$', ',');
|
|
|
|
//debugln([cl,' ## ', fn]);
|
|
AnEntry.Init(
|
|
addr,
|
|
Arguments,
|
|
func,
|
|
un, cl, fn, fa,
|
|
StrToIntDef(line, 0)
|
|
);
|
|
end
|
|
else begin
|
|
AnEntry.Init(
|
|
addr,
|
|
Arguments,
|
|
func,
|
|
filename, fullname,
|
|
StrToIntDef(line, 0)
|
|
);
|
|
end;
|
|
|
|
|
|
Arguments.Free;
|
|
end;
|
|
|
|
procedure PrepareArgs(var ADest: TGDBMINameValueListArray; AStart, AStop: Integer;
|
|
const ACmd, APath1, APath2: String);
|
|
var
|
|
R: TGDBMIExecResult;
|
|
i, lvl : Integer;
|
|
ResultList, SubList: TGDBMINameValueList;
|
|
begin
|
|
ExecuteCommand(ACmd, [AStart, AStop], R, [cfNoStackContext]);
|
|
|
|
if R.State = dsError
|
|
then begin
|
|
i := AStop - AStart;
|
|
case i of
|
|
0 : exit;
|
|
1..5: begin
|
|
while i >= 0 do
|
|
begin
|
|
PrepareArgs(ADest, AStart+i, AStart+i, ACmd, APath1, APath2);
|
|
dec(i);
|
|
end;
|
|
end;
|
|
else
|
|
i := i div 2;
|
|
PrepareArgs(ADest, AStart, AStart+i, ACmd, APath1, APath2);
|
|
PrepareArgs(ADest, AStart+i+1, AStop, ACmd, APath1, APath2);
|
|
end;
|
|
end;
|
|
|
|
ResultList := TGDBMINameValueList.Create(R, [APath1]);
|
|
for i := 0 to ResultList.Count - 1 do
|
|
begin
|
|
SubList := TGDBMINameValueList.Create(ResultList.GetString(i), ['frame']);
|
|
lvl := StrToIntDef(SubList.Values['level'], -1);
|
|
if (lvl >= AStart) and (lvl <= AStop)
|
|
then begin
|
|
if APath2 <> ''
|
|
then SubList.SetPath(APath2);
|
|
ADest[lvl-CurStartIdx] := SubList;
|
|
end
|
|
else SubList.Free;
|
|
end;
|
|
ResultList.Free;
|
|
end;
|
|
|
|
procedure ExecForRange(AStartIdx, AEndIdx: Integer);
|
|
var
|
|
Args: TGDBMINameValueListArray;
|
|
Frames: TGDBMINameValueListArray;
|
|
e: TCallStackEntry;
|
|
begin
|
|
try
|
|
CurStartIdx := AStartIdx;
|
|
SetLength(Args, AEndIdx-AStartIdx+1);
|
|
PrepareArgs(Args, AStartIdx, AEndIdx, '-stack-list-arguments 1 %d %d', 'stack-args', 'args');
|
|
if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
|
|
|
|
SetLength(Frames, AEndIdx-AStartIdx+1);
|
|
PrepareArgs(Frames, AStartIdx, AEndIdx, '-stack-list-frames %d %d', 'stack', '');
|
|
if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
|
|
|
|
if not It.Locate(AStartIdx)
|
|
then if not It.EOM
|
|
then IT.Next;
|
|
while it.Valid and (not It.EOM) do begin
|
|
e := TCallStackEntry(It.DataPtr^);
|
|
if e.Index > AEndIdx then break;
|
|
UpdateEntry(e, Args[e.Index-AStartIdx], Frames[e.Index-AStartIdx]);
|
|
It.Next;
|
|
end;
|
|
|
|
finally
|
|
FreeList(Args);
|
|
FreeList(Frames);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
StartIdx, EndIdx: Integer;
|
|
begin
|
|
Result := True;
|
|
if (FCallstack = nil) or (dcsCanceled in SeenStates) then exit;
|
|
|
|
FContext.StackContext := ccNotRequired;
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.ThreadId := FCallstack.ThreadId;
|
|
|
|
|
|
It := TMapIterator.Create(FCallstack.RawEntries);
|
|
try
|
|
//if It.Locate(AIndex)
|
|
StartIdx := Max(FCallstack.LowestUnknown, 0);
|
|
EndIdx := FCallstack.HighestUnknown;
|
|
while EndIdx >= StartIdx do begin
|
|
if (FCallstack = nil) or (dcsCanceled in SeenStates) then break;
|
|
debugln(DBG_VERBOSE, ['Callstack.Frames A StartIdx=',StartIdx, ' EndIdx=',EndIdx]);
|
|
// search for existing blocks in the middle
|
|
if not It.Locate(StartIdx)
|
|
then if not It.EOM
|
|
then IT.Next;
|
|
StartIdx := TCallStackEntry(It.DataPtr^).Index;
|
|
EndIdx := StartIdx;
|
|
It.Next;
|
|
while (not It.EOM) and (TCallStackEntry(It.DataPtr^).Index = EndIdx+1) do begin
|
|
inc(EndIdx);
|
|
if EndIdx = FCallstack.HighestUnknown then
|
|
Break;
|
|
It.Next;
|
|
end;
|
|
|
|
debugln(DBG_VERBOSE, ['Callstack.Frames B StartIdx=',StartIdx, ' EndIdx=',EndIdx]);
|
|
ExecForRange(StartIdx, EndIdx);
|
|
if (FCallstack = nil) or (dcsCanceled in SeenStates) then break;
|
|
|
|
StartIdx := EndIdx + 1;
|
|
EndIdx := FCallstack.HighestUnknown;
|
|
end;
|
|
finally
|
|
IT.Free;
|
|
if FCallstack <> nil
|
|
then FCallstack.DoEntriesUpdated;
|
|
end;
|
|
end;
|
|
|
|
{ TGDBMILineInfo }
|
|
|
|
procedure TGDBMILineInfo.DoGetLineSymbolsDestroyed(Sender: TObject);
|
|
begin
|
|
if FGetLineSymbolsCmdObj = Sender
|
|
then FGetLineSymbolsCmdObj := nil;
|
|
end;
|
|
|
|
procedure TGDBMILineInfo.ClearSources;
|
|
var
|
|
n: Integer;
|
|
begin
|
|
for n := Low(FSourceMaps) to High(FSourceMaps) do
|
|
FSourceMaps[n].Map.Free;
|
|
Setlength(FSourceMaps, 0);
|
|
|
|
for n := 0 to FSourceIndex.Count - 1 do
|
|
DoChange(FSourceIndex[n]);
|
|
|
|
FSourceIndex.Clear;
|
|
//FRequestedSources.Clear;
|
|
end;
|
|
|
|
procedure TGDBMILineInfo.AddInfo(const ASource: String; const AResult: TGDBMIExecResult);
|
|
var
|
|
ID: packed record
|
|
Line, Column: Integer;
|
|
end;
|
|
Map: TMap;
|
|
n, idx: Integer;
|
|
LinesList, LineList: TGDBMINameValueList;
|
|
Item: PGDBMINameValue;
|
|
Addr: TDbgPtr;
|
|
begin
|
|
n := FSourceIndex.IndexOf(ASource);
|
|
if n = -1
|
|
then begin
|
|
idx := Length(FSourceMaps);
|
|
SetLength(FSourceMaps, idx+1);
|
|
FSourceMaps[idx].Map := nil;
|
|
FSourceMaps[idx].Source := ASource;
|
|
n := FSourceIndex.AddObject(ASource, TObject(PtrInt(idx)));
|
|
end
|
|
else idx := PtrInt(FSourceIndex.Objects[n]);
|
|
|
|
LinesList := TGDBMINameValueList.Create(AResult, ['lines']);
|
|
if LinesList = nil then Exit;
|
|
|
|
Map := FSourceMaps[idx].Map;
|
|
if Map = nil
|
|
then begin
|
|
// no map present
|
|
Map := TMap.Create(its8, SizeOf(TDBGPtr));
|
|
FSourceMaps[idx].Map := Map;
|
|
end;
|
|
|
|
ID.Column := 0;
|
|
LineList := TGDBMINameValueList.Create('');
|
|
for n := 0 to LinesList.Count - 1 do
|
|
begin
|
|
Item := LinesList.Items[n];
|
|
LineList.Init(Item^.Name);
|
|
if not TryStrToInt(Unquote(LineList.Values['line']), ID.Line) then Continue;
|
|
if not TryStrToQWord(Unquote(LineList.Values['pc']), Addr) then Continue;
|
|
// one line can have more than one address
|
|
if Map.HasId(ID) then Continue;
|
|
Map.Add(ID, Addr);
|
|
end;
|
|
LineList.Free;
|
|
LinesList.Free;
|
|
DoChange(ASource);
|
|
end;
|
|
|
|
function TGDBMILineInfo.Count: Integer;
|
|
begin
|
|
Result := FSourceIndex.Count;
|
|
end;
|
|
|
|
function TGDBMILineInfo.GetSource(const AIndex: integer): String;
|
|
begin
|
|
if AIndex < Low(FSourceMaps) then Exit('');
|
|
if AIndex > High(FSourceMaps) then Exit('');
|
|
|
|
Result := FSourceMaps[AIndex].Source;
|
|
end;
|
|
|
|
function TGDBMILineInfo.GetAddress(const AIndex: Integer; const ALine: Integer): TDbgPtr;
|
|
var
|
|
ID: packed record
|
|
Line, Column: Integer;
|
|
end;
|
|
Map: TMap;
|
|
begin
|
|
if AIndex < Low(FSourceMaps) then Exit(0);
|
|
if AIndex > High(FSourceMaps) then Exit(0);
|
|
|
|
Map := FSourceMaps[AIndex].Map;
|
|
if Map = nil then Exit(0);
|
|
|
|
ID.Line := ALine;
|
|
// since we do not have column info we map all on column 0
|
|
// ID.Column := AColumn;
|
|
ID.Column := 0;
|
|
if (Map = nil) then Exit(0);
|
|
if not Map.GetData(ID, Result) then
|
|
Result := 0;
|
|
end;
|
|
|
|
function TGDBMILineInfo.GetInfo(AAdress: TDbgPtr; out ASource, ALine, AOffset: Integer): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TGDBMILineInfo.DoStateChange(const AOldState: TDBGState);
|
|
begin
|
|
if not (Debugger.State in [dsPause, dsInternalPause, dsRun]) then
|
|
ClearSources;
|
|
end;
|
|
|
|
function TGDBMILineInfo.IndexOf(const ASource: String): integer;
|
|
begin
|
|
Result := FSourceIndex.IndexOf(ASource);
|
|
if Result <> -1
|
|
then Result := PtrInt(FSourceIndex.Objects[Result]);
|
|
end;
|
|
|
|
constructor TGDBMILineInfo.Create(const ADebugger: TDebuggerIntf);
|
|
begin
|
|
FSourceIndex := TStringList.Create;
|
|
FSourceIndex.Sorted := True;
|
|
FSourceIndex.Duplicates := dupError;
|
|
FSourceIndex.CaseSensitive := True;
|
|
FRequestedSources := TStringList.Create;
|
|
FRequestedSources.Sorted := True;
|
|
FRequestedSources.Duplicates := dupError;
|
|
FRequestedSources.CaseSensitive := True;
|
|
inherited;
|
|
end;
|
|
|
|
destructor TGDBMILineInfo.Destroy;
|
|
begin
|
|
ClearSources;
|
|
FreeAndNil(FSourceIndex);
|
|
FreeAndNil(FRequestedSources);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TGDBMILineInfo.DoGetLineSymbolsFinished(Sender: TObject);
|
|
var
|
|
Cmd: TGDBMIDebuggerCommandLineSymbolInfo;
|
|
idx: LongInt;
|
|
begin
|
|
Cmd := TGDBMIDebuggerCommandLineSymbolInfo(Sender);
|
|
if Cmd.Result.State <> dsError
|
|
then
|
|
AddInfo(Cmd.Source, Cmd.Result);
|
|
|
|
idx := FRequestedSources.IndexOf(Cmd.Source);
|
|
if idx >= 0
|
|
then FRequestedSources.Delete(idx);
|
|
|
|
FGetLineSymbolsCmdObj := nil;
|
|
// DoChange is calle in AddInfo
|
|
end;
|
|
|
|
procedure TGDBMILineInfo.Request(const ASource: String);
|
|
var
|
|
idx: Integer;
|
|
begin
|
|
if (ASource = '') or (Debugger = nil) or (FRequestedSources.IndexOf(ASource) >= 0)
|
|
then Exit;
|
|
|
|
idx := IndexOf(ASource);
|
|
if (idx <> -1) and (FSourceMaps[idx].Map <> nil) then Exit; // already present
|
|
|
|
// add empty entry, to prevent further requests
|
|
FRequestedSources.Add(ASource);
|
|
|
|
// Need to interupt debugger
|
|
if Debugger.State = dsRun
|
|
then TGDBMIDebugger(Debugger).GDBPause(True);
|
|
|
|
FGetLineSymbolsCmdObj := TGDBMIDebuggerCommandLineSymbolInfo.Create(TGDBMIDebugger(Debugger), ASource);
|
|
FGetLineSymbolsCmdObj.OnExecuted := @DoGetLineSymbolsFinished;
|
|
FGetLineSymbolsCmdObj.OnDestroy := @DoGetLineSymbolsDestroyed;
|
|
FGetLineSymbolsCmdObj.Priority := GDCMD_PRIOR_LINE_INFO;
|
|
(* TGDBMIDebugger(Debugger).FCommandQueueExecLock > 0
|
|
Force queue, if locked. This will set the RunLevel
|
|
This can be called in AsyncCAll (TApplication), while in QueueExecuteLock (this does not run on unlock)
|
|
Without ForceQueue, the queue is virtually locked until the current command finishes.
|
|
But ExecCommand must be able to unlock
|
|
Reproduce: Trigger Exception in app startup (lfm loading). Stack is not searched.
|
|
*)
|
|
TGDBMIDebugger(Debugger).QueueCommand(FGetLineSymbolsCmdObj,
|
|
TGDBMIDebugger(Debugger).FCommandQueueExecLock > 0
|
|
);
|
|
(* DoEvaluationFinished may be called immediately at this point *)
|
|
end;
|
|
|
|
procedure TGDBMILineInfo.Cancel(const ASource: String);
|
|
var
|
|
i: Integer;
|
|
q: TGDBMIDebugger;
|
|
begin
|
|
q := TGDBMIDebugger(Debugger);
|
|
i := q.FCommandQueue.Count - 1;
|
|
while i >= 0 do begin
|
|
if (q.FCommandQueue[i] is TGDBMIDebuggerCommandLineSymbolInfo) and
|
|
(TGDBMIDebuggerCommandLineSymbolInfo(q.FCommandQueue[i]).Source = ASource)
|
|
then q.FCommandQueue[i].Cancel;
|
|
dec(i);
|
|
if i >= q.FCommandQueue.Count
|
|
then i := q.FCommandQueue.Count - 1;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ =========================================================================== }
|
|
{ TGDBMIDebuggerPropertiesBase }
|
|
{ =========================================================================== }
|
|
|
|
procedure TGDBMIDebuggerPropertiesBase.SetTimeoutForEval(const AValue: Integer);
|
|
begin
|
|
if FTimeoutForEval = AValue then exit;
|
|
FTimeoutForEval := AValue;
|
|
if (FTimeoutForEval <> -1) and (FTimeoutForEval < 50)
|
|
then FTimeoutForEval := -1;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerPropertiesBase.SetMaxDisplayLengthForString(AValue: Integer);
|
|
begin
|
|
if FMaxDisplayLengthForString = AValue then Exit;
|
|
if AValue < 0 then
|
|
AValue := 0;
|
|
FMaxDisplayLengthForString := AValue;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerPropertiesBase.SetWarnOnTimeOut(const AValue: Boolean);
|
|
begin
|
|
if FWarnOnTimeOut = AValue then exit;
|
|
FWarnOnTimeOut := AValue;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerPropertiesBase.Create;
|
|
begin
|
|
{$IFDEF UNIX}
|
|
FConsoleTty := '';
|
|
{$ENDIF}
|
|
FMaxDisplayLengthForString := 2500;
|
|
{$IFDEF darwin}
|
|
FTimeoutForEval := 250;
|
|
{$ELSE darwin}
|
|
FTimeoutForEval := -1;
|
|
{$ENDIF}
|
|
FWarnOnTimeOut := True;
|
|
FWarnOnInternalError := True;
|
|
FEncodeCurrentDirPath := gdfeDefault;
|
|
FEncodeExeFileName := gdfeDefault;
|
|
FInternalStartBreak := gdsbDefault;
|
|
FUseAsyncCommandMode := False;
|
|
FDisableLoadSymbolsForLibraries := False;
|
|
FUseNoneMiRunCommands := gdnmFallback;
|
|
FDisableForcedBreakpoint := False;
|
|
FWarnOnSetBreakpointError := gdbwAll;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerPropertiesBase.Assign(Source: TPersistent);
|
|
begin
|
|
inherited Assign(Source);
|
|
FGDBOptions := TGDBMIDebuggerPropertiesBase(Source).FGDBOptions;
|
|
{$IFDEF UNIX}
|
|
FConsoleTty := TGDBMIDebuggerPropertiesBase(Source).FConsoleTty;
|
|
{$ENDIF}
|
|
FMaxDisplayLengthForString := TGDBMIDebuggerPropertiesBase(Source).FMaxDisplayLengthForString;
|
|
FTimeoutForEval := TGDBMIDebuggerPropertiesBase(Source).FTimeoutForEval;
|
|
FWarnOnTimeOut := TGDBMIDebuggerPropertiesBase(Source).FWarnOnTimeOut;
|
|
FEncodeCurrentDirPath := TGDBMIDebuggerPropertiesBase(Source).FEncodeCurrentDirPath;
|
|
FEncodeExeFileName := TGDBMIDebuggerPropertiesBase(Source).FEncodeExeFileName;
|
|
FInternalStartBreak := TGDBMIDebuggerPropertiesBase(Source).FInternalStartBreak;
|
|
FUseAsyncCommandMode := TGDBMIDebuggerPropertiesBase(Source).FUseAsyncCommandMode;
|
|
FDisableLoadSymbolsForLibraries := TGDBMIDebuggerPropertiesBase(Source).FDisableLoadSymbolsForLibraries;
|
|
FUseNoneMiRunCommands := TGDBMIDebuggerPropertiesBase(Source).FUseNoneMiRunCommands;
|
|
FDisableForcedBreakpoint := TGDBMIDebuggerPropertiesBase(Source).FDisableForcedBreakpoint;
|
|
FWarnOnSetBreakpointError := TGDBMIDebuggerPropertiesBase(Source).FWarnOnSetBreakpointError;
|
|
end;
|
|
|
|
|
|
{ =========================================================================== }
|
|
{ TGDBMIDebugger }
|
|
{ =========================================================================== }
|
|
|
|
class function TGDBMIDebugger.Caption: String;
|
|
begin
|
|
Result := 'GNU debugger (gdb)';
|
|
end;
|
|
|
|
function TGDBMIDebugger.ChangeFileName: Boolean;
|
|
var
|
|
Cmd: TGDBMIDebuggerCommandChangeFilename;
|
|
begin
|
|
Result := False;
|
|
FCurrentStackFrameValid := False; // not running => not valid
|
|
FCurrentThreadIdValid := False;
|
|
|
|
if State = dsIdle then begin
|
|
// will do in start debugging
|
|
if not (inherited ChangeFileName) then Exit;
|
|
Result:=true;
|
|
exit;
|
|
end;
|
|
|
|
Cmd := TGDBMIDebuggerCommandChangeFilename.Create(Self, FileName);
|
|
Cmd.AddReference;
|
|
QueueCommand(Cmd);
|
|
// if filename = '', then command may be queued
|
|
if (FileName <> '') and (not Cmd.Success) then begin
|
|
MessageDlg('Debugger', Format('Failed to load file: %s', [Cmd.ErrorMsg]), mtError, [mbOK], 0);
|
|
Cmd.Cancel;
|
|
Cmd.ReleaseReference;
|
|
SetState(dsStop);
|
|
end
|
|
else begin
|
|
Cmd.ReleaseReference;
|
|
end;
|
|
|
|
if not (inherited ChangeFileName) then Exit;
|
|
Result:=true;
|
|
end;
|
|
|
|
constructor TGDBMIDebugger.Create(const AExternalDebugger: String);
|
|
begin
|
|
FReleaseLock := 0;
|
|
|
|
FMainAddrBreak := TGDBMIInternalBreakPoint.Create('main');
|
|
FBreakErrorBreak := TGDBMIInternalBreakPoint.Create('FPC_BREAK_ERROR');
|
|
FRunErrorBreak := TGDBMIInternalBreakPoint.Create('FPC_RUNERROR');
|
|
FExceptionBreak := TGDBMIInternalBreakPoint.Create('FPC_RAISEEXCEPTION');
|
|
FPopExceptStack := TGDBMIInternalBreakPoint.Create('FPC_POPADDRSTACK');
|
|
FCatchesBreak := TGDBMIInternalBreakPoint.Create('FPC_CATCHES');
|
|
FReRaiseBreak := TGDBMIInternalBreakPoint.Create('FPC_RERAISE');
|
|
{$IFdef WITH_GDB_FORCE_EXCEPTBREAK}
|
|
FBreakErrorBreak.UseForceFlag := True;
|
|
FRunErrorBreak.UseForceFlag := True;
|
|
FExceptionBreak.UseForceFlag := True;
|
|
{$ENDIF}
|
|
|
|
FInstructionQueue := TGDBMIDbgInstructionQueue.Create(Self);
|
|
FCommandQueue := TGDBMIDebuggerCommandList.Create;
|
|
FTargetInfo.TargetPID := 0;
|
|
FTargetInfo.TargetFlags := [];
|
|
FDebuggerFlags := [];
|
|
FSourceNames := TStringList.Create;
|
|
FSourceNames.Sorted := True;
|
|
FSourceNames.Duplicates := dupError;
|
|
FSourceNames.CaseSensitive := False;
|
|
FCommandQueueExecLock := 0;
|
|
FRunQueueOnUnlock := False;
|
|
FThreadGroups := TStringList.Create;
|
|
FTypeRequestCache := CreateTypeRequestCache;
|
|
FMaxLineForUnitCache := TStringList.Create;
|
|
FInProcessStopped := False;
|
|
FNeedStateToIdle := False;
|
|
FNeedReset := False;
|
|
|
|
|
|
{$IFdef MSWindows}
|
|
InitWin32;
|
|
{$ENDIF}
|
|
{$IFDEF DBG_ENABLE_TERMINAL}
|
|
FPseudoTerminal := TPseudoTerminal.Create;
|
|
FPseudoTerminal.OnCanRead :=@DoPseudoTerminalRead;
|
|
{$ENDIF}
|
|
|
|
inherited;
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateBreakPoints: TDBGBreakPoints;
|
|
begin
|
|
Result := TGDBMIBreakPoints.Create(Self, TGDBMIBreakPoint);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateCallStack: TCallStackSupplier;
|
|
begin
|
|
Result := TGDBMICallStack.Create(Self);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateDisassembler: TDBGDisassembler;
|
|
begin
|
|
Result := TGDBMIDisassembler.Create(Self);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateLocals: TLocalsSupplier;
|
|
begin
|
|
Result := TGDBMILocals.Create(Self);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateLineInfo: TDBGLineInfo;
|
|
begin
|
|
Result := TGDBMILineInfo.Create(Self);
|
|
end;
|
|
|
|
class function TGDBMIDebugger.CreateProperties: TDebuggerProperties;
|
|
begin
|
|
Result := TGDBMIDebuggerProperties.Create;
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateRegisters: TRegisterSupplier;
|
|
begin
|
|
Result := TGDBMIRegisterSupplier.Create(Self);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateWatches: TWatchesSupplier;
|
|
begin
|
|
Result := TGDBMIWatches.Create(Self);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateThreads: TThreadsSupplier;
|
|
begin
|
|
Result := TGDBMIThreads.Create(Self);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateCommandInit: TGDBMIDebuggerCommandInitDebugger;
|
|
begin
|
|
Result := TGDBMIDebuggerCommandInitDebugger.Create(Self);
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateCommandStartDebugging
|
|
(AContinueCommand: TGDBMIDebuggerCommand): TGDBMIDebuggerCommandStartDebugging;
|
|
begin
|
|
Result:= TGDBMIDebuggerCommandStartDebugging.Create(Self, AContinueCommand);
|
|
end;
|
|
|
|
destructor TGDBMIDebugger.Destroy;
|
|
begin
|
|
LockRelease;
|
|
inherited;
|
|
ClearCommandQueue;
|
|
//RemoveRunQueueASync;
|
|
FreeAndNil(FCommandQueue);
|
|
FreeAndNil(FInstructionQueue);
|
|
ClearSourceInfo;
|
|
FreeAndNil(FSourceNames);
|
|
FreeAndNil(FThreadGroups);
|
|
{$IFDEF DBG_ENABLE_TERMINAL}
|
|
FreeAndNil(FPseudoTerminal);
|
|
{$ENDIF}
|
|
FreeAndNil(FTypeRequestCache);
|
|
FreeAndNil(FMaxLineForUnitCache);
|
|
FreeAndNil(FMainAddrBreak);
|
|
FreeAndNil(FBreakErrorBreak);
|
|
FreeAndNil(FRunErrorBreak);
|
|
FreeAndNil(FExceptionBreak);
|
|
FreeAndNil(FPopExceptStack);
|
|
FreeAndNil(FCatchesBreak);
|
|
FreeAndNil(FReRaiseBreak);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.Done;
|
|
begin
|
|
if State = dsDestroying
|
|
then begin
|
|
ClearCommandQueue;
|
|
inherited Done;
|
|
exit;
|
|
end;
|
|
|
|
LockRelease;
|
|
try
|
|
CancelAllQueued;
|
|
if (DebugProcess <> nil) and DebugProcess.Running then begin
|
|
if FCurrentCommand <> Nil then
|
|
FCurrentCommand.KillNow;
|
|
if (State = dsRun) then GDBPause(True);
|
|
// fire and forget. Donst wait on the queue.
|
|
FCurrentStackFrameValid := False;
|
|
FCurrentThreadIdValid := False;
|
|
SendCmdLn('kill');
|
|
SendCmdLn('-gdb-exit');
|
|
end;
|
|
inherited Done;
|
|
finally
|
|
UnlockRelease;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GetLocation: TDBGLocationRec;
|
|
begin
|
|
Result := FCurrentLocation;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GetProcessList(AList: TRunningProcessInfoList): boolean;
|
|
{$ifdef darwin}
|
|
var
|
|
AResult: TGDBMIExecResult;
|
|
ARunningProcessInfo: TRunningProcessInfo;
|
|
pname,pid,aLine: string;
|
|
s: string;
|
|
i: integer;
|
|
{$endif}
|
|
begin
|
|
{$ifdef darwin}
|
|
result := State in [dsIdle, dsStop, dsInit];
|
|
if not Result then
|
|
exit;
|
|
|
|
AResult:=GDBMIExecResultDefault;
|
|
ExecuteCommand('info mach-tasks',[],[], AResult);
|
|
s := AResult.Values;
|
|
i := pos(sLineBreak,s);
|
|
while i>0 do
|
|
begin
|
|
aLine := trim(copy(s,1,i-1));
|
|
delete(s,1,i+1);
|
|
i := pos(' is ', aLine);
|
|
pid := copy(aLine,1,i-1);
|
|
pname := copy(aLine,i+4,PosEx(' ',aLine,i+4)-(i+4));
|
|
|
|
if pid <> '' then
|
|
begin
|
|
ARunningProcessInfo := TRunningProcessInfo.Create(StrToIntDef(pname,-1), pid);
|
|
AList.Add(ARunningProcessInfo);
|
|
end;
|
|
i := pos(sLineBreak,s);
|
|
end;
|
|
|
|
{$else}
|
|
result := false;
|
|
{$endif}
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.LockCommandProcessing;
|
|
begin
|
|
// Keep a different counter than QueueExecuteLock
|
|
// So we can detect, if RunQueue was blocked by this
|
|
inc(FCommandProcessingLock);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.UnLockCommandProcessing;
|
|
begin
|
|
dec(FCommandProcessingLock);
|
|
if (FCommandProcessingLock = 0)
|
|
and FRunQueueOnUnlock
|
|
then begin
|
|
FRunQueueOnUnlock := False;
|
|
// if FCommandQueueExecLock, then queu will be run, by however has that lock
|
|
if (FCommandQueueExecLock = 0) and (FCommandQueue.Count > 0)
|
|
then begin
|
|
DebugLnEnter(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.UnLockCommandProcessing: Execute RunQueue ']);
|
|
RunQueue; // ASync
|
|
DebugLnExit(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.UnLockCommandProcessing: Finished RunQueue']);
|
|
end
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoState(const OldState: TDBGState);
|
|
begin
|
|
FTypeRequestCache.Clear;
|
|
if not (State in [dsRun, dsPause, dsInit, dsInternalPause])
|
|
then FMaxLineForUnitCache.Clear;
|
|
|
|
if not (State in [dsPause, dsInternalPause]) then
|
|
FStoppedReason := srNone;;
|
|
|
|
if State in [dsStop, dsError]
|
|
then begin
|
|
ClearSourceInfo;
|
|
FPauseWaitState := pwsNone;
|
|
// clear un-needed commands
|
|
if State = dsError
|
|
then CancelAllQueued
|
|
else CancelAfterStop;
|
|
end;
|
|
if (State = dsError) and (DebugProcessRunning) then begin
|
|
FCurrentStackFrameValid := False;
|
|
FCurrentThreadIdValid := False;
|
|
FCurrentThreadId := 0;
|
|
FCurrentStackFrame := 0;
|
|
SendCmdLn('kill'); // try to kill the debugged process. bypass all queues.
|
|
TerminateGDB;
|
|
end;
|
|
if (OldState in [dsPause, dsInternalPause]) and (State = dsRun)
|
|
then begin
|
|
FPauseWaitState := pwsNone;
|
|
{$IFDEF MSWindows}
|
|
FPauseRequestInThreadID := 0;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
CallStack.CurrentCallStackList.EntriesForThreads[FCurrentThreadId].CurrentIndex := FCurrentStackFrame;
|
|
|
|
inherited DoState(OldState);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoBeforeState(const OldState: TDBGState);
|
|
begin
|
|
if State in [dsStop] then begin
|
|
FCurrentStackFrameValid := False;
|
|
FCurrentThreadIdValid := False;
|
|
FCurrentThreadId := 0;
|
|
FCurrentStackFrame := 0;
|
|
end;
|
|
inherited DoBeforeState(OldState);
|
|
Threads.CurrentThreads.CurrentThreadId := FCurrentThreadId; // TODO: Works only because CurrentThreadId is always valid
|
|
end;
|
|
|
|
function TGDBMIDebugger.LineEndPos(const s: string; out LineEndLen: integer): integer;
|
|
var
|
|
l: Integer;
|
|
begin
|
|
Result := 1;
|
|
LineEndLen := 0;
|
|
l := Length(s);
|
|
while (Result <= l) and not(s[Result] in [#10, #13]) do inc(Result);
|
|
|
|
if (Result <= l) then begin
|
|
LineEndLen := 1;
|
|
if (Result < l) and (s[Result + 1] in [#10, #13]) and (s[Result] <> s[Result + 1]) then
|
|
LineEndLen := 2;
|
|
end
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoThreadChanged;
|
|
begin
|
|
TGDBMICallstack(CallStack).DoThreadChanged;
|
|
if Registers.CurrentRegistersList <> nil then
|
|
Registers.CurrentRegistersList.Clear;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoRelease;
|
|
begin
|
|
SetState(dsDestroying);
|
|
if FReleaseLock > 0
|
|
then exit;
|
|
|
|
inherited DoRelease;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoUnknownException(Sender: TObject; AnException: Exception);
|
|
var
|
|
I: Integer;
|
|
Frames: PPointer;
|
|
Report, Report2: string;
|
|
begin
|
|
try
|
|
debugln(['ERROR: Exception occurred in ',Sender.ClassName+': ',
|
|
AnException.ClassName, ' Msg="', AnException.Message, '" Addr=', dbgs(ExceptAddr),
|
|
' Dbg.State=', dbgs(State)]);
|
|
Report := BackTraceStrFunc(ExceptAddr);
|
|
Report2 := Report;
|
|
Frames := ExceptFrames;
|
|
for I := 0 to ExceptFrameCount - 1 do begin
|
|
Report := Report + LineEnding + BackTraceStrFunc(Frames[I]);
|
|
if i < 5
|
|
then Report2 := Report;
|
|
end;
|
|
except
|
|
end;
|
|
debugln(Report);
|
|
|
|
if MessageDlg(gdbmiTheDebuggerExperiencedAnUnknownCondition,
|
|
Format(gdbmiPressIgnoreToContinueDebuggingThisMayNOTBeSafePres,
|
|
[LineEnding, AnException.ClassName, AnException.Message, Report2, Sender.ClassName, dbgs(State)]),
|
|
mtWarning, [mbIgnore, mbAbort], 0, mbAbort) = mrAbort
|
|
then begin
|
|
try
|
|
CancelAllQueued;
|
|
finally
|
|
Stop;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.AddThreadGroup(const S: String);
|
|
var
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
List := TGDBMINameValueList.Create(S);
|
|
FThreadGroups.Values[List.Values['id']] := List.Values['pid'];
|
|
List.Free;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.RemoveThreadGroup(const S: String);
|
|
begin
|
|
// Some gdb info contains thread group which are already exited => don't remove them
|
|
end;
|
|
|
|
function TGDBMIDebugger.ParseLibraryLoaded(const S: String): String;
|
|
const
|
|
DebugInfo: array[Boolean] of String = ('No Debug Info', 'Has Debug Info');
|
|
var
|
|
List: TGDBMINameValueList;
|
|
ThreadGroup: String;
|
|
begin
|
|
// input: =library-loaded,id="C:\\Windows\\system32\\ntdll.dll",target-name="C:\\Windows\\system32\\ntdll.dll",host-name="C:\\Windows\\system32\\ntdll.dll",symbols-loaded="0",thread-group="i1"
|
|
List := TGDBMINameValueList.Create(S);
|
|
ThreadGroup := List.Values['thread-group'];
|
|
Result := Format('Module Load: "%s". %s. Thread Group: %s (%s)', [ConvertGdbPathAndFile(List.Values['id']), DebugInfo[List.Values['symbols-loaded'] = '1'], ThreadGroup, FThreadGroups.Values[ThreadGroup]]);
|
|
List.Free;
|
|
end;
|
|
|
|
function TGDBMIDebugger.ParseLibraryUnLoaded(const S: String): String;
|
|
var
|
|
List: TGDBMINameValueList;
|
|
ThreadGroup: String;
|
|
begin
|
|
// input: =library-unloaded,id="C:\\Windows\\system32\\advapi32.dll",target-name="C:\\Windows\\system32\\advapi32.dll",host-name="C:\\Windows\\system32\\advapi32.dll",thread-group="i1"
|
|
List := TGDBMINameValueList.Create(S);
|
|
ThreadGroup := List.Values['thread-group'];
|
|
Result := Format('Module Unload: "%s". Thread Group: %s (%s)', [ConvertGdbPathAndFile(List.Values['id']), ThreadGroup, FThreadGroups.Values[ThreadGroup]]);
|
|
List.Free;
|
|
end;
|
|
|
|
function TGDBMIDebugger.ParseThread(const S, EventText: String): String;
|
|
var
|
|
List: TGDBMINameValueList;
|
|
ThreadGroup: String;
|
|
begin
|
|
if EventText = 'thread-created' then
|
|
Result := 'Thread Start: '
|
|
else
|
|
Result := 'Thread Exit: ';
|
|
List := TGDBMINameValueList.Create(S);
|
|
ThreadGroup := List.Values['group-id'];
|
|
Result := Result + Format('Thread ID: %s. Thread Group: %s (%s)', [List.Values['id'], ThreadGroup, FThreadGroups.Values[ThreadGroup]]);
|
|
List.Free;
|
|
end;
|
|
|
|
function TGDBMIDebugger.CreateTypeRequestCache: TGDBPTypeRequestCache;
|
|
begin
|
|
Result := TGDBPTypeRequestCache.Create;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoNotifyAsync(Line: String);
|
|
var
|
|
EventText: String;
|
|
begin
|
|
EventText := GetPart(['='], [','], Line, False, False);
|
|
case StringCase(EventText, [
|
|
'shlibs-added',
|
|
'library-loaded',
|
|
'library-unloaded',
|
|
'shlibs-updated',
|
|
'thread-group-started',
|
|
'thread-group-exited',
|
|
'thread-created',
|
|
'thread-exited'], False, False) of
|
|
0: DoDbgEvent(ecModule, etModuleLoad, Line);
|
|
1: DoDbgEvent(ecModule, etModuleLoad, ParseLibraryLoaded(Line));
|
|
2: DoDbgEvent(ecModule, etModuleUnload, ParseLibraryUnloaded(Line));
|
|
3: DoDbgEvent(ecModule, etDefault, Line);
|
|
4: AddThreadGroup(Line);
|
|
5: RemoveThreadGroup(Line);
|
|
6: DoDbgEvent(ecThread, etThreadStart, ParseThread(Line, EventText));
|
|
7: DoDbgEvent(ecThread, etThreadExit, ParseThread(Line, EventText));
|
|
else
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unexpected async-record: ', Line);
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoDbgBreakpointEvent(ABreakpoint: TDBGBreakPoint;
|
|
Location: TDBGLocationRec; AReason: TGDBMIBreakpointReason;
|
|
AOldVal: String = ''; ANewVal: String = '');
|
|
var
|
|
SrcName, Msg: String;
|
|
SrcLine: Integer;
|
|
begin
|
|
SrcName := Location.SrcFullName;
|
|
if SrcName = '' then
|
|
SrcName := Location.SrcFile;
|
|
if (SrcName = '') and (ABreakPoint <> nil) and (ABreakPoint.Kind = bpkSource) then
|
|
SrcName := ABreakpoint.Source;
|
|
SrcLine := Location.SrcLine;
|
|
if (SrcLine < 1) and (ABreakPoint <> nil) and (ABreakPoint.Kind = bpkSource) then
|
|
SrcLine := ABreakpoint.Line;
|
|
|
|
if ABreakpoint = nil then begin
|
|
Msg := Format('Unknown %s', [GDBMIBreakPointReasonNames[AReason]]);
|
|
if AReason = gbrWatchTrigger then
|
|
Msg := Msg + Format(' changed from "%s" to "%s"', [AOldVal, ANewVal]);
|
|
end
|
|
else begin
|
|
case ABreakPoint.Kind of
|
|
bpkSource: Msg := 'Source Breakpoint';
|
|
bpkAddress: Msg := 'Address Breakpoint';
|
|
bpkData:
|
|
begin
|
|
if AReason = gbrWatchScope then
|
|
Msg := Format('Watchpoint for "%s" out of scope', [ABreakpoint.WatchData])
|
|
else
|
|
Msg := Format('Watchpoint for "%s" was triggered. Old value "%s", New Value "%s"', [ABreakpoint.WatchData, AOldVal, ANewVal]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if SrcName <> '' then begin
|
|
DoDbgEvent(ecBreakpoint, etBreakpointHit,
|
|
Format('%s at $%.' + IntToStr(TargetPtrSize * 2) + 'x: %s line %d',
|
|
[Msg, Location.Address, SrcName, SrcLine]));
|
|
end
|
|
else begin
|
|
DoDbgEvent(ecBreakpoint, etBreakpointHit,
|
|
Format('%s at $%.' + IntToStr(TargetPtrSize * 2) + 'x',
|
|
[Msg, Location.Address]));
|
|
end;
|
|
|
|
end;
|
|
|
|
function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
|
|
const AValues: array of const; const AFlags: TGDBMICommandFlags): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
R:=GDBMIExecResultDefault;
|
|
Result := ExecuteCommandFull(ACommand, AValues, AFlags, nil, 0, R);
|
|
end;
|
|
|
|
function TGDBMIDebugger.ExecuteCommand(const ACommand: String;
|
|
const AValues: array of const; const AFlags: TGDBMICommandFlags;
|
|
var AResult: TGDBMIExecResult): Boolean;
|
|
begin
|
|
Result := ExecuteCommandFull(ACommand, AValues, AFlags, nil, 0, AResult);
|
|
end;
|
|
|
|
function TGDBMIDebugger.ExecuteCommandFull(const ACommand: String;
|
|
const AValues: array of const; const AFlags: TGDBMICommandFlags;
|
|
const ACallback: TGDBMICallback; const ATag: PtrInt;
|
|
var AResult: TGDBMIExecResult): Boolean;
|
|
var
|
|
CommandObj: TGDBMIDebuggerSimpleCommand;
|
|
begin
|
|
CommandObj := TGDBMIDebuggerSimpleCommand.Create(Self, ACommand, AValues, AFlags, ACallback, ATag);
|
|
CommandObj.AddReference;
|
|
QueueCommand(CommandObj);
|
|
Result := CommandObj.State in [dcsExecuting, dcsFinished];
|
|
if Result
|
|
then
|
|
AResult := CommandObj.Result;
|
|
CommandObj.ReleaseReference;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.RunQueue;
|
|
var
|
|
R: Boolean;
|
|
Cmd, NestedCurrentCmd, NestedCurrentCmdTmp: TGDBMIDebuggerCommand;
|
|
SavedInExecuteCount: LongInt;
|
|
begin
|
|
//RemoveRunQueueASync;
|
|
if FCommandQueue.Count = 0
|
|
then exit;
|
|
|
|
if FCommandProcessingLock > 0
|
|
then begin
|
|
FRunQueueOnUnlock := True;
|
|
exit
|
|
end;
|
|
|
|
// Safeguard the NestLvl and outer CurrrentCmd
|
|
SavedInExecuteCount := FInExecuteCount;
|
|
NestedCurrentCmd := FCurrentCommand;
|
|
LockRelease;
|
|
try
|
|
try
|
|
repeat
|
|
Cmd := FCommandQueue[0];
|
|
if (Cmd.QueueRunLevel >= 0) and (Cmd.QueueRunLevel < FInExecuteCount)
|
|
then break;
|
|
|
|
Inc(FInExecuteCount);
|
|
|
|
FCommandQueue.Delete(0);
|
|
DebugLnEnter(DBGMI_QUEUE_DEBUG, ['Executing (Recurse-Count=', FInExecuteCount-1, ') queued= ', FCommandQueue.Count, ' CmdPrior=', Cmd.Priority,' CmdMinRunLvl=', Cmd.QueueRunLevel, ' : "', Cmd.DebugText,'" State=',dbgs(State),' PauseWaitState=',ord(FPauseWaitState) ]);
|
|
// cmd may be canceled while executed => don't loose it while working with it
|
|
Cmd.AddReference;
|
|
NestedCurrentCmdTmp := FCurrentCommand; // TODO: needs to be canceled, if there is a cancelation
|
|
FCurrentCommand := Cmd;
|
|
// excute, has it's own try-except block => so we don't have one here
|
|
R := Cmd.Execute;
|
|
Cmd.DoFinished;
|
|
FCurrentCommand := NestedCurrentCmdTmp;
|
|
Cmd.ReleaseReference;
|
|
DebugLnExit(DBGMI_QUEUE_DEBUG, 'Exec done');
|
|
|
|
Dec(FInExecuteCount);
|
|
// Do not add code with callbacks outside "FInExecuteCount"
|
|
// Otherwhise "LockCommandProcessing" will fail to continue the queue
|
|
|
|
// TODO: if the debugger can accept them into a separate queue, the set stae here
|
|
// TODO: For now do not allow new session, before old session is finished
|
|
// There may already be commands for the next run queued,
|
|
// which will then set a new state.
|
|
//if FNeedStateToIdle and (FInExecuteCount = 0)
|
|
//then ResetStateToIdle;
|
|
|
|
if State in [dsError, dsDestroying]
|
|
then begin
|
|
//DebugLn(DBG_WARNINGS, '[WARNING] TGDBMIDebugger: ExecuteCommand "',Cmd,'" failed.');
|
|
Break;
|
|
end;
|
|
|
|
if FCommandQueue.Count = 0
|
|
then begin
|
|
if (FInExecuteCount = 0) // not in Recursive call
|
|
and (FPauseWaitState = pwsInternal)
|
|
and (State = dsRun)
|
|
then begin
|
|
// reset state
|
|
FPauseWaitState := pwsNone;
|
|
// insert continue command
|
|
Cmd := TGDBMIDebuggerCommandExecute.Create(Self, ectContinue);
|
|
FCommandQueue.Add(Cmd);
|
|
debugln(DBGMI_QUEUE_DEBUG, ['Internal Queueing: exec-continue']);
|
|
end
|
|
else Break; // Queue empty
|
|
end;
|
|
until not R;
|
|
debugln(DBGMI_QUEUE_DEBUG, ['Leaving Queue with count: ', FCommandQueue.Count, ' Recurse-Count=', FInExecuteCount,' State=',dbgs(State)]);
|
|
finally
|
|
UnlockRelease;
|
|
FInExecuteCount := SavedInExecuteCount;
|
|
FCurrentCommand := NestedCurrentCmd;
|
|
end;
|
|
except
|
|
On E: Exception do DoUnknownException(Self, E);
|
|
else
|
|
debugln(['ERROR: Exception occurred in ',ClassName+': ',
|
|
'" Addr=', dbgs(ExceptAddr), ' Dbg.State=', dbgs(State)]);
|
|
end;
|
|
|
|
if (FCommandQueue.Count = 0) and assigned(OnIdle) and (FInExecuteCount=0) and
|
|
(not FInIdle) and not(State in [dsError, dsDestroying])
|
|
then begin
|
|
repeat
|
|
DebugLnEnter(DBGMI_QUEUE_DEBUG, ['>> Run OnIdle']);
|
|
LockCommandProcessing;
|
|
FInIdle := True;
|
|
try
|
|
OnIdle(Self);
|
|
finally
|
|
R := (FCommandQueue.Count > 0) and (FCommandProcessingLock = 1) and FRunQueueOnUnlock;
|
|
DebugLn(DBGMI_QUEUE_DEBUG, ['OnIdle: UnLock']);
|
|
UnLockCommandProcessing;
|
|
FInIdle := False;
|
|
end;
|
|
DebugLnExit(DBGMI_QUEUE_DEBUG, ['<< Run OnIdle']);
|
|
until (not R) or (not assigned(OnIdle)) or (State in [dsError, dsDestroying]);
|
|
DebugLn(DBGMI_QUEUE_DEBUG, ['OnIdle: Finished ']);
|
|
end;
|
|
|
|
if FNeedStateToIdle and (FInExecuteCount = 0)
|
|
then ResetStateToIdle;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.QueueCommand(const ACommand: TGDBMIDebuggerCommand; ForceQueue: Boolean = False);
|
|
var
|
|
i, p: Integer;
|
|
CanRunQueue: Boolean;
|
|
begin
|
|
(* TODO: if an exec-command is queued, cancel watches-commands, etc (unless required for snapshot)
|
|
This may occur if multiply exe are queued.
|
|
Currently, they will be ForcedQueue, and end up, after the exec command => cancel by state change
|
|
Also see call to CancelBeforeRun in TGDBMIDebuggerCommandExecute.DoExecute
|
|
*)
|
|
|
|
|
|
p := ACommand.Priority;
|
|
i := 0;
|
|
// CanRunQueue: The queue can be run for "ACommand"
|
|
// Either the queue is empty (so no other command will run)
|
|
// Or the first command on the queue is blocked by "QueueRunLevel"
|
|
CanRunQueue := (FCommandQueue.Count = 0)
|
|
or ( (FCommandQueue.Count > 0)
|
|
and (FCommandQueue[0].QueueRunLevel >= 0)
|
|
and (FCommandQueue[0].QueueRunLevel < FInExecuteCount)
|
|
)
|
|
or ( (p > FCommandQueue[0].Priority) and (FCommandQueueExecLock = 0) );
|
|
|
|
if (ACommand is TGDBMIDebuggerCommandExecute) then begin
|
|
// Execute-commands, must be queued at the end. They have QueueRunLevel, so they only run in the outer loop
|
|
CanRunQueue := (FCommandQueue.Count = 0);
|
|
i := FCommandQueue.Add(ACommand);
|
|
end
|
|
else
|
|
if p > 0 then begin
|
|
// Queue Pririty commands
|
|
// TODO: check for "CanRunQueue": should be at start?
|
|
while (i < FCommandQueue.Count)
|
|
and (FCommandQueue[i].Priority >= p)
|
|
and ( (ForceQueue)
|
|
or (FCommandQueue[i].QueueRunLevel < 0)
|
|
or (FCommandQueue[i].QueueRunLevel >= FInExecuteCount)
|
|
)
|
|
do inc(i);
|
|
FCommandQueue.Insert(i, ACommand);
|
|
end
|
|
else begin
|
|
// Queue normal commands
|
|
if (not ForceQueue) and (FCommandQueue.Count > 0)
|
|
and CanRunQueue // first item is deferred, so new item inserted can run
|
|
then
|
|
FCommandQueue.Insert(0, ACommand)
|
|
else
|
|
i := FCommandQueue.Add(ACommand);
|
|
end;
|
|
|
|
// if other commands do run the queue,
|
|
// make sure this command only runs after the CurrentCommand finished
|
|
if ForceQueue and
|
|
( (ACommand.QueueRunLevel < 0) or (ACommand.QueueRunLevel >= FInExecuteCount) )
|
|
then
|
|
ACommand.QueueRunLevel := FInExecuteCount - 1;
|
|
|
|
if (not CanRunQueue) or (FCommandQueueExecLock > 0)
|
|
or (FCommandProcessingLock > 0) or ForceQueue
|
|
then begin
|
|
debugln(DBGMI_QUEUE_DEBUG, ['Queueing (Recurse-Count=', FInExecuteCount, ') at pos=', i, ' cnt=',FCommandQueue.Count-1, ' State=',dbgs(State), ' Lock=',FCommandQueueExecLock, ' Forced=', dbgs(ForceQueue), ' Prior=',p, ': "', ACommand.DebugText,'"']);
|
|
ACommand.DoQueued;
|
|
|
|
// FCommandProcessingLock still must call RunQueue
|
|
if FCommandProcessingLock = 0 then
|
|
Exit;
|
|
end;
|
|
|
|
// If we are here we can process the command directly
|
|
RunQueue;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.UnQueueCommand(const ACommand: TGDBMIDebuggerCommand);
|
|
begin
|
|
FCommandQueue.Remove(ACommand);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.CancelAllQueued;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := FCommandQueue.Count - 1;
|
|
while i >= 0 do begin
|
|
TGDBMIDebuggerCommand(FCommandQueue[i]).Cancel;
|
|
dec(i);
|
|
if i >= FCommandQueue.Count
|
|
then i := FCommandQueue.Count - 1;
|
|
end;
|
|
if FCurrentCommand <> nil
|
|
then FCurrentCommand.Cancel;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.CancelBeforeRun;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := FCommandQueue.Count - 1;
|
|
while i >= 0 do begin
|
|
if dcpCancelOnRun in TGDBMIDebuggerCommand(FCommandQueue[i]).Properties
|
|
then TGDBMIDebuggerCommand(FCommandQueue[i]).Cancel;
|
|
dec(i);
|
|
if i >= FCommandQueue.Count
|
|
then i := FCommandQueue.Count - 1;
|
|
end;
|
|
if (FCurrentCommand <> nil) and (dcpCancelOnRun in FCurrentCommand.Properties)
|
|
then FCurrentCommand.Cancel;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.CancelAfterStop;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := FCommandQueue.Count - 1;
|
|
while i >= 0 do begin
|
|
if TGDBMIDebuggerCommand(FCommandQueue[i]) is TGDBMIDebuggerCommandExecute
|
|
then TGDBMIDebuggerCommand(FCommandQueue[i]).Cancel;
|
|
dec(i);
|
|
if i >= FCommandQueue.Count
|
|
then i := FCommandQueue.Count - 1;
|
|
end;
|
|
// do not cancel FCurrentCommand;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.RunQueueASync;
|
|
begin
|
|
Application.QueueAsyncCall(@DoRunQueueFromASync, 0);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.RemoveRunQueueASync;
|
|
begin
|
|
Application.RemoveAsyncCalls(Self);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoRunQueueFromASync(Data: PtrInt);
|
|
begin
|
|
DebugLnEnter(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.DoRunQueueFromASync: Execute RunQueue ']);
|
|
RunQueue;
|
|
DebugLnExit(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.DoRunQueueFromASync: Finished RunQueue']);
|
|
end;
|
|
|
|
class function TGDBMIDebugger.ExePaths: String;
|
|
begin
|
|
{$IFdef MSWindows}
|
|
Result := '$(LazarusDir)\mingw\$(TargetCPU)-$(TargetOS)\bin\gdb.exe;$(LazarusDir)\mingw\bin\gdb.exe;C:\lazarus\mingw\bin\gdb.exe';
|
|
{$ELSE}
|
|
Result := 'gdb;/usr/bin/gdb;/usr/local/bin/gdb;/opt/fpc/gdb';
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TGDBMIDebugger.FindBreakpoint(
|
|
const ABreakpoint: Integer): TDBGBreakPoint;
|
|
var
|
|
n: Integer;
|
|
begin
|
|
if ABreakpoint > 0
|
|
then
|
|
for n := 0 to Breakpoints.Count - 1 do
|
|
begin
|
|
Result := Breakpoints[n];
|
|
if TGDBMIBreakPoint(Result).FBreakID = ABreakpoint
|
|
then Exit;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
function PosSetEx(const ASubStrSet, AString: string;
|
|
const Offset: integer): integer;
|
|
begin
|
|
for Result := Offset to Length(AString) do
|
|
if Pos(AString[Result], ASubStrSet) > 0 then
|
|
exit;
|
|
Result := 0;
|
|
end;
|
|
|
|
function EscapeGDBCommand(const AInput: string): string;
|
|
var
|
|
lPiece: string;
|
|
I, lPos, len: integer;
|
|
begin
|
|
lPos := 1;
|
|
Result := '';
|
|
repeat
|
|
I := PosSetEx(#9#10#13, AInput, lPos);
|
|
{ copy unmatched characters }
|
|
if I > 0 then
|
|
len := I-lPos
|
|
else
|
|
len := Length(AInput)+1-lPos;
|
|
Result := Result + Copy(AInput, lPos, len);
|
|
{ replace a matched character or be done }
|
|
if I > 0 then
|
|
begin
|
|
case AInput[I] of
|
|
#9: lPiece := '\t';
|
|
#10: lPiece := '\n';
|
|
#13: lPiece := '\r';
|
|
else
|
|
lPiece := '';
|
|
end;
|
|
Result := Result + lPiece;
|
|
lPos := I+1;
|
|
end else
|
|
exit;
|
|
until false;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBDisassemble(AAddr: TDbgPtr; ABackward: Boolean;
|
|
out ANextAddr: TDbgPtr; out ADump, AStatement, AFile: String; out ALine: Integer): Boolean;
|
|
var
|
|
NewEntryMap: TDBGDisassemblerEntryMap;
|
|
CmdObj: TGDBMIDebuggerCommandDisassemble;
|
|
Rng: TDBGDisassemblerEntryRange;
|
|
i: Integer;
|
|
begin
|
|
NewEntryMap := TDBGDisassemblerEntryMap.Create(itu8, SizeOf(TDBGDisassemblerEntryRange));
|
|
CmdObj := TGDBMIDebuggerCommandDisassemble.Create(Self, NewEntryMap, AAddr, AAddr, -1, 2);
|
|
CmdObj.AddReference;
|
|
CmdObj.Priority := GDCMD_PRIOR_IMMEDIATE;
|
|
QueueCommand(CmdObj);
|
|
Result := CmdObj.State in [dcsExecuting, dcsFinished];
|
|
|
|
Rng := NewEntryMap.GetRangeForAddr(AAddr);
|
|
if Result and (Rng <> nil)
|
|
then begin
|
|
i := Rng.IndexOfAddr(AAddr);
|
|
if ABackward
|
|
then dec(i);
|
|
|
|
if
|
|
i >= 0
|
|
then begin
|
|
if i < Rng.Count
|
|
then ANextAddr := Rng.EntriesPtr[i]^.Addr
|
|
else ANextAddr := Rng.LastEntryEndAddr;
|
|
|
|
ADump := Rng.EntriesPtr[i]^.Dump;
|
|
AStatement := Rng.EntriesPtr[i]^.Statement;
|
|
AFile := Rng.EntriesPtr[i]^.SrcFileName;
|
|
ALine := Rng.EntriesPtr[i]^.SrcFileLine;
|
|
end;
|
|
end;
|
|
|
|
if not Result
|
|
then CmdObj.Cancel;
|
|
|
|
CmdObj.ReleaseReference;
|
|
FreeAndNil(NewEntryMap);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.DoPseudoTerminalRead(Sender: TObject);
|
|
begin
|
|
{$IFDEF DBG_ENABLE_TERMINAL}
|
|
if assigned(OnConsoleOutput)
|
|
then OnConsoleOutput(self, FPseudoTerminal.Read);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBEnvironment(const AVariable: String; const ASet: Boolean): Boolean;
|
|
var
|
|
S: String;
|
|
begin
|
|
Result := True;
|
|
|
|
if State = dsRun
|
|
then GDBPause(True);
|
|
if ASet then
|
|
begin
|
|
S := EscapeGDBCommand(AVariable);
|
|
ExecuteCommand('-gdb-set env %s', [S], [cfscIgnoreState, cfNoThreadContext]);
|
|
end else begin
|
|
S := AVariable;
|
|
ExecuteCommand('unset env %s', [GetPart([], ['='], S, False, False)], [cfscIgnoreState, cfNoThreadContext]);
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBEvaluate(const AExpression: String; var AResult: String;
|
|
out ATypeInfo: TGDBType; EvalFlags: TDBGEvaluateFlags): Boolean;
|
|
var
|
|
CommandObj: TGDBMIDebuggerCommandEvaluate;
|
|
begin
|
|
CommandObj := TGDBMIDebuggerCommandEvaluate.Create(Self, AExpression, wdfDefault);
|
|
CommandObj.EvalFlags := EvalFlags;
|
|
CommandObj.AddReference;
|
|
CommandObj.Priority := GDCMD_PRIOR_IMMEDIATE; // try run imediately
|
|
QueueCommand(CommandObj);
|
|
Result := CommandObj.State in [dcsExecuting, dcsFinished];
|
|
AResult := CommandObj.TextValue;
|
|
ATypeInfo := CommandObj.TypeInfo;
|
|
if EvalFlags * [defNoTypeInfo, defSimpleTypeInfo, defFullTypeInfo] = [defNoTypeInfo]
|
|
then FreeAndNil(ATypeInfo);
|
|
CommandObj.ReleaseReference;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBModify(const AExpression, ANewValue: String): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
S: String;
|
|
begin
|
|
S := Trim(ANewValue);
|
|
if (S <> '') and (S[1] in ['''', '#'])
|
|
then begin
|
|
if not ConvertPascalExpression(S) then Exit(False);
|
|
end;
|
|
|
|
R := GDBMIExecResultDefault;
|
|
Result := ExecuteCommandFull('-gdb-set var %s := %s', [UpperCaseSymbols(AExpression), S], [cfscIgnoreError], @GDBModifyDone, 0, R)
|
|
and (R.State <> dsError);
|
|
|
|
FTypeRequestCache.Clear;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.GDBModifyDone(const AResult: TGDBMIExecResult;
|
|
const ATag: PtrInt);
|
|
begin
|
|
FTypeRequestCache.Clear;
|
|
TGDBMILocals(Locals).Changed;
|
|
TGDBMIWatches(Watches).Changed;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBJumpTo(const ASource: String; const ALine: Integer): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBAttach(AProcessID: String): Boolean;
|
|
var
|
|
Cmd: TGDBMIDebuggerCommandAttach;
|
|
begin
|
|
Result := False;
|
|
if State <> dsStop then exit;
|
|
|
|
Cmd := TGDBMIDebuggerCommandAttach.Create(Self, AProcessID);
|
|
Cmd.AddReference;
|
|
QueueCommand(Cmd);
|
|
Result := Cmd.Success;
|
|
if not Result
|
|
then Cmd.Cancel;
|
|
Cmd.ReleaseReference;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBDetach: Boolean;
|
|
begin
|
|
Result := False;
|
|
|
|
if State = dsRun
|
|
then GDBPause(True);
|
|
|
|
CancelAllQueued;
|
|
QueueCommand(TGDBMIDebuggerCommandDetach.Create(Self));
|
|
Result := True;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBPause(const AInternal: Boolean): Boolean;
|
|
begin
|
|
if FInProcessStopped then exit;
|
|
|
|
// Check if we already issued a break
|
|
if FPauseWaitState = pwsNone
|
|
then InterruptTarget;
|
|
|
|
if AInternal
|
|
then begin
|
|
if FPauseWaitState = pwsNone
|
|
then FPauseWaitState := pwsInternal;
|
|
end
|
|
else FPauseWaitState := pwsExternal;
|
|
|
|
Result := True;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBRun: Boolean;
|
|
begin
|
|
Result := False;
|
|
case State of
|
|
dsStop: begin
|
|
FThreadGroups.Clear;
|
|
Result := StartDebugging(ectContinue);
|
|
end;
|
|
dsPause: begin
|
|
CancelBeforeRun;
|
|
QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectContinue));
|
|
Result := True;
|
|
end;
|
|
dsIdle: begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to run in idle state');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBRunTo(const ASource: String;
|
|
const ALine: Integer): Boolean;
|
|
begin
|
|
Result := False;
|
|
case State of
|
|
dsStop: begin
|
|
Result := False;
|
|
end;
|
|
dsPause: begin
|
|
CancelBeforeRun;
|
|
QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectRunTo, [ASource, ALine]));
|
|
Result := True;
|
|
end;
|
|
dsIdle: begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to runto in idle state');
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBSourceAdress(const ASource: String; ALine, AColumn: Integer; out AAddr: TDbgPtr): Boolean;
|
|
var
|
|
ID: packed record
|
|
Line, Column: Integer;
|
|
end;
|
|
Map: TMap;
|
|
idx, n: Integer;
|
|
R: TGDBMIExecResult;
|
|
LinesList, LineList: TGDBMINameValueList;
|
|
Item: PGDBMINameValue;
|
|
Addr: TDbgPtr;
|
|
begin
|
|
Result := False;
|
|
AAddr := 0;
|
|
if ASource = ''
|
|
then Exit;
|
|
idx := FSourceNames.IndexOf(ASource);
|
|
if (idx <> -1)
|
|
then begin
|
|
Map := TMap(FSourceNames.Objects[idx]);
|
|
ID.Line := ALine;
|
|
// since we do not have column info we map all on column 0
|
|
// ID.Column := AColumn;
|
|
ID.Column := 0;
|
|
Result := (Map <> nil);
|
|
if Result
|
|
then Map.GetData(ID, AAddr);
|
|
Exit;
|
|
end;
|
|
|
|
R := GDBMIExecResultDefault;
|
|
Result := ExecuteCommand('-symbol-list-lines %s', [ASource], [cfscIgnoreError, cfNoThreadContext], R)
|
|
and (R.State <> dsError);
|
|
// if we have an .inc file then search for filename only since there are some
|
|
// problems with locating file by full path in gdb in case only relative file
|
|
// name is stored
|
|
if not Result then
|
|
Result := ExecuteCommand('-symbol-list-lines %s', [ExtractFileName(ASource)], [cfscIgnoreError, cfNoThreadContext], R)
|
|
and (R.State <> dsError);
|
|
|
|
if not Result then Exit;
|
|
|
|
Map := TMap.Create(its8, SizeOf(AAddr));
|
|
FSourceNames.AddObject(ASource, Map);
|
|
|
|
LinesList := TGDBMINameValueList.Create(R, ['lines']);
|
|
if LinesList = nil then Exit(False);
|
|
|
|
ID.Column := 0;
|
|
LineList := TGDBMINameValueList.Create('');
|
|
|
|
for n := 0 to LinesList.Count - 1 do
|
|
begin
|
|
Item := LinesList.Items[n];
|
|
LineList.Init(Item^.Name);
|
|
if not TryStrToInt(Unquote(LineList.Values['line']), ID.Line) then Continue;
|
|
if not TryStrToQWord(Unquote(LineList.Values['pc']), Addr) then Continue;
|
|
// one line can have more than one address
|
|
if Map.HasId(ID) then Continue;
|
|
Map.Add(ID, Addr);
|
|
if ID.Line = ALine
|
|
then AAddr := Addr;
|
|
end;
|
|
LineList.Free;
|
|
LinesList.Free;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.LockRelease;
|
|
begin
|
|
inc(FReleaseLock);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.UnlockRelease;
|
|
begin
|
|
dec(FReleaseLock);
|
|
if (FReleaseLock = 0) and (State = dsDestroying)
|
|
then Release;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBStepInto: Boolean;
|
|
begin
|
|
Result := False;
|
|
case State of
|
|
dsStop: begin
|
|
Result := StartDebugging;
|
|
end;
|
|
dsPause: begin
|
|
CancelBeforeRun;
|
|
QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepInto));
|
|
Result := True;
|
|
end;
|
|
dsIdle: begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step in idle state');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBStepOverInstr: Boolean;
|
|
begin
|
|
Result := False;
|
|
case State of
|
|
dsStop: begin
|
|
Result := StartDebugging;
|
|
end;
|
|
dsPause: begin
|
|
CancelBeforeRun;
|
|
QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepOverInstruction));
|
|
Result := True;
|
|
end;
|
|
dsIdle: begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step over instr in idle state');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBStepIntoInstr: Boolean;
|
|
begin
|
|
Result := False;
|
|
case State of
|
|
dsStop: begin
|
|
Result := StartDebugging;
|
|
end;
|
|
dsPause: begin
|
|
CancelBeforeRun;
|
|
QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepIntoInstruction));
|
|
Result := True;
|
|
end;
|
|
dsIdle: begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step in instr idle state');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBStepOut: Boolean;
|
|
begin
|
|
Result := False;
|
|
case State of
|
|
dsStop: begin
|
|
Result := False;
|
|
end;
|
|
dsPause: begin
|
|
CancelBeforeRun;
|
|
QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepOut));
|
|
Result := True;
|
|
end;
|
|
dsIdle: begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step out in idle state');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBStepOver: Boolean;
|
|
begin
|
|
Result := False;
|
|
case State of
|
|
dsStop: begin
|
|
Result := StartDebugging;
|
|
end;
|
|
dsPause: begin
|
|
CancelBeforeRun;
|
|
QueueCommand(TGDBMIDebuggerCommandExecute.Create(Self, ectStepOver));
|
|
Result := True;
|
|
end;
|
|
dsIdle: begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Unable to step over in idle state');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GDBStop: Boolean;
|
|
begin
|
|
if State = dsError
|
|
then begin
|
|
// We don't know the state of the debugger,
|
|
// force a reinit. Let's hope this works.
|
|
TerminateGDB;
|
|
Done;
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
|
|
if (FCurrentCommand <> nil) and FCurrentCommand.KillNow then begin
|
|
debugln(DBG_VERBOSE, ['KillNow did stop']);
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
|
|
if State = dsRun
|
|
then GDBPause(True);
|
|
|
|
CancelAllQueued;
|
|
QueueCommand(TGDBMIDebuggerCommandKill.Create(Self));
|
|
Result := True;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GetSupportedCommands: TDBGCommands;
|
|
begin
|
|
Result := [dcRun, dcPause, dcStop, dcStepOver, dcStepInto, dcStepOut,
|
|
dcStepOverInstr, dcStepIntoInstr, dcRunTo, dcAttach, dcDetach, dcJumpto,
|
|
dcBreak, dcWatch, dcLocal, dcEvaluate, dcModify, dcEnvironment,
|
|
dcSetStackFrame, dcDisassemble
|
|
{$IFDEF DBG_ENABLE_TERMINAL}, dcSendConsoleInput{$ENDIF}
|
|
];
|
|
end;
|
|
|
|
function TGDBMIDebugger.GetCommands: TDBGCommands;
|
|
begin
|
|
if FNeedStateToIdle
|
|
then Result := []
|
|
else Result := inherited GetCommands;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GetTargetWidth: Byte;
|
|
begin
|
|
Result := FTargetInfo.TargetPtrSize*8;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.Init;
|
|
|
|
procedure CheckGDBVersion;
|
|
begin
|
|
if FGDBVersion < '5.3'
|
|
then begin
|
|
DebugLn(DBG_WARNINGS, '[WARNING] Debugger: Running an old (< 5.3) GDB version: ', FGDBVersion);
|
|
DebugLn(DBG_WARNINGS, ' Not all functionality will be supported.');
|
|
end
|
|
else begin
|
|
DebugLn(DBG_VERBOSE, '[Debugger] Running GDB version: ', FGDBVersion);
|
|
Include(FDebuggerFlags, dfImplicidTypes);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
Options: String;
|
|
Cmd: TGDBMIDebuggerCommandInitDebugger;
|
|
env: TStringList;
|
|
begin
|
|
Exclude(FDebuggerFlags, dfForceBreakDetected);
|
|
Exclude(FDebuggerFlags, dfSetBreakFailed);
|
|
Exclude(FDebuggerFlags, dfSetBreakPending);
|
|
LockRelease;
|
|
try
|
|
FPauseWaitState := pwsNone;
|
|
FErrorHandlingFlags := [];
|
|
FInExecuteCount := 0;
|
|
FInIdle := False;
|
|
FNeedStateToIdle := False;
|
|
Options := '-silent -i mi -nx';
|
|
|
|
if Length(TGDBMIDebuggerPropertiesBase(GetProperties).Debugger_Startup_Options) > 0
|
|
then Options := Options + ' ' + TGDBMIDebuggerPropertiesBase(GetProperties).Debugger_Startup_Options;
|
|
|
|
env := EnvironmentAsStringList;
|
|
DebuggerEnvironment := env;
|
|
env.Free;
|
|
{$ifNdef MSWindows}
|
|
DebuggerEnvironment.Values['LANG'] := 'C'; // try to prevent GDB from using localized messages
|
|
{$ENDIF}
|
|
|
|
if CreateDebugProcess(Options)
|
|
then begin
|
|
if not ParseInitialization
|
|
then begin
|
|
SetState(dsError);
|
|
end
|
|
else begin
|
|
Cmd := CreateCommandInit;
|
|
Cmd.AddReference;
|
|
QueueCommand(Cmd);
|
|
if not Cmd.Success then begin
|
|
Cmd.Cancel;
|
|
Cmd.ReleaseReference;
|
|
SetState(dsError);
|
|
end
|
|
else begin
|
|
Cmd.ReleaseReference;
|
|
CheckGDBVersion;
|
|
inherited Init;
|
|
end;
|
|
end;
|
|
end
|
|
else begin
|
|
include(FErrorHandlingFlags, ehfDeferReadWriteError);
|
|
SetErrorState(gdbmiFailedToLaunchExternalDbg, ReadLine(50));
|
|
end;
|
|
|
|
FGDBPtrSize := CpuNameToPtrSize(FGDBCPU); // will be set in StartDebugging
|
|
finally
|
|
UnlockRelease;
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.InterruptTarget;
|
|
{$IFdef MSWindows}
|
|
function TryNT: Boolean;
|
|
var
|
|
hProcess: THandle;
|
|
hThread: THandle;
|
|
E: Integer;
|
|
Emsg: PChar;
|
|
begin
|
|
Result := False;
|
|
|
|
hProcess := OpenProcess(PROCESS_CREATE_THREAD or PROCESS_QUERY_INFORMATION or PROCESS_VM_OPERATION or PROCESS_VM_WRITE or PROCESS_VM_READ, False, TargetPID);
|
|
if hProcess = 0 then Exit;
|
|
|
|
try
|
|
hThread := _CreateRemoteThread(hProcess, nil, 0, DebugBreakAddr, nil, 0, FPauseRequestInThreadID);
|
|
if hThread = 0
|
|
then begin
|
|
E := GetLastError;
|
|
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ALLOCATE_BUFFER, nil, E, 0, PChar(@Emsg), 0, nil);
|
|
DebugLN(DBG_WARNINGS, 'Error creating remote thread: ' + String(EMsg));
|
|
// Yuck !
|
|
// mixing handles and pointers, but it is how MS documented it
|
|
LocalFree(HLOCAL(Emsg));
|
|
Exit;
|
|
end;
|
|
Result := True;
|
|
CloseHandle(hThread);
|
|
finally
|
|
CloseHandle(hProcess);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
begin
|
|
debugln(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.InterruptTarget: TargetPID=', TargetPID]);
|
|
|
|
//if FAsyncModeEnabled then begin
|
|
if FCurrentCmdIsAsync and (FCurrentCommand <> nil) then begin
|
|
FCurrentCommand.ExecuteCommand('interrupt', [cfNoThreadContext]);
|
|
FCurrentCommand.ExecuteCommand('info program', [cfNoThreadContext]); // trigger "*stopped..." msg. This may be deferred to the cmd after the "interupt"
|
|
exit;
|
|
end;
|
|
|
|
if TargetPID = 0 then Exit;
|
|
{$IFDEF UNIX}
|
|
FpKill(TargetPID, SIGINT);
|
|
{$ENDIF}
|
|
|
|
{$IFdef MSWindows}
|
|
// GenerateConsoleCtrlEvent is nice, but only works if both gdb and
|
|
// our target have a console. On win95 and family this is our only
|
|
// option, on NT4+ we have a choice. Since this is not likely that
|
|
// we have a console, we do it the hard way. On XP there exists
|
|
// DebugBreakProcess, but it does efectively the same.
|
|
|
|
if (DebugBreakAddr = nil)
|
|
or not Assigned(_CreateRemoteThread)
|
|
or not TryNT
|
|
then begin
|
|
// We have no other choice than trying this
|
|
debugln(DBGMI_QUEUE_DEBUG, ['TGDBMIDebugger.InterruptTarget: Send CTRL_BREAK_EVENT']);
|
|
GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, TargetPID);
|
|
Exit;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TGDBMIDebugger.ParseInitialization: Boolean;
|
|
var
|
|
Line, S: String;
|
|
begin
|
|
Result := True;
|
|
|
|
// Get initial debugger lines
|
|
S := '';
|
|
Line := ReadLine;
|
|
while DebugProcessRunning and (Line <> '(gdb) ') and (State <> dsError) do
|
|
begin
|
|
if Line <> ''
|
|
then
|
|
case Line[1] of
|
|
'=': begin
|
|
case StringCase(GetPart(['='], [','], Line, False, False),
|
|
['thread-group-added'])
|
|
of
|
|
0: {ignore};
|
|
else
|
|
S := S + Line + LineEnding;
|
|
end;
|
|
end;
|
|
else
|
|
S := S + Line + LineEnding;
|
|
end;
|
|
Line := ReadLine;
|
|
end;
|
|
if S <> ''
|
|
then MessageDlg('Debugger', 'Initialization output: ' + LineEnding + S,
|
|
mtInformation, [mbOK], 0);
|
|
end;
|
|
|
|
function TGDBMIDebugger.RequestCommand(const ACommand: TDBGCommand; const AParams: array of const): Boolean;
|
|
var
|
|
EvalFlags: TDBGEvaluateFlags;
|
|
begin
|
|
LockRelease;
|
|
try
|
|
case ACommand of
|
|
dcRun: Result := GDBRun;
|
|
dcPause: Result := GDBPause(False);
|
|
dcStop: Result := GDBStop;
|
|
dcStepOver: Result := GDBStepOver;
|
|
dcStepInto: Result := GDBStepInto;
|
|
dcStepOut: Result := GDBStepOut;
|
|
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;
|
|
dcEvaluate: begin
|
|
EvalFlags := [];
|
|
if high(AParams) >= 3 then
|
|
EvalFlags := TDBGEvaluateFlags(AParams[3].VInteger);
|
|
Result := GDBEvaluate(String(AParams[0].VAnsiString),
|
|
String(AParams[1].VPointer^), TGDBType(AParams[2].VPointer^),
|
|
EvalFlags);
|
|
end;
|
|
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;
|
|
{$IFDEF DBG_ENABLE_TERMINAL}
|
|
dcSendConsoleInput: FPseudoTerminal.Write(String(AParams[0].VAnsiString));
|
|
{$ENDIF}
|
|
end;
|
|
finally
|
|
UnlockRelease;
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.ClearCommandQueue;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i:=0 to FCommandQueue.Count-1 do begin
|
|
TGDBMIDebuggerCommand(FCommandQueue[i]).ReleaseReference;
|
|
end;
|
|
FCommandQueue.Clear;
|
|
end;
|
|
|
|
function TGDBMIDebugger.GetIsIdle: Boolean;
|
|
begin
|
|
Result := (FCommandQueue.Count = 0) and (State in [dsPause, dsInternalPause]);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.ResetStateToIdle;
|
|
begin
|
|
if FInExecuteCount > 0 then begin
|
|
debugln(DBGMI_QUEUE_DEBUG, ['Defer dsIdle: Recurse-Count=', FInExecuteCount]);
|
|
FNeedStateToIdle := True;
|
|
exit;
|
|
end;
|
|
FNeedStateToIdle := False;
|
|
inherited ResetStateToIdle;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.ClearSourceInfo;
|
|
var
|
|
n: Integer;
|
|
begin
|
|
for n := 0 to FSourceNames.Count - 1 do
|
|
FSourceNames.Objects[n].Free;
|
|
|
|
FSourceNames.Clear;
|
|
end;
|
|
|
|
function TGDBMIDebugger.StartDebugging(AContinueCommand: TGDBMIExecCommandType): Boolean;
|
|
begin
|
|
Result := StartDebugging(TGDBMIDebuggerCommandExecute.Create(Self, AContinueCommand));
|
|
end;
|
|
|
|
function TGDBMIDebugger.StartDebugging(AContinueCommand: TGDBMIExecCommandType;
|
|
AValues: array of const): Boolean;
|
|
begin
|
|
Result := StartDebugging(TGDBMIDebuggerCommandExecute.Create(Self, AContinueCommand, AValues));
|
|
end;
|
|
|
|
function TGDBMIDebugger.StartDebugging(AContinueCommand: TGDBMIDebuggerCommand = nil): Boolean;
|
|
var
|
|
Cmd: TGDBMIDebuggerCommandStartDebugging;
|
|
begin
|
|
// We expect to be run immediately, no queue
|
|
FCurrentStackFrameValid := False;
|
|
FCurrentThreadIdValid := False;
|
|
Cmd := CreateCommandStartDebugging(AContinueCommand);
|
|
Cmd.AddReference;
|
|
QueueCommand(Cmd);
|
|
Result := Cmd.Success;
|
|
if not Result
|
|
then Cmd.Cancel;
|
|
Cmd.ReleaseReference;
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.TerminateGDB;
|
|
begin
|
|
AbortReadLine;
|
|
FPauseWaitState := pwsNone;
|
|
if DebugProcessRunning then begin
|
|
debugln(DBG_VERBOSE, ['TGDBMIDebugger.TerminateGDB ']);
|
|
if not DebugProcess.Terminate(0) then begin
|
|
if OnFeedback = nil then
|
|
MessageDlg(gdbmiFailedToTerminateGDBTitle,
|
|
Format(gdbmiFailedToTerminateGDB, [LineEnding]), mtError, [mbOK], 0)
|
|
else
|
|
OnFeedback(Self,
|
|
Format(gdbmiFailedToTerminateGDB, [LineEnding]),
|
|
'',
|
|
ftError, [frOk]
|
|
);
|
|
SetState(dsError);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF DBG_ENABLE_TERMINAL}
|
|
procedure TGDBMIDebugger.ProcessWhileWaitForHandles;
|
|
begin
|
|
inherited ProcessWhileWaitForHandles;
|
|
FPseudoTerminal.CheckCanRead;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TGDBMIDebugger.QueueExecuteLock;
|
|
begin
|
|
inc(FCommandQueueExecLock);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.QueueExecuteUnlock;
|
|
begin
|
|
dec(FCommandQueueExecLock);
|
|
end;
|
|
|
|
procedure TGDBMIDebugger.TestCmd(const ACommand: String);
|
|
begin
|
|
ExecuteCommand(ACommand, [], [cfscIgnoreError]);
|
|
end;
|
|
|
|
function TGDBMIDebugger.NeedReset: Boolean;
|
|
begin
|
|
Result := FNeedReset;
|
|
end;
|
|
|
|
{%region ***** BreakPoints ***** }
|
|
|
|
{ TGDBMIDebuggerCommandBreakPointBase }
|
|
|
|
function TGDBMIDebuggerCommandBreakPointBase.ExecCheckLineInUnit(ASource: string;
|
|
ALine: Integer): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
i, m, n: Integer;
|
|
begin
|
|
Result := ALine > 0;
|
|
if not Result then exit;
|
|
|
|
m := -1;
|
|
i := FTheDebugger.FMaxLineForUnitCache.IndexOf(ASource);
|
|
if i >= 0 then
|
|
m := PtrInt(FTheDebugger.FMaxLineForUnitCache.Objects[i]);
|
|
|
|
if ALine <= m then exit;;
|
|
|
|
if ExecuteCommand('info line "' + ASource + '":' + IntToStr(ALine), R)
|
|
and (R.State <> dsError)
|
|
then begin
|
|
m := pos('"', R.Values); // find start of filename in messages
|
|
n := pos('out of range', R.Values);
|
|
Result := (n < 1) or (n >= m);
|
|
end;
|
|
|
|
if not Result then exit;
|
|
|
|
if i < 0 then
|
|
i := FTheDebugger.FMaxLineForUnitCache.Add(ASource);
|
|
FTheDebugger.FMaxLineForUnitCache.Objects[i] := TObject(PtrInt(ALine));
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandBreakPointBase.ExecBreakDelete(ABreakId: Integer): Boolean;
|
|
begin
|
|
Result := False;
|
|
if ABreakID = 0 then Exit;
|
|
|
|
Result := ExecuteCommand('-break-delete %d', [ABreakID], []);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandBreakPointBase.ExecBreakEnabled(ABreakId: Integer;
|
|
AnEnabled: Boolean): Boolean;
|
|
const
|
|
// Use shortstring as fix for fpc 1.9.5 [2004/07/15]
|
|
CMD: array[Boolean] of ShortString = ('disable', 'enable');
|
|
begin
|
|
Result := False;
|
|
if ABreakID = 0 then Exit;
|
|
|
|
Result := ExecuteCommand('-break-%s %d', [CMD[AnEnabled], ABreakID], []);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandBreakPointBase.ExecBreakCondition(ABreakId: Integer;
|
|
AnExpression: string): Boolean;
|
|
begin
|
|
Result := False;
|
|
if ABreakID = 0 then Exit;
|
|
|
|
Result := ExecuteCommand('-break-condition %d %s', [ABreakID, UpperCaseSymbols(AnExpression)], []);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandBreakInsert }
|
|
|
|
function TGDBMIDebuggerCommandBreakInsert.ExecBreakInsert(out ABreakId, AHitCnt: Integer; out
|
|
AnAddr: TDBGPtr): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
ResultList: TGDBMINameValueList;
|
|
WatchExpr, WatchDecl, WatchAddr: String;
|
|
s1, s2: String;
|
|
begin
|
|
Result := False;
|
|
ABreakId := 0;
|
|
AHitCnt := 0;
|
|
AnAddr := 0;
|
|
case FKind of
|
|
bpkSource:
|
|
begin
|
|
if (FSource = '') or (FLine < 0) then exit;
|
|
Result := ExecCheckLineInUnit(FSource, FLine);
|
|
if not Result then exit;
|
|
|
|
s1 := '';
|
|
s2 := StringReplace(FSource, '\', '/', [rfReplaceAll]);
|
|
//s2 := StringReplace(s2, '"', '\"', [rfReplaceAll]);
|
|
Result := ExecuteCommand('-break-insert %s "\"%s\":%d"', [s1, s2, FLine], R);
|
|
|
|
if dfForceBreak in FTheDebugger.FDebuggerFlags then s1 := '-f';
|
|
if (not Result) or (R.State = dsError) then
|
|
Result := ExecuteCommand('-break-insert %s %s:%d', [s1, ExtractFileName(FSource), FLine], R);
|
|
end;
|
|
bpkAddress:
|
|
begin
|
|
if (FAddress = 0) then exit;
|
|
if dfForceBreak in FTheDebugger.FDebuggerFlags
|
|
then Result := ExecuteCommand('-break-insert -f *%u', [FAddress], R)
|
|
else Result := ExecuteCommand('-break-insert *%u', [FAddress], R);
|
|
end;
|
|
bpkData:
|
|
begin
|
|
if (FWatchData = '') then exit;
|
|
WatchExpr := UpperCaseSymbols(WatchData);
|
|
if FWatchScope = wpsGlobal then begin
|
|
Result := ExecuteCommand('ptype %s', [WatchExpr], R);
|
|
Result := Result and (R.State <> dsError);
|
|
if not Result then exit;
|
|
WatchDecl := PCLenToString(ParseTypeFromGdb(R.Values).Name);
|
|
Result := ExecuteCommand('-data-evaluate-expression %s', [Quote('@'+WatchExpr)], R);
|
|
Result := Result and (R.State <> dsError);
|
|
if not Result then exit;
|
|
WatchAddr := StripLN(GetPart('value="', '"', R.Values));
|
|
WatchExpr := WatchDecl+'(' + WatchAddr + '^)';
|
|
end;
|
|
case FWatchKind of
|
|
wpkWrite: Result := ExecuteCommand('-break-watch %s', [WatchExpr], R);
|
|
wpkRead: Result := ExecuteCommand('-break-watch -r %s', [WatchExpr], R);
|
|
wpkReadWrite: Result := ExecuteCommand('-break-watch -a %s', [WatchExpr], R);
|
|
end;
|
|
Result := Result and (R.State <> dsError);
|
|
end;
|
|
end;
|
|
|
|
ResultList := TGDBMINameValueList.Create(R);
|
|
case FKind of
|
|
bpkSource, bpkAddress:
|
|
begin
|
|
ResultList.SetPath('bkpt');
|
|
if (not Result) or (r.State = dsError) and
|
|
(DebuggerProperties.WarnOnSetBreakpointError in [gdbwAll, gdbwUserBreakPoint])
|
|
then
|
|
Include(FTheDebugger.FDebuggerFlags, dfSetBreakFailed);
|
|
if ((ResultList.IndexOf('pending') >= 0) or
|
|
(pos('pend', lowercase(ResultList.Values['addr'])) > 0)) and
|
|
(DebuggerProperties.WarnOnSetBreakpointError in [gdbwAll, gdbwUserBreakPoint])
|
|
then
|
|
Include(FTheDebugger.FDebuggerFlags, dfSetBreakPending);
|
|
end;
|
|
bpkData:
|
|
case FWatchKind of
|
|
wpkWrite: begin
|
|
if ResultList.IndexOf('hw-wpt') >= 0 then ResultList.SetPath('hw-wpt')
|
|
else
|
|
if ResultList.IndexOf('wpt') >= 0 then ResultList.SetPath('wpt');
|
|
end;
|
|
wpkRead: begin
|
|
if ResultList.IndexOf('hw-rwpt') >= 0 then ResultList.SetPath('hw-rwpt')
|
|
else
|
|
if ResultList.IndexOf('rwpt') >= 0 then ResultList.SetPath('rwpt')
|
|
else
|
|
if ResultList.IndexOf('hw-wpt') >= 0 then ResultList.SetPath('hw-wpt')
|
|
else
|
|
if ResultList.IndexOf('wpt') >= 0 then ResultList.SetPath('wpt');
|
|
end;
|
|
wpkReadWrite: begin
|
|
if ResultList.IndexOf('hw-awpt') >= 0 then ResultList.SetPath('hw-awpt')
|
|
else
|
|
if ResultList.IndexOf('awpt') >= 0 then ResultList.SetPath('awpt')
|
|
else
|
|
if ResultList.IndexOf('hw-wpt') >= 0 then ResultList.SetPath('hw-wpt')
|
|
else
|
|
if ResultList.IndexOf('wpt') >= 0 then ResultList.SetPath('wpt');
|
|
end;
|
|
end;
|
|
end;
|
|
ABreakID := StrToIntDef(ResultList.Values['number'], 0);
|
|
AHitCnt := StrToIntDef(ResultList.Values['times'], 0);
|
|
AnAddr := StrToQWordDef(ResultList.Values['addr'], 0);
|
|
if ABreakID = 0
|
|
then Result := False;
|
|
ResultList.Free;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandBreakInsert.DoExecute: Boolean;
|
|
begin
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
FValid := False;
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval;
|
|
try
|
|
if FReplaceId <> 0
|
|
then ExecBreakDelete(FReplaceId);
|
|
|
|
FValid := ExecBreakInsert(FBreakID, FHitCnt, FAddr);
|
|
if not FValid then Exit;
|
|
|
|
if (FExpression <> '') and not (dcsCanceled in SeenStates)
|
|
then ExecBreakCondition(FBreakID, FExpression);
|
|
|
|
if not (dcsCanceled in SeenStates)
|
|
then ExecBreakEnabled(FBreakID, FEnabled);
|
|
|
|
if dcsCanceled in SeenStates
|
|
then begin
|
|
ExecBreakDelete(FBreakID);
|
|
FBreakID := 0;
|
|
FValid := False;
|
|
FAddr := 0;
|
|
FHitCnt := 0;
|
|
end;
|
|
finally
|
|
DefaultTimeOut := -1;
|
|
end;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakInsert.Create(AOwner: TGDBMIDebugger; ASource: string;
|
|
ALine: Integer; AEnabled: Boolean; AnExpression: string; AReplaceId: Integer);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FKind := bpkSource;
|
|
FSource := ASource;
|
|
FLine := ALine;
|
|
FEnabled := AEnabled;
|
|
FExpression := AnExpression;
|
|
FReplaceId := AReplaceId;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakInsert.Create(AOwner: TGDBMIDebugger;
|
|
AAddress: TDBGPtr; AEnabled: Boolean; AnExpression: string;
|
|
AReplaceId: Integer);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FKind := bpkAddress;
|
|
FAddress := AAddress;
|
|
FEnabled := AEnabled;
|
|
FExpression := AnExpression;
|
|
FReplaceId := AReplaceId;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakInsert.Create(AOwner: TGDBMIDebugger; AData: string;
|
|
AScope: TDBGWatchPointScope; AKind: TDBGWatchPointKind; AEnabled: Boolean;
|
|
AnExpression: string; AReplaceId: Integer);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FKind := bpkData;
|
|
FWatchData := AData;
|
|
FWatchScope := AScope;
|
|
FWatchKind := AKind;
|
|
FEnabled := AEnabled;
|
|
FExpression := AnExpression;
|
|
FReplaceId := AReplaceId;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandBreakInsert.DebugText: String;
|
|
begin
|
|
case FKind of
|
|
bpkAddress:
|
|
Result := Format('%s: Address=%x, Enabled=%s', [ClassName, FAddress, dbgs(FEnabled)]);
|
|
bpkData:
|
|
Result := Format('%s: Data=%s, Enabled=%s', [ClassName, FWatchData, dbgs(FEnabled)]);
|
|
else
|
|
Result := Format('%s: Source=%s, Line=%d, Enabled=%s', [ClassName, FSource, FLine, dbgs(FEnabled)]);
|
|
end;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandBreakRemove }
|
|
|
|
function TGDBMIDebuggerCommandBreakRemove.DoExecute: Boolean;
|
|
begin
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval;
|
|
try
|
|
ExecBreakDelete(FBreakId);
|
|
finally
|
|
DefaultTimeOut := -1;
|
|
end;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakRemove.Create(AOwner: TGDBMIDebugger;
|
|
ABreakId: Integer);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FBreakId := ABreakId;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandBreakRemove.DebugText: String;
|
|
begin
|
|
Result := Format('%s: BreakId=%d', [ClassName, FBreakId]);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandBreakUpdate }
|
|
|
|
function TGDBMIDebuggerCommandBreakUpdate.DoExecute: Boolean;
|
|
begin
|
|
Result := True;
|
|
FContext.ThreadContext := ccNotRequired;
|
|
FContext.StackContext := ccNotRequired;
|
|
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval;
|
|
try
|
|
if FUpdateExpression
|
|
then ExecBreakCondition(FBreakID, FExpression);
|
|
if FUpdateEnabled
|
|
then ExecBreakEnabled(FBreakID, FEnabled);
|
|
finally
|
|
DefaultTimeOut := -1;
|
|
end;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger; ABreakId: Integer);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FBreakID := ABreakId;
|
|
FUpdateEnabled := False;
|
|
FUpdateExpression := False;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger;
|
|
ABreakId: Integer; AnEnabled: Boolean);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FBreakID := ABreakId;
|
|
FEnabled := AnEnabled;
|
|
FUpdateEnabled := True;
|
|
FUpdateExpression := False;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger;
|
|
ABreakId: Integer; AnExpression: string);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FBreakID := ABreakId;
|
|
FExpression := AnExpression;
|
|
FUpdateExpression := True;
|
|
FUpdateEnabled := False;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandBreakUpdate.Create(AOwner: TGDBMIDebugger;
|
|
ABreakId: Integer; AnEnabled: Boolean; AnExpression: string);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FBreakID := ABreakId;
|
|
FEnabled := AnEnabled;
|
|
FUpdateEnabled := True;
|
|
FExpression := AnExpression;
|
|
FUpdateExpression := True;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandBreakUpdate.DebugText: String;
|
|
begin
|
|
Result := Format('%s: BreakId=%d ChangeEnabled=%s NewEnable=%s ChangeEpression=%s NewExpression=%s',
|
|
[ClassName, FBreakId, dbgs(FUpdateEnabled), dbgs(FEnabled), dbgs(FUpdateExpression), FExpression]);
|
|
end;
|
|
|
|
{ =========================================================================== }
|
|
{ TGDBMIBreakPoint }
|
|
{ =========================================================================== }
|
|
|
|
constructor TGDBMIBreakPoint.Create(ACollection: TCollection);
|
|
begin
|
|
inherited Create(ACollection);
|
|
FCurrentCmd := nil;
|
|
FUpdateFlags := [];
|
|
FBreakID := 0;
|
|
end;
|
|
|
|
destructor TGDBMIBreakPoint.Destroy;
|
|
begin
|
|
ReleaseBreakPoint;
|
|
if FCurrentCmd <> nil
|
|
then begin
|
|
// keep the command running
|
|
FCurrentCmd.OnDestroy := nil;
|
|
FCurrentCmd.OnCancel := nil;
|
|
FCurrentCmd.OnExecuted := nil;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.DoEnableChange;
|
|
begin
|
|
if (FBreakID = 0) and Enabled and
|
|
(TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun])
|
|
then
|
|
SetBreakPoint
|
|
else
|
|
UpdateProperties([bufEnabled]);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.DoExpressionChange;
|
|
var
|
|
S: String;
|
|
begin
|
|
S := Expression;
|
|
if ConvertPascalExpression(S)
|
|
then FParsedExpression := S
|
|
else FParsedExpression := Expression;
|
|
if (FBreakID = 0) and Enabled and
|
|
(TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun])
|
|
then
|
|
SetBreakPoint
|
|
else
|
|
UpdateProperties([bufCondition]);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.DoStateChange(const AOldState: TDBGState);
|
|
begin
|
|
inherited DoStateChange(AOldState);
|
|
|
|
case Debugger.State of
|
|
dsInit: begin
|
|
// Disabled data breakpoints: wait until enabled
|
|
// Disabled other breakpoints: Cive to GDB 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 TGDBMIBreakPoint.DoLogExpression(const AnExpression: String);
|
|
var
|
|
s: String;
|
|
t: TGDBType;
|
|
begin
|
|
s:='';
|
|
if TGDBMIDebugger(Debugger).GDBEvaluate(AnExpression, s, t, [defNoTypeInfo])
|
|
then begin
|
|
TGDBMIDebugger(Debugger).DoDbgEvent(ecBreakpoint, etBreakpointEvaluation, s);
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.MakeInvalid;
|
|
begin
|
|
BeginUpdate;
|
|
ReleaseBreakPoint;
|
|
SetValid(vsInvalid);
|
|
Changed;
|
|
EndUpdate;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.SetAddress(const AValue: TDBGPtr);
|
|
begin
|
|
if (Address = AValue) then exit;
|
|
inherited;
|
|
if (Debugger = nil) then Exit;
|
|
if TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun]
|
|
then SetBreakpoint;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.SetBreakpoint;
|
|
begin
|
|
if Debugger = nil then Exit;
|
|
if IsUpdating
|
|
then begin
|
|
FUpdateFlags := [bufSetBreakPoint];
|
|
exit;
|
|
end;
|
|
|
|
if (FCurrentCmd <> nil)
|
|
then begin
|
|
// We can not be changed, while we get destroyed
|
|
if (FCurrentCmd is TGDBMIDebuggerCommandBreakRemove)
|
|
then begin
|
|
SetValid(vsInvalid);
|
|
exit;
|
|
end;
|
|
|
|
if (FCurrentCmd is TGDBMIDebuggerCommandBreakInsert) and (FCurrentCmd.State = dcsQueued)
|
|
then begin
|
|
// update the current object
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Kind := Kind;
|
|
case Kind of
|
|
bpkSource:
|
|
begin
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Source := Source;
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Line := Line;
|
|
end;
|
|
bpkAddress:
|
|
begin
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Address := Address;
|
|
end;
|
|
bpkData:
|
|
begin
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).WatchData := WatchData;
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).WatchScope := WatchScope;
|
|
end;
|
|
end;
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Enabled := Enabled;
|
|
TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Expression := FParsedExpression;
|
|
exit;
|
|
end;
|
|
|
|
if (FCurrentCmd.State = dcsQueued)
|
|
then begin
|
|
// must be update for enabled or expression. both will be included in BreakInsert
|
|
// cancel and schedule BreakInsert
|
|
FCurrentCmd.OnDestroy := nil;
|
|
FCurrentCmd.OnCancel := nil;
|
|
FCurrentCmd.OnExecuted := nil;
|
|
FCurrentCmd.Cancel;
|
|
end
|
|
else begin
|
|
// let the command run (remove flags for enabled/condition)
|
|
FUpdateFlags := [bufSetBreakPoint];
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
FUpdateFlags := [];
|
|
case Kind of
|
|
bpkSource:
|
|
FCurrentCmd := TGDBMIDebuggerCommandBreakInsert.Create(TGDBMIDebugger(Debugger), Source, Line, Enabled, FParsedExpression, FBreakID);
|
|
bpkAddress:
|
|
FCurrentCmd := TGDBMIDebuggerCommandBreakInsert.Create(TGDBMIDebugger(Debugger), Address, Enabled, FParsedExpression, FBreakID);
|
|
bpkData:
|
|
FCurrentCmd := TGDBMIDebuggerCommandBreakInsert.Create(TGDBMIDebugger(Debugger), WatchData, WatchScope, WatchKind, Enabled, FParsedExpression, FBreakID);
|
|
end;
|
|
FBreakID := 0; // will be replaced => no longer valid
|
|
FCurrentCmd.OnDestroy := @DoCommandDestroyed;
|
|
FCurrentCmd.OnExecuted := @DoCommandExecuted;
|
|
FCurrentCmd.Priority := GDCMD_PRIOR_USER_ACT;
|
|
TGDBMIDebugger(Debugger).QueueCommand(FCurrentCmd);
|
|
|
|
if Debugger.State = dsRun
|
|
then TGDBMIDebugger(Debugger).GDBPause(True);
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.DoCommandDestroyed(Sender: TObject);
|
|
begin
|
|
if Sender = FCurrentCmd
|
|
then FCurrentCmd := nil;
|
|
// in case of cancelation
|
|
if bufSetBreakPoint in FUpdateFlags
|
|
then SetBreakPoint;
|
|
if FUpdateFlags * [bufEnabled, bufCondition] <> []
|
|
then UpdateProperties(FUpdateFlags);
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.DoCommandExecuted(Sender: TObject);
|
|
begin
|
|
if Sender = FCurrentCmd
|
|
then FCurrentCmd := nil;
|
|
|
|
if (Sender is TGDBMIDebuggerCommandBreakInsert)
|
|
then begin
|
|
// Check Insert Result
|
|
BeginUpdate;
|
|
|
|
if TGDBMIDebuggerCommandBreakInsert(Sender).Valid
|
|
then SetValid(vsValid)
|
|
else begin
|
|
if (TGDBMIDebuggerCommandBreakInsert(Sender).Kind = bpkData) and
|
|
(TGDBMIDebugger(Debugger).State = dsInit)
|
|
then begin
|
|
// disable data breakpoint, if unable to set (only at startup)
|
|
SetValid(vsValid);
|
|
SetEnabled(False);
|
|
end
|
|
else SetValid(vsInvalid);
|
|
end;
|
|
|
|
FBreakID := TGDBMIDebuggerCommandBreakInsert(Sender).BreakID;
|
|
SetHitCount(TGDBMIDebuggerCommandBreakInsert(Sender).HitCnt);
|
|
|
|
if Enabled
|
|
and (TGDBMIDebugger(Debugger).FBreakAtMain = nil)
|
|
then begin
|
|
// Check if this BP is at the same location as the temp break
|
|
if TGDBMIDebugger(Debugger).FMainAddrBreak.MatchAddr(TGDBMIDebuggerCommandBreakInsert(Sender).Addr)
|
|
then TGDBMIDebugger(Debugger).FBreakAtMain := Self;
|
|
end;
|
|
|
|
EndUpdate;
|
|
end;
|
|
|
|
if bufSetBreakPoint in FUpdateFlags
|
|
then SetBreakPoint;
|
|
if FUpdateFlags * [bufEnabled, bufCondition] <> []
|
|
then UpdateProperties(FUpdateFlags);
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.DoEndUpdate;
|
|
begin
|
|
if bufSetBreakPoint in FUpdateFlags
|
|
then SetBreakPoint;
|
|
if FUpdateFlags * [bufEnabled, bufCondition] <> []
|
|
then UpdateProperties(FUpdateFlags);
|
|
inherited DoChanged;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.ReleaseBreakPoint;
|
|
begin
|
|
if Debugger = nil then Exit;
|
|
|
|
FUpdateFlags := [];
|
|
if (FCurrentCmd <> nil) and (FCurrentCmd is TGDBMIDebuggerCommandBreakRemove)
|
|
then exit;
|
|
|
|
// Cancel any other current command
|
|
if (FCurrentCmd <> nil)
|
|
then begin
|
|
FCurrentCmd.OnDestroy := nil;
|
|
FCurrentCmd.OnCancel := nil;
|
|
FCurrentCmd.OnExecuted := nil;
|
|
// if CurrenCmd is TGDBMIDebuggerCommandBreakInsert then it will remove itself
|
|
FCurrentCmd.Cancel;
|
|
end;
|
|
|
|
if FBreakID = 0 then Exit;
|
|
|
|
FCurrentCmd := TGDBMIDebuggerCommandBreakRemove.Create(TGDBMIDebugger(Debugger), FBreakID);
|
|
FCurrentCmd.OnDestroy := @DoCommandDestroyed;
|
|
FCurrentCmd.OnExecuted := @DoCommandExecuted;
|
|
FCurrentCmd.Priority := GDCMD_PRIOR_USER_ACT;
|
|
TGDBMIDebugger(Debugger).QueueCommand(FCurrentCmd);
|
|
|
|
FBreakID:=0;
|
|
SetHitCount(0);
|
|
|
|
if Debugger.State = dsRun
|
|
then TGDBMIDebugger(Debugger).GDBPause(True);
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.SetLocation(const ASource: String; const ALine: Integer);
|
|
begin
|
|
if (Source = ASource) and (Line = ALine) then exit;
|
|
inherited;
|
|
if (Debugger = nil) or (Source = '') then Exit;
|
|
if TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun]
|
|
then SetBreakpoint;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.SetWatch(const AData: String; const AScope: TDBGWatchPointScope;
|
|
const AKind: TDBGWatchPointKind);
|
|
begin
|
|
if (AData = WatchData) and (AScope = WatchScope) and (AKind = WatchKind) then exit;
|
|
inherited SetWatch(AData, AScope, AKind);
|
|
if (Debugger = nil) or (WatchData = '') then Exit;
|
|
if TGDBMIDebugger(Debugger).State in [dsPause, dsInternalPause, dsRun]
|
|
then SetBreakpoint;
|
|
end;
|
|
|
|
procedure TGDBMIBreakPoint.UpdateProperties(AFlags: TGDBMIBreakPointUpdateFlags);
|
|
begin
|
|
if (Debugger = nil) then Exit;
|
|
if AFlags * [bufEnabled, bufCondition] = [] then Exit;
|
|
if IsUpdating
|
|
then begin
|
|
if not(bufSetBreakPoint in FUpdateFlags)
|
|
then FUpdateFlags := FUpdateFlags + AFlags;
|
|
exit;
|
|
end;
|
|
|
|
if (FCurrentCmd <> nil)
|
|
then begin
|
|
// We can not be changed, while we get destroyed
|
|
if (FCurrentCmd is TGDBMIDebuggerCommandBreakRemove)
|
|
then begin
|
|
SetValid(vsInvalid);
|
|
exit;
|
|
end;
|
|
|
|
if (FCurrentCmd is TGDBMIDebuggerCommandBreakInsert) and (FCurrentCmd.State = dcsQueued)
|
|
then begin
|
|
if bufEnabled in AFlags
|
|
then TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Enabled := Enabled;
|
|
if bufCondition in AFlags
|
|
then TGDBMIDebuggerCommandBreakInsert(FCurrentCmd).Expression := Expression;
|
|
exit;
|
|
end;
|
|
|
|
if (FCurrentCmd is TGDBMIDebuggerCommandBreakUpdate) and (FCurrentCmd.State = dcsQueued)
|
|
then begin
|
|
// update the current object
|
|
if bufEnabled in AFlags
|
|
then begin
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateEnabled := True;
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Enabled := Enabled;
|
|
end;
|
|
if bufCondition in AFlags
|
|
then begin
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateExpression := True;
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Expression := FParsedExpression;
|
|
end;
|
|
exit;
|
|
end;
|
|
|
|
if bufSetBreakPoint in FUpdateFlags
|
|
then exit;
|
|
|
|
// let the command run
|
|
FUpdateFlags := FUpdateFlags + AFlags;
|
|
exit;
|
|
end;
|
|
|
|
if (FBreakID = 0) then Exit;
|
|
|
|
FUpdateFlags := FUpdateFlags - [bufEnabled, bufCondition];
|
|
|
|
FCurrentCmd:= TGDBMIDebuggerCommandBreakUpdate.Create(TGDBMIDebugger(Debugger), FBreakID);
|
|
if bufEnabled in AFlags
|
|
then begin
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateEnabled := True;
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Enabled := Enabled;
|
|
end;
|
|
if bufCondition in AFlags
|
|
then begin
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).UpdateExpression := True;
|
|
TGDBMIDebuggerCommandBreakUpdate(FCurrentCmd).Expression := FParsedExpression;
|
|
end;
|
|
FCurrentCmd.OnDestroy := @DoCommandDestroyed;
|
|
FCurrentCmd.OnExecuted := @DoCommandExecuted;
|
|
FCurrentCmd.Priority := GDCMD_PRIOR_USER_ACT;
|
|
TGDBMIDebugger(Debugger).QueueCommand(FCurrentCmd);
|
|
|
|
if Debugger.State = dsRun
|
|
then TGDBMIDebugger(Debugger).GDBPause(True);
|
|
end;
|
|
|
|
{%endregion ^^^^^ BreakPoints ^^^^^ }
|
|
|
|
{%region ***** Locals ***** }
|
|
{ TGDBMIDebuggerCommandLocals }
|
|
|
|
procedure TGDBMIDebuggerCommandLocals.DoLockQueueExecute;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandLocals.DoUnLockQueueExecute;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandLocals.DoLockQueueExecuteForInstr;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandLocals.DoUnLockQueueExecuteForInstr;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandLocals.DoExecute: Boolean;
|
|
|
|
procedure AddLocals(const AParams: String);
|
|
var
|
|
n: Integer;
|
|
addr: TDbgPtr;
|
|
LocList, List: TGDBMINameValueList;
|
|
Item: PGDBMINameValue;
|
|
Name, Value: String;
|
|
begin
|
|
LocList := TGDBMINameValueList.Create(AParams);
|
|
List := TGDBMINameValueList.Create('');
|
|
for n := 0 to LocList.Count - 1 do
|
|
begin
|
|
Item := LocList.Items[n];
|
|
List.Init(Item^.Name);
|
|
Name := List.Values['name'];
|
|
if Name = 'this'
|
|
then Name := 'Self';
|
|
|
|
Value := List.Values['value'];
|
|
(* GDB up to about 6.6 (stabs only) may return:
|
|
{name="ARGANSISTRING",value="(ANSISTRING) 0x43cc84"}
|
|
* newer GDB may return AnsiString/PChar prefixed with an address (shortstring have no address)
|
|
{name="ARGANSISTRING",value="0x43cc84 'Ansi'"}
|
|
*)
|
|
if (lowercase(copy(Value, 1, 8)) = '(pchar) ') then begin
|
|
delete(Value, 1, 8);
|
|
if GetLeadingAddr(Value, addr) then begin
|
|
if addr = 0
|
|
then Value := ''''''
|
|
else Value := MakePrintable(GetText(addr));
|
|
end;
|
|
end
|
|
else
|
|
if (lowercase(copy(Value, 1, 13)) = '(ansistring) ') then begin
|
|
delete(Value, 1, 13);
|
|
if GetLeadingAddr(Value, addr) then begin
|
|
if addr = 0
|
|
then Value := ''''''
|
|
else Value := MakePrintable(GetText(addr));
|
|
end;
|
|
end
|
|
else
|
|
if GetLeadingAddr(Value, addr, True) then
|
|
begin
|
|
// AnsiString
|
|
if (length(Value) > 0) and (Value[1] in ['''', '#']) then begin
|
|
Value := MakePrintable(ProcessGDBResultText(Value, [prNoLeadingTab]));
|
|
end
|
|
else
|
|
Value := ProcessGDBResultStruct(List.Values['value'], [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
|
|
end
|
|
else
|
|
// ShortString
|
|
if (length(Value) > 0) and (Value[1] in ['''', '#']) then begin
|
|
Value := MakePrintable(ProcessGDBResultText(Value, [prNoLeadingTab]));
|
|
end
|
|
else
|
|
Value := ProcessGDBResultStruct(Value, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
|
|
|
|
FLocals.Add(Name, Value);
|
|
end;
|
|
FreeAndNil(List);
|
|
FreeAndNil(LocList);
|
|
end;
|
|
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
Result := True;
|
|
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.ThreadId := FLocals.ThreadId;
|
|
FContext.StackContext := ccUseLocal;
|
|
FContext.StackFrame := FLocals.StackFrame;
|
|
|
|
FLocals.Clear;
|
|
// args
|
|
ExecuteCommand('-stack-list-arguments 1 %0:d %0:d',
|
|
[FTheDebugger.FCurrentStackFrame], R, [cfNoStackContext]);
|
|
if R.State <> dsError
|
|
then begin
|
|
List := TGDBMINameValueList.Create(R, ['stack-args', 'frame']);
|
|
AddLocals(List.Values['args']);
|
|
FreeAndNil(List);
|
|
end;
|
|
|
|
// variables
|
|
ExecuteCommand('-stack-list-locals 1', R);
|
|
if R.State <> dsError
|
|
then begin
|
|
List := TGDBMINameValueList.Create(R);
|
|
AddLocals(List.Values['locals']);
|
|
FreeAndNil(List);
|
|
end;
|
|
FLocals.SetDataValidity(ddsValid);
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandLocals.Create(AOwner: TGDBMIDebugger; ALocals: TLocals);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FLocals := ALocals;
|
|
FLocals.AddReference;
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommandLocals.Destroy;
|
|
begin
|
|
ReleaseRefAndNil(FLocals);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandLocals.DebugText: String;
|
|
begin
|
|
Result := Format('%s:', [ClassName]);
|
|
end;
|
|
|
|
{ =========================================================================== }
|
|
{ TGDBMILocals }
|
|
{ =========================================================================== }
|
|
|
|
procedure TGDBMILocals.Changed;
|
|
begin
|
|
if CurrentLocalsList <> nil
|
|
then CurrentLocalsList.Clear;
|
|
end;
|
|
|
|
constructor TGDBMILocals.Create(const ADebugger: TDebuggerIntf);
|
|
begin
|
|
FCommandList := TList.Create;
|
|
inherited;
|
|
end;
|
|
|
|
destructor TGDBMILocals.Destroy;
|
|
begin
|
|
CancelAllCommands;
|
|
inherited;
|
|
FreeAndNil(FCommandList);
|
|
end;
|
|
|
|
procedure TGDBMILocals.CancelAllCommands;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FCommandList.Count-1 do
|
|
with TGDBMIDebuggerCommandStack(FCommandList[i]) do begin
|
|
OnExecuted := nil;
|
|
OnDestroy := nil;
|
|
Cancel;
|
|
end;
|
|
FCommandList.Clear;
|
|
end;
|
|
|
|
function TGDBMILocals.ForceQueuing: Boolean;
|
|
begin
|
|
Result := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
|
|
and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
|
|
and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
|
|
and (Debugger.State <> dsInternalPause);
|
|
end;
|
|
|
|
procedure TGDBMILocals.RequestData(ALocals: TLocals);
|
|
var
|
|
EvaluationCmdObj: TGDBMIDebuggerCommandLocals;
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then Exit;
|
|
|
|
EvaluationCmdObj := TGDBMIDebuggerCommandLocals.Create(TGDBMIDebugger(Debugger), ALocals);
|
|
EvaluationCmdObj.OnDestroy := @DoEvaluationDestroyed;
|
|
EvaluationCmdObj.Priority := GDCMD_PRIOR_LOCALS;
|
|
EvaluationCmdObj.Properties := [dcpCancelOnRun];
|
|
FCommandList.add(EvaluationCmdObj);
|
|
TGDBMIDebugger(Debugger).QueueCommand(EvaluationCmdObj, ForceQueuing);
|
|
(* DoEvaluationFinished may be called immediately at this point *)
|
|
end;
|
|
|
|
procedure TGDBMILocals.DoEvaluationDestroyed(Sender: TObject);
|
|
begin
|
|
FCommandList.Remove(Sender);
|
|
end;
|
|
|
|
procedure TGDBMILocals.CancelEvaluation;
|
|
begin
|
|
end;
|
|
|
|
{%endregion ^^^^^ BreakPoints ^^^^^ }
|
|
|
|
{ =========================================================================== }
|
|
{ TGDBMIWatches }
|
|
{ =========================================================================== }
|
|
|
|
procedure TGDBMIWatches.DoEvaluationDestroyed(Sender: TObject);
|
|
begin
|
|
FCommandList.Remove(Sender);
|
|
end;
|
|
|
|
function TGDBMIWatches.GetParentFPList(AThreadId: Integer): PGDBMIDebuggerParentFrameCache;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to high(FParentFPList) do
|
|
if FParentFPList[i].ThreadId = AThreadId
|
|
then exit(@FParentFPList[i]);
|
|
i := Length(FParentFPList);
|
|
SetLength(FParentFPList, i + 1);
|
|
FParentFPList[i].ThreadId := AThreadId;
|
|
Result := @FParentFPList[i];
|
|
end;
|
|
|
|
procedure TGDBMIWatches.DoStateChange(const AOldState: TDBGState);
|
|
begin
|
|
SetLength(FParentFPList, 0);
|
|
if FParentFPListChangeStamp = high(FParentFPListChangeStamp) then
|
|
FParentFPListChangeStamp := low(FParentFPListChangeStamp)
|
|
else
|
|
inc(FParentFPListChangeStamp);
|
|
inherited DoStateChange(AOldState);
|
|
end;
|
|
|
|
procedure TGDBMIWatches.Changed;
|
|
begin
|
|
SetLength(FParentFPList, 0);
|
|
if CurrentWatches <> nil
|
|
then CurrentWatches.ClearValues;
|
|
end;
|
|
|
|
procedure TGDBMIWatches.Clear;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FCommandList.Count-1 do
|
|
with TGDBMIDebuggerCommandStack(FCommandList[i]) do begin
|
|
OnExecuted := nil;
|
|
OnDestroy := nil;
|
|
Cancel;
|
|
end;
|
|
FCommandList.Clear;
|
|
end;
|
|
|
|
function TGDBMIWatches.ForceQueuing: Boolean;
|
|
begin
|
|
Result := (TGDBMIDebugger(Debugger).FCurrentCommand <> nil)
|
|
and (TGDBMIDebugger(Debugger).FCurrentCommand is TGDBMIDebuggerCommandExecute)
|
|
and (not TGDBMIDebuggerCommandExecute(TGDBMIDebugger(Debugger).FCurrentCommand).NextExecQueued)
|
|
and (Debugger.State <> dsInternalPause);
|
|
end;
|
|
|
|
procedure TGDBMIWatches.InternalRequestData(AWatchValue: TWatchValue);
|
|
var
|
|
EvaluationCmdObj: TGDBMIDebuggerCommandEvaluate;
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
|
|
AWatchValue.Validity := ddsInvalid;
|
|
Exit;
|
|
end;
|
|
|
|
EvaluationCmdObj := TGDBMIDebuggerCommandEvaluate.Create
|
|
(TGDBMIDebugger(Debugger), AWatchValue);
|
|
//EvaluationCmdObj.OnExecuted := @DoEvaluationFinished;
|
|
EvaluationCmdObj.OnDestroy := @DoEvaluationDestroyed;
|
|
EvaluationCmdObj.Properties := [dcpCancelOnRun];
|
|
// If a ExecCmd is running, then defer exec until the exec cmd is done
|
|
FCommandList.Add(EvaluationCmdObj);
|
|
TGDBMIDebugger(Debugger).QueueCommand(EvaluationCmdObj, ForceQueuing);
|
|
(* DoEvaluationFinished may be called immediately at this point *)
|
|
end;
|
|
|
|
constructor TGDBMIWatches.Create(const ADebugger: TDebuggerIntf);
|
|
begin
|
|
FCommandList := TList.Create;
|
|
inherited Create(ADebugger);
|
|
end;
|
|
|
|
destructor TGDBMIWatches.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
Clear;
|
|
FreeAndNil(FCommandList);
|
|
end;
|
|
|
|
|
|
|
|
{ =========================================================================== }
|
|
{ TGDBMICallStack }
|
|
{ =========================================================================== }
|
|
|
|
procedure TGDBMICallStack.DoDepthCommandExecuted(Sender: TObject);
|
|
var
|
|
Cmd: TGDBMIDebuggerCommandStackDepth;
|
|
begin
|
|
FCommandList.Remove(Sender);
|
|
FDepthEvalCmdObj := nil;
|
|
Cmd := TGDBMIDebuggerCommandStackDepth(Sender);
|
|
if Cmd.Callstack = nil then exit;
|
|
if Cmd.Depth < 0 then begin
|
|
Cmd.Callstack.SetCountValidity(ddsInvalid);
|
|
Cmd.Callstack.SetHasAtLeastCountInfo(ddsInvalid);
|
|
end else begin
|
|
if (Cmd.Limit > 0) and not(Cmd.Depth < Cmd.Limit) then begin
|
|
Cmd.Callstack.SetHasAtLeastCountInfo(ddsValid, Cmd.Depth);
|
|
end
|
|
else begin
|
|
Cmd.Callstack.Count := Cmd.Depth;
|
|
Cmd.Callstack.SetCountValidity(ddsValid);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMICallStack.RequestCount(ACallstack: TCallStackBase);
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause])
|
|
then begin
|
|
ACallstack.SetCountValidity(ddsInvalid);
|
|
exit;
|
|
end;
|
|
|
|
if (FDepthEvalCmdObj <> nil) and (FDepthEvalCmdObj .State = dcsQueued) then begin
|
|
FDepthEvalCmdObj.Limit := -1;
|
|
exit;
|
|
end;
|
|
|
|
FDepthEvalCmdObj := TGDBMIDebuggerCommandStackDepth.Create(TGDBMIDebugger(Debugger), ACallstack);
|
|
FDepthEvalCmdObj.OnExecuted := @DoDepthCommandExecuted;
|
|
FDepthEvalCmdObj.OnDestroy := @DoCommandDestroyed;
|
|
FDepthEvalCmdObj.Priority := GDCMD_PRIOR_STACK;
|
|
FCommandList.Add(FDepthEvalCmdObj);
|
|
TGDBMIDebugger(Debugger).QueueCommand(FDepthEvalCmdObj);
|
|
(* DoDepthCommandExecuted may be called immediately at this point *)
|
|
end;
|
|
|
|
procedure TGDBMICallStack.RequestAtLeastCount(ACallstack: TCallStackBase;
|
|
ARequiredMinCount: Integer);
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause])
|
|
then begin
|
|
ACallstack.SetCountValidity(ddsInvalid);
|
|
exit;
|
|
end;
|
|
|
|
// avoid calling with many small minimum
|
|
// FLimitSeen starts at 11;
|
|
FLimitSeen := Max(FLimitSeen, Min(ARequiredMinCount, 51)); // remember, if the user has asked for more
|
|
if ARequiredMinCount <= 11 then
|
|
ARequiredMinCount := 11
|
|
else
|
|
ARequiredMinCount := Max(ARequiredMinCount, FLimitSeen);
|
|
|
|
if (FDepthEvalCmdObj <> nil) and (FDepthEvalCmdObj .State = dcsQueued) then begin
|
|
if FDepthEvalCmdObj.Limit <= 0 then
|
|
exit;
|
|
if FDepthEvalCmdObj.Limit < ARequiredMinCount then
|
|
FDepthEvalCmdObj.Limit := ARequiredMinCount;
|
|
exit;
|
|
end;
|
|
|
|
FDepthEvalCmdObj := TGDBMIDebuggerCommandStackDepth.Create(TGDBMIDebugger(Debugger), ACallstack);
|
|
FDepthEvalCmdObj.Limit := ARequiredMinCount;
|
|
FDepthEvalCmdObj.OnExecuted := @DoDepthCommandExecuted;
|
|
FDepthEvalCmdObj.OnDestroy := @DoCommandDestroyed;
|
|
FDepthEvalCmdObj.Priority := GDCMD_PRIOR_STACK;
|
|
FCommandList.Add(FDepthEvalCmdObj);
|
|
TGDBMIDebugger(Debugger).QueueCommand(FDepthEvalCmdObj);
|
|
(* DoDepthCommandExecuted may be called immediately at this point *)
|
|
end;
|
|
|
|
procedure TGDBMICallStack.RequestCurrent(ACallstack: TCallStackBase);
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
|
|
ACallstack.SetCurrentValidity(ddsInvalid);
|
|
Exit;
|
|
end;
|
|
|
|
if ACallstack.ThreadId = TGDBMIDebugger(Debugger).FCurrentThreadId
|
|
then ACallstack.CurrentIndex := TGDBMIDebugger(Debugger).FCurrentStackFrame
|
|
else ACallstack.CurrentIndex := 0; // will be used, if thread is changed
|
|
ACallstack.SetCurrentValidity(ddsValid);
|
|
end;
|
|
|
|
procedure TGDBMICallStack.RequestEntries(ACallstack: TCallStackBase);
|
|
var
|
|
FramesEvalCmdObj: TGDBMIDebuggerCommandStackFrames;
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then Exit;
|
|
|
|
FramesEvalCmdObj := TGDBMIDebuggerCommandStackFrames.Create(TGDBMIDebugger(Debugger), ACallstack);
|
|
//FramesEvalCmdObj.OnExecuted := @DoFramesCommandExecuted;
|
|
FramesEvalCmdObj.OnDestroy := @DoCommandDestroyed;
|
|
FramesEvalCmdObj.Priority := GDCMD_PRIOR_STACK;
|
|
FCommandList.Add(FramesEvalCmdObj);
|
|
TGDBMIDebugger(Debugger).QueueCommand(FramesEvalCmdObj);
|
|
(* DoFramesCommandExecuted may be called immediately at this point *)
|
|
end;
|
|
|
|
procedure TGDBMICallStack.DoCommandDestroyed(Sender: TObject);
|
|
begin
|
|
FCommandList.Remove(Sender);
|
|
if FDepthEvalCmdObj = Sender then
|
|
FDepthEvalCmdObj := nil;
|
|
end;
|
|
|
|
procedure TGDBMICallStack.Clear;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to FCommandList.Count-1 do
|
|
with TGDBMIDebuggerCommandStack(FCommandList[i]) do begin
|
|
OnExecuted := nil;
|
|
OnDestroy := nil;
|
|
Cancel;
|
|
end;
|
|
FCommandList.Clear;
|
|
FDepthEvalCmdObj := nil;
|
|
end;
|
|
|
|
procedure TGDBMICallStack.UpdateCurrentIndex;
|
|
var
|
|
tid, idx: Integer;
|
|
cs: TCallStackBase;
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
|
|
exit;
|
|
end;
|
|
|
|
tid := Debugger.Threads.CurrentThreads.CurrentThreadId;
|
|
cs := TCallStackBase(CurrentCallStackList.EntriesForThreads[tid]);
|
|
idx := cs.NewCurrentIndex; // NEW-CURRENT
|
|
if TGDBMIDebugger(Debugger).FCurrentStackFrame = idx then Exit;
|
|
|
|
TGDBMIDebugger(Debugger).FCurrentStackFrame := idx;
|
|
if cs <> nil then
|
|
cs.CurrentIndex := idx;
|
|
end;
|
|
|
|
procedure TGDBMICallStack.DoThreadChanged;
|
|
var
|
|
tid, idx: Integer;
|
|
cs: TCallStackBase;
|
|
begin
|
|
if (Debugger = nil) or not(Debugger.State in [dsPause, dsInternalPause]) then begin
|
|
exit;
|
|
end;
|
|
|
|
TGDBMIDebugger(Debugger).FCurrentStackFrame := 0;
|
|
tid := Debugger.Threads.CurrentThreads.CurrentThreadId;
|
|
cs := TCallStackBase(CurrentCallStackList.EntriesForThreads[tid]);
|
|
idx := cs.CurrentIndex; // CURRENT
|
|
if idx < 0 then idx := 0;
|
|
|
|
TGDBMIDebugger(Debugger).FCurrentStackFrame := idx;
|
|
if cs <> nil then
|
|
cs.CurrentIndex := idx;
|
|
end;
|
|
|
|
constructor TGDBMICallStack.Create(const ADebugger: TDebuggerIntf);
|
|
begin
|
|
FCommandList := TList.Create;
|
|
FLimitSeen := 11;
|
|
inherited Create(ADebugger);
|
|
end;
|
|
|
|
destructor TGDBMICallStack.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
Clear;
|
|
FreeAndNil(FCommandList);
|
|
end;
|
|
|
|
{ TGDBStringIterator }
|
|
|
|
constructor TGDBStringIterator.Create(const AParsableData: String);
|
|
begin
|
|
inherited Create;
|
|
FParsableData := AParsableData;
|
|
FReadPointer := 1;
|
|
FDataSize := Length(AParsableData);
|
|
DebugLn(AParsableData);
|
|
end;
|
|
|
|
function TGDBStringIterator.ParseNext(out ADecomposable: Boolean; out
|
|
APayload: String; out ACharStopper: Char): Boolean;
|
|
var
|
|
InStr: Boolean;
|
|
InBrackets1, InBrackets2: Integer;
|
|
c: Char;
|
|
BeginString: Integer;
|
|
EndString: Integer;
|
|
begin
|
|
ADecomposable := False;
|
|
InStr := False;
|
|
InBrackets1 := 0;
|
|
InBrackets2 := 0;
|
|
BeginString := FReadPointer;
|
|
EndString := FDataSize;
|
|
ACharStopper := #0; //none
|
|
while FReadPointer <= FDataSize do
|
|
begin
|
|
c := FParsableData[FReadPointer];
|
|
if c = '''' then InStr := not InStr;
|
|
if not InStr
|
|
then begin
|
|
case c of
|
|
'{': Inc(InBrackets1);
|
|
'}': Dec(InBrackets1);
|
|
'[': Inc(InBrackets2);
|
|
']': Dec(InBrackets2);
|
|
end;
|
|
|
|
if (InBrackets1 = 0) and (InBrackets2 = 0) and (c in [',', '='])
|
|
then begin
|
|
EndString := FReadPointer - 1;
|
|
Inc(FReadPointer); //Skip this char
|
|
ACharStopper := c;
|
|
Break;
|
|
end;
|
|
end;
|
|
Inc(FReadPointer);
|
|
end;
|
|
|
|
//Remove boundary spaces.
|
|
while BeginString<EndString do
|
|
begin
|
|
if FParsableData[BeginString] <> ' ' then break;
|
|
Inc(BeginString);
|
|
end;
|
|
|
|
while EndString >= BeginString do
|
|
begin
|
|
if FParsableData[EndString] <> ' ' then break;
|
|
Dec(EndString);
|
|
end;
|
|
|
|
Result := EndString >= BeginString;
|
|
|
|
if Result
|
|
and (FParsableData[BeginString] = '{')
|
|
then begin
|
|
Result := FParsableData[EndString] = '}';
|
|
inc(BeginString);
|
|
dec(EndString);
|
|
ADecomposable := True;
|
|
end;
|
|
|
|
if Result
|
|
then APayload := Copy(FParsableData, BeginString, EndString - BeginString + 1)
|
|
else APayload := '';
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommand }
|
|
|
|
function TGDBMIDebuggerCommand.GetDebuggerState: TDBGState;
|
|
begin
|
|
Result := FTheDebugger.State;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetDebuggerProperties: TGDBMIDebuggerPropertiesBase;
|
|
begin
|
|
Result := TGDBMIDebuggerPropertiesBase(FTheDebugger.GetProperties);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetTargetInfo: PGDBMITargetInfo;
|
|
begin
|
|
Result := @FTheDebugger.FTargetInfo;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ContextThreadId: Integer;
|
|
begin
|
|
if FContext.ThreadContext = ccUseGlobal then
|
|
Result := FTheDebugger.FCurrentThreadId
|
|
else
|
|
Result := FContext.ThreadId;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ContextStackFrame: Integer;
|
|
begin
|
|
if FContext.StackContext = ccUseGlobal then
|
|
Result := FTheDebugger.FCurrentStackFrame
|
|
else
|
|
Result := FContext.StackFrame;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.CopyGlobalContextToLocal;
|
|
begin
|
|
if FContext.ThreadContext = ccUseGlobal then begin
|
|
if FTheDebugger.FCurrentThreadIdValid then begin
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.ThreadId := FTheDebugger.FCurrentThreadId
|
|
end
|
|
else
|
|
debugln(DBG_VERBOSE, ['CopyGlobalContextToLocal: FAILED thread, global data is not valid']);
|
|
end;
|
|
|
|
if FContext.StackContext = ccUseGlobal then begin
|
|
if FTheDebugger.FCurrentStackFrameValid then begin
|
|
FContext.StackContext := ccUseLocal;
|
|
FContext.StackFrame := FTheDebugger.FCurrentStackFrame;
|
|
end
|
|
else
|
|
debugln(DBG_VERBOSE, ['CopyGlobalContextToLocal: FAILED stackframe, global data is not valid']);
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.SetDebuggerState(const AValue: TDBGState);
|
|
begin
|
|
FTheDebugger.SetState(AValue);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.SetDebuggerErrorState(const AMsg: String;
|
|
const AInfo: String);
|
|
begin
|
|
FTheDebugger.SetErrorState(AMsg, AInfo);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ErrorStateMessage: String;
|
|
begin
|
|
Result := '';
|
|
if ehfGotWriteError in FTheDebugger.FErrorHandlingFlags
|
|
then Result := Result + Format(gdbmiErrorStateInfoFailedWrite, [LineEnding])
|
|
else
|
|
if ehfGotReadError in FTheDebugger.FErrorHandlingFlags
|
|
then Result := Result + Format(gdbmiErrorStateInfoFailedRead, [LineEnding]);
|
|
|
|
if not FTheDebugger.DebugProcessRunning
|
|
then Result := Result + Format(gdbmiErrorStateInfoGDBGone, [LineEnding]);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ErrorStateInfo: String;
|
|
begin
|
|
Result := Format(gdbmiErrorStateGenericInfo, [LineEnding, DebugText]);
|
|
if FLastExecResult.Values = ''
|
|
then Result := Format(gdbmiErrorStateInfoCommandNoResult, [LineEnding, FLastExecCommand])
|
|
else Result := Format(gdbmiErrorStateInfoCommandError, [LineEnding, FLastExecCommand, FLastExecResult.Values]);
|
|
if not FTheDebugger.DebugProcessRunning
|
|
then Result := Result + Format(gdbmiErrorStateInfoGDBGone, [LineEnding]);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.SetCommandState(NewState: TGDBMIDebuggerCommandState);
|
|
var
|
|
OldState: TGDBMIDebuggerCommandState;
|
|
begin
|
|
if FState = NewState
|
|
then exit;
|
|
OldState := FState;
|
|
FState := NewState;
|
|
Include(FSeenStates, NewState);
|
|
DoStateChanged(OldState);
|
|
if (State in [dcsFinished, dcsCanceled]) and not(dcsInternalRefReleased in FSeenStates)
|
|
then begin
|
|
Include(FSeenStates, dcsInternalRefReleased);
|
|
ReleaseReference; //internal reference
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoStateChanged(OldState: TGDBMIDebuggerCommandState);
|
|
begin
|
|
// nothing
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoLockQueueExecute;
|
|
begin
|
|
FTheDebugger.QueueExecuteLock;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoUnLockQueueExecute;
|
|
begin
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoLockQueueExecuteForInstr;
|
|
begin
|
|
FTheDebugger.QueueExecuteLock;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoUnLockQueueExecuteForInstr;
|
|
begin
|
|
FTheDebugger.QueueExecuteUnlock;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoOnExecuted;
|
|
begin
|
|
if assigned(FOnExecuted) then
|
|
FOnExecuted(self);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoCancel;
|
|
begin
|
|
// empty
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoOnCanceled;
|
|
begin
|
|
if assigned(FOnCancel) then
|
|
FOnCancel(self);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
|
|
AFlags: TGDBMICommandFlags = []; ATimeOut: Integer = -1): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Result := ExecuteCommand(ACommand, R, AFlags, ATimeOut);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
|
|
out AResult: TGDBMIExecResult; AFlags: TGDBMICommandFlags = [];
|
|
ATimeOut: Integer = -1): Boolean;
|
|
var
|
|
Instr: TGDBMIDebuggerInstruction;
|
|
ASyncFailed: Boolean;
|
|
begin
|
|
ASyncFailed := False;
|
|
|
|
if cfTryAsync in AFlags then begin
|
|
if FTheDebugger.FAsyncModeEnabled then begin
|
|
Result := ExecuteCommand(ACommand + ' &', AResult, AFlags - [cfTryAsync], ATimeOut);
|
|
if (not Result) or (AResult.State <> dsError) then
|
|
exit;
|
|
end;
|
|
|
|
ASyncFailed := True;
|
|
end;
|
|
|
|
FLastExecCommand := ACommand;
|
|
FLastExecwasTimeOut := False;
|
|
|
|
if (ATimeOut = -1) and (DefaultTimeOut > 0)
|
|
then ATimeOut := DefaultTimeOut;
|
|
|
|
try
|
|
DoLockQueueExecuteForInstr;
|
|
|
|
if (cfNoThreadContext in AFlags) or (FContext.ThreadContext = ccNotRequired) or
|
|
((FContext.ThreadContext = ccUseGlobal) and (not FTheDebugger.FCurrentThreadIdValid)) or
|
|
(ContextThreadId = 0) // TODO: 0 is not valid => use current
|
|
then
|
|
Instr := TGDBMIDebuggerInstruction.Create(ACommand, [], ATimeOut)
|
|
else
|
|
if (cfNoStackContext in AFlags) or (FContext.StackContext = ccNotRequired) or
|
|
((FContext.StackContext = ccUseGlobal) and (not FTheDebugger.FCurrentStackFrameValid))
|
|
then
|
|
Instr := TGDBMIDebuggerInstruction.Create(ACommand, ContextThreadId, [], ATimeOut)
|
|
else
|
|
Instr := TGDBMIDebuggerInstruction.Create(ACommand, ContextThreadId,
|
|
ContextStackFrame, [], ATimeOut);
|
|
Instr.AddReference;
|
|
Instr.Cmd := Self;
|
|
FTheDebugger.FInstructionQueue.RunInstruction(Instr);
|
|
|
|
Result := Instr.IsSuccess and Instr.FHasResult;
|
|
AResult := Instr.ResultData;
|
|
if ASyncFailed then
|
|
AResult.Flags := [rfAsyncFailed];
|
|
FLastExecResult := AResult;
|
|
FLogWarnings := Instr.LogWarnings; // TODO: Do not clear in time-out handling
|
|
FFullCmdReply := Instr.FullCmdReply; // TODO: Do not clear in time-out handling
|
|
|
|
if (ifeTimedOut in Instr.ErrorFlags) then begin
|
|
AResult.State := dsError;
|
|
FLastExecwasTimeOut := True;
|
|
end;
|
|
if (ifeRecoveredTimedOut in Instr.ErrorFlags) then begin
|
|
// TODO: use feedback dialog
|
|
Result := True;
|
|
DoDbgEvent(ecDebugger, etDefault, Format(gdbmiTimeOutForCmd, [ACommand]));
|
|
DoTimeoutFeedback;
|
|
end;
|
|
finally
|
|
DoUnLockQueueExecuteForInstr;
|
|
Instr.ReleaseReference;
|
|
end;
|
|
|
|
if not Result
|
|
then begin
|
|
// either gdb did not return a Result Record: "^xxxx,"
|
|
// or the Result Record was not a known one: 'done', 'running', 'exit', 'error'
|
|
DebugLn(DBG_WARNINGS, '[WARNING] TGDBMIDebugger: ExecuteCommand "',ACommand,'" failed.');
|
|
SetDebuggerErrorState(ErrorStateMessage, ErrorStateInfo);
|
|
AResult.State := dsError;
|
|
end;
|
|
|
|
if (cfCheckError in AFlags) and (AResult.State = dsError)
|
|
then SetDebuggerErrorState(ErrorStateMessage, ErrorStateInfo);
|
|
|
|
if (cfCheckState in AFlags) and not (AResult.State in [dsError, dsNone])
|
|
then SetDebuggerState(AResult.State);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
|
|
const AValues: array of const; AFlags: TGDBMICommandFlags;
|
|
ATimeOut: Integer = -1): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Result := ExecuteCommand(ACommand, AValues, R, AFlags, ATimeOut);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ExecuteCommand(const ACommand: String;
|
|
const AValues: array of const; out AResult: TGDBMIExecResult;
|
|
AFlags: TGDBMICommandFlags = []; ATimeOut: Integer = -1): Boolean;
|
|
begin
|
|
Result := ExecuteCommand(Format(ACommand, AValues), AResult, AFlags, ATimeOut);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoTimeoutFeedback;
|
|
begin
|
|
if DebuggerProperties.WarnOnTimeOut
|
|
then MessageDlg('Warning', 'A timeout occurred, the debugger will try to continue, but further error may occur later',
|
|
mtWarning, [mbOK], 0);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ProcessGDBResultStruct(S: String;
|
|
Opts: TGDBMIProcessResultOpts): String;
|
|
|
|
function ProcessData(AData: String): String;
|
|
var
|
|
addr: TDBGPtr;
|
|
begin
|
|
Result := AData;
|
|
if (prStripAddressFromString in Opts) and GetLeadingAddr(Result, addr, True) then
|
|
if (Result = '') or not(Result[1] in ['''', '#']) then
|
|
Result := AData; // Restore address, not a string
|
|
|
|
if (Result <> '') and (Result[1] in ['''', '#']) and (prMakePrintAble in Opts) then
|
|
Result := MakePrintable(ProcessGDBResultText(Result, Opts + [prNoLeadingTab]));
|
|
end;
|
|
|
|
var
|
|
start, idx, len: Integer;
|
|
InQuote, InSingle, InValue: Boolean;
|
|
InStruct: Integer;
|
|
begin
|
|
Result := '';
|
|
InQuote := False; // "
|
|
InSingle := False; // '
|
|
InValue := False; // after "="
|
|
InStruct := 0;
|
|
len := Length(S);
|
|
start := 1;
|
|
idx := 1;
|
|
while idx <= len do begin
|
|
case S[idx] of
|
|
'"': begin // will be escaped if in single quotes
|
|
inc(idx);
|
|
InValue := False; // should never happen
|
|
if not InQuote then
|
|
Result := Result + copy(s, start, idx - start)
|
|
else
|
|
Result := Result + ProcessData(copy(s, start, idx - start - 1)) + '"';
|
|
InQuote := not InQuote;
|
|
start := idx;
|
|
end;
|
|
'\': begin
|
|
inc(idx,2);
|
|
end;
|
|
'''': begin
|
|
InSingle := not InSingle;
|
|
inc(idx);
|
|
end;
|
|
'=': begin
|
|
if (not (InQuote or InSingle)) and (InStruct > 0) and (idx > 1) and (idx < len) and
|
|
(S[idx-1] = ' ') and (S[idx+1] = ' ') then
|
|
begin
|
|
inc(idx, 2);
|
|
Result := Result + copy(s, start, idx - start);
|
|
start := idx;
|
|
InValue := True;
|
|
end
|
|
else
|
|
inc(idx);
|
|
end;
|
|
',': begin
|
|
if (not (InQuote or InSingle)) and InValue and (idx < len) and
|
|
(S[idx+1] = ' ')
|
|
then begin
|
|
Result := Result + ProcessData(copy(s, start, idx - start));
|
|
start := idx;
|
|
InValue := False;
|
|
end
|
|
else
|
|
inc(idx);
|
|
end;
|
|
'}': begin
|
|
if (not (InQuote or InSingle)) then begin
|
|
if InStruct > 0 then
|
|
dec(InStruct);
|
|
if InValue then begin
|
|
Result := Result + ProcessData(copy(s, start, idx - start));
|
|
start := idx;
|
|
end;
|
|
InValue := False;
|
|
end;
|
|
inc(idx);
|
|
end;
|
|
'{': begin
|
|
if (not (InQuote or InSingle)) then begin
|
|
inc(InStruct);
|
|
InValue := False;
|
|
end;
|
|
inc(idx);
|
|
end;
|
|
else begin
|
|
inc(idx);
|
|
end;
|
|
end;
|
|
end;
|
|
if idx > len then idx := len + 1;
|
|
if not InQuote then
|
|
Result := Result + copy(s, start, idx - start)
|
|
else
|
|
Result := Result + ProcessData(copy(s, start, idx - start - 1)) + '"';
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.ProcessGDBResultText(S: String;
|
|
Opts: TGDBMIProcessResultOpts = []): String;
|
|
var
|
|
Trailor: String;
|
|
n, len, idx: Integer;
|
|
v: Integer;
|
|
begin
|
|
|
|
// don't use ' as end terminator, there might be one as part of the text
|
|
// since ' will be the last char, simply strip it.
|
|
if not (prNOLeadingTab in Opts) then begin
|
|
S := GetPart(['\t'], [], S);
|
|
if (length(S) > 0) and (S[1] = ' ') then
|
|
delete(S,1,1);
|
|
end;
|
|
|
|
// Scan the string
|
|
len := Length(S);
|
|
// Set the resultstring initially to the same size
|
|
SetLength(Result, len);
|
|
n := 0;
|
|
idx := 1;
|
|
Trailor:='';
|
|
while idx <= len do
|
|
begin
|
|
case S[idx] of
|
|
'''': begin
|
|
Inc(idx);
|
|
// scan till end
|
|
while idx <= len do
|
|
begin
|
|
case S[idx] of
|
|
'''' : begin
|
|
Inc(idx);
|
|
if idx > len then Break;
|
|
if S[idx] <> '''' then Break;
|
|
end;
|
|
'\' : if not (prKeepBackSlash in Opts) then begin
|
|
Inc(idx);
|
|
if idx > len then Break;
|
|
case S[idx] of
|
|
't': S[idx] := #9;
|
|
'n': S[idx] := #10;
|
|
'r': S[idx] := #13;
|
|
end;
|
|
end;
|
|
end;
|
|
Inc(n);
|
|
Result[n] := S[idx];
|
|
Inc(idx);
|
|
end;
|
|
end;
|
|
'#': begin
|
|
Inc(idx);
|
|
v := 0;
|
|
// scan till non number (correct input is assumed)
|
|
while (idx <= len) and (S[idx] >= '0') and (S[idx] <= '9') do
|
|
begin
|
|
v := v * 10 + Ord(S[idx]) - Ord('0');
|
|
Inc(idx)
|
|
end;
|
|
Inc(n);
|
|
Result[n] := Chr(v and $FF);
|
|
end;
|
|
',', ' ': begin
|
|
Inc(idx); //ignore them;
|
|
end;
|
|
'<': begin
|
|
// Debugger has returned something like <repeats 10 times>
|
|
v := StrToIntDef(GetPart(['<repeats '], [' times>'], S), 0);
|
|
// Since we deleted the first part of S, reset idx
|
|
idx := 8; // the char after ' times>'
|
|
len := Length(S);
|
|
if v <= 1 then Continue;
|
|
|
|
// limit the amount of repeats
|
|
if v > 1000
|
|
then begin
|
|
Trailor := Trailor + Format('###(repeat truncated: %u -> 1000)###', [v]);
|
|
v := 1000;
|
|
end;
|
|
|
|
// make sure result has some room
|
|
SetLength(Result, Length(Result) + v - 1);
|
|
while v > 1 do begin
|
|
Inc(n);
|
|
Result[n] := Result[n - 1];
|
|
Dec(v);
|
|
end;
|
|
end;
|
|
else // Should not get here
|
|
// Debugger has returned something we don't know of
|
|
// Append the remainder to our parsed result
|
|
Delete(S, 1, idx - 1);
|
|
Trailor := Trailor + '###(gdb unparsed remainder:' + S + ')###';
|
|
Break;
|
|
end;
|
|
end;
|
|
SetLength(Result, n);
|
|
Result := Result + Trailor;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetStackDepth(MaxDepth: integer): Integer;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
Result := -1;
|
|
if (MaxDepth < 0) and (not ExecuteCommand('-stack-info-depth', R, [cfNoStackContext]))
|
|
then exit;
|
|
if (MaxDepth >= 0) and (not ExecuteCommand('-stack-info-depth %d', [MaxDepth], R, [cfNoStackContext]))
|
|
then exit;
|
|
if R.State = dsError
|
|
then exit;
|
|
|
|
List := TGDBMINameValueList.Create(R);
|
|
Result := StrToIntDef(List.Values['depth'], -1);
|
|
FreeAndNil(List);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.FindStackFrame(FP: TDBGPtr; StartAt,
|
|
MaxDepth: Integer): Integer;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
Cur, Prv: QWord;
|
|
CurContext: TGDBMICommandContext;
|
|
begin
|
|
// Result;
|
|
// -1 : Not found
|
|
// -2 : FP is outside stack
|
|
Result := StartAt;
|
|
Cur := 0;
|
|
List := TGDBMINameValueList.Create('');
|
|
try
|
|
CurContext := FContext;
|
|
FContext.StackContext := ccUseLocal;
|
|
repeat
|
|
FContext.StackFrame := Result;
|
|
|
|
if not ExecuteCommand('-data-evaluate-expression $fp', R)
|
|
or (R.State = dsError)
|
|
then begin
|
|
Result := -1;
|
|
break;
|
|
end;
|
|
|
|
List.Init(R.Values);
|
|
Prv := Cur;
|
|
Cur := StrToQWordDef(List.Values['value'], 0);
|
|
if Fp = Cur then begin
|
|
exit;
|
|
end;
|
|
|
|
if (Prv <> 0) and (Prv < Cur)
|
|
then begin
|
|
// FP is increasing
|
|
if FP < Prv
|
|
then begin
|
|
Result := -2;
|
|
exit;
|
|
end;
|
|
end;
|
|
if (Prv <> 0) and (Prv > Cur)
|
|
then begin
|
|
// FP is decreasing
|
|
if FP > Prv
|
|
then begin
|
|
Result := -2;
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
inc(Result);
|
|
until Result > MaxDepth;
|
|
|
|
Result := -1;
|
|
finally
|
|
List.Free;
|
|
FContext := CurContext;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetFrame(const AIndex: Integer): String;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
begin
|
|
Result := '';
|
|
if ExecuteCommand('-stack-list-frames %d %d', [AIndex, AIndex], R, [cfNoStackContext])
|
|
then begin
|
|
List := TGDBMINameValueList.Create(R, ['stack']);
|
|
Result := List.Values['frame'];
|
|
List.Free;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetText(const ALocation: TDBGPtr): String;
|
|
var
|
|
S: String;
|
|
begin
|
|
Str(ALocation, S);
|
|
Result := GetText(S, []);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetText(const AExpression: String;
|
|
const AValues: array of const): String;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
if not ExecuteCommand('x/s ' + AExpression, AValues, R, [],
|
|
DebuggerProperties.TimeoutForEval)
|
|
then begin
|
|
FLastExecResult.State := dsError;
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
Result := ProcessGDBResultText(StripLN(R.Values));
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetChar(const AExpression: String;
|
|
const AValues: array of const): String;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
if not ExecuteCommand('x/c ' + AExpression, AValues, R)
|
|
then begin
|
|
FLastExecResult.State := dsError;
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
Result := ProcessGDBResultText(StripLN(R.Values));
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetFloat(const AExpression: String;
|
|
const AValues: array of const): String;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
if not ExecuteCommand('x/f ' + AExpression, AValues, R)
|
|
then begin
|
|
Result := '';
|
|
Exit;
|
|
end;
|
|
Result := ProcessGDBResultText(StripLN(R.Values));
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetWideText(const ALocation: TDBGPtr): String;
|
|
|
|
function GetWideChar(const ALocation: TDBGPtr): WideChar;
|
|
var
|
|
Address, S: String;
|
|
R: TGDBMIExecResult;
|
|
begin
|
|
Str(ALocation, Address);
|
|
if not ExecuteCommand('x/uh' + Address, [], R)
|
|
then begin
|
|
Result := #0;
|
|
Exit;
|
|
end;
|
|
S := StripLN(R.Values);
|
|
S := GetPart(['\t'], [], S);
|
|
Result := WideChar(StrToIntDef(S, 0) and $FFFF);
|
|
end;
|
|
var
|
|
OneChar: WideChar;
|
|
CurLocation: TDBGPtr;
|
|
WStr: WideString;
|
|
begin
|
|
WStr := '';
|
|
CurLocation := ALocation;
|
|
repeat
|
|
OneChar := GetWideChar(CurLocation);
|
|
if OneChar <> #0 then
|
|
begin
|
|
WStr := WStr + OneChar;
|
|
CurLocation := CurLocation + 2;
|
|
end;
|
|
until (OneChar = #0) or (Length(WStr) > DebuggerProperties.MaxDisplayLengthForString);
|
|
Result := UTF16ToUTF8(WStr);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetGDBTypeInfo(const AExpression: String;
|
|
FullTypeInfo: Boolean; AFlags: TGDBTypeCreationFlags; AFormat: TWatchDisplayFormat;
|
|
ARepeatCount: Integer): TGDBType;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
f: Boolean;
|
|
AReq: PGDBPTypeRequest;
|
|
CReq: TGDBPTypeRequest;
|
|
i: Integer;
|
|
begin
|
|
(* Analyze what type is in AExpression
|
|
* "whatis AExpr"
|
|
This return the declared type of the expression (as in the pascal source)
|
|
- The type may be replaced:
|
|
- type TAlias = TOriginal; // TAlias may be reported as TOriginal
|
|
type TAlias = type TOriginal; // Not guranteed, but not likely to be replaced
|
|
// This leaves room for arbitraty names for all types
|
|
- ^TFoo may be replaced by PFF, if PFF exist and is ^TFoo (seen with stabs, not dwarf)
|
|
- The type may be prefixed by "&" for var param under dwarf (an fpc workaround)
|
|
Under dwarf var param are hnadled by gdb, if casted or part of an expression,
|
|
but not if standalone or dereferred ("^") only
|
|
Under stabs "var param" have no indications, but are completely and correctly
|
|
handled by gdb
|
|
|
|
* ptype TheWhatisType
|
|
Should return the base type info
|
|
Since under dwarf classes are always pointers (again work in expression,
|
|
but not standalone); a further "whatis" on the declared-type may be needed,
|
|
to check if the type is a pointer or not.
|
|
This may be limited, if types are strongly aliased over several levels...
|
|
|
|
* tfClassIsPointer in TargetFlags
|
|
usually true for dwarf, false for stabs. Can be detected with "ptype TObject"
|
|
Dwarf:
|
|
"ptype TObject" => ~"type = ^TOBJECT = class \n"
|
|
Stabs:
|
|
"ptype TObject" => ~ ~"type = TOBJECT = class \n"
|
|
|
|
* Examples
|
|
* Type-info for objects
|
|
TFoo = Tobject; PFoo = ^TFoo;
|
|
ArgTFoo: TFoo; ArgPFoo: PFoo
|
|
Dwarf:
|
|
"whatis ArgTFoo\n" => ~"type = TFOO\n" (for var-param ~"type = &TFOO\n")
|
|
"ptype TFoo\n" => ~"type = ^TFOO = class : public TOBJECT \n"
|
|
|
|
whatis ArgPFoo\n" => ~"type = PFOO\n"
|
|
"ptype PFoo\n" => ~"type = ^TFOO = class : public TOBJECT \n"
|
|
|
|
// ptype is the same for TFoo and PFoo, so we need to find out if any is a pointer:
|
|
// they both have "^", but PFoo does not have "= class"
|
|
// (this may fial if pfoo is an alias for yet another name)
|
|
"whatis TFoo\n" => ~"type = ^TFOO = class \n"
|
|
"whatis PFoo\n" => ~"type = ^TFOO\n"
|
|
|
|
Stabs:
|
|
"whatis ArgTFoo\n" => ~"type = TFOO\n" (same vor var param)
|
|
"ptype TFoo\n" => ~"type = TFOO = class : public TOBJECT \n"
|
|
|
|
"whatis ArgPFoo\n" => ~"type = PFOO\n"
|
|
ptype PFoo\n" => ~"type = ^TFOO = class : public TOBJECT \n"
|
|
|
|
// ptype gives desired info in stabs (and whatis, does not reveal anything)
|
|
"whatis TFoo\n" => ~"type = TFOO\n"
|
|
"whatis PFoo\n" => ~"type = PFOO\n"
|
|
|
|
Limitations: Under Mac gdb 6.3.50 "whatis" does not work on types.
|
|
The info can not be obtained (with Dwarf: PFoo will be treated the same as TFoo)
|
|
*
|
|
|
|
*)
|
|
|
|
if tfClassIsPointer in TargetInfo^.TargetFlags
|
|
then AFlags := AFlags + [gtcfClassIsPointer];
|
|
if FullTypeInfo
|
|
then AFlags := AFlags + [gtcfFullTypeInfo];
|
|
Result := TGdbType.CreateForExpression(AExpression, AFlags, wdfDefault, ARepeatCount);
|
|
while not Result.ProcessExpression do begin
|
|
if Result.EvalError
|
|
then break;
|
|
AReq := Result.EvalRequest;
|
|
while AReq <> nil do begin
|
|
if (dcsCanceled in SeenStates) then begin
|
|
FreeAndNil(Result);
|
|
exit;
|
|
end;
|
|
|
|
i := FTheDebugger.FTypeRequestCache.IndexOf(ContextThreadId, ContextStackFrame, AReq^);
|
|
if i >= 0 then begin
|
|
debugln(DBGMI_QUEUE_DEBUG, ['DBG TypeRequest-Cache: Found entry for T=', ContextThreadId,
|
|
' F=', ContextStackFrame, ' R="', AReq^.Request,'"']);
|
|
CReq := FTheDebugger.FTypeRequestCache.Request[i];
|
|
AReq^.Result := CReq.Result;
|
|
AReq^.Error := CReq.Error;
|
|
end
|
|
else begin
|
|
f := ExecuteCommand(AReq^.Request, R);
|
|
if f and (R.State <> dsError) then begin
|
|
if AReq^.ReqType = gcrtPType
|
|
then AReq^.Result := ParseTypeFromGdb(R.Values)
|
|
else begin
|
|
AReq^.Result.GdbDescription := R.Values;
|
|
AReq^.Result.Kind := ptprkSimple;
|
|
end;
|
|
end
|
|
else begin
|
|
AReq^.Result.GdbDescription := R.Values;
|
|
AReq^.Error := R.Values;
|
|
end;
|
|
|
|
FTheDebugger.FTypeRequestCache.Add(ContextThreadId, ContextStackFrame, AReq^);
|
|
end;
|
|
|
|
AReq := AReq^.Next;
|
|
end;
|
|
end;
|
|
|
|
if Result.EvalError then begin
|
|
FreeAndNil(Result);
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetClassName(const AClass: TDBGPtr): String;
|
|
var
|
|
S: String;
|
|
begin
|
|
// format has a problem with %u, so use Str for it
|
|
Str(AClass, S);
|
|
Result := GetClassName(S, []);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetClassName(const AExpression: String;
|
|
const AValues: array of const): String;
|
|
var
|
|
OK: Boolean;
|
|
S: String;
|
|
R: TGDBMIExecResult;
|
|
ResultList: TGDBMINameValueList;
|
|
UseShortString: Boolean;
|
|
i: Integer;
|
|
begin
|
|
Result := '';
|
|
UseShortString := False;
|
|
|
|
if dfImplicidTypes in FTheDebugger.DebuggerFlags
|
|
then begin
|
|
S := Format(AExpression, AValues);
|
|
UseShortString := tfFlagHasTypeShortstring in TargetInfo^.TargetFlags;
|
|
if UseShortString
|
|
then s := Format('^^shortstring(%s+%d)^^', [S, TargetInfo^.TargetPtrSize * 3])
|
|
else s := Format('^^char(%s+%d)^', [S, TargetInfo^.TargetPtrSize * 3]);
|
|
OK := ExecuteCommand('-data-evaluate-expression %s',
|
|
[S], R);
|
|
if (not OK) or (LastExecResult.State = dsError)
|
|
or (pos('value="#0', LastExecResult.Values) > 0)
|
|
then begin
|
|
OK := ExecuteCommand('-data-evaluate-expression ^char(^pointer(%s+%d)^)',
|
|
[S, TargetInfo^.TargetPtrSize * 3], R);
|
|
UseShortString := False;
|
|
end;
|
|
end
|
|
else begin
|
|
UseShortString := True;
|
|
Str(TDbgPtr(GetData(AExpression + '+12', AValues)), S);
|
|
OK := ExecuteCommand('-data-evaluate-expression pshortstring(%s)^', [S], R);
|
|
end;
|
|
|
|
if OK
|
|
then begin
|
|
ResultList := TGDBMINameValueList.Create(R);
|
|
S := ResultList.Values['value'];
|
|
if UseShortString then begin
|
|
Result := GetPart('''', '''', S);
|
|
end
|
|
else begin
|
|
s := ParseGDBString(s);
|
|
if s <> ''
|
|
then i := ord(s[1])
|
|
else i := 1;
|
|
if i <= length(s)-1 then begin
|
|
Result := copy(s, 2, i);
|
|
end
|
|
else begin
|
|
// fall back
|
|
S := DeleteEscapeChars(S);
|
|
Result := GetPart('''', '''', S);
|
|
end;
|
|
end;
|
|
|
|
ResultList.Free;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetInstanceClassName(const AInstance: TDBGPtr): String;
|
|
var
|
|
S: String;
|
|
begin
|
|
Str(AInstance, S);
|
|
Result := GetInstanceClassName(S, []);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetInstanceClassName(const AExpression: String;
|
|
const AValues: array of const): String;
|
|
begin
|
|
if dfImplicidTypes in FTheDebugger.DebuggerFlags
|
|
then begin
|
|
Result := GetClassName('^' + PointerTypeCast + '(' + AExpression + ')^', AValues);
|
|
end
|
|
else begin
|
|
Result := GetClassName(GetData(AExpression, AValues));
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetData(const ALocation: TDbgPtr): TDbgPtr;
|
|
var
|
|
S: String;
|
|
begin
|
|
Str(ALocation, S);
|
|
Result := GetData(S, []);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetData(const AExpression: String;
|
|
const AValues: array of const): TDbgPtr;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
e: Integer;
|
|
begin
|
|
Result := 0;
|
|
if ExecuteCommand('x/d ' + AExpression, AValues, R)
|
|
then Val(StripLN(GetPart('\t', '', R.Values)), Result, e);
|
|
if e=0 then ;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetStrValue(const AExpression: String;
|
|
const AValues: array of const): String;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
ResultList: TGDBMINameValueList;
|
|
begin
|
|
if ExecuteCommand('-data-evaluate-expression %s', [Format(AExpression, AValues)], R)
|
|
then begin
|
|
ResultList := TGDBMINameValueList.Create(R);
|
|
Result := DeleteEscapeChars(ResultList.Values['value']);
|
|
ResultList.Free;
|
|
end
|
|
else Result := '';
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetIntValue(const AExpression: String;
|
|
const AValues: array of const): Integer;
|
|
var
|
|
e: Integer;
|
|
begin
|
|
Result := 0;
|
|
Val(GetStrValue(AExpression, AValues), Result, e);
|
|
if e=0 then ;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.GetPtrValue(const AExpression: String;
|
|
const AValues: array of const; ConvertNegative: Boolean = False): TDbgPtr;
|
|
var
|
|
e: Integer;
|
|
i: Int64;
|
|
s: String;
|
|
begin
|
|
Result := 0;
|
|
s := GetStrValue(AExpression, AValues);
|
|
if (s <> '') and (s[1] = '-')
|
|
then begin
|
|
Val(s, i, e);
|
|
Result := TDBGPtr(i);
|
|
end
|
|
else Val(s, Result, e);
|
|
if e=0 then ;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.CheckHasType(TypeName: String;
|
|
TypeFlag: TGDBMITargetFlag): TGDBMIExecResult;
|
|
begin
|
|
if not ExecuteCommand('ptype %s', [TypeName], Result, [], DebuggerProperties.TimeoutForEval) then begin
|
|
Result.State := dsError;
|
|
exit;
|
|
end;
|
|
if (LeftStr(Result.Values, 6) = 'type =') then
|
|
include(TargetInfo^.TargetFlags, TypeFlag);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.PointerTypeCast: string;
|
|
begin
|
|
if tfFlagHasTypePointer in TargetInfo^.TargetFlags
|
|
then Result := 'POINTER'
|
|
// TODO: check dfImplicidTypes support?
|
|
else if tfFlagHasTypeByte in TargetInfo^.TargetFlags
|
|
then Result := '^byte'
|
|
else Result := '^char';
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.FrameToLocation(const AFrame: String): TDBGLocationRec;
|
|
var
|
|
S: String;
|
|
e: Integer;
|
|
Frame: TGDBMINameValueList;
|
|
begin
|
|
// Do we have a frame ?
|
|
if AFrame = ''
|
|
then S := GetFrame(0)
|
|
else S := AFrame;
|
|
|
|
Frame := TGDBMINameValueList.Create(S);
|
|
|
|
Result.Address := 0;
|
|
Val(Frame.Values['addr'], Result.Address, e);
|
|
if e=0 then ;
|
|
Result.FuncName := Frame.Values['func'];
|
|
Result.SrcFile := ConvertGdbPathAndFile(Frame.Values['file']);
|
|
Result.SrcFullName := ConvertGdbPathAndFile(Frame.Values['fullname']);
|
|
Result.SrcLine := StrToIntDef(Frame.Values['line'], -1);
|
|
|
|
Frame.Free;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.ProcessFrame(ALocation: TDBGLocationRec;
|
|
ASeachStackForSource: Boolean);
|
|
begin
|
|
// TODO: process stack in gdbmi debugger // currently: signal IDE
|
|
if (not ASeachStackForSource) and (ALocation.SrcLine < 0) then
|
|
ALocation.SrcLine := -2;
|
|
FTheDebugger.DoCurrent(ALocation); // TODO: only selected callers
|
|
FTheDebugger.FCurrentLocation := ALocation;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.ProcessFrame(const AFrame: String;
|
|
ASeachStackForSource: Boolean);
|
|
var
|
|
Location: TDBGLocationRec;
|
|
begin
|
|
Location := FrameToLocation(AFrame);
|
|
ProcessFrame(Location, ASeachStackForSource);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoDbgEvent(const ACategory: TDBGEventCategory;
|
|
const AEventType: TDBGEventType; const AText: String);
|
|
begin
|
|
FTheDebugger.DoDbgEvent(ACategory, AEventType, AText);
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommand.Create(AOwner: TGDBMIDebugger);
|
|
begin
|
|
FQueueRunLevel := -1;
|
|
FState := dcsNone;
|
|
FTheDebugger := AOwner;
|
|
FContext.StackContext := ccUseGlobal;
|
|
FContext.ThreadContext := ccUseGlobal;
|
|
FDefaultTimeOut := -1;
|
|
FPriority := 0;
|
|
FProperties := [];
|
|
AddReference; // internal reference
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommand.Destroy;
|
|
begin
|
|
if assigned(FOnDestroy)
|
|
then FOnDestroy(Self);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoQueued;
|
|
begin
|
|
SetCommandState(dcsQueued);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.DoFinished;
|
|
begin
|
|
SetCommandState(dcsFinished);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.Execute: Boolean;
|
|
begin
|
|
// Set the state first, so DoExecute can set an error-state
|
|
SetCommandState(dcsExecuting);
|
|
AddReference;
|
|
DoLockQueueExecute;
|
|
try
|
|
Result := DoExecute;
|
|
DoOnExecuted;
|
|
except
|
|
|
|
On E: Exception do FTheDebugger.DoUnknownException(Self, E)
|
|
else
|
|
debugln(['ERROR: Exception occurred in ',ClassName+'.DoExecute ',
|
|
'" Addr=', dbgs(ExceptAddr), ' Dbg.State=', dbgs(FTheDebugger.State)]);
|
|
end;
|
|
// No re-raise in the except block. So no try-finally required
|
|
DoUnLockQueueExecute;
|
|
ReleaseReference;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommand.Cancel;
|
|
begin
|
|
debugln(DBGMI_QUEUE_DEBUG, ['Canceling: "', DebugText,'"']);
|
|
FTheDebugger.UnQueueCommand(Self);
|
|
DoCancel;
|
|
DoOnCanceled;
|
|
SetCommandState(dcsCanceled);
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.KillNow: Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommand.DebugText: String;
|
|
begin
|
|
Result := ClassName;
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandList }
|
|
|
|
function TGDBMIDebuggerCommandList.Get(Index: Integer): TGDBMIDebuggerCommand;
|
|
begin
|
|
Result := TGDBMIDebuggerCommand(inherited Items[Index]);
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandList.Put(Index: Integer; const AValue: TGDBMIDebuggerCommand);
|
|
begin
|
|
inherited Items[Index] := AValue;
|
|
end;
|
|
|
|
{ TGDBMIInternalBreakPoint }
|
|
|
|
procedure TGDBMIInternalBreakPoint.Clear(ACmd: TGDBMIDebuggerCommand;
|
|
ALoc: TInternalBreakLocation; ABlock: TBlockOpt);
|
|
begin
|
|
if (FBreaks[ALoc].BreakGdbId = -2) and (ABlock <> boUnblock) then exit;
|
|
if (FBreaks[ALoc].BreakGdbId = -1) then exit;
|
|
|
|
if (FBreaks[ALoc].BreakGdbId >= 0) then
|
|
ACmd.ExecuteCommand('-break-delete %d', [FBreaks[ALoc].BreakGdbId], [cfCheckError]);
|
|
if ABlock = boBlock then
|
|
FBreaks[ALoc].BreakGdbId := -2
|
|
else
|
|
FBreaks[ALoc].BreakGdbId := -1;
|
|
|
|
FBreaks[ALoc].BreakAddr := 0;
|
|
FBreaks[ALoc].BreakFunction := '';
|
|
FBreaks[ALoc].BreakFile := '';
|
|
FBreaks[ALoc].BreakLine := '';
|
|
|
|
FEnabled := FEnabled and IsBreakSet;
|
|
|
|
if ALoc = iblAddrOfNamed then FMainAddrFound := 0;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.BreakSet(ACmd: TGDBMIDebuggerCommand; ABreakLoc: String;
|
|
ALoc: TInternalBreakLocation; AClearIfSet: TClearOpt): Boolean;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
ResultList: TGDBMINameValueList;
|
|
begin
|
|
Result := True; // true, if already set (dsError does not matter)
|
|
if ACmd.DebuggerState = dsError then exit;
|
|
|
|
if AClearIfSet = coClearIfSet then
|
|
Clear(ACmd, ALoc); // keeps blocked indicator
|
|
if FBreaks[ALoc].BreakGdbId <> -1 then exit; // not(set or blocked)
|
|
|
|
FBreaks[ALoc].BreakGdbId := -1;
|
|
FBreaks[ALoc].BreakAddr := 0;
|
|
FBreaks[ALoc].BreakFunction := '';
|
|
|
|
if UseForceFlag and (dfForceBreak in ACmd.FTheDebugger.FDebuggerFlags) then
|
|
begin
|
|
if (not ACmd.ExecuteCommand('-break-insert -f %s', [ABreakLoc], R)) or
|
|
(R.State = dsError)
|
|
then
|
|
ACmd.ExecuteCommand('-break-insert %s', [ABreakLoc], R);
|
|
end
|
|
else
|
|
ACmd.ExecuteCommand('-break-insert %s', [ABreakLoc], R);
|
|
Result := R.State <> dsError;
|
|
if not Result then exit;
|
|
FEnabled := True; // TODO: What if some bp are disabled?
|
|
|
|
ResultList := TGDBMINameValueList.Create(R, ['bkpt']);
|
|
FBreaks[ALoc].BreakGdbId := StrToIntDef(ResultList.Values['number'], -1);
|
|
FBreaks[ALoc].BreakAddr := StrToQWordDef(ResultList.Values['addr'], 0);
|
|
FBreaks[ALoc].BreakFunction := ResultList.Values['func'];
|
|
FBreaks[ALoc].BreakFile := ResultList.Values['fullname'];
|
|
if FBreaks[ALoc].BreakFile = '' then
|
|
FBreaks[ALoc].BreakFile := ResultList.Values['file'];
|
|
FBreaks[ALoc].BreakLine := ResultList.Values['line'];
|
|
ResultList.Free;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.GetBreakAddr(ALoc: TInternalBreakLocation): TDBGPtr;
|
|
begin
|
|
Result := FBreaks[ALoc].BreakAddr;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.GetBreakFile(ALoc: TInternalBreakLocation): String;
|
|
begin
|
|
Result := FBreaks[ALoc].BreakFile;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.GetBreakId(ALoc: TInternalBreakLocation): Integer;
|
|
begin
|
|
Result := FBreaks[ALoc].BreakGdbId;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.GetBreakLine(ALoc: TInternalBreakLocation): String;
|
|
begin
|
|
Result := FBreaks[ALoc].BreakLine;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.GetInfoAddr(ACmd: TGDBMIDebuggerCommand): TDBGPtr;
|
|
var
|
|
R: TGDBMIExecResult;
|
|
S: String;
|
|
begin
|
|
Result := FMainAddrFound;
|
|
if Result <> 0 then
|
|
exit;
|
|
if ACmd.DebuggerState = dsError then Exit;
|
|
if (not ACmd.ExecuteCommand('info address ' + FName, R)) or
|
|
(R.State = dsError)
|
|
then exit;
|
|
S := GetPart(['at address ', ' at '], ['.', ' '], R.Values);
|
|
if S <> '' then
|
|
Result := StrToQWordDef(S, 0);
|
|
FMainAddrFound := Result;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.HasBreakAtAddr(AnAddr: TDBGPtr): Boolean;
|
|
var
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
Result := True;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
if (FBreaks[i].BreakGdbId >= 0) and (FBreaks[i].BreakAddr = AnAddr) then
|
|
exit;
|
|
Result := False;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.HasBreakWithId(AnId: Integer): Boolean;
|
|
var
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
Result := True;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
if (FBreaks[i].BreakGdbId = AnId) then
|
|
exit;
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.InternalSetAddr(ACmd: TGDBMIDebuggerCommand;
|
|
ALoc: TInternalBreakLocation; AnAddr: TDBGPtr);
|
|
begin
|
|
if (AnAddr = 0) or HasBreakAtAddr(AnAddr) then // HasBreakAddr includes this BP being allready at AnAddr.
|
|
exit;
|
|
|
|
// Always ClearIfSet since the address changed
|
|
BreakSet(ACmd, Format('*%u', [AnAddr]), ALoc, coClearIfSet);
|
|
end;
|
|
|
|
constructor TGDBMIInternalBreakPoint.Create(AName: string);
|
|
var
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
FMainAddrFound := 0;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do begin
|
|
FBreaks[i].BreakGdbId := -1;
|
|
FBreaks[i].BreakAddr := 0;
|
|
end;
|
|
FUseForceFlag := False;
|
|
FName := AName;
|
|
FEnabled := False;
|
|
end;
|
|
|
|
(* Using -insert-break with a function name allows GDB to adjust the address
|
|
to be behind the functions initialization.
|
|
Which means values passed by register may no longer be accessible.
|
|
Therefore we determine the address and force the breakpoint to it.
|
|
This does not work for position independent executables (PIE), if the
|
|
breakpoint is set before the application is run, because the real address
|
|
is only known at run time.
|
|
Therefore during startup a named break point is used as fallback.
|
|
*)
|
|
procedure TGDBMIInternalBreakPoint.SetBoth(ACmd: TGDBMIDebuggerCommand);
|
|
begin
|
|
if not BreakSet(ACmd, FName, iblNamed, coKeepIfSet) then exit;
|
|
|
|
if FBreaks[iblAddrOfNamed].BreakGdbId = -2 then exit;
|
|
// Try to retrieve the address of the procedure
|
|
InternalSetAddr(ACmd, iblAddrOfNamed, GetInfoAddr(ACmd));
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.SetByName(ACmd: TGDBMIDebuggerCommand);
|
|
begin
|
|
BreakSet(ACmd, FName, iblNamed, coKeepIfSet);
|
|
// keep others
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.SetByAddr(ACmd: TGDBMIDebuggerCommand; SetNamedOnFail: Boolean = False);
|
|
begin
|
|
if FBreaks[iblAddrOfNamed].BreakGdbId <> -2 then
|
|
InternalSetAddr(ACmd, iblAddrOfNamed, GetInfoAddr(ACmd));
|
|
|
|
// SetNamedOnFail includes if blocked
|
|
If SetNamedOnFail and (FBreaks[iblNamed].BreakGdbId < 0) then
|
|
BreakSet(ACmd, FName, iblNamed, coKeepIfSet);
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.SetAtCustomAddr(ACmd: TGDBMIDebuggerCommand; AnAddr: TDBGPtr);
|
|
begin
|
|
InternalSetAddr(ACmd, iblCustomAddr, AnAddr);
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.SetAtLineOffs(ACmd: TGDBMIDebuggerCommand; AnOffset: integer);
|
|
begin
|
|
// always clear, and set again
|
|
if AnOffset < 0 then
|
|
BreakSet(ACmd, Format('%d', [AnOffset]), iblAddOffset, coClearIfSet)
|
|
else
|
|
BreakSet(ACmd, Format('+%d', [AnOffset]), iblAddOffset, coClearIfSet);
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.SetAtFileLine(ACmd: TGDBMIDebuggerCommand; AFile,
|
|
ALine: String);
|
|
begin
|
|
AFile := StringReplace(AFile, '\', '/', [rfReplaceAll]);
|
|
BreakSet(ACmd, Format(' "\"%s\":%s"', [AFile, ALine]), iblFileLine, coKeepIfSet);
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.Clear(ACmd: TGDBMIDebuggerCommand);
|
|
var
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
if ACmd.DebuggerState = dsError then Exit;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
Clear(ACmd, i, boUnblock);
|
|
FEnabled := False;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.ClearId(ACmd: TGDBMIDebuggerCommand; AnId: Integer): Boolean;
|
|
var
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
Result := False;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
if (AnId = FBreaks[i].BreakGdbId) then begin
|
|
Clear(ACmd, i);
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.ClearAndBlockId(ACmd: TGDBMIDebuggerCommand;
|
|
AnId: Integer): Boolean;
|
|
var
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
Result := False;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
if (AnId = FBreaks[i].BreakGdbId) then begin
|
|
Clear(ACmd, i, boBlock);
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.MatchAddr(AnAddr: TDBGPtr): boolean;
|
|
begin
|
|
Result := (AnAddr <> 0) and HasBreakAtAddr(AnAddr);
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.MatchId(AnId: Integer): boolean;
|
|
begin
|
|
Result := (AnId >= 0) and HasBreakWithId(AnId);
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.IsBreakSet: boolean;
|
|
begin
|
|
Result := BreakSetCount > 0;
|
|
end;
|
|
|
|
function TGDBMIInternalBreakPoint.BreakSetCount: Integer;
|
|
var
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
Result := 0;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
if (FBreaks[i].BreakGdbId >= 0) then
|
|
inc(Result);
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.EnableOrSetByAddr(ACmd: TGDBMIDebuggerCommand;
|
|
SetNamedOnFail: Boolean);
|
|
begin
|
|
if IsBreakSet then
|
|
Enable(ACmd)
|
|
else
|
|
SetByAddr(ACmd, SetNamedOnFail);
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.Enable(ACmd: TGDBMIDebuggerCommand);
|
|
var
|
|
R: TGDBMIExecResult;
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
if FEnabled then exit;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
if FBreaks[i].BreakGdbId >= 0 then begin
|
|
ACmd.ExecuteCommand('-break-enable %d', [FBreaks[i].BreakGdbId], R);
|
|
FEnabled := True;
|
|
end;
|
|
end;
|
|
|
|
procedure TGDBMIInternalBreakPoint.Disable(ACmd: TGDBMIDebuggerCommand);
|
|
var
|
|
R: TGDBMIExecResult;
|
|
i: TInternalBreakLocation;
|
|
begin
|
|
if not FEnabled then exit;
|
|
FEnabled := False;
|
|
for i := low(TInternalBreakLocation) to high(TInternalBreakLocation) do
|
|
if FBreaks[i].BreakGdbId >= 0 then
|
|
ACmd.ExecuteCommand('-break-disable %d', [FBreaks[i].BreakGdbId], R);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerSimpleCommand }
|
|
|
|
constructor TGDBMIDebuggerSimpleCommand.Create(AOwner: TGDBMIDebugger;
|
|
const ACommand: String; const AValues: array of const; const AFlags: TGDBMICommandFlags;
|
|
const ACallback: TGDBMICallback; const ATag: PtrInt);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FCommand := Format(ACommand, AValues);
|
|
FFlags := AFlags;
|
|
FCallback := ACallback;
|
|
FTag := ATag;
|
|
FResult.Values := '';
|
|
FResult.State := dsNone;
|
|
FResult.Flags := [];
|
|
end;
|
|
|
|
function TGDBMIDebuggerSimpleCommand.DebugText: String;
|
|
begin
|
|
Result := Format('%s: %s', [ClassName, FCommand]);
|
|
end;
|
|
|
|
function TGDBMIDebuggerSimpleCommand.DoExecute: Boolean;
|
|
begin
|
|
Result := True;
|
|
if not ExecuteCommand(FCommand, FResult, FFlags)
|
|
then exit;
|
|
|
|
if (FResult.State <> dsNone)
|
|
and not (cfscIgnoreState in FFlags)
|
|
and ((FResult.State <> dsError) or not (cfscIgnoreError in FFlags))
|
|
then SetDebuggerState(FResult.State);
|
|
|
|
if Assigned(FCallback)
|
|
then FCallback(FResult, FTag);
|
|
end;
|
|
|
|
{ TGDBMIDebuggerCommandEvaluate }
|
|
|
|
function TGDBMIDebuggerCommandEvaluate.GetTypeInfo: TGDBType;
|
|
begin
|
|
Result := FTypeInfo;
|
|
// if the command wasn't executed, typeinfo may still get set, and need auto-destroy
|
|
FTypeInfoAutoDestroy := FTypeInfo = nil;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandEvaluate.DoWatchFreed(Sender: TObject);
|
|
begin
|
|
debugln(DBGMI_QUEUE_DEBUG, ['DoWatchFreed: ', DebugText]);
|
|
FWatchValue := nil;
|
|
Cancel;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandEvaluate.DoLockQueueExecute;
|
|
begin
|
|
FLockFlag := FWatchValue = nil;
|
|
//if FLockFlag then
|
|
// inherited DoLockQueueExecute;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandEvaluate.DoUnLockQueueExecute;
|
|
begin
|
|
//if FLockFlag then
|
|
// inherited DoUnLockQueueExecute;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandEvaluate.DoLockQueueExecuteForInstr;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandEvaluate.DoUnLockQueueExecuteForInstr;
|
|
begin
|
|
//
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandEvaluate.DoExecute: Boolean;
|
|
var
|
|
TypeInfoFlags: TGDBTypeCreationFlags;
|
|
|
|
function FormatResult(const AInput: String; IsArray: Boolean = False): String;
|
|
const
|
|
INDENTSTRING = ' ';
|
|
var
|
|
Indent: String;
|
|
i: Integer;
|
|
InStr: Boolean;
|
|
InBrackets, InRounds: Integer;
|
|
Limit: Integer;
|
|
Skip: Integer;
|
|
begin
|
|
Indent := '';
|
|
Skip := 0;
|
|
InStr := False;
|
|
InBrackets := 0;
|
|
InRounds := 0;
|
|
Limit := Length(AInput);
|
|
Result := '';
|
|
|
|
for i := 1 to Limit do
|
|
begin
|
|
if Skip>0
|
|
then begin
|
|
Dec(SKip);
|
|
Continue;
|
|
end;
|
|
|
|
if AInput[i] in [#10, #13]
|
|
then begin
|
|
//Removes unneeded LineEnding.
|
|
Continue;
|
|
end;
|
|
|
|
Result := Result + AInput[i];
|
|
if InStr
|
|
then begin
|
|
InStr := AInput[i] <> '''';
|
|
Continue;
|
|
end;
|
|
|
|
if InBrackets > 0
|
|
then begin
|
|
if AInput[i] = ']' then
|
|
dec(InBrackets);
|
|
Continue;
|
|
end;
|
|
|
|
case AInput[i] of
|
|
'[': begin
|
|
inc(InBrackets);
|
|
end;
|
|
'(': begin
|
|
inc(InRounds);
|
|
end;
|
|
')': begin
|
|
if InRounds > 0 then
|
|
dec(InRounds);
|
|
end;
|
|
'''': begin
|
|
InStr:=true;
|
|
end;
|
|
'{': begin
|
|
if (i < Limit) and (AInput[i+1] <> '}')
|
|
then begin
|
|
Indent := Indent + INDENTSTRING;
|
|
if (not IsArray) or (InRounds = 0) then
|
|
Result := Result + LineEnding + Indent;
|
|
end;
|
|
end;
|
|
'}': begin
|
|
if (i > 1) and (AInput[i-1] <> '{') and
|
|
((not IsArray) or (InRounds = 0))
|
|
then Delete(Indent, 1, Length(INDENTSTRING));
|
|
end;
|
|
' ': begin
|
|
if ((i > 1) and (AInput[i-1] = ',')) and
|
|
( (not IsArray) or
|
|
((Indent = '') and (InRounds <= 1)) or
|
|
((Indent = INDENTSTRING) and (InRounds = 0))
|
|
)
|
|
then Result := Result + LineEnding + Indent;
|
|
end;
|
|
'0': begin
|
|
if (i > 4) and (i < Limit - 2)
|
|
then begin
|
|
//Pascalize pointers "Var = 0x12345 => Var = $12345"
|
|
if (AInput[i-3] = ' ')
|
|
and (AInput[i-2] = '=')
|
|
and (AInput[i-1] = ' ')
|
|
and (AInput[i+1] = 'x')
|
|
then begin
|
|
Skip := 1;
|
|
Result[Length(Result)] := '$';
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
end;
|
|
|
|
function WhichIsFirst(const ASource: String; const ASearchable: array of Char): Integer;
|
|
var
|
|
j, k: Integer;
|
|
InString: Boolean;
|
|
begin
|
|
InString := False;
|
|
for j := 1 to Length(ASource) do
|
|
begin
|
|
if ASource[j] = '''' then InString := not InString;
|
|
if InString then Continue;
|
|
|
|
for k := Low(ASearchable) to High(ASearchable) do
|
|
begin
|
|
if ASource[j] = ASearchable[k] then Exit(j);
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function SkipPairs(var ASource: String; const ABeginChar: Char; const AEndChar: Char): String;
|
|
var
|
|
Deep,j: SizeInt;
|
|
InString: Boolean;
|
|
begin
|
|
DebugLn(DBG_VERBOSE, '->->', ASource);
|
|
Deep := 0;
|
|
InString := False;
|
|
|
|
for j := 1 to Length(ASource) do
|
|
begin
|
|
if ASource[j]='''' then InString := not InString;
|
|
if InString then Continue;
|
|
|
|
if ASource[j] = ABeginChar
|
|
then begin
|
|
Inc(Deep)
|
|
end
|
|
else begin
|
|
if ASource[j] = AEndChar
|
|
then Dec(Deep);
|
|
end;
|
|
|
|
if Deep=0
|
|
then begin
|
|
Result := Copy(ASource, 1, j);
|
|
ASource := Copy(ASource, j + 1, Length(ASource) - j);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function IsHexC(const ASource: String): Boolean;
|
|
begin
|
|
if Length(ASource) <= 2 then Exit(False);
|
|
if ASource[1] <> '0' then Exit(False);
|
|
Result := ASource[2] = 'x';
|
|
end;
|
|
|
|
function HexCToHexPascal(const ASource: String; MinChars: Byte = 0): String;
|
|
var
|
|
Zeros: String;
|
|
begin
|
|
if IsHexC(Asource)
|
|
then begin
|
|
Result := Copy(ASource, 3, Length(ASource) - 2);
|
|
if Length(Result) < MinChars then
|
|
begin
|
|
SetLength(Zeros, MinChars - Length(Result));
|
|
FillChar(Zeros[1], Length(Zeros), '0');
|
|
Result := Zeros + Result;
|
|
end;
|
|
Result := '$' + Result;
|
|
end
|
|
else Result := ASource;
|
|
end;
|
|
|
|
procedure PutValuesInTypeRecord(const AType: TDBGType; const ATextInfo: String);
|
|
var
|
|
GDBParser: TGDBStringIterator;
|
|
Payload: String;
|
|
Composite: Boolean;
|
|
StopChar: Char;
|
|
j: Integer;
|
|
begin
|
|
GDBParser := TGDBStringIterator.Create(ATextInfo);
|
|
GDBParser.ParseNext(Composite, Payload, StopChar);
|
|
GDBParser.Free;
|
|
|
|
if not Composite
|
|
then begin
|
|
//It is not a record
|
|
debugln(DBGMI_STRUCT_PARSER, 'Expected record, but found: "', ATextInfo, '"');
|
|
exit;
|
|
end;
|
|
|
|
//Parse information between brackets...
|
|
GDBParser := TGDBStringIterator.Create(Payload);
|
|
for j := 0 to AType.Fields.Count-1 do
|
|
begin
|
|
if not GDBParser.ParseNext(Composite, Payload, StopChar)
|
|
then begin
|
|
debugln(DBGMI_STRUCT_PARSER, 'Premature end of parsing');
|
|
Break;
|
|
end;
|
|
|
|
if Payload <> AType.Fields[j].Name
|
|
then begin
|
|
debugln(DBGMI_STRUCT_PARSER, 'Field name does not match, expected "', AType.Fields[j].Name, '" but found "', Payload,'"');
|
|
Break;
|
|
end;
|
|
|
|
if StopChar <> '='
|
|
then begin
|
|
debugln(DBGMI_STRUCT_PARSER, 'Expected assignment, but other found.');
|
|
Break;
|
|
end;
|
|
|
|
//Field name verified...
|
|
if not GDBParser.ParseNext(Composite, Payload, StopChar)
|
|
then begin
|
|
debugln(DBGMI_STRUCT_PARSER, 'Premature end of parsing');
|
|
Break;
|
|
end;
|
|
|
|
if Composite
|
|
then THackDBGType(AType.Fields[j].DBGType).FKind := skRecord;
|
|
|
|
AType.Fields[j].DBGType.Value.AsString := HexCToHexPascal(Payload);
|
|
end;
|
|
|
|
GDBParser.Free;
|
|
end;
|
|
|
|
procedure PutValuesInClass(const AType: TGDBType; ATextInfo: String);
|
|
var
|
|
//GDBParser: TGDBStringIterator;
|
|
//Payload: String;
|
|
//Composite: Boolean;
|
|
//StopChar: Char;
|
|
//j: Integer;
|
|
AWarnText: string;
|
|
StartPtr, EndPtr: PChar;
|
|
|
|
Procedure SkipSpaces;
|
|
begin
|
|
while (StartPtr <= EndPtr) and (StartPtr^ = ' ') do inc(StartPtr);
|
|
end;
|
|
|
|
Procedure SkipToEndOfField(EndAtComma: Boolean = False);
|
|
var
|
|
i, j: Integer;
|
|
begin
|
|
// skip forward, past the next ",", but do NOT skip the closing "}"
|
|
i := 1;
|
|
j := 0;
|
|
while (StartPtr <= EndPtr) and (i > 0) do begin
|
|
case StartPtr^ of
|
|
'{': inc(i);
|
|
'}': if i = 1
|
|
then break // do not skip }
|
|
else dec(i);
|
|
'[': inc(j);
|
|
']': dec(j);
|
|
'''': begin
|
|
inc(StartPtr);
|
|
while (StartPtr <= EndPtr) and (StartPtr^ <> '''') do inc(StartPtr);
|
|
end;
|
|
',': if (i = 1) and (j < 1) then begin
|
|
if EndAtComma then break; // Do not increase StartPtr;
|
|
i := 0;
|
|
end;
|
|
end;
|
|
inc(StartPtr);
|
|
end;
|
|
SkipSpaces;
|
|
end;
|
|
|
|
procedure ProcessAncestor(ATypeName: String);
|
|
var
|
|
HelpPtr, HelpPtr2: PChar;
|
|
NewName, NewVal: String;
|
|
i: Integer;
|
|
NewField: TDBGField;
|
|
begin
|
|
inc(StartPtr); // skip '{'
|
|
SkipSpaces;
|
|
if StartPtr^ = '<' Then begin
|
|
inc(StartPtr);
|
|
HelpPtr := StartPtr;
|
|
while (HelpPtr <= EndPtr) and (HelpPtr^ <> '>') do inc(HelpPtr);
|
|
NewName := copy(StartPtr, 1, HelpPtr - StartPtr);
|
|
StartPtr := HelpPtr + 1;
|
|
SkipSpaces;
|
|
if StartPtr^ <> '=' then begin
|
|
debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: Expected "=" for ancestor "' + NewName + '" in: ' + AWarnText);
|
|
AWarnText := '';
|
|
SkipToEndOfField;
|
|
// continue fields, or end
|
|
end
|
|
else begin
|
|
inc(StartPtr);
|
|
SkipSpaces;
|
|
if StartPtr^ <> '{'
|
|
then begin
|
|
//It is not a class
|
|
debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: Expected "{" for ancestor "' + NewName + '" in: ' + AWarnText);
|
|
AWarnText := '';
|
|
SkipToEndOfField;
|
|
end
|
|
else
|
|
ProcessAncestor(NewName);
|
|
if StartPtr^ = ',' then inc(StartPtr);
|
|
SkipSpaces;
|
|
end;
|
|
end;
|
|
|
|
// process fields in this ancestor
|
|
while (StartPtr <= EndPtr) and (StartPtr^ <> '}') do begin
|
|
HelpPtr := StartPtr;
|
|
while (HelpPtr < EndPtr) and not (HelpPtr^ in [' ', '=', ',']) do inc(HelpPtr);
|
|
NewName := uppercase(copy(StartPtr, 1, HelpPtr - StartPtr)); // name of field
|
|
|
|
StartPtr := HelpPtr;
|
|
SkipSpaces;
|
|
if StartPtr^ <> '=' then begin
|
|
debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: Expected "=" for field"' + NewName + '" in: ' + AWarnText);
|
|
AWarnText := '';
|
|
SkipToEndOfField;
|
|
continue;
|
|
end;
|
|
|
|
inc(StartPtr);
|
|
SkipSpaces;
|
|
HelpPtr := StartPtr;
|
|
SkipToEndOfField(True);
|
|
HelpPtr2 := StartPtr; // "," or "}"
|
|
dec(HelpPtr2);
|
|
while HelpPtr2^ = ' ' do dec(HelpPtr2);
|
|
NewVal := copy(HelpPtr, 1, HelpPtr2 + 1 - HelpPtr); // name of field
|
|
|
|
i := AType.Fields.Count - 1;
|
|
while (i >= 0)
|
|
and ( (uppercase(AType.Fields[i].Name) <> NewName)
|
|
or (uppercase(AType.Fields[i].ClassName) <> ATypeName) )
|
|
do dec(i);
|
|
|
|
if i < 0 then begin
|
|
if (uppercase(ATypeName) <> 'TOBJECT') or (pos('VPTR', uppercase(NewName)) < 1) then begin
|
|
if not(defFullTypeInfo in FEvalFlags) then begin
|
|
NewField := TDBGField.Create(NewName, TGDBType.Create(skSimple, ''), flPublic, [], '');
|
|
AType.Fields.Add(NewField);
|
|
NewField.DBGType.Value.AsString := HexCToHexPascal(NewVal);
|
|
end
|
|
else
|
|
debugln(DBGMI_STRUCT_PARSER, 'WARNING: PutValuesInClass: No field for "' + ATypeName + '"."' + NewName + '"');
|
|
end;
|
|
end
|
|
else
|
|
AType.Fields[i].DBGType.Value.AsString := HexCToHexPascal(NewVal);
|
|
|
|
if (StartPtr^ <> '}') then inc(StartPtr);
|
|
SkipSpaces;
|
|
end;
|
|
|
|
inc(StartPtr); // skip the }
|
|
end;
|
|
|
|
begin
|
|
if ATextInfo = '' then exit;
|
|
AWarnText := ATextInfo;
|
|
StartPtr := @ATextInfo[1];
|
|
EndPtr := @ATextInfo[length(ATextInfo)];
|
|
|
|
while EndPtr^ = ' ' do dec(EndPtr);
|
|
|
|
SkipSpaces;
|
|
if StartPtr^ <> '{'
|
|
then begin
|
|
//It is not a class
|
|
debugln(DBGMI_STRUCT_PARSER, 'ERROR: PutValuesInClass: Expected class, but found: "', ATextInfo, '"');
|
|
exit;
|
|
end;
|
|
|
|
ProcessAncestor(AType.TypeName);
|
|
|
|
end;
|
|
|
|
procedure PutValuesInTree();
|
|
var
|
|
ValData: string;
|
|
begin
|
|
if not Assigned(FTypeInfo) then exit;
|
|
|
|
ValData := FTextValue;
|
|
case FTypeInfo.Kind of
|
|
skClass: begin
|
|
GetPart('','{',ValData);
|
|
PutValuesInClass(FTypeInfo,ValData);
|
|
end;
|
|
skRecord: begin
|
|
GetPart('','{',ValData);
|
|
PutValuesInTypeRecord(FTypeInfo,ValData);
|
|
end;
|
|
skVariant: begin
|
|
FTypeInfo.Value.AsString:=ValData;
|
|
end;
|
|
skEnum: begin
|
|
FTypeInfo.Value.AsString:=ValData;
|
|
end;
|
|
skSet: begin
|
|
FTypeInfo.Value.AsString:=ValData;
|
|
end;
|
|
skSimple: begin
|
|
FTypeInfo.Value.AsString:=ValData;
|
|
end;
|
|
// skPointer: ;
|
|
end;
|
|
end;
|
|
|
|
function SelectParentFrame(var aFrameIdx: Integer): Boolean;
|
|
var
|
|
CurPFPListChangeStamp: Integer;
|
|
|
|
function ParentSearchCanContinue: Boolean;
|
|
begin
|
|
Result :=
|
|
(not (dcsCanceled in SeenStates)) and
|
|
(CurPFPListChangeStamp = TGDBMIWatches(FTheDebugger.Watches).ParentFPListChangeStamp) and // State changed: FrameCache is no longer valid
|
|
(FTheDebugger.State <> dsError);
|
|
end;
|
|
|
|
var
|
|
R: TGDBMIExecResult;
|
|
List: TGDBMINameValueList;
|
|
ParentFp, Fp, LastFp: String;
|
|
i, j: Integer;
|
|
FrameCache: PGDBMIDebuggerParentFrameCache;
|
|
ParentFpNum, FpNum, FpDiff, LastFpDiff: QWord;
|
|
FpDir: Integer;
|
|
begin
|
|
Result := False;
|
|
CurPFPListChangeStamp := TGDBMIWatches(FTheDebugger.Watches).ParentFPListChangeStamp;
|
|
FrameCache := TGDBMIWatches(FTheDebugger.Watches).GetParentFPList(ContextThreadId);
|
|
List := nil;
|
|
try
|
|
|
|
i := length(FrameCache^.ParentFPList);
|
|
j := Max(i, aFrameIdx+1);
|
|
if j >= i
|
|
then SetLength(FrameCache^.ParentFPList, j + 3);
|
|
|
|
// Did a previous check for parentfp fail?
|
|
ParentFP := FrameCache^.ParentFPList[aFrameIdx].parentfp;
|
|
if ParentFp = '-'
|
|
then Exit(False);
|
|
|
|
if ParentFp = '' then begin
|
|
// not yet evaluated
|
|
if ExecuteCommand('-data-evaluate-expression parentfp', R)
|
|
and (R.State <> dsError)
|
|
then begin
|
|
List := TGDBMINameValueList.Create(R);
|
|
ParentFP := List.Values['value'];
|
|
end;
|
|
if not ParentSearchCanContinue then
|
|
exit;
|
|
if ParentFp = '' then begin
|
|
FrameCache^.ParentFPList[aFrameIdx].parentfp := '-'; // mark as no parentfp
|
|
Exit(False);
|
|
end;
|
|
FrameCache^.ParentFPList[aFrameIdx].parentfp := ParentFp;
|
|
end;
|
|
|
|
ParentFpNum := StrToQWordDef(ParentFp, 0);
|
|
if ParentFpNum = 0 then begin
|
|
FrameCache^.ParentFPList[aFrameIdx].parentfp := '-'; // mark as no parentfp
|
|
Exit(False);
|
|
end;
|
|
|
|
if List = nil
|
|
then List := TGDBMINameValueList.Create('');
|
|
|
|
LastFp := '';
|
|
LastFpDiff := 0;
|
|
FpDir := 0;
|
|
repeat
|
|
Inc(aFrameIdx);
|
|
i := length(FrameCache^.ParentFPList);
|
|
j := Max(i, aFrameIdx+1);
|
|
if j >= i
|
|
then SetLength(FrameCache^.ParentFPList, j + 5);
|
|
|
|
Fp := FrameCache^.ParentFPList[aFrameIdx].Fp;
|
|
if Fp = '-'
|
|
then begin
|
|
Exit(False);
|
|
end;
|
|
|
|
if (Fp = '') or (Fp = ParentFP) then begin
|
|
FContext.StackContext := ccUseLocal;
|
|
FContext.StackFrame := aFrameIdx;
|
|
|
|
if (Fp = '') then begin
|
|
if not ExecuteCommand('-data-evaluate-expression $fp', R)
|
|
or (R.State = dsError)
|
|
then begin
|
|
FrameCache^.ParentFPList[aFrameIdx].Fp := '-'; // mark as no Fp (not accesible)
|
|
Exit(False);
|
|
end;
|
|
if not ParentSearchCanContinue then
|
|
exit;
|
|
List.Init(R.Values);
|
|
Fp := List.Values['value'];
|
|
if Fp = ''
|
|
then Fp := '-';
|
|
FrameCache^.ParentFPList[aFrameIdx].Fp := Fp;
|
|
end;
|
|
end;
|
|
|
|
if FP = LastFp then // Propably top of stack, FP no longer changes
|
|
Exit(False);
|
|
LastFp := Fp;
|
|
|
|
// check that FP gets closer to ParentFp
|
|
FpNum := StrToQWordDef(Fp, 0);
|
|
if FpNum > ParentFpNum then begin
|
|
if FpDir = 1 then exit; // went to far
|
|
FpDir := -1;
|
|
FpDiff := FpNum - ParentFpNum;
|
|
end else begin
|
|
if FpDir = -1 then exit; // went to far
|
|
FpDir := 1;
|
|
FpDiff := ParentFpNum - FpNum;
|
|
end;
|
|
if (LastFpDiff <> 0) and (FpDiff >= LastFpDiff) then
|
|
Exit(False);
|
|
|
|
LastFpDiff := FpDiff;
|
|
|
|
until ParentFP = Fp;
|
|
|
|
Result := True;
|
|
|
|
finally
|
|
List.Free;
|
|
end;
|
|
end;
|
|
|
|
function PascalizePointer(AString: String; const TypeCast: String = ''): String;
|
|
var
|
|
s: String;
|
|
begin
|
|
Result := AString;
|
|
if not IsHexC(AString)
|
|
then exit;
|
|
|
|
// there may be data after the pointer
|
|
s := GetPart([], [' '], AString, False, True);
|
|
if s = '0x0'
|
|
then begin
|
|
Result := 'nil';
|
|
end
|
|
else begin
|
|
// 0xabc0 => $0000ABC0
|
|
Result := UpperCase(HexCToHexPascal(s, FTheDebugger.TargetWidth div 4));
|
|
end;
|
|
|
|
if TypeCast <> '' then
|
|
Result := TypeCast + '(' + Result + ')';
|
|
if AString <> '' then
|
|
Result := Result + ' ' + AString;
|
|
end;
|
|
|
|
function FormatCurrency(const AString: String): String;
|
|
var
|
|
i, e: Integer;
|
|
c: Currency;
|
|
begin
|
|
Result := AString;
|
|
Val(Result, i, e);
|
|
// debugger outputs 12345 for 1,2345 values
|
|
if e=0 then
|
|
begin
|
|
c := i / 10000;
|
|
Result := CurrToStr(c);
|
|
end;
|
|
end;
|
|
|
|
function GetVariantValue(AString: String): String;
|
|
|
|
function FormatVarError(const AString: String): String; inline;
|
|
begin
|
|
Result := 'Error('+AString+')';
|
|
end;
|
|
|
|
var
|
|
VarList: TGDBMINameValueList;
|
|
VType: Integer;
|
|
Addr: TDbgPtr;
|
|
dt: TDateTime;
|
|
e: Integer;
|
|
begin
|
|
VarList := TGDBMINameValueList.Create('');
|
|
try
|
|
VarList.UseTrim := True;
|
|
VarList.Init(AString);
|
|
VType := StrToIntDef(VarList.Values['VTYPE'], -1);
|
|
if VType = -1 then // can never happen if no error since varType is word
|
|
Exit('variant: unknown type');
|
|
case VType and not varTypeMask of
|
|
0:
|
|
begin
|
|
case VType of
|
|
varEmpty: Result := 'UnAssigned';
|
|
varNull: Result := 'Null';
|
|
varsmallint: Result := VarList.Values['VSMALLINT'];
|
|
varinteger: Result := VarList.Values['VINTEGER'];
|
|
varsingle: Result := VarList.Values['VSINGLE'];
|
|
vardouble: Result := VarList.Values['VDOUBLE'];
|
|
vardate:
|
|
begin
|
|
// float number
|
|
Result := VarList.Values['VDATE'];
|
|
val(Result, dt, e);
|
|
if e = 0 then
|
|
Result := DateTimeToStr(dt);
|
|
end;
|
|
varcurrency: Result := FormatCurrency(VarList.Values['VCURRENCY']);
|
|
varolestr: Result := VarList.Values['VOLESTR'];
|
|
vardispatch: Result := PascalizePointer(VarList.Values['VDISPATCH'], 'IDispatch');
|
|
varerror: Result := FormatVarError(VarList.Values['VERROR']);
|
|
varboolean: Result := VarList.Values['VBOOLEAN'];
|
|
varunknown: Result := PascalizePointer(VarList.Values['VUNKNOWN'], 'IUnknown');
|
|
varshortint: Result := VarList.Values['VSHORTINT'];
|
|
varbyte: Result := VarList.Values['VBYTE'];
|
|
varword: Result := VarList.Values['VWORD'];
|
|
varlongword: Result := VarList.Values['VLONGWORD'];
|
|
varint64: Result := VarList.Values['VINT64'];
|
|
varqword: Result := VarList.Values['VQWORD'];
|
|
varstring:
|
|
begin
|
|
// address of string
|
|
Result := VarList.Values['VSTRING'];
|
|
Val(Result, Addr, e);
|
|
if e = 0 then
|
|
begin
|
|
if Addr = 0 then
|
|
Result := ''''''
|
|
else
|
|
Result := MakePrintable(GetText(Addr));
|
|
end;
|
|
end;
|
|
varany: Result := VarList.Values['VANY'];
|
|
else
|
|
Result := 'unsupported variant type: ' + VarTypeAsText(VType);
|
|
end;
|
|
end;
|
|
varArray:
|
|
begin
|
|
Result := VarTypeAsText(VType);
|
|
// TODO: show variant array data?
|
|
// Result := VarList.Values['VARRAY'];
|
|
end;
|
|
varByRef:
|
|
begin
|
|
Result := VarList.Values['VPOINTER'];
|
|
Val(Result, Addr, e);
|
|
if e = 0 then
|
|
begin
|
|
if Addr = 0 then
|
|
Result := '???'
|
|
else
|
|
begin
|
|
// Result contains a valid address
|
|
case VType xor varByRef of
|
|
varEmpty: Result := 'UnAssigned';
|
|
varNull: Result := 'Null';
|
|
varsmallint: Result := GetStrValue('psmallint(%s)^', [Result]);
|
|
varinteger: Result := GetStrValue('pinteger(%s)^', [Result]);
|
|
varsingle: Result := GetStrValue('psingle(%s)^', [Result]);
|
|
vardouble: Result := GetStrValue('pdouble(%s)^', [Result]);
|
|
vardate:
|
|
begin
|
|
// float number
|
|
Result := GetStrValue('pdatetime(%s)^', [Result]);
|
|
val(Result, dt, e);
|
|
if e = 0 then
|
|
Result := DateTimeToStr(dt);
|
|
end;
|
|
varcurrency: Result := FormatCurrency(GetStrValue('pcurrency(%s)^', [Result]));
|
|
varolestr:
|
|
begin
|
|
Result := GetStrValue('^pointer(%s)^', [Result]);
|
|
val(Result, Addr, e);
|
|
if e = 0 then
|
|
Result := MakePrintable(GetWideText(Addr));
|
|
end;
|
|
vardispatch: Result := PascalizePointer(GetStrValue('ppointer(%s)^', [Result]), 'IDispatch');
|
|
varerror: Result := FormatVarError(GetStrValue('phresult(%s)^', [Result]));
|
|
varboolean: Result := GetStrValue('pwordbool(%s)^', [Result]);
|
|
varunknown: Result := PascalizePointer(GetStrValue('ppointer(%s)^', [Result]), 'IUnknown');
|
|
varshortint: Result := GetStrValue('pshortint(%s)^', [Result]);
|
|
varbyte: Result := GetStrValue('pbyte(%s)^', [Result]);
|
|
varword: Result := GetStrValue('pword(%s)^', [Result]);
|
|
varlongword: Result := GetStrValue('plongword(%s)^', [Result]);
|
|
varint64: Result := GetStrValue('pint64(%s)^', [Result]);
|
|
varqword: Result := GetStrValue('pqword(%s)^', [Result]);
|
|
varstring: Result := MakePrintable(GetText('pansistring(%s)^', [Result]));
|
|
else
|
|
Result := 'unsupported variant type: ' + VarTypeAsText(VType);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
else
|
|
Result := 'unsupported variant type: ' + VarTypeAsText(VType);
|
|
end;
|
|
finally
|
|
VarList.Free;
|
|
end;
|
|
end;
|
|
|
|
function StripExprNewlines(const ASource: String): String;
|
|
var
|
|
len: Integer;
|
|
srcPtr, dstPtr: PChar;
|
|
begin
|
|
len := Length(ASource);
|
|
SetLength(Result, len);
|
|
if len = 0 then Exit;
|
|
srcPtr := @ASource[1];
|
|
dstPtr := @Result[1];
|
|
while len > 0 do
|
|
begin
|
|
case srcPtr^ of
|
|
#0:;
|
|
#10, #13: dstPtr^ := ' ';
|
|
else
|
|
dstPtr^ := srcPtr^;
|
|
end;
|
|
Dec(len);
|
|
Inc(srcPtr);
|
|
Inc(dstPtr);
|
|
end;
|
|
end;
|
|
|
|
procedure FixUpResult(AnExpression: string; ResultInfo: TGDBType = nil);
|
|
var
|
|
addr: TDbgPtr;
|
|
e: Integer;
|
|
PrintableString: String;
|
|
i: Integer;
|
|
addrtxt: string;
|
|
begin
|
|
// Check for strings
|
|
if ResultInfo = nil then
|
|
ResultInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags, TypeInfoFlags);
|
|
if (ResultInfo = nil) then Exit;
|
|
FTypeInfo := ResultInfo;
|
|
|
|
case ResultInfo.Kind of
|
|
skPointer: begin
|
|
addrtxt := GetPart([], [' '], FTextValue, False, False);
|
|
Val(addrtxt, addr, e);
|
|
if e <> 0 then
|
|
Exit;
|
|
|
|
AnExpression := Lowercase(ResultInfo.TypeName);
|
|
case StringCase(AnExpression, ['char', 'character', 'ansistring', '__vtbl_ptr_type',
|
|
'wchar', 'widechar', 'widestring', 'unicodestring',
|
|
'pointer'])
|
|
of
|
|
0, 1, 2: begin // 'char', 'character', 'ansistring'
|
|
// check for addr 'text' / 0x1234 'abc'
|
|
i := length(addrtxt)+1;
|
|
if (i <= length(FTextValue)) and (FTextValue[i] = ' ') then inc(i); // skip 1 or 2 spaces after addr
|
|
if (i <= length(FTextValue)) and (FTextValue[i] = ' ') then inc(i);
|
|
|
|
if (i <= length(FTextValue)) and (FTextValue[i] in ['''', '#'])
|
|
then
|
|
FTextValue := MakePrintable(ProcessGDBResultText(
|
|
copy(FTextValue, i, length(FTextValue) - i + 1), [prNoLeadingTab]))
|
|
else
|
|
if Addr = 0
|
|
then
|
|
FTextValue := ''''''
|
|
else
|
|
FTextValue := MakePrintable(GetText(Addr));
|
|
PrintableString := FTextValue;
|
|
end;
|
|
3: begin // '__vtbl_ptr_type'
|
|
if Addr = 0
|
|
then FTextValue := 'nil'
|
|
else begin
|
|
AnExpression := GetClassName(Addr);
|
|
if AnExpression = '' then AnExpression := '???';
|
|
FTextValue := 'class of ' + AnExpression + ' ' + UnEscapeBackslashed(FTextValue);
|
|
end;
|
|
end;
|
|
4,5,6,7: begin // 'wchar', 'widechar'
|
|
// widestring handling
|
|
if Addr = 0
|
|
then FTextValue := ''''''
|
|
else FTextValue := MakePrintable(GetWideText(Addr));
|
|
PrintableString := FTextValue;
|
|
end;
|
|
8: begin // pointer
|
|
if Addr = 0
|
|
then FTextValue := 'nil';
|
|
FTextValue := PascalizePointer(UnEscapeBackslashed(FTextValue));
|
|
end;
|
|
else
|
|
if Addr = 0
|
|
then FTextValue := 'nil';
|
|
if (Length(AnExpression) > 0)
|
|
then begin
|
|
if AnExpression[1] = 't'
|
|
then begin
|
|
AnExpression[1] := 'T';
|
|
if Length(AnExpression) > 1 then AnExpression[2] := UpperCase(AnExpression[2])[1];
|
|
end;
|
|
FTextValue := PascalizePointer(UnEscapeBackslashed(FTextValue), AnExpression);
|
|
end;
|
|
|
|
end;
|
|
|
|
ResultInfo.Value.AsPointer := {%H-}Pointer(PtrUint(Addr));
|
|
AnExpression := Format('$%x', [Addr]);
|
|
if PrintableString <> ''
|
|
then AnExpression := AnExpression + ' ' + PrintableString;
|
|
ResultInfo.Value.AsString := AnExpression;
|
|
end;
|
|
|
|
skClass: begin
|
|
Val(FTextValue, addr, e); //Get the class mem address
|
|
if (e = 0) and (addr = 0)
|
|
then FTextValue := 'nil';
|
|
|
|
if (FTextValue <> '') and (FTypeInfo <> nil)
|
|
then begin
|
|
FTextValue := '<' + FTypeInfo.TypeName + '> = ' +
|
|
ProcessGDBResultStruct(FTextValue, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
|
|
end
|
|
else
|
|
if (e = 0) and (addr <> 0)
|
|
then begin //No error ?
|
|
AnExpression := GetInstanceClassName(Addr);
|
|
if AnExpression = '' then AnExpression := '???'; //No instanced class found
|
|
FTextValue := 'instance of ' + AnExpression + ' ' +
|
|
ProcessGDBResultStruct(FTextValue, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
|
|
end;
|
|
end;
|
|
|
|
skVariant: begin
|
|
FTextValue := UnEscapeBackslashed(GetVariantValue(FTextValue));
|
|
end;
|
|
skRecord: begin
|
|
FTextValue := 'record ' + ResultInfo.TypeName + ' '+
|
|
ProcessGDBResultStruct(FTextValue, [prNoLeadingTab, prMakePrintAble, prStripAddressFromString]);
|
|
end;
|
|
|
|
skSimple: begin
|
|
if ResultInfo.TypeName = 'CURRENCY' then
|
|
FTextValue := FormatCurrency(UnEscapeBackslashed(FTextValue))
|
|
else
|
|
if ResultInfo.TypeName = 'ShortString' then
|
|
FTextValue := MakePrintable(ProcessGDBResultText(FTextValue, [prNoLeadingTab]))
|
|
else
|
|
if (ResultInfo.TypeName = '&ShortString') then // should no longer happen
|
|
FTextValue := GetStrValue('ShortString(%s)', [AnExpression]) // we have an address here, so we need to typecast
|
|
else
|
|
if saDynArray in ResultInfo.Attributes then // may also be a string
|
|
FTextValue := PascalizePointer(UnEscapeBackslashed(FTextValue))
|
|
else
|
|
FTextValue := UnEscapeBackslashed(FTextValue); // TODO: Check for string
|
|
end;
|
|
end;
|
|
|
|
PutValuesInTree;
|
|
FTextValue := FormatResult(FTextValue, (ResultInfo.Kind = skSimple) and (ResultInfo.Attributes*[saArray,saDynArray] <> []));
|
|
end;
|
|
|
|
function AddAddressOfToExpression(const AnExpression: string; TypeInfo: TGDBType): String;
|
|
var
|
|
UseAt: Boolean;
|
|
begin
|
|
UseAt := True;
|
|
case TypeInfo.Kind of // (skClass, skRecord, skEnum, skSet, skProcedure, skFunction, skSimple, skPointer, skVariant)
|
|
skPointer: begin
|
|
case StringCase(Lowercase(TypeInfo.TypeName),
|
|
['char', 'character', 'ansistring', '__vtbl_ptr_type', 'wchar', 'widechar', 'pointer']
|
|
)
|
|
of
|
|
2: UseAt := False;
|
|
3: UseAt := False;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if UseAt
|
|
then Result := '@(' + AnExpression + ')'
|
|
else Result := AnExpression;
|
|
end;
|
|
|
|
function QuoteExpr(const AnExpression: string): string;
|
|
var
|
|
i, j, Cnt: integer;
|
|
begin
|
|
if pos(' ', AnExpression) < 1
|
|
then exit(AnExpression);
|
|
Cnt := length(AnExpression);
|
|
SetLength(Result, 2 * Cnt + 2);
|
|
Result[1] := '"';
|
|
i := 1;
|
|
j := 2;
|
|
while i <= Cnt do begin
|
|
if AnExpression[i] in ['"', '\']
|
|
then begin
|
|
Result[j] := '\';
|
|
inc(j);
|
|
end;
|
|
Result[j] := AnExpression[i];
|
|
inc(i);
|
|
inc(j);
|
|
end;
|
|
Result[j] := '"';
|
|
SetLength(Result, j + 1);
|
|
end;
|
|
|
|
procedure ParseLastError;
|
|
var
|
|
ResultList: TGDBMINameValueList;
|
|
begin
|
|
if (dcsCanceled in SeenStates)
|
|
then begin
|
|
FTextValue := '<Canceled>';
|
|
FValidity := ddsInvalid;
|
|
exit;
|
|
end;
|
|
ResultList := TGDBMINameValueList.Create(LastExecResult.Values);
|
|
FTextValue := ResultList.Values['msg'];
|
|
if FTextValue = ''
|
|
then FTextValue := '<Error>';
|
|
FreeAndNil(ResultList);
|
|
FValidity := ddsError;
|
|
end;
|
|
|
|
function TryExecute(AnExpression: string): Boolean;
|
|
|
|
function PrepareExpr(var expr: string; NoAddressOp: Boolean = False): boolean;
|
|
begin
|
|
Assert(FTypeInfo = nil, 'Type info must be nil');
|
|
FTypeInfo := GetGDBTypeInfo(expr, defFullTypeInfo in FEvalFlags, TypeInfoFlags);
|
|
Result := FTypeInfo <> nil;
|
|
if (not Result) then begin
|
|
ParseLastError;
|
|
exit;
|
|
end;
|
|
|
|
if NoAddressOp
|
|
then expr := QuoteExpr(expr)
|
|
else expr := QuoteExpr(AddAddressOfToExpression(expr, FTypeInfo));
|
|
end;
|
|
|
|
var
|
|
ResultList: TGDBMINameValueList;
|
|
R: TGDBMIExecResult;
|
|
MemDump: TGDBMIMemoryDumpResultList;
|
|
i, Size: integer;
|
|
s: String;
|
|
begin
|
|
Result := False;
|
|
|
|
case FDisplayFormat of
|
|
wdfStructure:
|
|
begin
|
|
Result := ExecuteCommand('-data-evaluate-expression %s', [Quote(AnExpression)], R);
|
|
Result := Result and (R.State <> dsError);
|
|
if (not Result) then begin
|
|
ParseLastError;
|
|
exit;
|
|
end;
|
|
|
|
ResultList := TGDBMINameValueList.Create(R.Values);
|
|
if Result
|
|
then FTextValue := ResultList.Values['value']
|
|
else FTextValue := ResultList.Values['msg'];
|
|
FTextValue := DeleteEscapeChars(FTextValue);
|
|
ResultList.Free;
|
|
|
|
if Result
|
|
then begin
|
|
FixUpResult(AnExpression);
|
|
FValidity := ddsValid;
|
|
end;
|
|
end;
|
|
wdfChar:
|
|
begin
|
|
Result := PrepareExpr(AnExpression);
|
|
if not Result
|
|
then exit;
|
|
FValidity := ddsValid;
|
|
FTextValue := GetChar(AnExpression, []);
|
|
if LastExecResult.State = dsError
|
|
then ParseLastError;
|
|
end;
|
|
wdfString:
|
|
begin
|
|
Result := PrepareExpr(AnExpression);
|
|
if not Result
|
|
then exit;
|
|
FValidity := ddsValid;
|
|
FTextValue := GetText(AnExpression, []); // GetText takes Addr
|
|
if LastExecResult.State = dsError
|
|
then ParseLastError;
|
|
end;
|
|
wdfDecimal:
|
|
begin
|
|
Result := PrepareExpr(AnExpression, True);
|
|
if not Result
|
|
then exit;
|
|
FValidity := ddsValid;
|
|
FTextValue := IntToStr(Int64(GetPtrValue(AnExpression, [], True)));
|
|
if LastExecResult.State = dsError
|
|
then ParseLastError;
|
|
end;
|
|
wdfUnsigned:
|
|
begin
|
|
Result := PrepareExpr(AnExpression, True);
|
|
if not Result
|
|
then exit;
|
|
FValidity := ddsValid;
|
|
FTextValue := IntToStr(GetPtrValue(AnExpression, [], True));
|
|
if LastExecResult.State = dsError
|
|
then ParseLastError;
|
|
end;
|
|
//wdfFloat:
|
|
// begin
|
|
// Result := PrepareExpr(AnExpression);
|
|
// if not Result
|
|
// then exit;
|
|
// FTextValue := GetFloat(AnExpression, []); // GetFloat takes address
|
|
// if LastExecResult.State = dsError
|
|
// then FTextValue := '<error>';
|
|
// end;
|
|
wdfHex:
|
|
begin
|
|
Result := PrepareExpr(AnExpression, True);
|
|
if not Result
|
|
then exit;
|
|
FTextValue := IntToHex(GetPtrValue(AnExpression, [], True), 2);
|
|
FValidity := ddsValid;
|
|
if length(FTextValue) mod 2 = 1
|
|
then FTextValue := '0'+FTextValue; // make it an even number of digets
|
|
if LastExecResult.State = dsError
|
|
then ParseLastError;
|
|
end;
|
|
wdfPointer:
|
|
begin
|
|
Result := PrepareExpr(AnExpression, True);
|
|
if not Result
|
|
then exit;
|
|
FTextValue := PascalizePointer('0x' + IntToHex(GetPtrValue(AnExpression, [], True), TargetInfo^.TargetPtrSize*2));
|
|
FValidity := ddsValid;
|
|
if LastExecResult.State = dsError
|
|
then FTextValue := '<error>';
|
|
end;
|
|
wdfMemDump:
|
|
begin
|
|
Result := PrepareExpr(AnExpression);
|
|
if not Result
|
|
then exit;
|
|
|
|
Result := False;
|
|
Size := 256;
|
|
if (FTypeInfo <> nil) and (saInternalPointer in FTypeInfo.Attributes) then begin
|
|
Result := ExecuteCommand('-data-read-memory %s^ x 1 1 %u', [AnExpression, Size], R);
|
|
Result := Result and (R.State <> dsError);
|
|
// nil ?
|
|
if (R.State = dsError) and (pos('Unable to read memory', R.Values) > 0) then
|
|
Size := TargetInfo^.TargetPtrSize;
|
|
end;
|
|
if (not Result) then begin
|
|
Result := ExecuteCommand('-data-read-memory %s x 1 1 %u', [AnExpression, Size], R);
|
|
Result := Result and (R.State <> dsError);
|
|
end;
|
|
if (not Result) then begin
|
|
ParseLastError;
|
|
exit;
|
|
end;
|
|
MemDump := TGDBMIMemoryDumpResultList.Create(R);
|
|
FValidity := ddsValid;
|
|
FTextValue := MemDump.AsText(0, MemDump.Count, TargetInfo^.TargetPtrSize*2);
|
|
MemDump.Free;
|
|
end;
|
|
else // wdfDefault
|
|
begin
|
|
Result := False;
|
|
Assert(FTypeInfo = nil, 'Type info must be nil');
|
|
i := 0;
|
|
if FWatchValue <> nil then i := FWatchValue.RepeatCount;
|
|
FTypeInfo := GetGDBTypeInfo(AnExpression, defFullTypeInfo in FEvalFlags,
|
|
TypeInfoFlags + [gtcfExprEvaluate, gtcfExprEvalStrFixed], FDisplayFormat, i);
|
|
|
|
if (FTypeInfo = nil) or (dcsCanceled in SeenStates)
|
|
then begin
|
|
ParseLastError;
|
|
exit;
|
|
end;
|
|
if FTypeInfo.HasExprEvaluatedAsText then begin
|
|
FTextValue := FTypeInfo.ExprEvaluatedAsText;
|
|
//FTextValue := DeleteEscapeChars(FTextValue); // TODO: move to FixUpResult / only if really needed
|
|
FValidity := ddsValid;
|
|
Result := True;
|
|
FixUpResult(AnExpression, FTypeInfo);
|
|
|
|
if FTypeInfo.HasStringExprEvaluatedAsText then begin
|
|
s := FTextValue;
|
|
FTextValue := FTypeInfo.StringExprEvaluatedAsText;
|
|
//FTextValue := DeleteEscapeChars(FTextValue); // TODO: move to FixUpResult / only if really needed
|
|
FixUpResult(AnExpression, FTypeInfo);
|
|
FTextValue := 'PCHAR: ' + s + LineEnding + 'STRING: ' + FTextValue;
|
|
end;
|
|
|
|
exit;
|
|
end;
|
|
|
|
debugln(DBG_WARNINGS, '############# Not expected to be here');
|
|
FTextValue := '<ERROR>';
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
var
|
|
S: String;
|
|
ResultList: TGDBMINameValueList;
|
|
frameidx: Integer;
|
|
{$IFDEF DBG_WITH_GDB_WATCHES} R: TGDBMIExecResult; {$ENDIF}
|
|
begin
|
|
SelectContext;
|
|
|
|
try
|
|
FTextValue:='';
|
|
FTypeInfo:=nil;
|
|
TypeInfoFlags := [];
|
|
if defClassAutoCast in FEvalFlags
|
|
then include(TypeInfoFlags, gtcfAutoCastClass);
|
|
|
|
|
|
S := StripExprNewlines(FExpression);
|
|
|
|
if S = '' then Exit(false);
|
|
|
|
{$IFDEF DBG_WITH_GDB_WATCHES}
|
|
(* This code is experimental. No support will be provided.
|
|
It is intended for people extending the GDBMI classes of the IDE, and requires deep knowledge on how the IDE works.
|
|
WARNING:
|
|
- This bypasses some of the internals of the debugger.
|
|
- It does intentionally no check or validation
|
|
- Using this feature without full knowledge of all internals of the debugger, can *HANG* or *CRASH* the debugger or the entire IDE.
|
|
*)
|
|
if S[1]='>' then begin // raw cli commands
|
|
delete(S,1,1);
|
|
Result := ExecuteCommand('%s', [S], R);
|
|
Result := Result and (R.State <> dsError);
|
|
if (not Result) then begin
|
|
ParseLastError;
|
|
exit(True);
|
|
end;
|
|
FValidity := ddsValid;
|
|
FTextValue := UnEscapeBackslashed(R.Values, [uefNewLine, uefTab], 3);
|
|
exit;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
ResultList := TGDBMINameValueList.Create('');
|
|
// keep the internal stackframe => same as requested by watch
|
|
frameidx := ContextStackFrame;
|
|
DefaultTimeOut := DebuggerProperties.TimeoutForEval;
|
|
try
|
|
repeat
|
|
if TryExecute(S)
|
|
then Break;
|
|
FreeAndNil(FTypeInfo);
|
|
if (dcsCanceled in SeenStates)
|
|
then break;
|
|
until not SelectParentFrame(frameidx); // may set FStackFrameChanged to force UnSelectContext()
|
|
|
|
finally
|
|
DefaultTimeOut := -1;
|
|
FreeAndNil(ResultList);
|
|
end;
|
|
Result := True;
|
|
finally
|
|
UnSelectContext;
|
|
if FWatchValue <> nil then begin
|
|
FWatchValue.Value := FTextValue;
|
|
FWatchValue.TypeInfo := TypeInfo;
|
|
FWatchValue.Validity := FValidity;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandEvaluate.SelectContext: Boolean;
|
|
begin
|
|
Result := True;
|
|
if FWatchValue = nil then begin
|
|
CopyGlobalContextToLocal;
|
|
exit;
|
|
end;
|
|
|
|
FContext.ThreadContext := ccUseLocal;
|
|
FContext.ThreadId := FWatchValue.ThreadId;
|
|
|
|
FContext.StackContext := ccUseLocal;
|
|
FContext.StackFrame := FWatchValue.StackFrame;
|
|
end;
|
|
|
|
procedure TGDBMIDebuggerCommandEvaluate.UnSelectContext;
|
|
begin
|
|
FContext.ThreadContext := ccUseGlobal;
|
|
FContext.StackContext := ccUseGlobal;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandEvaluate.Create(AOwner: TGDBMIDebugger; AExpression: String;
|
|
ADisplayFormat: TWatchDisplayFormat);
|
|
begin
|
|
inherited Create(AOwner);
|
|
FWatchValue := nil;
|
|
FExpression := AExpression;
|
|
FDisplayFormat := ADisplayFormat;
|
|
FTextValue := '';
|
|
FTypeInfo:=nil;
|
|
FEvalFlags := [];
|
|
FTypeInfoAutoDestroy := True;
|
|
FValidity := ddsValid;
|
|
FLockFlag := False;
|
|
end;
|
|
|
|
constructor TGDBMIDebuggerCommandEvaluate.Create(AOwner: TGDBMIDebugger;
|
|
AWatchValue: TWatchValue);
|
|
begin
|
|
Create(AOwner, AWatchValue.Watch.Expression, AWatchValue.DisplayFormat);
|
|
EvalFlags := AWatchValue.EvaluateFlags;
|
|
FWatchValue := AWatchValue;
|
|
FWatchValue.AddFreeNotification(@DoWatchFreed);
|
|
end;
|
|
|
|
destructor TGDBMIDebuggerCommandEvaluate.Destroy;
|
|
begin
|
|
if FWatchValue <> nil
|
|
then FWatchValue.RemoveFreeNotification(@DoWatchFreed);
|
|
if FTypeInfoAutoDestroy
|
|
then FreeAndNil(FTypeInfo);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TGDBMIDebuggerCommandEvaluate.DebugText: String;
|
|
begin
|
|
if FWatchValue <> nil
|
|
then Result := Format('%s: %s Thread=%d, Frame=%d', [ClassName, FExpression, FWatchValue.ThreadId, FWatchValue.StackFrame])
|
|
else Result := Format('%s: %s', [ClassName, FExpression]);
|
|
end;
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterDebugger(TGDBMIDebugger);
|
|
end;
|
|
|
|
initialization
|
|
DBGMI_QUEUE_DEBUG := DebugLogger.RegisterLogGroup('DBGMI_QUEUE_DEBUG' {$IFDEF DBGMI_QUEUE_DEBUG} , True {$ENDIF} );
|
|
DBGMI_STRUCT_PARSER := DebugLogger.RegisterLogGroup('DBGMI_STRUCT_PARSER' {$IFDEF DBGMI_STRUCT_PARSER} , True {$ENDIF} );
|
|
DBG_VERBOSE := DebugLogger.FindOrRegisterLogGroup('DBG_VERBOSE' {$IFDEF DBG_VERBOSE} , True {$ENDIF} );
|
|
DBG_WARNINGS := DebugLogger.FindOrRegisterLogGroup('DBG_WARNINGS' {$IFDEF DBG_WARNINGS} , True {$ENDIF} );
|
|
DBG_DISASSEMBLER := DebugLogger.FindOrRegisterLogGroup('DBG_DISASSEMBLER' {$IFDEF DBG_DISASSEMBLER} , True {$ENDIF} );
|
|
DBG_THREAD_AND_FRAME := DebugLogger.FindOrRegisterLogGroup('DBG_THREAD_AND_FRAME' {$IFDEF DBG_THREAD_AND_FRAME} , True {$ENDIF} );
|
|
|
|
end.
|