From b2d1ab7f056019ede7512ff8b055e2df5cf57bc2 Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sun, 28 Oct 2018 18:16:42 +0000 Subject: [PATCH] * basic helpers for DWARF/PSABI EH-based exception handling (based on 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 - --- .gitattributes | 2 + rtl/inc/except.inc | 7 +- rtl/inc/excepth.inc | 4 + rtl/inc/objpash.inc | 25 ++ rtl/inc/psabieh.inc | 822 +++++++++++++++++++++++++++++++++++++++++++ rtl/inc/psabiehh.inc | 61 ++++ 6 files changed, 920 insertions(+), 1 deletion(-) create mode 100644 rtl/inc/psabieh.inc create mode 100644 rtl/inc/psabiehh.inc diff --git a/.gitattributes b/.gitattributes index 6f5a427feb..090d352ff8 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/rtl/inc/except.inc b/rtl/inc/except.inc index 53df3e33c7..dc518bcf7f 100644 --- a/rtl/inc/except.inc +++ b/rtl/inc/except.inc @@ -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; diff --git a/rtl/inc/excepth.inc b/rtl/inc/excepth.inc index 19c2106d5d..a4c0901c3a 100644 --- a/rtl/inc/excepth.inc +++ b/rtl/inc/excepth.inc @@ -12,6 +12,10 @@ **********************************************************************} +{$if defined(FPC_USE_PSEABIEH)} +{$i psabiehh.inc} +{$endif} + Const { Type of exception. Currently only one. } FPC_EXCEPTION = 1; diff --git a/rtl/inc/objpash.inc b/rtl/inc/objpash.inc index 8e8b92d704..dd4f53dc85 100644 --- a/rtl/inc/objpash.inc +++ b/rtl/inc/objpash.inc @@ -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 diff --git a/rtl/inc/psabieh.inc b/rtl/inc/psabieh.inc new file mode 100644 index 0000000000..2081dfa69b --- /dev/null +++ b/rtl/inc/psabieh.inc @@ -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 (p0 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; diff --git a/rtl/inc/psabiehh.inc b/rtl/inc/psabiehh.inc new file mode 100644 index 0000000000..51dd5442ee --- /dev/null +++ b/rtl/inc/psabiehh.inc @@ -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}