paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-12-06 14:27:41 +01:00
Code Issues Packages Projects Releases Wiki Activity

* Refactored FpDbgClasses unit. Moved all Windows-specific code into the new FpDbgWinClasses unit.

Browse Source 
git-svn-id: trunk@43987 -
This commit is contained in:
joost 2014-02-09 21:02:38 +00:00
parent 1bea33f5ba
commit fac7e13063
7 changed files with 594 additions and 362 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -1257,6 +1257,7 @@ components/fpdebug/fpdbgloader.pp svneol=native#text/pascal
components/fpdebug/fpdbgpetypes.pp svneol=native#text/pascal
components/fpdebug/fpdbgsymbols.pas svneol=native#text/pascal
components/fpdebug/fpdbgutil.pp svneol=native#text/pascal
components/fpdebug/fpdbgwinclasses.pas svneol=native#text/pascal
components/fpdebug/fpdbgwinextra.pp svneol=native#text/pascal
components/fpdebug/fpdebug.lpk svneol=native#text/pascal
components/fpdebug/fpdebug.pas svneol=native#text/pascal

5
components/fpdebug/app/fpd/fpd.lpr
View File

@ -44,7 +44,8 @@ uses
FPDLoop,
FPDPEImage,
FPDType,
FpDbgClasses, FpDbgWinExtra, FpDbgPETypes, FpDbgDwarfConst, FpDbgDwarf;
FpDbgClasses, FpDbgWinExtra, FpDbgPETypes, FpDbgDwarfConst, FpDbgDwarf,
FpDbgWinClasses;
function CtrlCHandler(CtrlType: Cardinal): BOOL; stdcall;
begin
@ -54,7 +55,7 @@ begin
CTRL_BREAK_EVENT: begin
if GState <> dsRun then Exit;
if GMainProcess = nil then Exit;
GMainProcess.Interrupt;
TDbgWinProcess(GMainProcess).Interrupt;
Result := True;
end;

9
components/fpdebug/app/fpd/fpdloop.pas
View File

@ -37,7 +37,8 @@ unit FPDLoop;
interface
uses
Windows, Classes, SysUtils, FileUtil, FpDbgInfo, FpDbgClasses, FpDbgWinExtra, FpDbgDisasX86;
Windows, Classes, SysUtils, FileUtil, FpDbgInfo, FpDbgClasses, FpDbgWinExtra, FpDbgDisasX86,
FpDbgWinClasses;
procedure DebugLoop;
@ -67,7 +68,7 @@ begin
if GMainProcess = nil
then S := GFileName;
Proc := TDbgProcess.Create(S, AEvent.dwProcessId, AEvent.dwThreadId, AEvent.CreateProcessInfo);
Proc := TDbgWinProcess.Create(S, AEvent.dwProcessId, AEvent.dwThreadId, AEvent.CreateProcessInfo);
if GMainProcess = nil
then GMainProcess := Proc;
GProcessMap.Add(AEvent.dwProcessId, Proc);
@ -465,7 +466,7 @@ begin
repeat
if (GCurrentProcess <> nil) and (GState = dsPause)
then begin
GCurrentProcess.ContinueDebugEvent(GCurrentThread, MDebugEvent);
(GCurrentProcess as TDbgWinProcess).ContinueDebugEvent(GCurrentThread, MDebugEvent);
end;
if GState in [dsStop, dsPause, dsEvent]
@ -488,7 +489,7 @@ begin
GState := dsEvent;
if GCurrentProcess <> nil
then begin
if GCurrentProcess.HandleDebugEvent(MDebugEvent) then Continue;
if TDbgWinProcess(GCurrentProcess).HandleDebugEvent(MDebugEvent) then Continue;
if not GCurrentProcess.GetThread(MDebugEvent.dwTHreadID, GCurrentThread)
then WriteLN('LOOP: Unable to retrieve current thread');
end;

451
components/fpdebug/fpdbgclasses.pp
View File

@ -37,12 +37,8 @@ unit FpDbgClasses;
interface
uses
{$ifdef windows}
Windows,
{$endif}
Classes, SysUtils, Maps, FpDbgDwarf, FpDbgUtil, FpDbgWinExtra, FpDbgLoader, FpDbgInfo, LazLoggerBase, LazClasses;
{$ifdef windows}
type
TDbgProcess = class;
@ -56,30 +52,32 @@ type
FSingleStepping: Boolean;
protected
public
constructor Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle; const ABase, AStart: Pointer);
constructor Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle; const ABase, AStart: Pointer); virtual;
destructor Destroy; override;
function SingleStep: Boolean;
function SingleStep: Boolean; virtual;
property ID: Integer read FID;
property Handle: THandle read FHandle;
property SingleStepping: boolean read FSingleStepping;
end;
TDbgThreadClass = class of TDbgThread;
TDbgBreakpoint = class;
TDbgBreakpointEvent = procedure(const ASender: TDbgBreakpoint; const AContext: TContext) of object;
TDbgBreakpoint = class(TObject)
private
FProcess: TDbgProcess;
FLocation: TDbgPtr;
FOrgValue: Byte;
procedure SetBreak;
procedure ResetBreak;
protected
FOrgValue: Byte;
property Process: TDbgProcess read FProcess;
public
constructor Create(const AProcess: TDbgProcess; const ALocation: TDbgPtr);
constructor Create(const AProcess: TDbgProcess; const ALocation: TDbgPtr); virtual;
destructor Destroy; override;
function Hit(const AThreadID: Integer): Boolean;
function Hit(const AThreadID: Integer): Boolean; virtual;
property Location: TDbgPtr read FLocation;
procedure SetBreak; virtual;
procedure ResetBreak; virtual;
end;
TDbgBreakpointClass = class of TDbgBreakpoint;
{ TDbgInstance }
@ -93,11 +91,14 @@ type
FDbgInfo: TDbgInfo;
FLoader: TDbgImageLoader;
procedure LoadInfo;
procedure LoadInfo; virtual;
procedure CheckName;
procedure SetName(const AValue: String);
protected
function InitializeLoader: TDbgImageLoader; virtual;
function GetModuleFileName(AModuleHandle: THandle): string; virtual;
public
constructor Create(const AProcess: TDbgProcess; const ADefaultName: String; const AModuleHandle: THandle; const ABaseAddr, ANameAddr: TDbgPtr; const AUnicode: Boolean);
constructor Create(const AProcess: TDbgProcess; const ADefaultName: String; const AModuleHandle: THandle; const ABaseAddr, ANameAddr: TDbgPtr; const AUnicode: Boolean); virtual;
destructor Destroy; override;
function AddBreak(const AFileName: String; ALine: Cardinal): TDbgBreakpoint;
@ -108,12 +109,14 @@ type
property Process: TDbgProcess read FProcess;
property ModuleHandle: THandle read FModuleHandle;
property BaseAddr: TDbgPtr read FBaseAddr;
property DbgInfo: TDbgInfo read FDbgInfo;
end;
{ TDbgLibrary }
TDbgLibrary = class(TDbgInstance)
private
public
constructor Create(const AProcess: TDbgProcess; const ADefaultName: String; const AInfo: TLoadDLLDebugInfo);
constructor Create(const AProcess: TDbgProcess; const ADefaultName: String; const AModuleHandle: THandle; const ABaseAddr, ANameAddr: TDbgPtr; const AUnicode: Boolean);
property Name: String read FName;
end;
@ -123,61 +126,81 @@ type
private
FProcessID: Integer;
FThreadID: Integer;
FInfo: TCreateProcessDebugInfo;
FThreadMap: TMap; // map ThreadID -> ThreadObject
FLibMap: TMap; // map LibAddr -> LibObject
FBreakMap: TMap; // map BreakAddr -> BreakObject
FSymInstances: TList; // list of dbgInstances with debug info
FMainThread: TDbgThread;
procedure SetName(const AValue: String);
procedure ThreadDestroyed(const AThread: TDbgThread);
protected
FCurrentBreakpoint: TDbgBreakpoint; // set if we are executing the code at the break
// if the singlestep is done, set the break again
FReEnableBreakStep: Boolean; // Set when we are reenabling a breakpoint
// We need a single step, so the IP is after the break to set
procedure SetName(const AValue: String);
procedure ThreadDestroyed(const AThread: TDbgThread);
protected
FSymInstances: TList; // list of dbgInstances with debug info
FThreadMap: TMap; // map ThreadID -> ThreadObject
FLibMap: TMap; // map LibAddr -> LibObject
FBreakMap: TMap; // map BreakAddr -> BreakObject
FMainThread: TDbgThread;
property ProcessID: integer read FProcessID;
function GetHandle: THandle; virtual;
public
constructor Create(const ADefaultName: String; const AProcessID, AThreadID: Integer; const AInfo: TCreateProcessDebugInfo);
constructor Create(const ADefaultName: String; const AProcessID, AThreadID: Integer; const AModuleHandle: THandle; const ABaseAddr, ANameAddr: TDbgPtr; const AUnicode: boolean);
destructor Destroy; override;
function AddBreak(const ALocation: TDbgPtr): TDbgBreakpoint;
function AddLib(const AInfo: TLoadDLLDebugInfo): TDbgLibrary;
procedure AddThread(const AID: Integer; const AInfo: TCreateThreadDebugInfo);
function FindSymbol(const AName: String): TDbgSymbol;
function FindSymbol(AAdress: TDbgPtr): TDbgSymbol;
function GetLib(const AHandle: THandle; out ALib: TDbgLibrary): Boolean;
function GetThread(const AID: Integer; out AThread: TDbgThread): Boolean;
procedure Interrupt;
procedure ContinueDebugEvent(const AThread: TDbgThread; const ADebugEvent: TDebugEvent);
function HandleDebugEvent(const ADebugEvent: TDebugEvent): Boolean;
function RemoveBreak(const ALocation: TDbgPtr): Boolean;
procedure RemoveLib(const AInfo: TUnloadDLLDebugInfo);
procedure RemoveThread(const AID: DWord);
function ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean;
function ReadOrdinal(const AAdress: TDbgPtr; out AData): Boolean;
function ReadString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: String): Boolean;
function ReadWString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: WideString): Boolean;
function ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean; virtual;
function ReadOrdinal(const AAdress: TDbgPtr; out AData): Boolean; virtual;
function ReadString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: String): Boolean; virtual;
function ReadWString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: WideString): Boolean; virtual;
function WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean;
function WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean; virtual;
property Handle: THandle read FInfo.hProcess;
property Handle: THandle read GetHandle;
property Name: String read FName write SetName;
end;
{$endif}
TDbgProcessClass = class of TDbgProcess;
TOSDbgClasses = class
public
DbgThreadClass : TDbgThreadClass;
DbgBreakpointClass : TDbgBreakpointClass;
DbgProcessClass : TDbgProcessClass;
end;
function OSDbgClasses: TOSDbgClasses;
implementation
procedure LogLastError;
{$ifdef windows}
uses
FpDbgWinClasses;
{$endif}
var
GOSDbgClasses : TOSDbgClasses;
function OSDbgClasses: TOSDbgClasses;
begin
DebugLn('FpDbg-ERROR: ', GetLastErrorText);
if GOSDbgClasses=nil then
begin
GOSDbgClasses := TOSDbgClasses.create;
GOSDbgClasses.DbgThreadClass := TDbgThread;
GOSDbgClasses.DbgBreakpointClass := TDbgBreakpoint;
GOSDbgClasses.DbgProcessClass := TDbgProcess;
{$ifdef windows}
RegisterDbgClasses;
{$endif windows}
end;
result := OSDbgClasses;
end;
{$ifdef windows}
{ TDbgInstance }
function TDbgInstance.AddBreak(const AFileName: String; ALine: Cardinal): TDbgBreakpoint;
@ -207,7 +230,6 @@ var
NamePtr: TDbgPtr;
S: String;
W: WideString;
len: Integer;
begin
FBaseAddr := ABaseAddr;
FModuleHandle := AModuleHandle;
@ -231,15 +253,7 @@ begin
if W = ''
then begin
SetLength(S, MAX_PATH);
len := GetModuleFileName(FModuleHandle, @S[1], MAX_PATH);
if len > 0
then SetLength(S, len - 1)
else begin
S := '';
LogLastError;
end;
W := S;
W := GetModuleFileName(FModuleHandle);
end;
if W = ''
@ -273,7 +287,7 @@ end;
procedure TDbgInstance.LoadInfo;
begin
FLoader := TDbgImageLoader.Create(FModuleHandle);
FLoader := InitializeLoader;
assert(false, 'fpc will not compile this');
FDbgInfo := TDbgDwarf.Create(FLoader);
TDbgDwarf(FDbgInfo).LoadCompilationUnits;
@ -295,63 +309,33 @@ begin
FName := AValue;
CheckName;
end;
{$endif}
{$ifdef windows}
function TDbgInstance.InitializeLoader: TDbgImageLoader;
begin
result := nil;
end;
function TDbgInstance.GetModuleFileName(AModuleHandle: THandle): string;
begin
result := '';
end;
{ TDbgLibrary }
constructor TDbgLibrary.Create(const AProcess: TDbgProcess; const ADefaultName: String; const AInfo: TLoadDLLDebugInfo);
constructor TDbgLibrary.Create(const AProcess: TDbgProcess; const ADefaultName: String; const AModuleHandle: THandle; const ABaseAddr, ANameAddr: TDbgPtr; const AUnicode: Boolean);
begin
inherited Create(AProcess, ADefaultName, AInfo.hFile, TDbgPtr(AInfo.lpBaseOfDll), TDbgPtr(AInfo.lpImageName), AInfo.fUnicode <> 0);
inherited Create(AProcess, ADefaultName, AModuleHandle, ABaseAddr, ANameAddr, AUnicode);
end;
{$endif}
{$ifdef windows}
{ TDbgProcess }
function TDbgProcess.AddBreak(const ALocation: TDbgPtr): TDbgBreakpoint;
begin
Result := TDbgBreakpoint.Create(Self, ALocation);
Result := OSDbgClasses.DbgBreakpointClass.Create(Self, ALocation);
FBreakMap.Add(ALocation, Result);
end;
function TDbgProcess.AddLib(const AInfo: TLoadDLLDebugInfo): TDbgLibrary;
var
ID: TDbgPtr;
begin
Result := TDbgLibrary.Create(Self, HexValue(AInfo.lpBaseOfDll, SizeOf(Pointer), [hvfIncludeHexchar]), AInfo);
ID := TDbgPtr(AInfo.lpBaseOfDll);
FLibMap.Add(ID, Result);
if Result.FDbgInfo.HasInfo
then FSymInstances.Add(Result);
end;
procedure TDbgProcess.AddThread(const AID: Integer; const AInfo: TCreateThreadDebugInfo);
var
Thread: TDbgThread;
begin
Thread := TDbgThread.Create(Self, AID, AInfo.hThread, AInfo.lpThreadLocalBase, AInfo.lpStartAddress);
FThreadMap.Add(AID, Thread);
end;
procedure TDbgProcess.ContinueDebugEvent(const AThread: TDbgThread; const ADebugEvent: TDebugEvent);
begin
case ADebugEvent.dwDebugEventCode of
EXCEPTION_DEBUG_EVENT: begin
case ADebugEvent.Exception.ExceptionRecord.ExceptionCode of
EXCEPTION_BREAKPOINT: begin
if AThread = nil then Exit;
if FCurrentBreakpoint = nil then Exit;
if AThread.SingleStepping then Exit;
AThread.SingleStep;
FReEnableBreakStep := True;
end;
end;
end;
end;
end;
constructor TDbgProcess.Create(const ADefaultName: String; const AProcessID, AThreadID: Integer; const AInfo: TCreateProcessDebugInfo);
constructor TDbgProcess.Create(const ADefaultName: String; const AProcessID, AThreadID: Integer; const AModuleHandle: THandle; const ABaseAddr, ANameAddr: TDbgPtr; const AUnicode: boolean);
const
{.$IFDEF CPU64}
MAP_ID_SIZE = itu8;
@ -361,8 +345,7 @@ const
begin
FProcessID := AProcessID;
FThreadID := AThreadID;
FInfo := AInfo;
FThreadMap := TMap.Create(itu4, SizeOf(TDbgThread));
FLibMap := TMap.Create(MAP_ID_SIZE, SizeOf(TDbgLibrary));
FBreakMap := TMap.Create(MAP_ID_SIZE, SizeOf(TDbgBreakpoint));
@ -370,9 +353,8 @@ begin
FSymInstances := TList.Create;
inherited Create(Self, ADefaultName, AInfo.hFile, TDbgPtr(AInfo.lpBaseOfImage), TDbgPtr(AInfo.lpImageName), AInfo.fUnicode <> 0);
inherited Create(Self, ADefaultName, AModuleHandle, ABaseAddr, ANameAddr, AUnicode);
FMainThread := TDbgThread.Create(Self, AThreadID, AInfo.hThread, AInfo.lpThreadLocalBase, AInfo.lpStartAddress);
FThreadMap.Add(AThreadID, FMainThread);
if FDbgInfo.HasInfo
@ -382,7 +364,6 @@ end;
destructor TDbgProcess.Destroy;
begin
// CloseHandle(FInfo.hThread);
CloseHandle(FInfo.hProcess);
FreeAndNil(FBreakMap);
FreeAndNil(FThreadMap);
FreeAndNil(FLibMap);
@ -440,146 +421,9 @@ begin
else Log('Unknown thread ID %u for process %u', [AID, FProcessID]);
end;
{ ------------------------------------------------------------------
HandleDebugEvent
Result: True if the event was triggered internally
The callee should continue the process
------------------------------------------------------------------ }
function TDbgProcess.HandleDebugEvent(const ADebugEvent: TDebugEvent): Boolean;
function DoBreak: Boolean;
var
ID: TDbgPtr;
begin
Result := False;
ID := TDbgPtr(ADebugEvent.Exception.ExceptionRecord.ExceptionAddress);
if not FBreakMap.GetData(ID, FCurrentBreakpoint) then Exit;
if FCurrentBreakpoint = nil then Exit;
Result := True;
if not FCurrentBreakpoint.Hit(ADebugEvent.dwThreadId)
then FCurrentBreakpoint := nil; // no need for a singlestep if we continue
end;
function DoSingleStep: Boolean;
var
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
Result := False;
// check if we are interupting
Context := AlignPtr(@_UC, $10);
Context^.ContextFlags := CONTEXT_DEBUG_REGISTERS;
if GetThreadContext(FInfo.hThread, Context^)
then begin
if Context^.Dr6 and 1 <> 0
then begin
// interrupt !
// disable break.
Context^.Dr7 := Context^.Dr7 and not $1;
Context^.Dr0 := 0;
if not SetThreadContext(FInfo.hThread, Context^)
then begin
// Heeellppp!!
Log('Thread %u: Unable to reset BR0', [ADebugEvent.dwThreadId]);
end;
// check if we are also singlestepping
// if not, then exit, else proceed to next check
if Context^.Dr6 and $40 = 0
then Exit;
end;
end
else begin
// if we can not get the context, we probable weren't able to set it either
Log('Thread %u: Unable to get context', [ADebugEvent.dwThreadId]);
end;
// check if we are single stepping ourself
if FCurrentBreakpoint = nil then Exit;
FCurrentBreakpoint.SetBreak;
FCurrentBreakpoint := nil;
Result := FReEnableBreakStep;
FReEnableBreakStep := False;
end;
begin
Result := False;
case ADebugEvent.dwDebugEventCode of
EXCEPTION_DEBUG_EVENT: begin
case ADebugEvent.Exception.ExceptionRecord.ExceptionCode of
EXCEPTION_BREAKPOINT: {Result :=} DoBreak; // we never set a break ourself, let the callee pause!
EXCEPTION_SINGLE_STEP: Result := DoSingleStep;
end;
end;
CREATE_THREAD_DEBUG_EVENT: begin
AddThread(ADebugEvent.dwThreadId, ADebugEvent.CreateThread)
end;
EXIT_THREAD_DEBUG_EVENT: begin
RemoveThread(ADebugEvent.dwThreadId);
end;
LOAD_DLL_DEBUG_EVENT: begin
AddLib(ADebugEvent.LoadDll);
end;
UNLOAD_DLL_DEBUG_EVENT: begin
RemoveLib(ADebugEvent.UnloadDll);
end;
end;
end;
procedure TDbgProcess.Interrupt;
var
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
// Interrupting is implemented by suspending the thread and set DB0 to the
// (to be) executed EIP. When the thread is resumed, it will generate a break
// Single stepping doesn't work in all cases.
// A context needs to be aligned to 16 bytes. Unfortunately, the compiler has
// no directive for this, so align it somewhere in our "reserved" memory
Context := AlignPtr(@_UC, $10);
SuspendThread(FInfo.hThread);
try
Context^.ContextFlags := CONTEXT_CONTROL or CONTEXT_DEBUG_REGISTERS;
if not GetThreadContext(FInfo.hThread, Context^)
then begin
Log('Proces %u interrupt: Unable to get context', [FProcessID]);
Exit;
end;
Context^.ContextFlags := CONTEXT_DEBUG_REGISTERS;
{$ifdef cpui386}
Context^.Dr0 := Context^.Eip;
{$else}
Context^.Dr0 := Context^.Rip;
{$endif}
Context^.Dr7 := (Context^.Dr7 and $FFF0FFFF) or $1;
if not SetThreadContext(FInfo.hThread, Context^)
then begin
Log('Proces %u interrupt: Unable to set context', [FProcessID]);
Exit;
end;
finally
ResumeTHread(FInfo.hThread);
end;
end;
function TDbgProcess.ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean;
var
BytesRead: Cardinal;
begin
Result := ReadProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @AData, ASize, BytesRead) and (BytesRead = ASize);
if not Result then LogLastError;
result := false
end;
function TDbgProcess.ReadOrdinal(const AAdress: TDbgPtr; out AData): Boolean;
@ -588,32 +432,13 @@ begin
end;
function TDbgProcess.ReadString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: String): Boolean;
var
BytesRead: Cardinal;
buf: array of Char;
begin
SetLength(buf, AMaxSize + 1);
Result := ReadProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @Buf[0], AMaxSize, BytesRead);
if not Result then Exit;
if BytesRead < AMaxSize
then Buf[BytesRead] := #0
else Buf[AMaxSize] := #0;
AData := PChar(@Buf[0]);
Result := false;
end;
function TDbgProcess.ReadWString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: WideString): Boolean;
var
BytesRead: Cardinal;
buf: array of WChar;
begin
SetLength(buf, AMaxSize + 1);
Result := ReadProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @Buf[0], SizeOf(WChar) * AMaxSize, BytesRead);
if not Result then Exit;
BytesRead := BytesRead div SizeOf(WChar);
if BytesRead < AMaxSize
then Buf[BytesRead] := #0
else Buf[AMaxSize] := #0;
AData := PWChar(@Buf[0]);
result := false;
end;
function TDbgProcess.RemoveBreak(const ALocation: TDbgPtr): Boolean;
@ -623,20 +448,6 @@ begin
else Result := FBreakMap.Delete(ALocation);
end;
procedure TDbgProcess.RemoveLib(const AInfo: TUnloadDLLDebugInfo);
var
Lib: TDbgLibrary;
ID: TDbgPtr;
begin
if FLibMap = nil then Exit;
ID := TDbgPtr(AInfo.lpBaseOfDll);
if not FLibMap.GetData(ID, Lib) then Exit;
if Lib.FDbgInfo.HasInfo
then FSymInstances.Remove(Lib);
FLibMap.Delete(ID);
// TODO: Free lib ???
end;
procedure TDbgProcess.RemoveThread(const AID: DWord);
begin
if FThreadMap = nil then Exit;
@ -648,6 +459,11 @@ begin
FName := AValue;
end;
function TDbgProcess.GetHandle: THandle;
begin
result := 0;
end;
procedure TDbgProcess.ThreadDestroyed(const AThread: TDbgThread);
begin
if AThread = FMainThread
@ -655,16 +471,10 @@ begin
end;
function TDbgProcess.WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean;
var
BytesWritten: Cardinal;
begin
Result := WriteProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @AData, ASize, BytesWritten) and (BytesWritten = ASize);
if not Result then LogLastError;
result := false;
end;
{$endif}
{$ifdef windows}
{ TDbgThread }
constructor TDbgThread.Create(const AProcess: TDbgProcess; const AID: Integer; const AHandle: THandle; const ABase, AStart: Pointer);
@ -685,35 +495,10 @@ begin
end;
function TDbgThread.SingleStep: Boolean;
var
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
Context := AlignPtr(@_UC, $10);
Context^.ContextFlags := CONTEXT_CONTROL;
if not GetThreadContext(FHandle, Context^)
then begin
Log('Thread %u: Unable to get context', [FID]);
Exit;
end;
Context^.ContextFlags := CONTEXT_CONTROL;
Context^.EFlags := Context^.EFlags or FLAG_TRACE_BIT;
if not SetThreadContext(FHandle, Context^)
then begin
Log('Thread %u: Unable to set context', [FID]);
Exit;
end;
FSingleStepping := True;
end;
{$endif}
{$ifdef windows}
{ TDbgBreak }
constructor TDbgBreakpoint.Create(const AProcess: TDbgProcess; const ALocation: TDbgPtr);
@ -731,43 +516,8 @@ begin
end;
function TDbgBreakpoint.Hit(const AThreadID: Integer): Boolean;
var
Thread: TDbgThread;
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
Result := False;
if FOrgValue = $CC then Exit; // breakpoint on a hardcoded breakpoint
// no need to jum back and restore instruction
ResetBreak;
if not FProcess.GetThread(AThreadId, Thread) then Exit;
Context := AlignPtr(@_UC, $10);
Context^.ContextFlags := CONTEXT_CONTROL;
if not GetThreadContext(Thread.Handle, Context^)
then begin
Log('Break $s: Unable to get context', [HexValue(FLocation, SizeOf(Pointer), [hvfIncludeHexchar])]);
Exit;
end;
Context^.ContextFlags := CONTEXT_CONTROL;
{$ifdef cpui386}
Dec(Context^.Eip);
{$else}
Dec(Context^.Rip);
{$endif}
if not SetThreadContext(Thread.Handle, Context^)
then begin
Log('Break %s: Unable to set context', [HexValue(FLocation, SizeOf(Pointer), [hvfIncludeHexchar])]);
Exit;
end;
Result := True;
result := false;
end;
procedure TDbgBreakpoint.ResetBreak;
@ -779,7 +529,6 @@ begin
Log('Unable to reset breakpoint at $%p', [FLocation]);
Exit;
end;
FlushInstructionCache(FProcess.FInfo.hProcess, Pointer(PtrUInt(FLocation)), 1);
end;
procedure TDbgBreakpoint.SetBreak;
@ -799,8 +548,10 @@ begin
Log('Unable to set breakpoint at $%p', [FLocation]);
Exit;
end;
FlushInstructionCache(FProcess.FInfo.hProcess, Pointer(PtrUInt(FLocation)), 1);
end;
{$endif}
initialization
GOSDbgClasses := nil;
finalization
GOSDbgClasses.Free;
end.

472
components/fpdebug/fpdbgwinclasses.pas Normal file
View File

@ -0,0 +1,472 @@
{ $Id: fpdbgwinclasses.pp 43410 2013-11-09 20:34:31Z martin $ }
{
---------------------------------------------------------------------------
fpdbgwinclasses.pp - Native freepascal debugger
---------------------------------------------------------------------------
This unit contains debugger classes for a native freepascal debugger
---------------------------------------------------------------------------
@created(Sun Feb 9th WET 2014)
@lastmod($Date: 2013-11-09 21:34:31 +0100 (za, 09 nov 2013) $)
@author(Joost van der Sluis <joost@@cnoc.nl>)
***************************************************************************
* *
* 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
}
unit FpDbgWinClasses;
{$mode objfpc}{$H+}
interface
uses
Classes,
SysUtils,
Windows,
FpDbgUtil,
FpDbgClasses,
FpDbgWinExtra,
FpDbgInfo,
FpDbgLoader,
LazLoggerBase;
type
{ TDbgWinThread }
TDbgWinThread = class(TDbgThread)
public
function SingleStep: Boolean; virtual;
end;
{ TDbgWinBreakpoint }
TDbgWinBreakpointEvent = procedure(const ASender: TDbgBreakpoint; const AContext: TContext) of object;
TDbgWinBreakpoint = class(TDbgBreakpoint)
protected
procedure SetBreak; override;
procedure ResetBreak; override;
public
function Hit(const AThreadID: Integer): Boolean; override;
end;
{ TDbgWinProcess }
TDbgWinProcess = class(TDbgProcess)
private
FInfo: TCreateProcessDebugInfo;
protected
function GetModuleFileName(AModuleHandle: THandle): string; override;
function GetHandle: THandle; override;
function InitializeLoader: TDbgImageLoader; override;
public
constructor Create(const ADefaultName: String; const AProcessID, AThreadID: Integer; const AInfo: TCreateProcessDebugInfo);
destructor Destroy; override;
function ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean; override;
function WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean; override;
function ReadString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: String): Boolean; override;
function ReadWString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: WideString): Boolean; override;
procedure Interrupt;
procedure ContinueDebugEvent(const AThread: TDbgThread; const ADebugEvent: TDebugEvent);
function HandleDebugEvent(const ADebugEvent: TDebugEvent): Boolean;
function AddLib(const AInfo: TLoadDLLDebugInfo): TDbgLibrary;
procedure AddThread(const AID: Integer; const AInfo: TCreateThreadDebugInfo);
procedure RemoveLib(const AInfo: TUnloadDLLDebugInfo);
end;
procedure RegisterDbgClasses;
implementation
procedure RegisterDbgClasses;
begin
OSDbgClasses.DbgThreadClass:=TDbgWinThread;
OSDbgClasses.DbgBreakpointClass:=TDbgWinBreakpoint;
OSDbgClasses.DbgProcessClass:=TDbgWinProcess;
end;
procedure LogLastError;
begin
DebugLn('FpDbg-ERROR: ', GetLastErrorText);
end;
{ TDbgWinProcess }
function TDbgWinProcess.GetModuleFileName(AModuleHandle: THandle): string;
var
s: string;
len: Integer;
begin
SetLength(S, MAX_PATH);
len := windows.GetModuleFileName(AModuleHandle, @S[1], MAX_PATH);
if len > 0
then SetLength(S, len - 1)
else begin
S := '';
LogLastError;
end;
result := s;
end;
function TDbgWinProcess.GetHandle: THandle;
begin
Result:=FInfo.hProcess;
end;
function TDbgWinProcess.InitializeLoader: TDbgImageLoader;
begin
result := TDbgImageLoader.Create(ModuleHandle);
end;
constructor TDbgWinProcess.Create(const ADefaultName: String; const AProcessID, AThreadID: Integer; const AInfo: TCreateProcessDebugInfo);
begin
FInfo := AInfo;
inherited Create(ADefaultName, AProcessID, AThreadID, AInfo.hFile, TDbgPtr(AInfo.lpBaseOfImage), TDbgPtr(AInfo.lpImageName), AInfo.fUnicode <> 0);
FMainThread := OSDbgClasses.DbgThreadClass.Create(Self, AThreadID, AInfo.hThread, AInfo.lpThreadLocalBase, AInfo.lpStartAddress);
end;
destructor TDbgWinProcess.Destroy;
begin
CloseHandle(FInfo.hProcess);
inherited Destroy;
end;
function TDbgWinProcess.ReadData(const AAdress: TDbgPtr; const ASize: Cardinal; out AData): Boolean;
var
BytesRead: Cardinal;
begin
Result := ReadProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @AData, ASize, BytesRead) and (BytesRead = ASize);
if not Result then LogLastError;
end;
function TDbgWinProcess.WriteData(const AAdress: TDbgPtr; const ASize: Cardinal; const AData): Boolean;
var
BytesWritten: Cardinal;
begin
Result := WriteProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @AData, ASize, BytesWritten) and (BytesWritten = ASize);
if not Result then LogLastError;
end;
function TDbgWinProcess.ReadString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: String): Boolean;
var
BytesRead: Cardinal;
buf: array of Char;
begin
SetLength(buf, AMaxSize + 1);
Result := ReadProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @Buf[0], AMaxSize, BytesRead);
if not Result then Exit;
if BytesRead < AMaxSize
then Buf[BytesRead] := #0
else Buf[AMaxSize] := #0;
AData := PChar(@Buf[0]);
end;
function TDbgWinProcess.ReadWString(const AAdress: TDbgPtr; const AMaxSize: Cardinal; out AData: WideString): Boolean;
var
BytesRead: Cardinal;
buf: array of WChar;
begin
SetLength(buf, AMaxSize + 1);
Result := ReadProcessMemory(Handle, Pointer(PtrUInt(AAdress)), @Buf[0], SizeOf(WChar) * AMaxSize, BytesRead);
if not Result then Exit;
BytesRead := BytesRead div SizeOf(WChar);
if BytesRead < AMaxSize
then Buf[BytesRead] := #0
else Buf[AMaxSize] := #0;
AData := PWChar(@Buf[0]);
end;
procedure TDbgWinProcess.Interrupt;
var
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
// Interrupting is implemented by suspending the thread and set DB0 to the
// (to be) executed EIP. When the thread is resumed, it will generate a break
// Single stepping doesn't work in all cases.
// A context needs to be aligned to 16 bytes. Unfortunately, the compiler has
// no directive for this, so align it somewhere in our "reserved" memory
Context := AlignPtr(@_UC, $10);
SuspendThread(FInfo.hThread);
try
Context^.ContextFlags := CONTEXT_CONTROL or CONTEXT_DEBUG_REGISTERS;
if not GetThreadContext(FInfo.hThread, Context^)
then begin
Log('Proces %u interrupt: Unable to get context', [ProcessID]);
Exit;
end;
Context^.ContextFlags := CONTEXT_DEBUG_REGISTERS;
{$ifdef cpui386}
Context^.Dr0 := Context^.Eip;
{$else}
Context^.Dr0 := Context^.Rip;
{$endif}
Context^.Dr7 := (Context^.Dr7 and $FFF0FFFF) or $1;
if not SetThreadContext(FInfo.hThread, Context^)
then begin
Log('Proces %u interrupt: Unable to set context', [ProcessID]);
Exit;
end;
finally
ResumeTHread(FInfo.hThread);
end;
end;
procedure TDbgWinProcess.ContinueDebugEvent(const AThread: TDbgThread; const ADebugEvent: TDebugEvent);
begin
case ADebugEvent.dwDebugEventCode of
EXCEPTION_DEBUG_EVENT: begin
case ADebugEvent.Exception.ExceptionRecord.ExceptionCode of
EXCEPTION_BREAKPOINT: begin
if AThread = nil then Exit;
if FCurrentBreakpoint = nil then Exit;
if AThread.SingleStepping then Exit;
AThread.SingleStep;
FReEnableBreakStep := True;
end;
end;
end;
end;
end;
{ ------------------------------------------------------------------
HandleDebugEvent
Result: True if the event was triggered internally
The callee should continue the process
------------------------------------------------------------------ }
function TDbgWinProcess.HandleDebugEvent(const ADebugEvent: TDebugEvent): Boolean;
function DoBreak: Boolean;
var
ID: TDbgPtr;
begin
Result := False;
ID := TDbgPtr(ADebugEvent.Exception.ExceptionRecord.ExceptionAddress);
if not FBreakMap.GetData(ID, FCurrentBreakpoint) then Exit;
if FCurrentBreakpoint = nil then Exit;
Result := True;
if not FCurrentBreakpoint.Hit(ADebugEvent.dwThreadId)
then FCurrentBreakpoint := nil; // no need for a singlestep if we continue
end;
function DoSingleStep: Boolean;
var
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
Result := False;
// check if we are interupting
Context := AlignPtr(@_UC, $10);
Context^.ContextFlags := CONTEXT_DEBUG_REGISTERS;
if GetThreadContext(FInfo.hThread, Context^)
then begin
if Context^.Dr6 and 1 <> 0
then begin
// interrupt !
// disable break.
Context^.Dr7 := Context^.Dr7 and not $1;
Context^.Dr0 := 0;
if not SetThreadContext(FInfo.hThread, Context^)
then begin
// Heeellppp!!
Log('Thread %u: Unable to reset BR0', [ADebugEvent.dwThreadId]);
end;
// check if we are also singlestepping
// if not, then exit, else proceed to next check
if Context^.Dr6 and $40 = 0
then Exit;
end;
end
else begin
// if we can not get the context, we probable weren't able to set it either
Log('Thread %u: Unable to get context', [ADebugEvent.dwThreadId]);
end;
// check if we are single stepping ourself
if FCurrentBreakpoint = nil then Exit;
FCurrentBreakpoint.SetBreak;
FCurrentBreakpoint := nil;
Result := FReEnableBreakStep;
FReEnableBreakStep := False;
end;
begin
Result := False;
case ADebugEvent.dwDebugEventCode of
EXCEPTION_DEBUG_EVENT: begin
case ADebugEvent.Exception.ExceptionRecord.ExceptionCode of
EXCEPTION_BREAKPOINT: {Result :=} DoBreak; // we never set a break ourself, let the callee pause!
EXCEPTION_SINGLE_STEP: Result := DoSingleStep;
end;
end;
CREATE_THREAD_DEBUG_EVENT: begin
AddThread(ADebugEvent.dwThreadId, ADebugEvent.CreateThread)
end;
EXIT_THREAD_DEBUG_EVENT: begin
RemoveThread(ADebugEvent.dwThreadId);
end;
LOAD_DLL_DEBUG_EVENT: begin
AddLib(ADebugEvent.LoadDll);
end;
UNLOAD_DLL_DEBUG_EVENT: begin
RemoveLib(ADebugEvent.UnloadDll);
end;
end;
end;
function TDbgWinProcess.AddLib(const AInfo: TLoadDLLDebugInfo): TDbgLibrary;
var
ID: TDbgPtr;
begin
Result := TDbgLibrary.Create(Self, HexValue(AInfo.lpBaseOfDll, SizeOf(Pointer), [hvfIncludeHexchar]), AInfo.hFile, TDbgPtr(AInfo.lpBaseOfDll), TDbgPtr(AInfo.lpImageName), AInfo.fUnicode <> 0);
ID := TDbgPtr(AInfo.lpBaseOfDll);
FLibMap.Add(ID, Result);
if Result.DbgInfo.HasInfo
then FSymInstances.Add(Result);
end;
procedure TDbgWinProcess.AddThread(const AID: Integer; const AInfo: TCreateThreadDebugInfo);
var
Thread: TDbgThread;
begin
Thread := OSDbgClasses.DbgThreadClass.Create(Self, AID, AInfo.hThread, AInfo.lpThreadLocalBase, AInfo.lpStartAddress);
FThreadMap.Add(AID, Thread);
end;
procedure TDbgWinProcess.RemoveLib(const AInfo: TUnloadDLLDebugInfo);
var
Lib: TDbgLibrary;
ID: TDbgPtr;
begin
if FLibMap = nil then Exit;
ID := TDbgPtr(AInfo.lpBaseOfDll);
if not FLibMap.GetData(ID, Lib) then Exit;
if Lib.DbgInfo.HasInfo
then FSymInstances.Remove(Lib);
FLibMap.Delete(ID);
// TODO: Free lib ???
end;
{ TDbgWinBreakpoint }
procedure TDbgWinBreakpoint.SetBreak;
begin
inherited;
FlushInstructionCache(Process.Handle, Pointer(PtrUInt(Location)), 1);
end;
procedure TDbgWinBreakpoint.ResetBreak;
begin
inherited;
FlushInstructionCache(Process.Handle, Pointer(PtrUInt(Location)), 1);
end;
function TDbgWinBreakpoint.Hit(const AThreadID: Integer): Boolean;
var
Thread: TDbgThread;
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
Result := False;
if FOrgValue = $CC then Exit; // breakpoint on a hardcoded breakpoint
// no need to jum back and restore instruction
ResetBreak;
if not Process.GetThread(AThreadId, Thread) then Exit;
Context := AlignPtr(@_UC, $10);
Context^.ContextFlags := CONTEXT_CONTROL;
if not GetThreadContext(Thread.Handle, Context^)
then begin
Log('Break $s: Unable to get context', [HexValue(Location, SizeOf(Pointer), [hvfIncludeHexchar])]);
Exit;
end;
Context^.ContextFlags := CONTEXT_CONTROL;
{$ifdef cpui386}
Dec(Context^.Eip);
{$else}
Dec(Context^.Rip);
{$endif}
if not SetThreadContext(Thread.Handle, Context^)
then begin
Log('Break %s: Unable to set context', [HexValue(Location, SizeOf(Pointer), [hvfIncludeHexchar])]);
Exit;
end;
Result := True;
end;
{ TDbgWinThread }
function TDbgWinThread.SingleStep: Boolean;
var
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
Context := AlignPtr(@_UC, $10);
Context^.ContextFlags := CONTEXT_CONTROL;
if not GetThreadContext(Handle, Context^)
then begin
Log('Thread %u: Unable to get context', [ID]);
Exit;
end;
Context^.ContextFlags := CONTEXT_CONTROL;
Context^.EFlags := Context^.EFlags or FLAG_TRACE_BIT;
if not SetThreadContext(Handle, Context^)
then begin
Log('Thread %u: Unable to set context', [ID]);
Exit;
end;
Inherited;
end;
end.

9
components/fpdebug/fpdebug.lpk
View File

@ -34,7 +34,7 @@ File(s) with other licenses (see also header in file(s):
(Any modifications/translations of this file are from duby)
"/>
<Files Count="19">
<Files Count="20">
<Item1>
<Filename Value="fpdbgclasses.pp"/>
<UnitName Value="FpDbgClasses"/>
@ -109,8 +109,13 @@ File(s) with other licenses (see also header in file(s):
</Item18>
<Item19>
<Filename Value="fpdbginfo.pas"/>
<UnitName Value="fpdbginfo"/>
<UnitName Value="FpDbgInfo"/>
</Item19>
<Item20>
<Filename Value="fpdbgwinclasses.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="FpDbgWinClasses"/>
</Item20>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">

9
components/fpdebug/fpdebug.pas
View File

@ -7,10 +7,11 @@ unit fpdebug;
interface
uses
FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader, FpDbgPETypes,
FpDbgSymbols, FpDbgUtil, FpDbgWinExtra, FpImgReaderWinPE, FpImgReaderElf,
FpImgReaderElfTypes, FpImgReaderBase, FpPascalParser, macho, FpImgReaderMachoFile,
FpImgReaderMacho, FpPascalBuilder, FpDbgInfo, LazarusPackageIntf;
FpDbgClasses, FpDbgDisasX86, FpDbgDwarf, FpDbgDwarfConst, FpDbgLoader,
FpDbgPETypes, FpDbgSymbols, FpDbgUtil, FpDbgWinExtra, FpImgReaderWinPE,
FpImgReaderElf, FpImgReaderElfTypes, FpImgReaderBase, FpPascalParser, macho,
FpImgReaderMachoFile, FpImgReaderMacho, FpPascalBuilder, FpDbgInfo,
LazarusPackageIntf;
implementation