1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
unit FpDbgCommon;
{$mode objfpc}{$H+}
{$IFDEF INLINE_OFF}{$INLINE OFF}{$ENDIF}
interface
uses Classes;
type
// Target information, could be different from host debugger
TMachineType = (mtNone, mtSPARC, mt386, mt68K, mtPPC, mtPPC64, mtARM, mtARM64,
mtOLD_ALPHA, mtIA_64, mtX86_64, mtAVR8, mtALPHA,
mtMIPS, mtMIPSEL,mtLA64, mtXTENSA, mtRISCV);
TBitness = (bNone, b32, b64);
TByteOrder = (boNone, boLSB, boMSB);
TOperatingSystem = (osNone, osBSD, osDarwin, osEmbedded, osLinux, osUnix, osMac, osWindows);
TTargetDescriptor = record
machineType: TMachineType;
bitness: TBitness;
byteOrder: TByteOrder;
OS: TOperatingSystem;
end;
// This function returns the host descriptor
// Use when target information not yet loaded - assumes that debug target is the same as host
function hostDescriptor: TTargetDescriptor;
function TargetFormatDescriptor(const aTargetDescriptor: TTargetDescriptor): String;
function dbgs(AMachineType: TMachineType): String; overload;
function dbgs(ABitness: TBitness): String; overload;
function dbgs(AByteOrder: TByteOrder): String; overload;
function dbgs(AOperatingSystem: TOperatingSystem): String; overload;
{$IFDEF FPDEBUG_THREAD_CHECK}
procedure AssertFpDebugThreadId(const AName: String);
procedure AssertFpDebugThreadIdNotMain(const AName: String);
procedure SetCurrentFpDebugThreadIdForAssert(AnId: TThreadID);
procedure ClearCurrentFpDebugThreadIdForAssert;
property CurrentFpDebugThreadIdForAssert: TThreadID write SetCurrentFpDebugThreadIdForAssert;
{$ENDIF}
implementation
function hostDescriptor: TTargetDescriptor;
begin
with Result do
begin
// TODO: Expand list when debugger support updated for other targets
machineType := {$if defined(CPU386) or defined(CPUI386)} mt386
{$elseif defined(CPUX86_64) or defined(CPUAMD64) or defined(CPUX64)} mtX86_64
{$elseif defined(CPUAARCH64)} mtARM64
{$elseif defined(CPUARM)} mtARM
{$elseif defined(CPUPOWERPC)} mtPPC
{$elseif defined(CPUMIPS)} mtMIPS
{$elseif defined(CPUMIPSEL)} mtMIPSEL
{$elseif defined(CPU68K)} mt68K
{$elseif defined(CPULOONGARCH64)} mtLA64
{$else} mtNone
{$endif};
bitness := {$if defined(CPU64)} b64 {$elseif defined(CPU32)} b32 {$else} bNone {$endif};
byteorder := {$ifdef ENDIAN_LITTLE} boLSB {$else} boMSB {$endif};
OS := {$if defined(DARWIN)} osDarwin
{$elseif defined(EMBEDDED)} osEmbedded
{$elseif defined(LINUX)} osLinux
{$elseif defined(BSD)} osBSD
{$elseif defined(UNIX)} osUnix
{$elseif defined(MSWINDOWS)} osWindows {$endif};
end;
end;
function TargetFormatDescriptor(const aTargetDescriptor: TTargetDescriptor): String;
const
machineNames: array[TMachineType] of string = (
'none', 'sparc', 'i386', 'm68K', 'ppc', 'ppc64', 'arm', 'aarch64',
'old-alpha', 'ia_64', 'x86_64', 'avr', 'alpha',
'mips', 'mipsel', 'loongarch64', 'xtensa', 'riscv');
OSname: array[TOperatingSystem] of string = (
'none', 'bsd', 'darwin', 'embedded', 'linux', 'unix', 'mac', 'win');
begin
Result := machineNames[aTargetDescriptor.machineType] + '-' +
OSname[aTargetDescriptor.OS];
if aTargetDescriptor.OS = osWindows then
case aTargetDescriptor.bitness of
b32: Result := Result + '32';
b64: Result := Result + '64';
end;
end;
function dbgs(AMachineType: TMachineType): String;
begin
writestr(Result{%H-}, AMachineType);
end;
function dbgs(ABitness: TBitness): String;
begin
writestr(Result{%H-}, ABitness);
end;
function dbgs(AByteOrder: TByteOrder): String;
begin
writestr(Result{%H-}, AByteOrder);
end;
function dbgs(AOperatingSystem: TOperatingSystem): String;
begin
writestr(Result{%H-}, AOperatingSystem);
end;
{$IFDEF FPDEBUG_THREAD_CHECK}
var
FCurrentFpDebugThreadIdForAssert: TThreadID;
FCurrentFpDebugThreadIdValidForAssert: Boolean;
procedure AssertFpDebugThreadId(const AName: String);
begin
{$IFnDEF LINUX}
if FCurrentFpDebugThreadIdValidForAssert then
assert(GetCurrentThreadId = FCurrentFpDebugThreadIdForAssert, AName);
{$ENDIF}
end;
procedure AssertFpDebugThreadIdNotMain(const AName: String);
begin
AssertFpDebugThreadId(AName);
assert(GetCurrentThreadId<>MainThreadID, AName + ' runnig outside main thread');
end;
procedure SetCurrentFpDebugThreadIdForAssert(AnId: TThreadID);
begin
FCurrentFpDebugThreadIdForAssert := AnId;
FCurrentFpDebugThreadIdValidForAssert := True;
end;
procedure ClearCurrentFpDebugThreadIdForAssert;
begin
FCurrentFpDebugThreadIdValidForAssert := False;
end;
{$ENDIF}
end.
|
