paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 09:19:45 +02:00
Code Issues Packages Projects Releases Wiki Activity

* updated all the RTL helper functions related to exceptions and stack traces to use codepointer instead of pointer

Browse Source 
git-svn-id: trunk@25513 -
This commit is contained in:
nickysn 2013-09-17 21:25:26 +00:00
parent b688b79a0d
commit c1b0fb81f1
9 changed files with 74 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
rtl/i8086/i8086.inc
View File

@ -53,26 +53,32 @@ asm
end;
{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;nostackframe;assembler;
function get_caller_addr(framebp:pointer;addr:codepointer=nil):codepointer;nostackframe;assembler;
asm
push bp
mov bp, sp
mov ax, ss:[bp + 6 + extra_param_offset] // framebp
{$ifdef FPC_X86_CODE_FAR}
xor dx, dx
{$endif FPC_X86_CODE_FAR}
mov ax, ss:[bp + 6 + extra_param_offset + extra_param_offset] // framebp
or ax, ax
jz @@Lg_a_null
xchg ax, bx
mov bx, [bx+2]
{$ifdef FPC_X86_CODE_FAR}
mov dx, [bx+4]
{$endif FPC_X86_CODE_FAR}
xchg ax, bx
@@Lg_a_null:
pop bp
end;
{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;nostackframe;assembler;
function get_caller_frame(framebp:pointer;addr:codepointer=nil):pointer;nostackframe;assembler;
asm
push bp
mov bp, sp
mov ax, ss:[bp + 6 + extra_param_offset] // framebp
mov ax, ss:[bp + 6 + extra_param_offset + extra_param_offset] // framebp
or ax, ax
jz @@Lgnf_null
xchg ax, bx

4
rtl/inc/compproc.inc
View File

@ -592,14 +592,14 @@ procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;DispDesc:
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
Function fpc_PushExceptAddr (Ft: {$ifdef CPU16}SmallInt{$else}Longint{$endif};_buf,_newaddr : pointer): PJmp_buf ; compilerproc;
Function fpc_Raiseexception (Obj : TObject; AnAddr,AFrame : Pointer) : TObject; compilerproc;
Function fpc_Raiseexception (Obj : TObject; AnAddr : CodePointer; AFrame : Pointer) : TObject; compilerproc;
Procedure fpc_PopAddrStack; compilerproc;
function fpc_PopObjectStack : TObject; compilerproc;
function fpc_PopSecondObjectStack : TObject; compilerproc;
Procedure fpc_ReRaise; compilerproc;
Function fpc_Catches(Objtype : TClass) : TObject; compilerproc;
Procedure fpc_DestroyException(o : TObject); compilerproc;
function fpc_GetExceptionAddr : Pointer; compilerproc;
function fpc_GetExceptionAddr : CodePointer; compilerproc;
function fpc_safecallhandler(obj: TObject): HResult; compilerproc;
function fpc_safecallcheck(res : hresult) : hresult; compilerproc; {$ifdef CPU86} register; {$endif}
procedure fpc_doneexception; compilerproc;

16
rtl/inc/except.inc
View File

@ -112,18 +112,18 @@ end;
{$define FPC_CHECK_GET_CALLER_EXCEPTIONS}
{$endif}
Procedure PushExceptObject(Obj : TObject; AnAddr,AFrame : Pointer);
Procedure PushExceptObject(Obj : TObject; AnAddr : CodePointer; AFrame : Pointer);
var
Newobj : PExceptObject;
_ExceptObjectStack : ^PExceptObject;
framebufsize,
framecount : longint;
frames : PPointer;
frames : PCodePointer;
prev_frame,
curr_frame,
caller_frame : Pointer;
curr_addr,
caller_frame,
caller_addr : Pointer;
caller_addr : CodePointer;
begin
{$ifdef excdebug}
writeln ('In PushExceptObject');
@ -179,7 +179,7 @@ begin
if (framecount>=framebufsize) then
begin
inc(framebufsize,16);
reallocmem(frames,framebufsize*sizeof(pointer));
reallocmem(frames,framebufsize*sizeof(codepointer));
end;
frames[framecount]:=caller_addr;
inc(framecount);
@ -211,7 +211,7 @@ begin
end;
{$ifndef FPC_SYSTEM_HAS_RAISEEXCEPTION}
Function fpc_RaiseException (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
Function fpc_RaiseException (Obj : TObject; AnAddr : CodePointer; AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
var
_ExceptObjectStack : PExceptObject;
_ExceptAddrstack : PExceptAddr;
@ -376,7 +376,7 @@ begin
end;
{ TODO: no longer used, clean up }
function fpc_GetExceptionAddr : Pointer;[Public, Alias : 'FPC_GETEXCEPTIONADDR']; compilerproc;
function fpc_GetExceptionAddr : CodePointer;[Public, Alias : 'FPC_GETEXCEPTIONADDR']; compilerproc;
var
_ExceptObjectStack : PExceptObject;
begin
@ -411,7 +411,7 @@ end;
function fpc_safecallhandler(obj: TObject): HResult; [public,alias:'FPC_SAFECALLHANDLER']; compilerproc;
var
raiselist: PExceptObject;
adr: Pointer;
adr: CodePointer;
exc: TObject;
begin
raiselist:=ExceptObjectStack;

24
rtl/inc/heaptrc.pp
View File

@ -132,7 +132,7 @@ type
release_sig : longword;
prev_valid : pheap_mem_info;
{$endif EXTRA}
calls : array [1..tracesize] of pointer;
calls : array [1..tracesize] of codepointer;
exact_info_size : word;
extra_info_size : word;
extra_info : pheap_extra_info;
@ -336,7 +336,8 @@ end;
procedure dump_already_free(p : pheap_mem_info;var ptext : text);
var
bp, pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
begin
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
call_free_stack(p,ptext);
@ -349,7 +350,8 @@ end;
procedure dump_error(p : pheap_mem_info;var ptext : text);
var
bp, pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
begin
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
@ -382,7 +384,8 @@ end;
procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
var
bp, pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
begin
Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
@ -464,7 +467,8 @@ Function TraceGetMem(size:ptruint):pointer;
var
allocsize,i : ptruint;
oldbp,
bp,pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
pl : pdword;
p : pointer;
pp : pheap_mem_info;
@ -573,7 +577,8 @@ function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info;
size, ppsize: ptruint): boolean; inline;
var
i: ptruint;
bp,pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
ptext : ^text;
{$ifdef EXTRA}
pp2 : pheap_mem_info;
@ -798,8 +803,8 @@ var
movesize,
i : ptruint;
oldbp,
bp,
pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
pl : pdword;
pp : pheap_mem_info;
oldsize,
@ -1005,7 +1010,8 @@ var
{$ifdef morphos}
stack_top: longword;
{$endif morphos}
bp,pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
ptext : ^text;
label
_exit;

2
rtl/inc/lineinfo.pp
View File

@ -258,7 +258,7 @@ begin
end;
function StabBackTraceStr(addr:Pointer):shortstring;
function StabBackTraceStr(addr:CodePointer):shortstring;
var
func,
source : string;

2
rtl/inc/objpas.inc
View File

@ -501,7 +501,7 @@
end;
function TObject.SafeCallException(exceptobject : tobject;
exceptaddr : pointer) : HResult;
exceptaddr : codepointer) : HResult;
begin
safecallexception:=E_UNEXPECTED;

8
rtl/inc/objpash.inc
View File

@ -196,7 +196,7 @@
class function newinstance : tobject;virtual;
procedure FreeInstance;virtual;
function SafeCallException(exceptobject : tobject;
exceptaddr : pointer) : HResult;virtual;
exceptaddr : codepointer) : HResult;virtual;
procedure DefaultHandler(var message);virtual;
procedure Free;
@ -322,17 +322,17 @@
PInterface = PUnknown;
TExceptProc = Procedure (Obj : TObject; Addr : Pointer; FrameCount:Longint; Frame: PPointer);
TExceptProc = Procedure (Obj : TObject; Addr : CodePointer; FrameCount:Longint; Frame: PCodePointer);
{ Exception object stack }
PExceptObject = ^TExceptObject;
TExceptObject = record
FObject : TObject;
Addr : pointer;
Addr : codepointer;
Next : PExceptObject;
refcount : Longint;
Framecount : Longint;
Frames : PPointer;
Frames : PCodePointer;
end;
Const

38
rtl/inc/system.inc
View File

@ -69,8 +69,8 @@ Const
Procedure HandleError (Errno : Longint); external name 'FPC_HANDLEERROR';
Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer); forward;
Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer); forward;
Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer); forward;
Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer); forward;
{$ifdef FPC_HAS_FEATURE_TEXTIO}
type
@ -686,7 +686,7 @@ End;
{ This provides a dummy implementation
of get_pc_addr function, for CPU's that don't need
the instruction address to walk the stack. }
function get_pc_addr : pointer;
function get_pc_addr : codepointer;
begin
get_pc_addr:=nil;
end;
@ -697,9 +697,10 @@ end;
of get_caller_stackinfo procedure,
using get_caller_addr and get_caller_frame
functions. }
procedure get_caller_stackinfo(var framebp,addr : pointer);
procedure get_caller_stackinfo(var framebp : pointer; addr : codepointer);
var
nextbp,nextaddr : pointer;
nextbp : pointer;
nextaddr : codepointer;
begin
nextbp:=get_caller_frame(framebp,addr);
nextaddr:=get_caller_addr(framebp,addr);
@ -967,7 +968,11 @@ Begin
pstdout:=@stdout;
If erroraddr<>nil Then
Begin
{$if defined(CPUI8086) and defined(FPC_X86_CODE_FAR)}
Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(DWord(erroraddr) shr 16,4),':',hexstr(DWord(erroraddr) and $FFFF,4));
{$else}
Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
{$endif}
{ to get a nice symify }
Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
dump_stack(pstdout^,ErrorBase,ErrorAddr);
@ -1041,13 +1046,17 @@ Begin
end;
function SysBackTraceStr (Addr: Pointer): ShortString;
function SysBackTraceStr (Addr: CodePointer): ShortString;
begin
{$if defined(CPUI8086) and defined(FPC_X86_CODE_FAR)}
SysBackTraceStr:=' $'+hexstr(DWord(addr) shr 16,4)+':'+hexstr(DWord(addr) and $FFFF,4);
{$else}
SysBackTraceStr:=' $'+hexstr(addr);
{$endif}
end;
Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
begin
If pointer(ErrorProc)<>Nil then
ErrorProc(Errno,addr,frame);
@ -1064,7 +1073,7 @@ end;
{ This is used internally by system skip first level,
and generated the same output as before, when
HandleErrorFrame function was used internally. }
Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer);
Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer);
begin
get_caller_stackinfo (frame, addr);
HandleErrorAddrFrame (Errno,addr,frame);
@ -1093,7 +1102,8 @@ end;
procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
var
bp,pcaddr : pointer;
bp : pointer;
pcaddr : codepointer;
begin
errorcode:=w;
pcaddr:=get_pc_addr;
@ -1123,14 +1133,14 @@ begin
end;
Procedure dump_stack(var f : text;fp,addr : Pointer);
Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer);
var
i : Longint;
prevfp : Pointer;
prevaddr : pointer;
prevaddr : CodePointer;
is_dev : boolean;
caller_frame,
caller_addr : Pointer;
caller_frame : Pointer;
caller_addr : CodePointer;
Begin
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
try
@ -1171,7 +1181,7 @@ procedure DumpExceptionBackTrace(var f:text);
var
FrameNumber,
FrameCount : longint;
Frames : PPointer;
Frames : PCodePointer;
begin
if RaiseList=nil then
exit;

18
rtl/inc/systemh.inc
View File

@ -618,7 +618,7 @@ const
{ Exit Procedure handling consts and types }
ExitProc : codepointer = nil;
Erroraddr: pointer = nil;
Erroraddr: codepointer = nil;
Errorcode: Word = 0;
{ file input modes }
@ -1258,11 +1258,11 @@ function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:
function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ENDIF}
Function Get_pc_addr : Pointer;
Function Get_pc_addr : CodePointer;
function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;
function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;
procedure get_caller_stackinfo(var framebp,addr : pointer);
function get_caller_addr(framebp:pointer;addr:codepointer=nil):codepointer;
function get_caller_frame(framebp:pointer;addr:codepointer=nil):pointer;
procedure get_caller_stackinfo(var framebp : pointer; addr : codepointer);
Function IOResult:Word;
Function Sptr:Pointer;[internconst:fpc_in_const_ptr];
@ -1344,7 +1344,7 @@ Function Paramcount:Longint;
Function ParamStr(l:Longint):string;
{$endif FPC_HAS_FEATURE_COMMANDARGS}
Procedure Dump_Stack(var f : text;fp:pointer;addr : pointer = nil);
Procedure Dump_Stack(var f : text;fp:pointer;addr : codepointer = nil);
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
procedure DumpExceptionBackTrace(var f:text);
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
@ -1387,7 +1387,7 @@ Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
procedure AbstractError;external name 'FPC_ABSTRACTERROR';
procedure EmptyMethod;external name 'FPC_EMPTYMETHOD';
Function SysBackTraceStr(Addr:Pointer): ShortString;
Function SysBackTraceStr(Addr:CodePointer): ShortString;
Procedure SysAssert(const Msg,FName:ShortString;LineNo:Longint;ErrorAddr:Pointer);
(* Supposed to return address of previous CtrlBreakHandler *)
(* (may be nil), returned value of pointer (-1) means that *)
@ -1396,8 +1396,8 @@ function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler;
{ Error handlers }
Type
TBackTraceStrFunc = Function (Addr: Pointer): ShortString;
TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer);
TBackTraceStrFunc = Function (Addr: CodePointer): ShortString;
TErrorProc = Procedure (ErrNo : Longint; Address : CodePointer; Frame : Pointer);
TAbstractErrorProc = Procedure;
TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno:longint;erroraddr:pointer);
TSafeCallErrorProc = Procedure(error : HResult;addr : pointer);