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

* retrieve backtrace when exception is raised

Browse Source 
* RaiseMaxFrameCount added to limit the number of backtraces, setting
    it to 0 disables backtraces. Default is 16
This commit is contained in:
peter 2005-01-26 17:07:10 +00:00
parent d3b559cfcc
commit a68b710efd
3 changed files with 76 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
rtl/inc/except.inc
View File

@ -125,6 +125,13 @@ Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer);
[Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}{$ifdef hascompilerproc} compilerproc; {$endif} [Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];{$ifndef NOSAVEREGISTERS}saveregisters;{$endif}{$ifdef hascompilerproc} compilerproc; {$endif}
var var
Newobj : PExceptObject; Newobj : PExceptObject;
framebufsize,
framecount : longint;
frames : PPointer;
prev_frame,
curr_frame,
caller_frame,
caller_addr : Pointer;
begin begin
{$ifdef excdebug} {$ifdef excdebug}
writeln ('In PushExceptObject'); writeln ('In PushExceptObject');
@ -142,8 +149,32 @@ begin
end; end;
ExceptObjectStack^.FObject:=Obj; ExceptObjectStack^.FObject:=Obj;
ExceptObjectStack^.Addr:=AnAddr; ExceptObjectStack^.Addr:=AnAddr;
ExceptObjectStack^.Frame:=AFrame; ExceptObjectStack^.refcount:=0;
ExceptObjectStack^.refcount := 0; { Backtrace }
curr_frame:=AFrame;
prev_frame:=AFrame-1;
frames:=nil;
framebufsize:=0;
framecount:=0;
while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) Do
Begin
caller_addr := get_caller_addr(curr_frame);
caller_frame := get_caller_frame(curr_frame);
if (caller_addr=nil) or
(caller_frame=nil) then
break;
if (framecount>=framebufsize) then
begin
inc(framebufsize,16);
reallocmem(frames,framebufsize*sizeof(pointer));
end;
frames[framecount]:=caller_addr;
inc(framecount);
prev_frame:=curr_frame;
curr_frame:=caller_frame;
End;
ExceptObjectStack^.framecount:=framecount;
ExceptObjectStack^.frames:=frames;
end; end;
{$ifdef hascompilerproc} {$ifdef hascompilerproc}
@ -154,9 +185,9 @@ Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); [external
Procedure DoUnHandledException; Procedure DoUnHandledException;
begin begin
If ExceptProc<>Nil then If (ExceptProc<>Nil) and (ExceptObjectStack<>Nil) then
If ExceptObjectStack<>Nil then with ExceptObjectStack^ do
TExceptPRoc(ExceptProc)(ExceptObjectStack^.FObject,ExceptObjectStack^.Addr,ExceptObjectStack^.Frame); TExceptProc(ExceptProc)(FObject,Addr,FrameCount,Frames);
RunError(217); RunError(217);
end; end;
@ -171,7 +202,8 @@ begin
If ExceptAddrStack=Nil then If ExceptAddrStack=Nil then
DoUnhandledException; DoUnhandledException;
if (RaiseProc <> nil) and (ExceptObjectStack <> nil) then if (RaiseProc <> nil) and (ExceptObjectStack <> nil) then
RaiseProc(Obj, AnAddr, AFrame); with ExceptObjectStack^ do
RaiseProc(FObject,Addr,FrameCount,Frames);
longjmp(ExceptAddrStack^.Buf^,FPC_Exception); longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
end; end;
@ -226,6 +258,8 @@ begin
end; end;
hp:=ExceptObjectStack; hp:=ExceptObjectStack;
ExceptObjectStack:=ExceptObjectStack^.next; ExceptObjectStack:=ExceptObjectStack^.next;
if assigned(hp^.frames) then
freemem(hp^.frames);
dispose(hp); dispose(hp);
end; end;
end; end;
@ -251,6 +285,8 @@ begin
fpc_PopSecondObjectStack:=ExceptObjectStack^.next^.FObject; fpc_PopSecondObjectStack:=ExceptObjectStack^.next^.FObject;
hp:=ExceptObjectStack^.next; hp:=ExceptObjectStack^.next;
ExceptObjectStack^.next:=hp^.next; ExceptObjectStack^.next:=hp^.next;
if assigned(hp^.frames) then
freemem(hp^.frames);
dispose(hp); dispose(hp);
end; end;
end; end;
@ -310,7 +346,12 @@ begin
end; end;
{ {
$Log$ $Log$
Revision 1.16 2004-10-24 20:01:41 peter Revision 1.17 2005-01-26 17:07:10 peter
* retrieve backtrace when exception is raised
* RaiseMaxFrameCount added to limit the number of backtraces, setting
it to 0 disables backtraces. Default is 16
Revision 1.16 2004/10/24 20:01:41 peter
* saveregisters calling convention is obsolete * saveregisters calling convention is obsolete
Revision 1.15 2004/04/27 18:47:51 florian Revision 1.15 2004/04/27 18:47:51 florian

21
rtl/inc/objpash.inc
View File

@ -200,21 +200,23 @@
{$endif HASINTF} {$endif HASINTF}
TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer); TExceptProc = Procedure (Obj : TObject; Addr : Pointer; FrameCount:Longint; Frame: PPointer);
{ Exception object stack } { Exception object stack }
PExceptObject = ^TExceptObject; PExceptObject = ^TExceptObject;
TExceptObject = record TExceptObject = record
FObject : TObject; FObject : TObject;
Addr, Addr : pointer;
Frame : pointer; Next : PExceptObject;
Next : PExceptObject; refcount : Longint;
refcount: Longint; Framecount : Longint;
Frames : PPointer;
end; end;
Const Const
ExceptProc : TExceptProc = Nil; ExceptProc : TExceptProc = Nil;
RaiseProc : TExceptProc = Nil; RaiseProc : TExceptProc = Nil;
RaiseMaxFrameCount : Longint = 16;
Function RaiseList : PExceptObject; Function RaiseList : PExceptObject;
@ -299,7 +301,12 @@
{ {
$Log$ $Log$
Revision 1.24 2004-04-28 19:52:41 peter Revision 1.25 2005-01-26 17:07:10 peter
* retrieve backtrace when exception is raised
* RaiseMaxFrameCount added to limit the number of backtraces, setting
it to 0 disables backtraces. Default is 16
Revision 1.24 2004/04/28 19:52:41 peter
* vtype changed to ptrint * vtype changed to ptrint
Revision 1.23 2004/04/26 21:06:00 peter Revision 1.23 2004/04/26 21:06:00 peter

22
rtl/objpas/sysutils/sysutils.inc
View File

@ -168,12 +168,13 @@
{$define STACKCHECK_WAS_ON} {$define STACKCHECK_WAS_ON}
{$S-} {$S-}
{$endif OPT S } {$endif OPT S }
Procedure CatchUnhandledException (Obj : TObject; Addr,Frame: Pointer);[public,alias:'FPC_BREAK_UNHANDLED_EXCEPTION']; Procedure CatchUnhandledException (Obj : TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);[public,alias:'FPC_BREAK_UNHANDLED_EXCEPTION'];
Var Var
Message : String; Message : String;
{$IFDEF VIRTUALPASCAL} {$IFDEF VIRTUALPASCAL}
stdout:text absolute output; stdout:text absolute output;
{$ENDIF} {$ENDIF}
i : longint;
begin begin
Writeln(stdout,'An unhandled exception occurred at $',HexStr(Ptrint(Addr),sizeof(PtrInt)*2),' :'); Writeln(stdout,'An unhandled exception occurred at $',HexStr(Ptrint(Addr),sizeof(PtrInt)*2),' :');
if Obj is exception then if Obj is exception then
@ -183,7 +184,12 @@ begin
end end
else else
Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.'); Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.');
Writeln(stdout,''); if (FrameCount>0) then
begin
Writeln(stdout,BackTraceStrFunc(Addr));
for i:=0 to FrameCount-1 do
Writeln(stdout,BackTraceStrFunc(Frames[i]));
end;
Halt(217); Halt(217);
end; end;
@ -457,14 +463,14 @@ end;
{ --------------------------------------------------------------------- { ---------------------------------------------------------------------
Diskh functions, OS independent. Diskh functions, OS independent.
---------------------------------------------------------------------} ---------------------------------------------------------------------}
function ForceDirectories(Const Dir: string): Boolean; function ForceDirectories(Const Dir: string): Boolean;
var var
E: EInOutError; E: EInOutError;
ADir : String; ADir : String;
begin begin
Result:=True; Result:=True;
ADir:=ExcludeTrailingPathDelimiter(Dir); ADir:=ExcludeTrailingPathDelimiter(Dir);
@ -474,14 +480,14 @@ begin
E.ErrorCode:=3; E.ErrorCode:=3;
Raise E; Raise E;
end; end;
if Not DirectoryExists(ADir) then if Not DirectoryExists(ADir) then
begin begin
Result:=ForceDirectories(ExtractFilePath(ADir)); Result:=ForceDirectories(ExtractFilePath(ADir));
If Result then If Result then
CreateDir(ADir); CreateDir(ADir);
end; end;
end; end;
{ {
Revision 1.1 2003/10/06 21:01:06 peter Revision 1.1 2003/10/06 21:01:06 peter