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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
unit LazTracer;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Laz_AVL_Tree,
// LazUtils
LazLoggerBase, LazUtilities, LazUtilsStrConsts;
type
TStackTracePointers = array of Pointer;
TLineInfoCacheItem = record
Addr: Pointer;
Info: string;
end;
PLineInfoCacheItem = ^TLineInfoCacheItem;
procedure RaiseGDBException(const Msg: string);
procedure RaiseAndCatchException;
function GetStackTrace(UseCache: boolean): string;
procedure GetStackTracePointers(var AStack: TStackTracePointers);
function StackTraceAsString(const AStack: TStackTracePointers;
UseCache: boolean): string;
function GetLineInfo(Addr: Pointer; UseCache: boolean): string;
implementation
var
LineInfoCache: TAvlTree = nil;
{------------------------------------------------------------------------------
procedure RaiseGDBException(const Msg: string);
Raises an exception.
Normally gdb does not catch fpc Exception objects, therefore this procedure
raises a standard "division by zero" exception which is catched by gdb.
This allows one to stop a program, without extra gdb configuration.
------------------------------------------------------------------------------}
procedure RaiseGDBException(const Msg: string);
begin
DebugLn(lrsERRORInCode, Msg);
// creates an exception, that gdb catches:
DebugLn(lrsCreatingGdbCatchableError);
DumpStack;
{$ifndef HASAMIGA} // On Amiga Division by 0 is not catchable, just crash
if (length(Msg) div (length(Msg) div 10000))=0 then ;
{$endif}
end;
procedure RaiseAndCatchException;
begin
try
{$ifndef HASAMIGA} // On Amiga Division by 0 is not catchable, just crash
if (length(lrsERRORInCode) div (length(lrsERRORInCode) div 10000))=0 then ;
{$else}
DumpStack;
{$endif}
except
end;
end;
function GetStackTrace(UseCache: boolean): string;
var
bp: Pointer;
addr: Pointer;
oldbp: Pointer;
CurAddress: Shortstring;
begin
Result:='';
{ retrieve backtrace info }
bp:=get_caller_frame(get_frame);
while bp<>nil do begin
addr:=get_caller_addr(bp);
CurAddress:=GetLineInfo(addr,UseCache);
//DebugLn('GetStackTrace ',CurAddress);
Result:=Result+CurAddress+LineEnding;
oldbp:=bp;
bp:=get_caller_frame(bp);
if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
bp:=nil;
end;
end;
procedure GetStackTracePointers(var AStack: TStackTracePointers);
var
Depth: Integer;
bp: Pointer;
oldbp: Pointer;
begin
// get stack depth
Depth:=0;
bp:=get_caller_frame(get_frame);
while bp<>nil do begin
inc(Depth);
oldbp:=bp;
bp:=get_caller_frame(bp);
if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
bp:=nil;
end;
SetLength(AStack,Depth);
if Depth>0 then begin
Depth:=0;
bp:=get_caller_frame(get_frame);
while bp<>nil do begin
AStack[Depth]:=get_caller_addr(bp);
inc(Depth);
oldbp:=bp;
bp:=get_caller_frame(bp);
if (bp<=oldbp) or (bp>(StackBottom + StackLength)) then
bp:=nil;
end;
end;
end;
function StackTraceAsString(const AStack: TStackTracePointers;
UseCache: boolean): string;
var
i: Integer;
CurAddress: String;
begin
Result:='';
for i:=0 to length(AStack)-1 do begin
CurAddress:=GetLineInfo(AStack[i],UseCache);
Result:=Result+CurAddress+LineEnding;
end;
end;
function CompareLineInfoCacheItems(Data1, Data2: Pointer): integer;
begin
Result:=ComparePointers(PLineInfoCacheItem(Data1)^.Addr,
PLineInfoCacheItem(Data2)^.Addr);
end;
function CompareAddrWithLineInfoCacheItem(Addr, Item: Pointer): integer;
begin
Result:=ComparePointers(Addr,PLineInfoCacheItem(Item)^.Addr);
end;
function GetLineInfo(Addr: Pointer; UseCache: boolean): string;
var
ANode: TAvlTreeNode;
Item: PLineInfoCacheItem;
begin
if UseCache then begin
if LineInfoCache=nil then
LineInfoCache:=TAvlTree.Create(@CompareLineInfoCacheItems);
ANode:=LineInfoCache.FindKey(Addr,@CompareAddrWithLineInfoCacheItem);
if ANode=nil then begin
Result:=BackTraceStrFunc(Addr);
New(Item);
Item^.Addr:=Addr;
Item^.Info:=Result;
LineInfoCache.Add(Item);
end else begin
Result:=PLineInfoCacheItem(ANode.Data)^.Info;
end;
end else
Result:=BackTraceStrFunc(Addr);
end;
procedure FreeLineInfoCache;
var
ANode: TAvlTreeNode;
Item: PLineInfoCacheItem;
begin
if LineInfoCache=nil then exit;
ANode:=LineInfoCache.FindLowest;
while ANode<>nil do begin
Item:=PLineInfoCacheItem(ANode.Data);
Dispose(Item);
ANode:=LineInfoCache.FindSuccessor(ANode);
end;
LineInfoCache.Free;
LineInfoCache:=nil;
end;
finalization
FreeLineInfoCache;
end.
|
