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

* refactored psabieh handling, most code is now in psabiehpi

Browse Source 
git-svn-id: branches/debug_eh@41367 -
This commit is contained in:
florian 2019-02-17 21:20:40 +00:00
parent c0c14d5362
commit 9514bd9162
6 changed files with 711 additions and 393 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -654,6 +654,7 @@ compiler/ppheap.pas svneol=native#text/plain
compiler/ppu.pas svneol=native#text/plain
compiler/procdefutil.pas svneol=native#text/plain
compiler/procinfo.pas svneol=native#text/plain
compiler/psabiehpi.pas svneol=native#text/plain
compiler/pstatmnt.pas svneol=native#text/plain
compiler/psub.pas svneol=native#text/plain
compiler/psystem.pas svneol=native#text/plain

4
compiler/i386/cpupi.pas
View File

@ -28,10 +28,10 @@ unit cpupi;
interface
uses
psub,procinfo,aasmdata;
psub,procinfo,psabiehpi,aasmdata;
type
tcpuprocinfo = class(tcgprocinfo)
tcpuprocinfo = class(tpsabiehprocinfo)
constructor create(aparent:tprocinfo);override;
procedure set_first_temp_offset;override;
function calc_stackframe_size:longint;override;

306
compiler/ncgflw.pas
View File

@ -75,7 +75,9 @@ interface
tcgraisenode = class(traisenode)
function pass_1: tnode;override;
{$ifndef jvm}
procedure pass_generate_code;override;
{$endif jvm}
end;
{ Utility class for exception handling state management that is used
@ -127,38 +129,6 @@ interface
end;
tcgexceptionstatehandlerclass = class of tcgexceptionstatehandler;
{ Utility class for exception handling state management that is used
by tryexcept/tryfinally/on nodes (in a separate class so it can both
be shared and overridden)
Never instantiated. }
tpsabiehexceptionstatehandler = class(tcgexceptionstatehandler)
protected
class procedure begin_catch_internal(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel; add_catch: boolean; out exceptlocdef: tdef; out
exceptlocreg: tregister);
class procedure catch_all_start_internal(list: TAsmList; add_catch: boolean);
public
class procedure get_exception_temps(list:TAsmList;var t:texceptiontemps); override;
class procedure unget_exception_temps(list:TAsmList;const t:texceptiontemps); override;
class procedure new_exception(list:TAsmList;const t:texceptiontemps; const exceptframekind: texceptframekind; out exceptstate: texceptionstate); override;
{ start of "except/finally" block }
class procedure emit_except_label(list: TAsmList; exceptframekind: texceptframekind; var exceptionstate: texceptionstate;var exceptiontemps:texceptiontemps); override;
{ end of a try-block, label comes after the end of try/except or
try/finally }
class procedure end_try_block(list: TAsmList; exceptframekind: texceptframekind; const t: texceptiontemps; var exceptionstate: texceptionstate; endlabel: TAsmLabel); override;
class procedure free_exception(list: TAsmList; const t: texceptiontemps; const s: texceptionstate; a: aint; endexceptlabel: tasmlabel; onlyfree:boolean); override;
class procedure handle_reraise(list:TAsmList;const t:texceptiontemps;const entrystate: texceptionstate; const exceptframekind: texceptframekind); override;
{ start of an "on" (catch) block }
class procedure begin_catch(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel; out exceptlocdef: tdef; out exceptlocreg: tregister); override;
{ end of an "on" (catch) block }
class procedure end_catch(list: TAsmList); override;
{ called for a catch all exception }
class procedure catch_all_start(list: TAsmList); override;
class procedure catch_all_end(list: TAsmList); override;
class procedure cleanupobjectstack(list: TAsmList); override;
class procedure popaddrstack(list: TAsmList); override;
end;
tcgtryexceptnode = class(ttryexceptnode)
protected
type
@ -197,245 +167,10 @@ implementation
cpubase,
tgobj,paramgr,
cgobj,hlcgobj,nutils
{$ifndef jvm}
,psabiehpi
{$endif jvm}
;
class procedure tpsabiehexceptionstatehandler.get_exception_temps(list: TAsmList; var t: texceptiontemps);
begin
tg.gethltemp(list,ossinttype,ossinttype.size,tt_persistent,t.reasonbuf);
end;
class procedure tpsabiehexceptionstatehandler.unget_exception_temps(list: TAsmList; const t: texceptiontemps);
begin
tg.ungettemp(list,t.reasonbuf);
current_procinfo.PopAction(current_procinfo.CurrentAction);
end;
class procedure tpsabiehexceptionstatehandler.new_exception(list: TAsmList; const t: texceptiontemps;
const exceptframekind: texceptframekind; out exceptstate: texceptionstate);
var
reg: tregister;
action: TPSABIEHAction;
begin
exceptstate.oldflowcontrol:=flowcontrol;
current_asmdata.getjumplabel(exceptstate.exceptionlabel);
if exceptframekind<>tek_except then
begin
current_asmdata.getjumplabel(exceptstate.finallycodelabel);
action:=TPSABIEHAction.Create(exceptstate.finallycodelabel);
end
else
begin
exceptstate.finallycodelabel:=nil;
action:=TPSABIEHAction.Create(exceptstate.exceptionlabel);
end;
current_procinfo.CreateNewPSABIEHCallsite;
current_procinfo.PushAction(action);
current_procinfo.PushLandingPad(action);
if exceptframekind<>tek_except then
current_procinfo.CurrentAction.AddAction(nil);
flowcontrol:=[fc_inflowcontrol,fc_catching_exceptions];
if exceptframekind<>tek_except then
begin
reg:=hlcg.getintregister(list,ossinttype);
hlcg.a_load_const_reg(list,ossinttype,1,reg);
hlcg.g_exception_reason_save(list,ossinttype,ossinttype,reg,t.reasonbuf);
end;
end;
class procedure tpsabiehexceptionstatehandler.emit_except_label(list: TAsmList; exceptframekind: texceptframekind;
var exceptionstate: texceptionstate;var exceptiontemps:texceptiontemps);
begin
hlcg.g_unreachable(list);
hlcg.a_label(list,exceptionstate.exceptionlabel);
if exceptframekind<>tek_except then
begin
if not assigned(exceptionstate.finallycodelabel) then
internalerror(2019021002);
hlcg.a_label(list,exceptionstate.finallycodelabel);
exceptionstate.finallycodelabel:=nil;
exceptiontemps.unwind_info:=cg.getaddressregister(list);
hlcg.a_load_reg_reg(list,voidpointertype,voidpointertype,NR_FUNCTION_RESULT_REG,exceptiontemps.unwind_info);
end;
end;
class procedure tpsabiehexceptionstatehandler.end_try_block(list: TAsmList; exceptframekind: texceptframekind; const t: texceptiontemps;
var exceptionstate: texceptionstate; endlabel: TAsmLabel);
var
reg: TRegister;
begin
current_procinfo.CreateNewPSABIEHCallsite;
current_procinfo.PopLandingPad(current_procinfo.CurrentLandingPad);
if exceptframekind<>tek_except then
begin
{ record that no exception happened in the reason buf, in case we are in a try block of a finally statement }
reg:=hlcg.getintregister(list,ossinttype);
hlcg.a_load_const_reg(list,ossinttype,0,reg);
hlcg.g_exception_reason_save(list,ossinttype,ossinttype,reg,t.reasonbuf);
end;
inherited;
if exceptframekind=tek_except then
hlcg.a_jmp_always(list,endlabel);
end;
class procedure tpsabiehexceptionstatehandler.free_exception(list: TAsmList; const t: texceptiontemps; const s: texceptionstate; a: aint;
endexceptlabel: tasmlabel; onlyfree: boolean);
begin
current_procinfo.CreateNewPSABIEHCallsite;
// inherited free_exception(list, t, s, a, endexceptlabel, onlyfree);
end;
class procedure tpsabiehexceptionstatehandler.handle_reraise(list: TAsmList; const t: texceptiontemps; const entrystate: texceptionstate;
const exceptframekind: texceptframekind);
var
cgpara1: tcgpara;
pd: tprocdef;
action: TPSABIEHAction;
begin
cgpara1.init;
if not(fc_catching_exceptions in flowcontrol) and
use_cleanup(exceptframekind) then
begin
pd:=search_system_proc('fpc_resume');
paramanager.getintparaloc(list,pd,1,cgpara1);
hlcg.a_load_reg_cgpara(list,voidpointertype,t.unwind_info,cgpara1);
paramanager.freecgpara(list,cgpara1);
hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_resume',[@cgpara1],nil).resetiftemp
end
else
hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_reraise',[],nil).resetiftemp;
cgpara1.done;
end;
class procedure tpsabiehexceptionstatehandler.begin_catch_internal(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel;
add_catch: boolean; out exceptlocdef: tdef; out exceptlocreg: tregister);
var
catchstartlab : tasmlabel;
begincatchres,
typeidres,
paraloc1: tcgpara;
pd: tprocdef;
landingpadstructdef,
landingpadtypeiddef: tdef;
rttisym: TAsmSymbol;
rttidef: tdef;
rttiref: treference;
wrappedexception,
exceptiontypeidreg,
landingpadres: tregister;
exceptloc: tlocation;
indirect: boolean;
otherunit: boolean;
typeindex : aint;
begin
paraloc1.init;
rttidef:=nil;
rttisym:=nil;
if add_catch then
begin
if assigned(excepttype) then
begin
otherunit:=findunitsymtable(excepttype.owner).moduleid<>findunitsymtable(current_procinfo.procdef.owner).moduleid;
indirect:=(tf_supports_packages in target_info.flags) and
(target_info.system in systems_indirect_var_imports) and
(cs_imported_data in current_settings.localswitches) and
otherunit;
{ add "catch exceptiontype" clause to the landing pad }
rttidef:=cpointerdef.getreusable(excepttype.vmt_def);
rttisym:=current_asmdata.RefAsmSymbol(excepttype.vmt_mangledname, AT_DATA, indirect);
end;
end;
{ check if the exception is handled by this node }
if assigned(excepttype) then
begin
typeindex:=current_procinfo.CurrentAction.AddAction(excepttype);
current_asmdata.getjumplabel(catchstartlab);
{$ifdef i386}
hlcg.a_cmp_const_reg_label (list,osuinttype,OC_EQ,typeindex+1,NR_FUNCTION_RESULT64_HIGH_REG,catchstartlab);
{$else i386}
{ we need to find a way to fix this in a generic way }
Internalerror(2019021008);
{$endif i386}
hlcg.a_jmp_always(list,nextonlabel);
hlcg.a_label(list,catchstartlab);
end
else
current_procinfo.CurrentAction.AddAction(tobjectdef(-1));
wrappedexception:=hlcg.getaddressregister(list,voidpointertype);
pd:=search_system_proc('fpc_psabi_begin_catch');
paramanager.getintparaloc(list, pd, 1, paraloc1);
hlcg.a_load_reg_cgpara(list,voidpointertype,wrappedexception,paraloc1);
begincatchres:=hlcg.g_call_system_proc(list,pd,[@paraloc1],nil);
location_reset(exceptloc, LOC_REGISTER, def_cgsize(begincatchres.def));
exceptloc.register:=hlcg.getaddressregister(list, begincatchres.def);
hlcg.gen_load_cgpara_loc(list, begincatchres.def, begincatchres, exceptloc, true);
begincatchres.resetiftemp;
paraloc1.done;
exceptlocdef:=begincatchres.def;
exceptlocreg:=exceptloc.register;
end;
class procedure tpsabiehexceptionstatehandler.catch_all_start_internal(list: TAsmList; add_catch: boolean);
var
exceptlocdef: tdef;
exceptlocreg: tregister;
begin
begin_catch_internal(list,nil,nil,add_catch,exceptlocdef,exceptlocreg);
end;
class procedure tpsabiehexceptionstatehandler.begin_catch(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel; out exceptlocdef: tdef; out
exceptlocreg: tregister);
begin
begin_catch_internal(list,excepttype,nextonlabel,true,exceptlocdef,exceptlocreg);
end;
class procedure tpsabiehexceptionstatehandler.end_catch(list: TAsmList);
begin
hlcg.g_call_system_proc(list,'fpc_psabi_end_catch',[],nil).resetiftemp;
inherited;
end;
class procedure tpsabiehexceptionstatehandler.catch_all_start(list: TAsmList);
begin
catch_all_start_internal(list,true);
end;
class procedure tpsabiehexceptionstatehandler.catch_all_end(list: TAsmList);
begin
hlcg.g_call_system_proc(list,'fpc_psabi_end_catch',[],nil).resetiftemp;
end;
class procedure tpsabiehexceptionstatehandler.cleanupobjectstack(list: TAsmList);
begin
// inherited cleanupobjectstack(list);
//!!! some catch all clause needed?
//!!! internalerror(2019021004)
end;
class procedure tpsabiehexceptionstatehandler.popaddrstack(list: TAsmList);
begin
{ there is no addr stack, so do nothing }
end;
{*****************************************************************************
Second_While_RepeatN
*****************************************************************************}
@ -1664,43 +1399,46 @@ implementation
end;
end;
{$ifndef jvm}
{ has to be factored out as well }
procedure tcgraisenode.pass_generate_code;
var
CurrentLandingPad, CurrentAction, ReRaiseLandingPad: TPSABIEHAction;
psabiehprocinfo: tpsabiehprocinfo;
begin
if not(tf_use_psabieh in target_info.flags) then
Internalerror(2019021701);
location_reset(location,LOC_VOID,OS_NO);
CurrentLandingPad:=nil;
psabiehprocinfo:=current_procinfo as tpsabiehprocinfo;
{ a reraise must raise the exception to the parent exception frame }
if fc_catching_exceptions in flowcontrol then
begin
current_procinfo.CreateNewPSABIEHCallsite;
CurrentLandingPad:=current_procinfo.CurrentLandingPad;
if current_procinfo.PopLandingPad(CurrentLandingPad) then
psabiehprocinfo.CreateNewPSABIEHCallsite;
CurrentLandingPad:=psabiehprocinfo.CurrentLandingPad;
if psabiehprocinfo.PopLandingPad(CurrentLandingPad) then
exclude(flowcontrol,fc_catching_exceptions);
CurrentAction:=current_procinfo.CurrentAction;
current_procinfo.PopAction(CurrentAction);
CurrentAction:=psabiehprocinfo.CurrentAction;
psabiehprocinfo.PopAction(CurrentAction);
ReRaiseLandingPad:=TPSABIEHAction.Create(nil);
current_procinfo.PushAction(ReRaiseLandingPad);
current_procinfo.PushLandingPad(ReRaiseLandingPad);
psabiehprocinfo.PushAction(ReRaiseLandingPad);
psabiehprocinfo.PushLandingPad(ReRaiseLandingPad);
end;
hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_reraise',[],nil).resetiftemp;
if assigned(CurrentLandingPad) then
begin
current_procinfo.CreateNewPSABIEHCallsite;
current_procinfo.PopLandingPad(current_procinfo.CurrentLandingPad);
current_procinfo.PopAction(ReRaiseLandingPad);
psabiehprocinfo.CreateNewPSABIEHCallsite;
psabiehprocinfo.PopLandingPad(psabiehprocinfo.CurrentLandingPad);
psabiehprocinfo.PopAction(ReRaiseLandingPad);
current_procinfo.PushAction(CurrentAction);
current_procinfo.PushLandingPad(CurrentLandingPad);
psabiehprocinfo.PushAction(CurrentAction);
psabiehprocinfo.PushLandingPad(CurrentLandingPad);
include(flowcontrol,fc_catching_exceptions);
end;
end;
{$endif jvm}
begin

20
compiler/procinfo.pas
View File

@ -51,9 +51,6 @@ unit procinfo;
{ This object gives information on the current routine being
compiled.
}
{ tprocinfo }
tprocinfo = class(tlinkedlistitem)
private
{ list to store the procinfo's of the nested procedures }
@ -184,6 +181,9 @@ unit procinfo;
{ set exception handling info }
procedure set_eh_info; virtual;
procedure setup_eh; virtual;
procedure finish_eh; virtual;
end;
tcprocinfo = class of tprocinfo;
@ -325,14 +325,28 @@ implementation
be initialized }
end;
procedure tprocinfo.postprocess_code;
begin
{ no action by default }
end;
procedure tprocinfo.set_eh_info;
begin
{ default code is in tcgprocinfo }
end;
procedure tprocinfo.setup_eh;
begin
{ no action by default }
end;
procedure tprocinfo.finish_eh;
begin
{ no action by default }
end;
end.

669
compiler/psabiehpi.pas Normal file
View File

@ -0,0 +1,669 @@
{
Copyright (c) 1998-2002 by Florian Klaempfl
Information about the current procedure that is being compiled
This program 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 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit psabiehpi;
{ $define debug_eh}
{$i fpcdefs.inc}
interface
uses
{ common }
cclasses,
{ global }
globtype,
{ symtable }
symconst,symtype,symdef,symsym,
node,
{ aasm }
cpubase,cgbase,cgutils,
aasmbase,aasmdata,aasmtai,
psub;
type
TPSABIEHAction = class
landingpad : TAsmLabel;
actiontablelabel : TAsmLabel;
actionlist : TAsmList;
first : boolean;
constructor Create(pad : TAsmLabel);
destructor Destroy; override;
function AddAction(p: tobjectdef): LongInt;
end;
{ This object gives information on the current routine being
compiled.
}
tpsabiehprocinfo = class(tcgprocinfo)
{ psabieh stuff, might be subject to be moved elsewhere }
{ gcc exception table list that belongs to this routine }
callsite_table_data,
action_table_data,
gcc_except_table_data : TAsmList;
typefilterlistlabel,typefilterlistlabelref,
callsitetablestart,callsitetableend : TAsmLabel;
callsitelaststart : TAsmLabel;
typefilterlist,
landingpadstack,
actionstack : tfplist;
CurrentCallSiteNumber : Longint;
destructor destroy; override;
{ PSABIEH stuff }
procedure PushAction(action: TPSABIEHAction);
function CurrentAction: TPSABIEHAction;inline;
function PopAction(action: TPSABIEHAction): boolean;
{ a landing pad is also an action, however, when the landing pad is popped from the stack
the area covered by this landing pad ends, i.e. it is popped at the beginning of the finally/except clause,
the action above is popped at the end of the finally/except clause, so if on clauses add new types, they
are added to CurrentAction }
procedure PushLandingPad(action: TPSABIEHAction);
function CurrentLandingPad: TPSABIEHAction;inline;
function PopLandingPad(action: TPSABIEHAction): boolean;
procedure CreateNewPSABIEHCallsite;
{ adds a new type to the type filter list and returns its index
be aware, that this method can also handle catch all filters so it
is valid to pass nil }
function AddTypeFilter(p: tobjectdef): Longint;
procedure set_eh_info; override;
procedure setup_eh; override;
procedure finish_eh; override;
end;
implementation
uses
cutils,
verbose,
systems,
dwarfbase,
cfidwarf,
globals,
procinfo,
symtable,
defutil,
tgobj,
cgobj,
parabase,paramgr,
hlcgobj,
pass_2,
ncgflw;
type
{ Utility class for exception handling state management that is used
by tryexcept/tryfinally/on nodes (in a separate class so it can both
be shared and overridden)
Never instantiated. }
tpsabiehexceptionstatehandler = class(tcgexceptionstatehandler)
protected
class procedure begin_catch_internal(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel; add_catch: boolean; out exceptlocdef: tdef; out
exceptlocreg: tregister);
class procedure catch_all_start_internal(list: TAsmList; add_catch: boolean);
public
class procedure get_exception_temps(list:TAsmList;var t:texceptiontemps); override;
class procedure unget_exception_temps(list:TAsmList;const t:texceptiontemps); override;
class procedure new_exception(list:TAsmList;const t:texceptiontemps; const exceptframekind: texceptframekind; out exceptstate: texceptionstate); override;
{ start of "except/finally" block }
class procedure emit_except_label(list: TAsmList; exceptframekind: texceptframekind; var exceptionstate: texceptionstate;var exceptiontemps:texceptiontemps); override;
{ end of a try-block, label comes after the end of try/except or
try/finally }
class procedure end_try_block(list: TAsmList; exceptframekind: texceptframekind; const t: texceptiontemps; var exceptionstate: texceptionstate; endlabel: TAsmLabel); override;
class procedure free_exception(list: TAsmList; const t: texceptiontemps; const s: texceptionstate; a: aint; endexceptlabel: tasmlabel; onlyfree:boolean); override;
class procedure handle_reraise(list:TAsmList;const t:texceptiontemps;const entrystate: texceptionstate; const exceptframekind: texceptframekind); override;
{ start of an "on" (catch) block }
class procedure begin_catch(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel; out exceptlocdef: tdef; out exceptlocreg: tregister); override;
{ end of an "on" (catch) block }
class procedure end_catch(list: TAsmList); override;
{ called for a catch all exception }
class procedure catch_all_start(list: TAsmList); override;
class procedure catch_all_end(list: TAsmList); override;
class procedure cleanupobjectstack(list: TAsmList); override;
class procedure popaddrstack(list: TAsmList); override;
end;
constructor TPSABIEHAction.Create(pad: TAsmLabel);
begin
landingpad:=pad;
actionlist:=TAsmList.create;
current_asmdata.getlabel(actiontablelabel,alt_data);
actionlist.concat(tai_label.create(actiontablelabel));
first:=true;
end;
destructor TPSABIEHAction.Destroy;
begin
if not(actionlist.Empty) then
Internalerror(2019020501);
actionlist.Free;
inherited Destroy;
end;
function TPSABIEHAction.AddAction(p: tobjectdef) : LongInt;
var
index: LongInt;
begin
{ if not first entry, signal that another action follows }
if not(first) then
actionlist.concat(tai_const.Create_uleb128bit(1));
first:=false;
{ catch all? }
if p=tobjectdef(-1) then
index:=(current_procinfo as tpsabiehprocinfo).AddTypeFilter(nil)
else if assigned(p) then
index:=(current_procinfo as tpsabiehprocinfo).AddTypeFilter(p)
else
index:=-1;
{$ifdef debug_eh}
if p=tobjectdef(-1) then
actionlist.concat(tai_comment.Create(strpnew('Catch all')))
else if assigned(p) then
actionlist.concat(tai_comment.Create(strpnew('Action for '+p.GetTypeName)))
else
actionlist.concat(tai_comment.Create(strpnew('Cleanup')));
{$endif debug_eh}
if assigned(p) then
actionlist.concat(tai_const.Create_uleb128bit(index+1))
else
actionlist.concat(tai_const.Create_uleb128bit(0));
Result:=index;
end;
{****************************************************************************
tpsabiehprocinfo
****************************************************************************}
destructor tpsabiehprocinfo.destroy;
begin
gcc_except_table_data.free;
actionstack.free;
landingpadstack.free;
typefilterlist.free;
callsite_table_data.Free;
action_table_data.Free;
inherited;
end;
procedure tpsabiehprocinfo.PushAction(action: TPSABIEHAction);
begin
actionstack.add(action);
end;
function tpsabiehprocinfo.PopAction(action: TPSABIEHAction): boolean;
var
curpos: tasmlabel;
begin
include(flags,pi_has_except_table_data);
if CurrentAction<>action then
internalerror(2019021006);
{ no further actions follow, finalize table }
if landingpadstack.count>0 then
begin
current_asmdata.getlabel(curpos,alt_data);
action.actionlist.concat(tai_label.create(curpos));
action.actionlist.concat(tai_const.Create_rel_sym(aitconst_sleb128bit,curpos,TPSABIEHAction(landingpadstack[landingpadstack.count-1]).actiontablelabel));
end
else
action.actionlist.concat(tai_const.Create_uleb128bit(0));
action_table_data.concatList(action.actionlist);
actionstack.count:=actionstack.count-1;
result:=actionstack.count=0;
end;
procedure tpsabiehprocinfo.PushLandingPad(action: TPSABIEHAction);
begin
landingpadstack.add(action);
end;
function tpsabiehprocinfo.CurrentLandingPad: TPSABIEHAction;
begin
result:=TPSABIEHAction(landingpadstack.last);
end;
function tpsabiehprocinfo.PopLandingPad(action: TPSABIEHAction): boolean;
begin
if CurrentLandingPad<>action then
internalerror(2019021007);
landingpadstack.count:=landingpadstack.count-1;
result:=landingpadstack.count=0;
end;
procedure tpsabiehprocinfo.CreateNewPSABIEHCallsite;
var
callsiteend : TAsmLabel;
begin
include(flags,pi_has_except_table_data);
{ first, finish last entry }
if assigned(callsitelaststart) and assigned(CurrentLandingPad) then
begin
{$ifdef debug_eh}
if assigned(CurrentLandingPad.actiontablelabel) then
callsite_table_data.concat(tai_comment.Create(strpnew('Call site '+tostr(CurrentCallSiteNumber)+', action table index = '+tostr(landingpadstack.count-1))))
else
callsite_table_data.concat(tai_comment.Create(strpnew('Call site '+tostr(CurrentCallSiteNumber)+', no action')));
{$endif debug_eh}
callsite_table_data.concat(tai_const.create_rel_sym(aitconst_uleb128bit,TDwarfAsmCFI(current_asmdata.AsmCFI).get_frame_start,callsitelaststart));
current_asmdata.getlabel(callsiteend,alt_eh_end);
current_asmdata.CurrAsmList.concat(tai_label.create(callsiteend));
callsite_table_data.concat(tai_const.create_rel_sym(aitconst_uleb128bit,callsitelaststart,callsiteend));
{ landing pad? }
if assigned(CurrentLandingPad.landingpad) then
callsite_table_data.concat(tai_const.create_rel_sym(aitconst_uleb128bit,TDwarfAsmCFI(current_asmdata.AsmCFI).get_frame_start,CurrentLandingPad.landingpad))
else
callsite_table_data.concat(tai_const.Create_uleb128bit(0));
{ action number set? if yes, concat }
if assigned(CurrentLandingPad.actiontablelabel) then
begin
callsite_table_data.concat(tai_const.Create_rel_sym_offset(aitconst_uleb128bit,callsitetableend,CurrentLandingPad.actiontablelabel,1));
{$ifdef debug_eh}
current_asmdata.CurrAsmList.concat(tai_comment.Create(strpnew('New call site '+tostr(CurrentCallSiteNumber)+', action table index = '+tostr(landingpadstack.count-1))));
{$endif debug_eh}
end
else
begin
callsite_table_data.concat(tai_const.Create_uleb128bit(0));
{$ifdef debug_eh}
current_asmdata.CurrAsmList.concat(tai_comment.Create(strpnew('New call site '+tostr(CurrentCallSiteNumber)+', no action')));
{$endif debug_eh}
end
end;
current_asmdata.getlabel(callsitelaststart,alt_eh_begin);
current_asmdata.CurrAsmList.concat(tai_label.create(callsitelaststart));
Inc(CurrentCallSiteNumber);
end;
function tpsabiehprocinfo.AddTypeFilter(p: tobjectdef) : Longint;
var
i: Integer;
begin
for i:=0 to typefilterlist.count-1 do
begin
if tobjectdef(typefilterlist[i])=p then
begin
result:=i;
exit;
end;
end;
result:=typefilterlist.add(p);
end;
procedure tpsabiehprocinfo.set_eh_info;
begin
inherited set_eh_info;
if (tf_use_psabieh in target_info.flags) and not(pi_has_except_table_data in flags) then
(current_asmdata.AsmCFI as TDwarfAsmCFI).LSDALabel:=nil;
end;
function tpsabiehprocinfo.CurrentAction: TPSABIEHAction; inline;
begin
result:=TPSABIEHAction(actionstack.last);
end;
procedure tpsabiehprocinfo.setup_eh;
var
gcc_except_table: tai_section;
begin
gcc_except_table_data:=TAsmList.Create;
callsite_table_data:=TAsmList.Create;
action_table_data:=TAsmList.Create;
actionstack:=TFPList.Create;
landingpadstack:=TFPList.Create;
typefilterlist:=TFPList.Create;
gcc_except_table:=new_section(gcc_except_table_data,sec_gcc_except_table,'',0);
gcc_except_table.secflags:=SF_A;
gcc_except_table.secprogbits:=SPB_PROGBITS;
if not(current_asmdata.AsmCFI is TDwarfAsmCFI) then
internalerror(2019021003);
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('gcc_except_table for '+procdef.fullprocname(true))));
{$endif debug_eh}
current_asmdata.getlabel(TDwarfAsmCFI(current_asmdata.AsmCFI).LSDALabel,alt_data);
current_asmdata.getlabel(callsitetablestart,alt_data);
current_asmdata.getlabel(callsitetableend,alt_data);
callsite_table_data.concat(tai_label.create(callsitetablestart));
cexceptionstatehandler:=tpsabiehexceptionstatehandler;
end;
procedure tpsabiehprocinfo.finish_eh;
var
i: Integer;
begin
if (tf_use_psabieh in target_info.flags) then
begin
if pi_has_except_table_data in flags then
begin
gcc_except_table_data.concat(tai_label.create(TDwarfAsmCFI(current_asmdata.AsmCFI).LSDALabel));
{ landing pad base is relative to procedure start, so write an omit }
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_omit));
if typefilterlist.count>0 then
begin
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_udata4));
current_asmdata.getlabel(typefilterlistlabel,alt_data);
current_asmdata.getlabel(typefilterlistlabelref,alt_data);
gcc_except_table_data.concat(tai_const.create_rel_sym(aitconst_uleb128bit,typefilterlistlabel,typefilterlistlabelref));
gcc_except_table_data.concat(tai_label.create(typefilterlistlabel));
end
else
{ default types table encoding }
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_omit));
{ call-site table encoded using uleb128 }
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_uleb128));
gcc_except_table_data.concat(tai_const.create_rel_sym(aitconst_uleb128bit,callsitetablestart,callsitetableend));
callsite_table_data.concat(tai_label.create(callsitetableend));
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('Call site table for '+procdef.fullprocname(true))));
{$endif debug_eh}
gcc_except_table_data.concatList(callsite_table_data);
{ action table must follow immediatly after callsite table }
{$ifdef debug_eh}
if not(action_table_data.Empty) then
gcc_except_table_data.concat(tai_comment.Create(strpnew('Action table for '+procdef.fullprocname(true))));
{$endif debug_eh}
gcc_except_table_data.concatlist(action_table_data);
if typefilterlist.count>0 then
begin
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('Type filter list for '+procdef.fullprocname(true))));
{$endif debug_eh}
for i:=typefilterlist.count-1 downto 0 do
begin
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('Type filter '+tostr(i))));
{$endif debug_eh}
if assigned(typefilterlist[i]) then
gcc_except_table_data.concat(tai_const.Create_sym(current_asmdata.RefAsmSymbol(tobjectdef(typefilterlist[i]).vmt_mangledname, AT_DATA)))
else
gcc_except_table_data.concat(tai_const.Create_32bit(0));
end;
{ the types are resolved by the negative offset, so the label must be written after all types }
gcc_except_table_data.concat(tai_label.create(typefilterlistlabelref));
end;
new_section(gcc_except_table_data,sec_code,'',0);
aktproccode.concatlist(gcc_except_table_data);
end;
end;
end;
class procedure tpsabiehexceptionstatehandler.get_exception_temps(list: TAsmList; var t: texceptiontemps);
begin
tg.gethltemp(list,ossinttype,ossinttype.size,tt_persistent,t.reasonbuf);
end;
class procedure tpsabiehexceptionstatehandler.unget_exception_temps(list: TAsmList; const t: texceptiontemps);
begin
tg.ungettemp(list,t.reasonbuf);
(current_procinfo as tpsabiehprocinfo).PopAction((current_procinfo as tpsabiehprocinfo).CurrentAction);
end;
class procedure tpsabiehexceptionstatehandler.new_exception(list: TAsmList; const t: texceptiontemps;
const exceptframekind: texceptframekind; out exceptstate: texceptionstate);
var
reg: tregister;
action: TPSABIEHAction;
begin
exceptstate.oldflowcontrol:=flowcontrol;
current_asmdata.getjumplabel(exceptstate.exceptionlabel);
if exceptframekind<>tek_except then
begin
current_asmdata.getjumplabel(exceptstate.finallycodelabel);
action:=TPSABIEHAction.Create(exceptstate.finallycodelabel);
end
else
begin
exceptstate.finallycodelabel:=nil;
action:=TPSABIEHAction.Create(exceptstate.exceptionlabel);
end;
(current_procinfo as tpsabiehprocinfo).CreateNewPSABIEHCallsite;
(current_procinfo as tpsabiehprocinfo).PushAction(action);
(current_procinfo as tpsabiehprocinfo).PushLandingPad(action);
if exceptframekind<>tek_except then
(current_procinfo as tpsabiehprocinfo).CurrentAction.AddAction(nil);
flowcontrol:=[fc_inflowcontrol,fc_catching_exceptions];
if exceptframekind<>tek_except then
begin
reg:=hlcg.getintregister(list,ossinttype);
hlcg.a_load_const_reg(list,ossinttype,1,reg);
hlcg.g_exception_reason_save(list,ossinttype,ossinttype,reg,t.reasonbuf);
end;
end;
class procedure tpsabiehexceptionstatehandler.emit_except_label(list: TAsmList; exceptframekind: texceptframekind;
var exceptionstate: texceptionstate;var exceptiontemps:texceptiontemps);
begin
hlcg.g_unreachable(list);
hlcg.a_label(list,exceptionstate.exceptionlabel);
if exceptframekind<>tek_except then
begin
if not assigned(exceptionstate.finallycodelabel) then
internalerror(2019021002);
hlcg.a_label(list,exceptionstate.finallycodelabel);
exceptionstate.finallycodelabel:=nil;
exceptiontemps.unwind_info:=cg.getaddressregister(list);
hlcg.a_load_reg_reg(list,voidpointertype,voidpointertype,NR_FUNCTION_RESULT_REG,exceptiontemps.unwind_info);
end;
end;
class procedure tpsabiehexceptionstatehandler.end_try_block(list: TAsmList; exceptframekind: texceptframekind; const t: texceptiontemps;
var exceptionstate: texceptionstate; endlabel: TAsmLabel);
var
reg: TRegister;
begin
(current_procinfo as tpsabiehprocinfo).CreateNewPSABIEHCallsite;
(current_procinfo as tpsabiehprocinfo).PopLandingPad((current_procinfo as tpsabiehprocinfo).CurrentLandingPad);
if exceptframekind<>tek_except then
begin
{ record that no exception happened in the reason buf, in case we are in a try block of a finally statement }
reg:=hlcg.getintregister(list,ossinttype);
hlcg.a_load_const_reg(list,ossinttype,0,reg);
hlcg.g_exception_reason_save(list,ossinttype,ossinttype,reg,t.reasonbuf);
end;
inherited;
if exceptframekind=tek_except then
hlcg.a_jmp_always(list,endlabel);
end;
class procedure tpsabiehexceptionstatehandler.free_exception(list: TAsmList; const t: texceptiontemps; const s: texceptionstate; a: aint;
endexceptlabel: tasmlabel; onlyfree: boolean);
begin
(current_procinfo as tpsabiehprocinfo).CreateNewPSABIEHCallsite;
// inherited free_exception(list, t, s, a, endexceptlabel, onlyfree);
end;
class procedure tpsabiehexceptionstatehandler.handle_reraise(list: TAsmList; const t: texceptiontemps; const entrystate: texceptionstate;
const exceptframekind: texceptframekind);
var
cgpara1: tcgpara;
pd: tprocdef;
action: TPSABIEHAction;
begin
cgpara1.init;
if not(fc_catching_exceptions in flowcontrol) and
use_cleanup(exceptframekind) then
begin
pd:=search_system_proc('fpc_resume');
paramanager.getintparaloc(list,pd,1,cgpara1);
hlcg.a_load_reg_cgpara(list,voidpointertype,t.unwind_info,cgpara1);
paramanager.freecgpara(list,cgpara1);
hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_resume',[@cgpara1],nil).resetiftemp
end
else
hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_reraise',[],nil).resetiftemp;
cgpara1.done;
end;
class procedure tpsabiehexceptionstatehandler.begin_catch_internal(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel;
add_catch: boolean; out exceptlocdef: tdef; out exceptlocreg: tregister);
var
catchstartlab : tasmlabel;
begincatchres,
typeidres,
paraloc1: tcgpara;
pd: tprocdef;
landingpadstructdef,
landingpadtypeiddef: tdef;
rttisym: TAsmSymbol;
rttidef: tdef;
rttiref: treference;
wrappedexception,
exceptiontypeidreg,
landingpadres: tregister;
exceptloc: tlocation;
indirect: boolean;
otherunit: boolean;
typeindex : aint;
begin
paraloc1.init;
rttidef:=nil;
rttisym:=nil;
if add_catch then
begin
if assigned(excepttype) then
begin
otherunit:=findunitsymtable(excepttype.owner).moduleid<>findunitsymtable(current_procinfo.procdef.owner).moduleid;
indirect:=(tf_supports_packages in target_info.flags) and
(target_info.system in systems_indirect_var_imports) and
(cs_imported_data in current_settings.localswitches) and
otherunit;
{ add "catch exceptiontype" clause to the landing pad }
rttidef:=cpointerdef.getreusable(excepttype.vmt_def);
rttisym:=current_asmdata.RefAsmSymbol(excepttype.vmt_mangledname, AT_DATA, indirect);
end;
end;
{ check if the exception is handled by this node }
if assigned(excepttype) then
begin
typeindex:=(current_procinfo as tpsabiehprocinfo).CurrentAction.AddAction(excepttype);
current_asmdata.getjumplabel(catchstartlab);
{$ifdef i386}
hlcg.a_cmp_const_reg_label (list,osuinttype,OC_EQ,typeindex+1,NR_FUNCTION_RESULT64_HIGH_REG,catchstartlab);
{$else i386}
{ we need to find a way to fix this in a generic way }
Internalerror(2019021008);
{$endif i386}
hlcg.a_jmp_always(list,nextonlabel);
hlcg.a_label(list,catchstartlab);
end
else
(current_procinfo as tpsabiehprocinfo).CurrentAction.AddAction(tobjectdef(-1));
wrappedexception:=hlcg.getaddressregister(list,voidpointertype);
pd:=search_system_proc('fpc_psabi_begin_catch');
paramanager.getintparaloc(list, pd, 1, paraloc1);
hlcg.a_load_reg_cgpara(list,voidpointertype,wrappedexception,paraloc1);
begincatchres:=hlcg.g_call_system_proc(list,pd,[@paraloc1],nil);
location_reset(exceptloc, LOC_REGISTER, def_cgsize(begincatchres.def));
exceptloc.register:=hlcg.getaddressregister(list, begincatchres.def);
hlcg.gen_load_cgpara_loc(list, begincatchres.def, begincatchres, exceptloc, true);
begincatchres.resetiftemp;
paraloc1.done;
exceptlocdef:=begincatchres.def;
exceptlocreg:=exceptloc.register;
end;
class procedure tpsabiehexceptionstatehandler.catch_all_start_internal(list: TAsmList; add_catch: boolean);
var
exceptlocdef: tdef;
exceptlocreg: tregister;
begin
begin_catch_internal(list,nil,nil,add_catch,exceptlocdef,exceptlocreg);
end;
class procedure tpsabiehexceptionstatehandler.begin_catch(list: TAsmList; excepttype: tobjectdef; nextonlabel: tasmlabel; out exceptlocdef: tdef; out
exceptlocreg: tregister);
begin
begin_catch_internal(list,excepttype,nextonlabel,true,exceptlocdef,exceptlocreg);
end;
class procedure tpsabiehexceptionstatehandler.end_catch(list: TAsmList);
begin
hlcg.g_call_system_proc(list,'fpc_psabi_end_catch',[],nil).resetiftemp;
inherited;
end;
class procedure tpsabiehexceptionstatehandler.catch_all_start(list: TAsmList);
begin
catch_all_start_internal(list,true);
end;
class procedure tpsabiehexceptionstatehandler.catch_all_end(list: TAsmList);
begin
hlcg.g_call_system_proc(list,'fpc_psabi_end_catch',[],nil).resetiftemp;
end;
class procedure tpsabiehexceptionstatehandler.cleanupobjectstack(list: TAsmList);
begin
// inherited cleanupobjectstack(list);
//!!! some catch all clause needed?
//!!! internalerror(2019021004)
end;
class procedure tpsabiehexceptionstatehandler.popaddrstack(list: TAsmList);
begin
{ there is no addr stack, so do nothing }
end;
end.

104
compiler/psub.pas
View File

@ -68,8 +68,6 @@ interface
function has_assembler_child : boolean;
procedure set_eh_info; override;
procedure setup_eh;
procedure finish_eh;
end;
@ -121,10 +119,6 @@ implementation
{ codegen }
tgobj,cgbase,cgobj,hlcgobj,hlcgcpu,dbgbase,
{ dwarf }
dwarfbase,
cfidwarf,
ncgflw,
ncgutil,
@ -1163,104 +1157,6 @@ implementation
(pi_needs_implicit_finally in flags))) or
(pi_has_except_table_data in flags) then
procdef.personality:=search_system_proc('_FPC_PSABIEH_PERSONALITY_V0');
if (tf_use_psabieh in target_info.flags) and not(pi_has_except_table_data in flags) then
(current_asmdata.AsmCFI as TDwarfAsmCFI).LSDALabel:=nil;
end;
procedure tcgprocinfo.setup_eh;
var
gcc_except_table: tai_section;
begin
if tf_use_psabieh in target_info.flags then
begin
gcc_except_table_data:=TAsmList.Create;
callsite_table_data:=TAsmList.Create;
action_table_data:=TAsmList.Create;
actionstack:=TFPList.Create;
landingpadstack:=TFPList.Create;
typefilterlist:=TFPList.Create;
gcc_except_table:=new_section(gcc_except_table_data,sec_gcc_except_table,'',0);
gcc_except_table.secflags:=SF_A;
gcc_except_table.secprogbits:=SPB_PROGBITS;
if not(current_asmdata.AsmCFI is TDwarfAsmCFI) then
internalerror(2019021003);
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('gcc_except_table for '+procdef.fullprocname(true))));
{$endif debug_eh}
current_asmdata.getlabel(TDwarfAsmCFI(current_asmdata.AsmCFI).LSDALabel,alt_data);
current_asmdata.getlabel(callsitetablestart,alt_data);
current_asmdata.getlabel(callsitetableend,alt_data);
callsite_table_data.concat(tai_label.create(callsitetablestart));
cexceptionstatehandler:=tpsabiehexceptionstatehandler;
end;
end;
procedure tcgprocinfo.finish_eh;
var
i: Integer;
begin
if (tf_use_psabieh in target_info.flags) then
begin
if pi_has_except_table_data in flags then
begin
gcc_except_table_data.concat(tai_label.create(TDwarfAsmCFI(current_asmdata.AsmCFI).LSDALabel));
{ landing pad base is relative to procedure start, so write an omit }
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_omit));
if typefilterlist.count>0 then
begin
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_udata4));
current_asmdata.getlabel(typefilterlistlabel,alt_data);
current_asmdata.getlabel(typefilterlistlabelref,alt_data);
gcc_except_table_data.concat(tai_const.create_rel_sym(aitconst_uleb128bit,typefilterlistlabel,typefilterlistlabelref));
gcc_except_table_data.concat(tai_label.create(typefilterlistlabel));
end
else
{ default types table encoding }
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_omit));
{ call-site table encoded using uleb128 }
gcc_except_table_data.concat(tai_const.create_8bit(DW_EH_PE_uleb128));
gcc_except_table_data.concat(tai_const.create_rel_sym(aitconst_uleb128bit,callsitetablestart,callsitetableend));
callsite_table_data.concat(tai_label.create(callsitetableend));
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('Call site table for '+procdef.fullprocname(true))));
{$endif debug_eh}
gcc_except_table_data.concatList(callsite_table_data);
{ action table must follow immediatly after callsite table }
{$ifdef debug_eh}
if not(action_table_data.Empty) then
gcc_except_table_data.concat(tai_comment.Create(strpnew('Action table for '+procdef.fullprocname(true))));
{$endif debug_eh}
gcc_except_table_data.concatlist(action_table_data);
if typefilterlist.count>0 then
begin
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('Type filter list for '+procdef.fullprocname(true))));
{$endif debug_eh}
for i:=typefilterlist.count-1 downto 0 do
begin
{$ifdef debug_eh}
gcc_except_table_data.concat(tai_comment.Create(strpnew('Type filter '+tostr(i))));
{$endif debug_eh}
if assigned(typefilterlist[i]) then
gcc_except_table_data.concat(tai_const.Create_sym(current_asmdata.RefAsmSymbol(tobjectdef(typefilterlist[i]).vmt_mangledname, AT_DATA)))
else
gcc_except_table_data.concat(tai_const.Create_32bit(0));
end;
{ the types are resolved by the negative offset, so the label must be written after all types }
gcc_except_table_data.concat(tai_label.create(typefilterlistlabelref));
end;
new_section(gcc_except_table_data,sec_code,'',0);
aktproccode.concatlist(gcc_except_table_data);
end;
end;
end;