paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-22 15:19:35 +02:00
Code Issues Packages Projects Releases Wiki Activity

* more alignment

Browse Source 
git-svn-id: trunk@9157 -
This commit is contained in:
marc 2006-04-21 22:25:31 +00:00
parent 14a0ab0d14
commit 1862e5c637
4 changed files with 139 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
debugger/windebug/fpwd/fpwdloop.pas
View File

@ -240,11 +240,36 @@ procedure DebugLoop;
{$ifdef cpui386}
with GCurrentContext^ do WriteLN(Format('DS: 0x%x, ES: 0x%x, FS: 0x%x, GS: 0x%x', [SegDs, SegEs, SegFs, SegGs]));
with GCurrentContext^ do WriteLN(Format('EAX: 0x%x, EBX: 0x%x, ECX: 0x%x, EDX: 0x%x, EDI: 0x%x, ESI: 0x%x', [Eax, Ebx, Ecx, Edx, Edi, Esi]));
with GCurrentContext^ do WriteLN(Format('CS: 0x%x, SS: 0x%x, EBP: 0x%x, EIP: 0x%x, ESP: 0x%x, EFlags: 0x%x', [SegCs, SegSs, Ebp, Eip, Esp, EFlags]));
with GCurrentContext^ do Write(Format('CS: 0x%x, SS: 0x%x, EBP: 0x%x, EIP: 0x%x, ESP: 0x%x, EFlags: 0x%x [', [SegCs, SegSs, Ebp, Eip, Esp, EFlags]));
{$else}
with GCurrentContext^ do WriteLN(Format('SegDS: 0x%4.4x, SegES: 0x%4.4x, SegFS: 0x%4.4x, SegGS: 0x%4.4x', [SegDs, SegEs, SegFs, SegGs]));
with GCurrentContext^ do WriteLN(Format('RAX: 0x%16.16x, RBX: 0x%16.16x, RCX: 0x%16.16x, RDX: 0x%16.16x, RDI: 0x%16.16x, RSI: 0x%16.16x, R9: 0x%16.16x, R10: 0x%16.16x, R11: 0x%16.16x, R12: 0x%16.16x, R13: 0x%16.16x, R14: 0x%16.16x, R15: 0x%16.16x', [Rax, Rbx, Rcx, Rdx, Rdi, Rsi, R9, R10, R11, R12, R13, R14, R15]));
with GCurrentContext^ do Write(Format('SegCS: 0x%4.4x, SegSS: 0x%4.4x, RBP: 0x%16.16x, RIP: 0x%16.16x, RSP: 0x%16.16x, EFlags: 0x%8.8x [', [SegCs, SegSs, Rbp, Rip, Rsp, EFlags]));
{$endif}
// luckely flag and debug registers are named the same
with GCurrentContext^ do
begin
if EFlags and (1 shl 0) <> 0 then Write('CF ');
if EFlags and (1 shl 2) <> 0 then Write('PF ');
if EFlags and (1 shl 4) <> 0 then Write('AF ');
if EFlags and (1 shl 6) <> 0 then Write('ZF ');
if EFlags and (1 shl 7) <> 0 then Write('SF ');
if EFlags and (1 shl 8) <> 0 then Write('TF ');
if EFlags and (1 shl 9) <> 0 then Write('IF ');
if EFlags and (1 shl 10) <> 0 then Write('DF ');
if EFlags and (1 shl 11) <> 0 then Write('OF ');
if (EFlags shr 12) and 3 <> 0 then Write('IOPL=', (EFlags shr 12) and 3);
if EFlags and (1 shl 14) <> 0 then Write('NT ');
if EFlags and (1 shl 16) <> 0 then Write('RF ');
if EFlags and (1 shl 17) <> 0 then Write('VM ');
if EFlags and (1 shl 18) <> 0 then Write('AC ');
if EFlags and (1 shl 19) <> 0 then Write('VIF ');
if EFlags and (1 shl 20) <> 0 then Write('VIP ');
if EFlags and (1 shl 21) <> 0 then Write('ID ');
WriteLn(']');
Write(Format('DR0: 0x%x, DR1: 0x%x, DR2: 0x%x, DR3: 0x%x', [Dr0, Dr1, Dr2, Dr3]));
Write(' DR6: 0x', IntToHex(Dr6, 8), ' [');
Write(' DR6: 0x', IntToHex(Dr6, SizeOf(Pointer) * 2), ' [');
if Dr6 and $0001 <> 0 then Write('B0 ');
if Dr6 and $0002 <> 0 then Write('B1 ');
if Dr6 and $0004 <> 0 then Write('B2 ');
@ -252,7 +277,7 @@ procedure DebugLoop;
if Dr6 and $2000 <> 0 then Write('BD ');
if Dr6 and $4000 <> 0 then Write('BS ');
if Dr6 and $8000 <> 0 then Write('BT ');
Write('] DR7: 0x', IntToHex(Dr7, 8), ' [');
Write('] DR7: 0x', IntToHex(Dr7, SizeOf(Pointer) * 2), ' [');
if Dr7 and $01 <> 0 then Write('L0 ');
if Dr7 and $02 <> 0 then Write('G0 ');
if Dr7 and $04 <> 0 then Write('L1 ');
@ -280,11 +305,6 @@ procedure DebugLoop;
end;
WriteLN(']');
end;
{$else}
with GCurrentContext^ do WriteLN(Format('SegDS: 0x%4.4x, SegES: 0x%4.4x, SegFS: 0x%4.4x, SegGS: 0x%4.4x', [SegDs, SegEs, SegFs, SegGs]));
with GCurrentContext^ do WriteLN(Format('RAX: 0x%16.16x, RBX: 0x%16.16x, RCX: 0x%16.16x, RDX: 0x%16.16x, RDI: 0x%16.16x, RSI: 0x%16.16x, R9: 0x%16.16x, R10: 0x%16.16x, R11: 0x%16.16x, R12: 0x%16.16x, R13: 0x%16.16x, R14: 0x%16.16x, R15: 0x%16.16x', [Rax, Rbx, Rcx, Rdx, Rdi, Rsi, R9, R10, R11, R12, R13, R14, R15]));
with GCurrentContext^ do WriteLN(Format('SegCS: 0x%4.4x, SegSS: 0x%4.4x, RBP: 0x%16.16x, RIP: 0x%16.16x, RSP: 0x%16.16x, EFlags: 0x%8.8x', [SegCs, SegSs, Rbp, Rip, Rsp, EFlags]));
{$endif}
WriteLN('---');
end;
@ -316,8 +336,7 @@ begin
then begin
if GCurrentProcess.HandleDebugEvent(MDebugEvent) then Continue;
if not GCurrentProcess.GetThread(MDebugEvent.dwTHreadID, GCurrentThread)
then WriteLN('LOOP: Unable to retrieve current thread')
else WriteLN('LOOP: ID:', MDebugEvent.dwTHreadID, ' -> H:', GCurrentThread.Handle);
then WriteLN('LOOP: Unable to retrieve current thread');
end;
FillChar(GCurrentContext^, SizeOf(GCurrentContext^), $EE);
@ -325,17 +344,10 @@ begin
if GCurrentThread <> nil
then begin
// TODO: move to TDbgThread
{$ifdef cpui386}
GCurrentContext^.ContextFlags := CONTEXT_SEGMENTS or CONTEXT_INTEGER or CONTEXT_CONTROL {or CONTEXT_DEBUG_REGISTERS};
{$else}
GCurrentContext^.ContextFlags := CONTEXT_SEGMENTS_AMD64 or CONTEXT_INTEGER_AMD64 or CONTEXT_CONTROL_AMD64;
{$endif}
GCurrentContext^.ContextFlags := CONTEXT_SEGMENTS or CONTEXT_INTEGER or CONTEXT_CONTROL or CONTEXT_DEBUG_REGISTERS;
SetLastError(0);
// SuspendTHread(GCurrentThread.Handle);
if not GetThreadContext(GCurrentThread.Handle, GCurrentContext^)
then WriteLN('LOOP: Unable to retrieve thread context')
else WriteLN('LOOP context: ', IntToHex(GCurrentContext^.ContextFlags, SizeOf(Pointer) * 2), ' error: ', GetLastErrorText);
// ResumeThread(GCurrentThread.Handle);
then WriteLN('LOOP: Unable to retrieve thread context');
end;
case MDebugEvent.dwDebugEventCode of

7
debugger/windebug/fpwd/fpwdtype.pas
View File

@ -90,6 +90,7 @@ type
EXCEPTION_POINTERS64 = _EXCEPTION_POINTERS64;
*)
// PExceptionDebugInfo64 = QWORD;
(*
PExceptionDebugInfo64 = ^_EXCEPTION_DEBUG_INFO64;
_EXCEPTION_DEBUG_INFO64 = record
ExceptionRecord: TExceptionRecord64;
@ -97,6 +98,7 @@ type
end;
TExceptionDebugInfo64 = _EXCEPTION_DEBUG_INFO64;
EXCEPTION_DEBUG_INFO64 = _EXCEPTION_DEBUG_INFO64;
*)
(*
PCreateThreadDebugInfo64 = QWORD;
_CREATE_THREAD_DEBUG_INFO64 = record
@ -184,7 +186,10 @@ type
TDebugEvent64 = _DEBUG_EVENT64;
DEBUG_EVENT64 = _DEBUG_EVENT64;
*)
{$ifdef __dont_use__}
const
CONTEXT_AMD64 = $100000;
// MWE: added _AMD64 postfix to distinguish between i386 and amd64
@ -416,6 +421,8 @@ type
CONTEXTAMD64 = _CONTEXTAMD64;
TContextAMD64 = _CONTEXTAMD64;
PContextAMD64 = ^TContextAMD64;
{$endif}
implementation

165
debugger/windebug/windebugger.pp
View File

@ -366,56 +366,67 @@ begin
end;
function TDbgProcess.HandleDebugEvent(const ADebugEvent: TDebugEvent): Boolean;
var
Context: TContext;
function DoBreak: Boolean;
begin
if not FBreakMap.GetData(TDbgPtr(ADebugEvent.Exception.ExceptionRecord.ExceptionAddress), FSingleStepBreak) then Exit;
if FSingleStepBreak = nil then Exit;
Result := True;
if not FSingleStepBreak.Hit(ADebugEvent.dwThreadId)
then FSingleStepBreak := 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
// 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 cant 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
if FSingleStepBreak = nil then Exit;
FSingleStepBreak.SetBreak;
FSingleStepBreak := nil;
Result := FSingleStepSet;
FSingleStepSet := False;
end;
begin
Result := False;
case ADebugEvent.dwDebugEventCode of
EXCEPTION_DEBUG_EVENT: begin
case ADebugEvent.Exception.ExceptionRecord.ExceptionCode of
EXCEPTION_BREAKPOINT: begin
if not FBreakMap.GetData(TDbgPtr(ADebugEvent.Exception.ExceptionRecord.ExceptionAddress), FSingleStepBreak) then Exit;
if FSingleStepBreak = nil then Exit;
Result := True;
if not FSingleStepBreak.Hit(ADebugEvent.dwThreadId)
then FSingleStepBreak := nil; // no need for a singlestep if we continue
end;
EXCEPTION_SINGLE_STEP: begin
// check if we are interupting
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 cant 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
if FSingleStepBreak = nil then Exit;
FSingleStepBreak.SetBreak;
FSingleStepBreak := nil;
Result := FSingleStepSet;
FSingleStepSet := False;
end;
EXCEPTION_BREAKPOINT: Result := DoBreak;
EXCEPTION_SINGLE_STEP: Result := DoSingleStep;
end;
end;
CREATE_THREAD_DEBUG_EVENT: begin
@ -435,35 +446,38 @@ end;
procedure TDbgProcess.Interrupt;
var
Context: TContext;
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
r: DWORD;
begin
Context := AlignPtr(@_UC, $10);
r := SuspendThread(FInfo.hThread);
try
Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_DEBUG_REGISTERS;
if not GetThreadContext(FInfo.hThread, Context)
Context^.ContextFlags := CONTEXT_CONTROL or CONTEXT_DEBUG_REGISTERS;
if not GetThreadContext(FInfo.hThread, Context^)
then begin
// Log('Thread %u: Unable to get context', [FID]);
Log('Proces %u interrupt: Unable to get context', [FProcessID]);
Exit;
end;
Context.ContextFlags := CONTEXT_DEBUG_REGISTERS;
Context^.ContextFlags := CONTEXT_DEBUG_REGISTERS;
{$ifdef cpui386}
Context.Dr0 := Context.Eip;
Context.Dr7 := (Context.Dr7 and $FFF0FFFF) or $1;
Context^.Dr0 := Context^.Eip;
{$else}
Context.Dr0 := Context.Rip;
Context.Dr7 := (Context.Dr7 and $FFFFFFFFFFF0FFFF) or $1;
Context^.Dr0 := Context^.Rip;
{$endif}
Context^.Dr7 := (Context^.Dr7 and $FFF0FFFF) or $1;
// Context.EFlags := Context.EFlags or $100;
if not SetThreadContext(FInfo.hThread, Context)
if not SetThreadContext(FInfo.hThread, Context^)
then begin
// Log('Thread %u: Unable to set context', [FID]);
Log('Proces %u interrupt: Unable to set context', [FProcessID]);
Exit;
end;
finally
@ -573,19 +587,24 @@ end;
function TDbgThread.SingleStep: Boolean;
var
Context: TContext;
_UC: record
C: TContext;
D: array[1..16] of Byte;
end;
Context: PContext;
begin
Context.ContextFlags := CONTEXT_CONTROL;
if not GetThreadContext(FHandle, Context)
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 $100;
Context^.ContextFlags := CONTEXT_CONTROL;
Context^.EFlags := Context^.EFlags or $100;
if not SetThreadContext(FHandle, Context)
if not SetThreadContext(FHandle, Context^)
then begin
Log('Thread %u: Unable to set context', [FID]);
Exit;
@ -633,7 +652,11 @@ end;
function TDbgBreakpoint.Hit(const AThreadID: Integer): Boolean;
var
Thread: TDbgThread;
Context: TContext;
_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
@ -641,22 +664,24 @@ begin
ResetBreak;
if not FProcess.GetThread(AThreadId, Thread) then Exit;
Context := AlignPtr(@_UC, $10);
Context.ContextFlags := CONTEXT_CONTROL;
if not GetThreadContext(Thread.Handle, Context)
Context^.ContextFlags := CONTEXT_CONTROL;
if not GetThreadContext(Thread.Handle, Context^)
then begin
Log('Break $s: Unable to get context', [FormatAdress(FLocation)]);
Exit;
end;
Context.ContextFlags := CONTEXT_CONTROL;
Context^.ContextFlags := CONTEXT_CONTROL;
{$ifdef cpui386}
Dec(Context.Eip);
Dec(Context^.Eip);
{$else}
Dec(Context.Rip);
Dec(Context^.Rip);
{$endif}
if not SetThreadContext(Thread.Handle, Context)
if not SetThreadContext(Thread.Handle, Context^)
then begin
Log('Break %s: Unable to set context', [FormatAdress(FLocation)]);
Exit;

6
debugger/windebug/windextra.pp
View File

@ -43,6 +43,7 @@ uses
function FormatAdress(const P): String;
function GetLastErrorText(AErrorCode: Cardinal): String; {$IFNDEF FPC} overload; {$ENDIF}
function GetLastErrorText: String; {$IFNDEF FPC} overload; {$ENDIF}
function AlignPtr(Src: Pointer; Alignment: Byte): Pointer;
//function OpenThread(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwThreadId: DWORD): THandle; stdcall;
@ -100,5 +101,10 @@ begin
then LocalFree(HLOCAL(Temp));
end;
function AlignPtr(Src: Pointer; Alignment: Byte): Pointer;
begin
Result := Pointer(((PtrUInt(Src) + Alignment - 1) and not PtrUInt(Alignment - 1)));
end;
end.