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

* basic helpers for DWARF/PSABI EH-based exception handling (based on

Browse Source 
GCC 4.2.1's libstdc++/libsupc++)
   - compile RTL with -dFPC_USE_PSEABIEH to include
   - the x86-64 compiler currently crashes if it has been compiled with
     optimizations (the eh_return_data_regno function from cpubase
     probably triggers mantis #34385)

git-svn-id: branches/debug_eh@40071 -
This commit is contained in:
Jonas Maebe 2018-10-28 18:16:42 +00:00
parent 8555ec1438
commit b2d1ab7f05
6 changed files with 920 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -9503,6 +9503,8 @@ rtl/inc/objcnf.inc svneol=native#text/plain
rtl/inc/objpas.inc svneol=native#text/plain
rtl/inc/objpash.inc svneol=native#text/plain
rtl/inc/pagemem.pp svneol=native#text/plain
rtl/inc/psabieh.inc svneol=native#text/plain
rtl/inc/psabiehh.inc svneol=native#text/plain
rtl/inc/readme -text
rtl/inc/real2str.inc svneol=native#text/plain
rtl/inc/resh.inc svneol=native#text/plain

7
rtl/inc/except.inc
View File

@ -26,6 +26,10 @@ Var
ExceptObjectStack : PExceptObject;
ExceptTryLevel : ObjpasInt;
{$ifdef FPC_USE_PSEABIEH}
{$i psabieh.inc}
{$endif}
Function RaiseList : PExceptObject;
begin
RaiseList:=ExceptObjectStack;
@ -82,7 +86,7 @@ end;
{ This routine is called only from fpc_raiseexception, which uses ExceptTryLevel
flag to guard against repeated exceptions which can occur due to corrupted stack
or heap. }
Procedure PushExceptObject(Obj : TObject; AnAddr : CodePointer; AFrame : Pointer);
function PushExceptObject(Obj : TObject; AnAddr : CodePointer; AFrame : Pointer): PExceptObject;
var
Newobj : PExceptObject;
_ExceptObjectStack : ^PExceptObject;
@ -131,6 +135,7 @@ begin
End;
NewObj^.framecount:=framecount;
NewObj^.frames:=frames;
Result:=NewObj;
end;
Procedure DoUnHandledException;

4
rtl/inc/excepth.inc
View File

@ -12,6 +12,10 @@
**********************************************************************}
{$if defined(FPC_USE_PSEABIEH)}
{$i psabiehh.inc}
{$endif}
Const
{ Type of exception. Currently only one. }
FPC_EXCEPTION = 1;

25
rtl/inc/objpash.inc
View File

@ -339,6 +339,23 @@
PPDispatch = ^PDispatch;
PInterface = PUnknown;
{$ifdef FPC_USE_PSEABIEH}
{ needed here for TExceptObject (rest is in psabiehh.inc) }
FPC_Unwind_Reason_Code = longint; {cint}
FPC_Unwind_Action = longint; {cint}
PFPC_Unwind_Exception = ^FPC_Unwind_Exception;
FPC_Unwind_Exception_Cleanup_Fn =
procedure(reason: FPC_Unwind_Reason_Code; exc: PFPC_Unwind_Exception); cdecl;
FPC_Unwind_Exception = record
exception_class: qword;
exception_cleanup: FPC_Unwind_Exception_Cleanup_Fn;
private_1: ptruint;
private_2: ptruint;
end;
{$endif FPC_USE_PSEABIEH}
TExceptProc = Procedure (Obj : TObject; Addr : CodePointer; FrameCount:Longint; Frame: PCodePointer);
@ -356,6 +373,14 @@
ExceptRec : Pointer;
ReraiseBuf : jmp_buf;
{$endif FPC_USE_WIN32_SEH}
{$ifdef FPC_USE_PSEABIEH}
{ cached info from unwind phase for action phase }
handler_switch_value: longint;
language_specific_data: PByte;
landing_pad: PtrUInt;
{ libunwind exception handling data (must be last!) }
unwind_exception: FPC_Unwind_Exception;
{$endif FPC_USE_PSEABIEH}
end;
Const

822
rtl/inc/psabieh.inc Normal file
View File

@ -0,0 +1,822 @@
{
This file is part of the Free Pascal run time library.
Translated to Pascal by Jonas Maebe,
member of the Free Pascal development team
This file is based on the source code of libsupc++ from GCC 4.2.1.
See below for details about the copyright. While it is GPLv2 rather
than LGPLv2 like the rest of the FPC RTL, it has the same linking
exception as the rest of the FPC RTL and hence it can be used in the
same way.
**********************************************************************}
// -*- C++ -*- The GNU C++ exception personality routine.
// Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc.
//
// This file is part of GCC.
//
// GCC is free software; you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation; either version 2, or (at your option)
// any later version.
//
// GCC is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with GCC; see the file COPYING. If not, write to
// the Free Software Foundation, 51 Franklin Street, Fifth Floor,
// Boston, MA 02110-1301, USA.
// As a special exception, you may use this file as part of a free software
// library without restriction. Specifically, if other files instantiate
// templates or use macros or inline functions from this file, or you compile
// this file and link it with other files to produce an executable, this
// file does not by itself cause the resulting executable to be covered by
// the GNU General Public License. This exception does not however
// invalidate any other reasons why the executable file might be covered by
// the GNU General Public License.
{$packrecords c}
{$if (defined(CPUARMEL) or defined(CPUARMHF)) and not defined(darwin)}
{$define __ARM_EABI_UNWINDER__}
{$error add ARM EABI unwinder support}
{$endif}
function FPC_psabieh_GetExceptionWrapper(exceptionObject: PFPC_Unwind_Exception): PExceptObject; inline;
begin
{ go to end of the wrapped exception (it's the last field in PFPC_Unwind_Exception), then to the start }
result:=PExceptObject(exceptionObject+1)-1;
end;
procedure _Unwind_DeleteException(context:PFPC_Unwind_Context);cdecl;external;
function _Unwind_GetGR(context:PFPC_Unwind_Context; index:cint):PtrUInt;cdecl;external;
procedure _Unwind_SetGR(context:PFPC_Unwind_Context; index:cint; new_value:PtrUInt);cdecl;external;
function _Unwind_GetIP(context:PFPC_Unwind_Context):PtrUInt;cdecl;external;
procedure _Unwind_SetIP(_para1:PFPC_Unwind_Context; new_value:PtrUInt);cdecl;external;
function _Unwind_GetRegionStart(context:PFPC_Unwind_Context):PtrUInt;cdecl;external;
function _Unwind_GetLanguageSpecificData(context:PFPC_Unwind_Context):PtrUInt;cdecl;external;
function _Unwind_GetDataRelBase(context:PFPC_Unwind_Context):PtrUInt;cdecl;external;
function _Unwind_GetTextRelBase(context:PFPC_Unwind_Context):PtrUInt;cdecl;external;
{ _Unwind_Backtrace() is a gcc extension that walks the stack and calls the }
{ _Unwind_Trace_Fn once per frame until it reaches the bottom of the stack }
{ or the _Unwind_Trace_Fn function returns something other than _URC_NO_REASON. }
{ }
type
FPC_Unwind_Trace_Fn = function (_para1:PFPC_Unwind_Context; _para2:pointer):FPC_Unwind_Reason_Code;cdecl;
function _Unwind_Backtrace(_para1:FPC_Unwind_Trace_Fn; _para2:pointer):FPC_Unwind_Reason_Code;cdecl;weakexternal;
{ _Unwind_GetCFA is a gcc extension that can be called from within a personality }
{ handler to get the CFA (stack pointer before call) of current frame. }
{ }
function _Unwind_GetCFA(_para1:PFPC_Unwind_Context):PtrUInt;cdecl;weakexternal;
const
DW_EH_PE_absptr = $00;
DW_EH_PE_omit = $ff;
DW_EH_PE_uleb128 = $01;
DW_EH_PE_udata2 = $02;
DW_EH_PE_udata4 = $03;
DW_EH_PE_udata8 = $04;
DW_EH_PE_sleb128 = $09;
DW_EH_PE_sdata2 = $0A;
DW_EH_PE_sdata4 = $0B;
DW_EH_PE_sdata8 = $0C;
DW_EH_PE_signed = $08;
DW_EH_PE_pcrel = $10;
DW_EH_PE_textrel = $20;
DW_EH_PE_datarel = $30;
DW_EH_PE_funcrel = $40;
DW_EH_PE_aligned = $50;
DW_EH_PE_indirect = $80;
function FPC_psabieh_size_of_encoded_value(encoding: byte): longint;
begin
if encoding = DW_EH_PE_omit then
exit(0);
case (encoding and 7) of
DW_EH_PE_absptr:
exit(sizeof(pointer));
DW_EH_PE_udata2:
exit(2);
DW_EH_PE_udata4:
exit(4);
DW_EH_PE_udata8:
exit(8);
else
halt(217);
end
end;
{ Given an encoding and an _Unwind_Context, return the base to which
the encoding is relative. This base may then be passed to
read_encoded_value_with_base for use when the _Unwind_Context is
not available. }
function FPC_psabieh_base_of_encoded_value (encoding: byte; context: PFPC_Unwind_Context): PtrUInt;
begin
if encoding = DW_EH_PE_omit then
exit(0);
case (encoding and $70) of
DW_EH_PE_absptr,
DW_EH_PE_pcrel,
DW_EH_PE_aligned:
exit(0);
DW_EH_PE_textrel:
exit(_Unwind_GetTextRelBase(context));
DW_EH_PE_datarel:
exit(_Unwind_GetDataRelBase(context));
DW_EH_PE_funcrel:
exit(_Unwind_GetRegionStart(context));
else
halt(217);
end;
end;
function fpc_read_uleb128 (p: PByte; out val: PTRUInt): PByte;
var
shift: longint;
b: byte;
res: PtrUInt;
begin
shift:=0;
res:=0;
repeat
b:=p^;
inc(p);
res:=res or (PtrUInt(b and $7f) shl shift);
inc(shift,7);
until (b and $80)<>0;
val:=res;
result:=p;
end;
function fpc_read_sleb128 (p: PByte; out val: PtrInt): PByte;
var
shift: longint;
b: byte;
res: PtrUInt;
begin
shift:=0;
res:=0;
repeat
b:=p^;
inc(p);
res:=res or (PtrUInt(b and $7f) shl shift);
inc(shift,7);
until (b and $80)<>0;
if (shift<8*(sizeof(res))) and
((b and $40)<>0) then
res:=res or -(PtrUInt(1) shl shift);
val:=PTRInt(res);
result:=p;
end;
function FPC_psabieh_read_encoded_value_with_base (encoding: byte; base: PtrUInt; p: PByte; out val: PtrUInt): PByte;
var
res: PtrUInt;
tmpres: PtrInt;
alignedp: PPtrUint;
begin
if encoding=DW_EH_PE_aligned then
begin
alignedp:=PPtrUint(align(PtrUInt(p),sizeof(PtrUint)));
res:=alignedp^;
result:=PByte(alignedp)+sizeof(PtrUInt);
end
else
begin
case encoding and $0f of
DW_EH_PE_absptr:
begin
res:=unaligned(PPtrUint(p)^);
result:=p+sizeof(PtrUInt);
end;
DW_EH_PE_uleb128:
begin
result:=fpc_read_uleb128(p,res);
end;
DW_EH_PE_sleb128:
begin
result:=fpc_read_sleb128(p,tmpres);
res:=PtrUInt(tmpres);;
end;
DW_EH_PE_udata2:
begin
res:=unaligned(pword(p)^);
result:=p+2;
end;
DW_EH_PE_udata4:
begin
res:=unaligned(pdword(p)^);
result:=p+4;
end;
DW_EH_PE_udata8:
begin
res:=unaligned(pqword(p)^);
result:=p+8;
end;
DW_EH_PE_sdata2:
begin
res:=PtrUInt(unaligned(psmallint(p)^));
result:=p+2;
end;
DW_EH_PE_sdata4:
begin
res:=PtrUInt(unaligned(plongint(p)^));
result:=p+4;
end;
DW_EH_PE_sdata8:
begin
res:=PtrUInt(unaligned(pint64(p)^));
result:=p+8;
end;
else
halt(217);
end;
if res<>0 then
begin
if (encoding and $70)=DW_EH_PE_pcrel then
inc(res,PtrUInt(p))
else
inc(res, base);
if (encoding and DW_EH_PE_indirect)<>0 then
res:=PPtrUInt(res)^;
end;
end;
val:=res;
end;
function FPC_psabieh_read_encoded_value (context: PFPC_Unwind_Context; encoding: byte; p: PByte; out val: PtrUInt): PByte; inline;
begin
result:=FPC_psabieh_read_encoded_value_with_base(encoding,FPC_psabieh_base_of_encoded_value(encoding,context),p,val);
end;
type
FPC_psabieh_lsda_header_info = record
Start: PtrUInt;
LPStart: PtrUInt;
ttype_base: PtrUInt;
TType: Pointer;
action_table: pointer;
ttype_encoding: byte;
call_site_encoding: byte;
end;
function FPC_psabieh_parse_lsda_header(context: PFPC_Unwind_Context; p: PByte; out info: FPC_psabieh_lsda_header_info): PByte;
var
tmp: PTRUint;
lpstart_encoding: byte;
begin
if assigned(context) then
info.Start:=_Unwind_GetRegionStart(context)
else
info.Start:=0;
// Find @LPStart, the base to which landing pad offsets are relative.
lpstart_encoding:=p^;
inc(p);
if lpstart_encoding<>DW_EH_PE_omit then
p:=FPC_psabieh_read_encoded_value(context,lpstart_encoding,p,info.LPStart)
else
info.LPStart:=info.Start;
// Find @TType, the base of the handler and exception spec type data.
info.ttype_encoding:=p^;
inc(p);
if info.ttype_encoding<>DW_EH_PE_omit then
begin
p:=fpc_read_uleb128(p,tmp);
info.TType:=p+tmp;
end
else
info.TType:=nil;
// The encoding and length of the call-site table; the action table
// immediately follows.
info.call_site_encoding:=p^;
inc(p);
p:=fpc_read_uleb128(p,tmp);
info.action_table:=p+tmp;
result:=p;
end;
// Return an element from a type table.
function FPC_psabieh_get_ttype_entry(const info: FPC_psabieh_lsda_header_info; i: PtrUInt): TClass;
var
ptr: PtrUInt;
begin
i:=i*FPC_psabieh_size_of_encoded_value(info.ttype_encoding);
FPC_psabieh_read_encoded_value_with_base(info.ttype_encoding,info.ttype_base,info.TType-i,ptr);
result:=TClass(ptr);
end;
function FPC_psabieh_can_catch(catch_type: TClass; thrown: TObject): boolean;
begin
result:=thrown is catch_type
end;
// Return true if THROW_TYPE matches one if the filter types.
function FPC_psabieh_check_exception_spec(const info: FPC_psabieh_lsda_header_info; thrown: TObject; filter_value: PtrInt): boolean;
var
e: PByte;
catch_type: TClass;
tmp: PtrUInt;
begin
e:=info.TType - filter_value - 1;
repeat
e:=fpc_read_uleb128(e,tmp);
// Zero signals the end of the list. If we've not found
// a match by now, then we've failed the specification.
if tmp=0 then
exit(false);
// Match a ttype entry.
catch_type:=FPC_psabieh_get_ttype_entry(info,tmp);
until thrown is catch_type;
result:=true;
end;
// Save stage1 handler information in the exception object
procedure FPC_psabieh_save_caught_exception(ue_header: PFPC_Unwind_Exception;
handler_switch_value: longint;
language_specific_data: PByte;
landing_pad: PtrUInt);
var
xh: PExceptObject;
begin
xh:=FPC_psabieh_GetExceptionWrapper(ue_header);
xh^.handler_switch_value:=handler_switch_value;
xh^.language_specific_data:=language_specific_data;
xh^.landing_pad:=landing_pad;
end;
// Restore the catch handler information saved during phase1.
procedure FPC_psabieh_restore_caught_exception(ue_header: PFPC_Unwind_Exception;
out handler_switch_value: longint;
out language_specific_data: PByte;
out landing_pad: PtrUInt);
var
xh: PExceptObject;
begin
xh:=FPC_psabieh_GetExceptionWrapper(ue_header);
handler_switch_value:=xh^.handler_switch_value;
language_specific_data:=xh^.language_specific_data;
landing_pad:=xh^.landing_pad;
end;
function FPC_psabieh_find_action_record(const info: FPC_psabieh_lsda_header_info; var p: PByte; const ip: PTRUint; var landing_pad: PtrUInt; var action_record: PByte): boolean;
var
cs_start, cs_len, cs_lp: PtrUint{_Unwind_Ptr};
cs_action: PtrUInt {_Unwind_Word};
begin
result:=false;
while (p<info.action_table) do
begin
// Note that all call-site encodings are "absolute" displacements.
p:=FPC_psabieh_read_encoded_value (nil, info.call_site_encoding, p, cs_start);
p:=FPC_psabieh_read_encoded_value (nil, info.call_site_encoding, p, cs_len);
p:=FPC_psabieh_read_encoded_value (nil, info.call_site_encoding, p, cs_lp);
p:=FPC_read_uleb128 (p, &cs_action);
// The table is sorted, so if we've passed the ip, stop.
if ip<(info.Start+cs_start) then
p:=info.action_table
else if ip<(info.Start+cs_start+cs_len) then
begin
if cs_lp<>0 then
landing_pad:=info.LPStart+cs_lp;
if cs_action<>0 then
action_record:=info.action_table+cs_action-1;
result:=true;
end;
end;
end;
// Return true if the filter spec is empty, ie throw().
function fpc_psabieh_empty_exception_spec(const info: FPC_psabieh_lsda_header_info; const filter_value: PtrInt {_Unwind_Sword}): boolean;
var
e: PByte;
tmp: PtrUInt;
begin
e:=PByte(info.ttype - filter_value - 1);
e:=fpc_read_uleb128(e,tmp);
result:=tmp = 0;
end;
type
FPC_psabieh_found_handler_type = (
found_nothing,
found_terminate,
found_cleanup,
found_handler
);
function FPC_psabieh_find_handler(const info: FPC_psabieh_lsda_header_info; const foreign_exception: boolean; actions: FPC_Unwind_Action; thrown: TObject; var action_record: PByte; var handler_switch_value: longint): FPC_psabieh_found_handler_type;
var
ar_filter, ar_disp: PtrInt;
catch_type: TClass;
throw_type: TOBject;
saw_cleanup, saw_handler: boolean;
p: PByte;
begin
saw_cleanup:=false;
saw_handler:=false;
// During forced unwinding, we only run cleanups. With a foreign
// exception class, there's no exception type.
if ((actions and FPC_UA_FORCE_UNWIND)<>0) or
foreign_exception then
throw_type:=nil
else
throw_type:=thrown;
while true do
begin
p:=action_record;
p:=fpc_read_sleb128(p,ar_filter);
fpc_read_sleb128(p,ar_disp);
if ar_filter=0 then
begin
// Zero filter values are cleanups.
saw_cleanup:=true;
end
else if ar_filter>0 then
begin
// Positive filter values are handlers.
catch_type:=FPC_psabieh_get_ttype_entry(info,ar_filter);
// Null catch type is a catch-all handler; we can catch foreign
// exceptions with this. Otherwise we must match types.
if not assigned(catch_type) or
(assigned(throw_type) and
(throw_type is catch_type)) then
begin
saw_handler:=true;
break;
end
end
else
begin
// Negative filter values are exception specifications.
// ??? How do foreign exceptions fit in? As far as I can
// see we can't match because there's no __cxa_exception
// object to stuff bits in for __cxa_call_unexpected to use.
// Allow them iff the exception spec is non-empty. I.e.
// a throw() specification results in __unexpected.
if (assigned(throw_type) and
not FPC_psabieh_check_exception_spec(info,thrown,ar_filter)) or
(not assigned(throw_type) and
FPC_psabieh_empty_exception_spec(info,ar_filter)) then
begin
saw_handler:=true;
break;
end;
end;
if ar_disp=0 then
break;
action_record:=p+ar_disp;
end;
if saw_handler then
begin
handler_switch_value:=ar_filter;
result:=found_handler;
end
else
begin
if saw_cleanup then
result:=found_cleanup
else
result:=found_nothing;
end;
end;
{$ifdef FPC_PSABIEH_CPLUSPLUSSUPPORT}
procedure __gxx_personality_v0(version: cint; actions: FPC_Unwind_Action; exceptionClass: cuint64; libunwind_exception: PFPC_Unwind_Exception; context: PFPC_Unwind_Context); cdecl; external;
{$endif FPC_PSABIEH_CPLUSPLUSSUPPORT}
function FPC_psabieh_personality_v0(version: cint; actions: FPC_Unwind_Action; exceptionClass: cuint64; libunwind_exception: PFPC_Unwind_Exception; context: PFPC_Unwind_Context): FPC_Unwind_Reason_Code; cdecl;
var
WrappedException: PExceptObject;
found_type: FPC_psabieh_found_handler_type;
info: FPC_psabieh_lsda_header_info;
language_specific_data: PByte;
action_record: PByte;
p: PByte;
landing_pad, ip: PtrUInt;
handler_switch_value: longint;
foreign_exception: boolean;
begin
{ unsupported version -> failure }
if version<>1 then
begin
result:=FPC_URC_FATAL_PHASE1_ERROR;
exit;
end;
{ foreign exception type -> let c++ runtime handle it }
foreign_exception:=exceptionClass<>FPC_psabieh_exceptionClass_ID.u;
{$ifdef FPC_PSABIEH_CPLUSPLUSSUPPORT}
if foreign_exception then
begin
result:=__gxx_personality_v0(version, actions, exceptionClass, libunwind_exception, context)
exit;
end;
{$endif FPC_PSABIEH_CPLUSPLUSSUPPORT}
WrappedException:=FPC_psabieh_GetExceptionWrapper(libunwind_exception);
// Shortcut for phase 2 found handler for domestic exception.
if (actions=(FPC_UA_CLEANUP_PHASE or FPC_UA_HANDLER_FRAME)) and
not foreign_exception then
begin
FPC_psabieh_restore_caught_exception(libunwind_exception,handler_switch_value,
language_specific_data,landing_pad);
if landing_pad<>0 then
found_type:=found_handler
else
found_type:=found_terminate;
end
else
begin
language_specific_data:=PByte(_Unwind_GetLanguageSpecificData(context));
// If no LSDA, then there are no handlers or cleanups.
if not assigned(language_specific_data) then
begin
exit(FPC_URC_CONTINUE_UNWIND);
end;
// Parse the LSDA header.
p:=FPC_psabieh_parse_lsda_header(context,language_specific_data,info);
info.ttype_base:=FPC_psabieh_base_of_encoded_value(info.ttype_encoding,context);
ip:=_Unwind_GetIP(context);
dec(ip);
landing_pad:=0;
action_record:=nil;
handler_switch_value:=0;
// Search the call-site table for the action associated with this IP.
if FPC_psabieh_find_action_record(info,p,ip,landing_pad,action_record) then
begin
if landing_pad=0 then
begin
// If ip is present, and has a null landing pad, there are
// no cleanups or handlers to be run.
found_type:=found_nothing;
end
else if action_record=nil then
begin
// If ip is present, has a non-null landing pad, and a null
// action table offset, then there are only cleanups present.
// Cleanups use a zero switch value, as set above.
found_type:=found_cleanup;
end
else
begin
// Otherwise we have a catch handler or exception specification.
found_type:=FPC_psabieh_find_handler(info,foreign_exception,actions,WrappedException^.FObject,action_record,handler_switch_value);
end
end
else
begin
// If ip is not present in the table, call terminate. This is for
// a destructor inside a cleanup, or a library routine the compiler
// was not expecting to throw.
found_type:=found_terminate;
end;
if found_type=found_nothing then
exit(FPC_URC_CONTINUE_UNWIND);
if (actions and FPC_UA_SEARCH_PHASE)<>0 then
begin
if found_type=found_cleanup then
exit(FPC_URC_CONTINUE_UNWIND);
if not foreign_exception then
begin
// For domestic exceptions, we cache data from phase 1 for phase 2.
FPC_psabieh_save_caught_exception(libunwind_exception,
handler_switch_value,language_specific_data,
landing_pad);
end;
exit(FPC_URC_HANDLER_FOUND);
end;
end;
if ((actions and FPC_UA_FORCE_UNWIND)<>0) or
foreign_exception then
begin
if found_type=found_terminate then
halt(217)
{ can only perform cleanups when force-unwinding }
else if handler_switch_value<0 then
begin
RunError(217)
end
end
else
begin
if found_type=found_terminate then
halt(217);
end;
{ For targets with pointers smaller than the word size, we must extend the
pointer, and this extension is target dependent. }
{$if sizeof(pointer)<>sizeof(SizeInt)}
{$error Add support for extending pointer values}
{$endif}
_Unwind_SetGR(context,fpc_eh_return_data_regno(0),libunwind_exception);
_Unwind_SetGR (context,fpc_eh_return_data_regno(1),handler_switch_value);
_Unwind_SetIP(context,landing_pad);
result:=FPC_URC_INSTALL_CONTEXT;
end;
//////////////////////////////
///// Raising an exception
//////////////////////////////
procedure FPC_psabieh_ExceptionCleanUp(reason: FPC_Unwind_Reason_Code; exc:PFPC_Unwind_Exception); cdecl;
var
ExceptWrapper: PExceptObject;
begin
// If we haven't been caught by a foreign handler, then this is
// some sort of unwind error. In that case just die immediately.
// _Unwind_DeleteException in the HP-UX IA64 libunwind library
// returns _URC_NO_REASON and not _URC_FOREIGN_EXCEPTION_CAUGHT
// like the GCC _Unwind_DeleteException function does.
if (reason<>FPC_URC_FOREIGN_EXCEPTION_CAUGHT) and
(reason<>FPC_URC_NO_REASON) then
halt(217);
ExceptWrapper:=FPC_psabieh_GetExceptionWrapper(exc);
ExceptWrapper^.FObject.free;
ExceptWrapper^.FObject:=nil;
Dispose(ExceptWrapper);
end;
function PushExceptObject(Obj : TObject; AnAddr : CodePointer; AFrame : Pointer): PExceptObject; forward;
{$define FPC_SYSTEM_HAS_RAISEEXCEPTION}
procedure fpc_RaiseException(Obj: TObject; AnAddr: CodePointer; AFrame: Pointer); compilerproc;
var
_ExceptObjectStack : PExceptObject;
_ExceptAddrstack : PExceptAddr;
ExceptWrapper: PExceptObject;
begin
{$ifdef excdebug}
writeln ('In psabieh RaiseException');
{$endif}
if ExceptTryLevel<>0 then
Halt(217);
ExceptTryLevel:=1;
ExceptWrapper:=PushExceptObject(Obj,AnAddr,AFrame);
ExceptWrapper^.unwind_exception.exception_class:=FPC_psabieh_exceptionClass_ID.u;
ExceptWrapper^.unwind_exception.exception_cleanup:=@FPC_psabieh_ExceptionCleanUp;
{ if PushExceptObject causes another exception, the following won't be executed,
causing halt upon entering this routine recursively. }
ExceptTryLevel:=0;
_ExceptObjectStack:=ExceptObjectStack;
if (RaiseProc <> nil) and (_ExceptObjectStack <> nil) then
with _ExceptObjectStack^ do
RaiseProc(FObject,Addr,FrameCount,Frames);
_Unwind_RaiseException(@ExceptWrapper^.unwind_exception);
// should never return
Halt(217);
end;
{$ifdef FPC_PSABIEH_CPLUSPLUSSUPPORT}
function __cxa_begin_catch(exc:PFPC_Unwind_Exception): pointer; cdecl; external;
{$endif FPC_PSABIEH_CPLUSPLUSSUPPORT}
function FPC_psabi_begin_catch(exc:PFPC_Unwind_Exception): pointer; cdecl; compilerproc;
var
ExceptWrapper: PExceptObject;
_ExceptObjectStack : PExceptObject;
count: longint;
begin
_ExceptObjectStack:=ExceptObjectStack;
// hand off foreign exceptions to the C++ runtime
if exc^.exception_class<>FPC_psabieh_exceptionClass_ID.u then
begin
// Can't link foreign exceptions with our stack
if assigned(_ExceptObjectStack) then
halt(217);
// This is a wrong conversion, but as long as afterwards we only access
// fields of PFPC_Unwind_Exception, it's fine
_ExceptObjectStack:=FPC_psabieh_GetExceptionWrapper(exc);
{$ifdef FPC_PSABIEH_CPLUSPLUSSUPPORT}
result:=__cxa_begin_catch(exc);
{$else}
// ??? No sensible value to return; we don't know what the
// object is, much less where it is in relation to the header.
result:=nil;
{$endif}
exit;
end;
ExceptWrapper:=FPC_psabieh_GetExceptionWrapper(exc);
count:=ExceptWrapper^.refcount;
// Count is less than zero if this exception was rethrown from an
// immediately enclosing region.
if count < 0 then
count:=-count+1
else
inc(count);
ExceptWrapper^.refcount:=count;
// globals->uncaughtExceptions -= 1;
if _ExceptObjectStack<>ExceptWrapper then
begin
ExceptWrapper^.Next:=_ExceptObjectStack;
_ExceptObjectStack:=ExceptWrapper;
end;
result:= ExceptWrapper^.FObject;
{$ifdef __ARM_EABI_UNWINDER__}
_Unwind_Complete(ExceptWrapper);
{$endif}
end;
{$ifdef FPC_PSABIEH_CPLUSPLUSSUPPORT}
procedure __cxa_end_catch; cdecl; external;
{$endif FPC_PSABIEH_CPLUSPLUSSUPPORT}
procedure FPC_psabi_end_catch; cdecl; compilerproc;
var
_ExceptObjectStack: PExceptObject;
refcount: longint;
begin
_ExceptObjectStack:=ExceptObjectStack;
// A rethrow of a foreign exception will be removed from the
// the exception stack immediately by __cxa_rethrow.
if not assigned(_ExceptObjectStack) then
exit;
// Pass foreign exception to the C++ runtime
if _ExceptObjectStack^.unwind_exception.exception_class<>FPC_psabieh_exceptionClass_ID.u then
begin
{ remove foreign exception; since we never link multiple foreign
exceptions, we know the stack is now empty }
ExceptObjectStack:=nil;
{$ifdef FPC_PSABIEH_CPLUSPLUSSUPPORT}
__cxa_end_catch();
{$else}
_Unwind_DeleteException(@_ExceptObjectStack^.unwind_exception);
{$endif}
exit;
end;
refcount:=_ExceptObjectStack^.refcount;
if refcount<0 then
begin
// This exception was rethrown. Decrement the (inverted) catch
// count and remove it from the chain when it reaches zero.
inc(refcount);
if refcount = 0 then
ExceptObjectStack:=_ExceptObjectStack^.next;
end
else
begin
dec(refcount);
if refcount=0 then
begin
// Handling for this exception is complete. Destroy the object.
ExceptObjectStack:=_ExceptObjectStack^.next;
_Unwind_DeleteException(@_ExceptObjectStack^.unwind_exception);
exit;
end
else if refcount<0 then
begin
// A bug in the exception handling library or compiler.
halt(217);
end;
end;
_ExceptObjectStack^.refcount:=refcount;
end;

61
rtl/inc/psabiehh.inc Normal file
View File

@ -0,0 +1,61 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2017-2018 by Jonas Maebe,
member of the Free Pascal development team
This file contains support for Itanium psABI EH
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{$packrecords c}
const
FPC_URC_NO_REASON = FPC_Unwind_Reason_Code(0);
FPC_URC_FOREIGN_EXCEPTION_CAUGHT = FPC_Unwind_Reason_Code(1);
FPC_URC_FATAL_PHASE2_ERROR = FPC_Unwind_Reason_Code(2);
FPC_URC_FATAL_PHASE1_ERROR = FPC_Unwind_Reason_Code(3);
FPC_URC_NORMAL_STOP = FPC_Unwind_Reason_Code(4);
FPC_URC_END_OF_STACK = FPC_Unwind_Reason_Code(5);
FPC_URC_HANDLER_FOUND = FPC_Unwind_Reason_Code(6);
FPC_URC_INSTALL_CONTEXT = FPC_Unwind_Reason_Code(7);
FPC_URC_CONTINUE_UNWIND = FPC_Unwind_Reason_Code(8);
const
FPC_UA_SEARCH_PHASE = FPC_Unwind_Action(1);
FPC_UA_CLEANUP_PHASE = FPC_Unwind_Action(2);
FPC_UA_HANDLER_FRAME = FPC_Unwind_Action(4);
FPC_UA_FORCE_UNWIND = FPC_Unwind_Action(8);
FPC_UA_END_OF_STACK = FPC_Unwind_Action(16);
type
PFPC_Unwind_Context = ^FPC_Unwind_Context;
FPC_Unwind_Context = record
end;
procedure _Unwind_RaiseException(exception_object: PFPC_Unwind_Exception); cdecl; external;
procedure _Unwind_Resume(exception_object: PFPC_Unwind_Exception); cdecl; external;
type
TFPC_psabieh_exceptionClass = record
case byte of
0: (u: qword); {cuint64}
1: (a: array[0..7] of char);
end;
{$push}
{$j-}
const
FPC_psabieh_exceptionClass_ID: TFPC_psabieh_exceptionClass =
(a: 'FPC1PAS'#0);
{$pop}
{$packrecords default}