diff --git a/rtl/i8086/i8086.inc b/rtl/i8086/i8086.inc index 25a95a530f..c8d3fee6e2 100644 --- a/rtl/i8086/i8086.inc +++ b/rtl/i8086/i8086.inc @@ -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 diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc index 4a6e28019e..dc4cdd9d9e 100644 --- a/rtl/inc/compproc.inc +++ b/rtl/inc/compproc.inc @@ -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; diff --git a/rtl/inc/except.inc b/rtl/inc/except.inc index d14104366f..c2de88e519 100644 --- a/rtl/inc/except.inc +++ b/rtl/inc/except.inc @@ -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; diff --git a/rtl/inc/heaptrc.pp b/rtl/inc/heaptrc.pp index 6e80e8e66d..337485326d 100644 --- a/rtl/inc/heaptrc.pp +++ b/rtl/inc/heaptrc.pp @@ -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; diff --git a/rtl/inc/lineinfo.pp b/rtl/inc/lineinfo.pp index c4573e17e3..4bb56f997f 100644 --- a/rtl/inc/lineinfo.pp +++ b/rtl/inc/lineinfo.pp @@ -258,7 +258,7 @@ begin end; -function StabBackTraceStr(addr:Pointer):shortstring; +function StabBackTraceStr(addr:CodePointer):shortstring; var func, source : string; diff --git a/rtl/inc/objpas.inc b/rtl/inc/objpas.inc index 22f8d3c66d..5e7596cbd8 100644 --- a/rtl/inc/objpas.inc +++ b/rtl/inc/objpas.inc @@ -501,7 +501,7 @@ end; function TObject.SafeCallException(exceptobject : tobject; - exceptaddr : pointer) : HResult; + exceptaddr : codepointer) : HResult; begin safecallexception:=E_UNEXPECTED; diff --git a/rtl/inc/objpash.inc b/rtl/inc/objpash.inc index 4be3fb6f7c..aa9d02de39 100644 --- a/rtl/inc/objpash.inc +++ b/rtl/inc/objpash.inc @@ -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 diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index 0c4bebc037..47d1637531 100644 --- a/rtl/inc/system.inc +++ b/rtl/inc/system.inc @@ -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; diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index 3631282117..0e1b0f7a62 100644 --- a/rtl/inc/systemh.inc +++ b/rtl/inc/systemh.inc @@ -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);