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

+ SEH support for Win32. Enable by cycling with OPT=-dTEST_WIN32_SEH.

Browse Source 
Although basic things work (no regressions in test suite, also with TEST_OPT=-O2), there are some secondary issues/TODOs:
- Exception frame around PASCALMAIN is not properly removed in DLLs
- No stack traces yet
- Stack overallocated in finalizer procedures, their entry/exit code needs cleanup
- Signals unit is probably completely broken.

git-svn-id: trunk@26225 -
This commit is contained in:
sergei 2013-12-12 12:43:46 +00:00
parent b2e85d2c56
commit 179586f589
11 changed files with 1114 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -204,6 +204,7 @@ compiler/i386/i386prop.inc svneol=native#text/plain
compiler/i386/i386tab.inc svneol=native#text/plain
compiler/i386/n386add.pas svneol=native#text/plain
compiler/i386/n386cal.pas svneol=native#text/plain
compiler/i386/n386flw.pas svneol=native#text/plain
compiler/i386/n386inl.pas svneol=native#text/plain
compiler/i386/n386mat.pas svneol=native#text/plain
compiler/i386/n386mem.pas svneol=native#text/plain
@ -9112,6 +9113,7 @@ rtl/win32/gprt0.as svneol=native#text/plain
rtl/win32/initc.pp svneol=native#text/plain
rtl/win32/objinc.inc svneol=native#text/plain
rtl/win32/rtldefs.inc svneol=native#text/plain
rtl/win32/seh32.inc svneol=native#text/plain
rtl/win32/signals.pp svneol=native#text/plain
rtl/win32/sysinit.inc svneol=native#text/plain
rtl/win32/sysinitcyg.pp svneol=native#text/plain

13
compiler/i386/cgcpu.pas
View File

@ -294,13 +294,13 @@ unit cgcpu;
procedure tcg386.g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean);
procedure increase_fp(a : tcgint);
procedure increase_sp(a : tcgint);
var
href : treference;
begin
reference_reset_base(href,current_procinfo.framepointer,a,0);
reference_reset_base(href,NR_STACK_POINTER_REG,a,0);
{ normally, lea is a better choice than an add }
list.concat(Taicpu.op_ref_reg(A_LEA,TCGSize2OpSize[OS_ADDR],href,current_procinfo.framepointer));
list.concat(Taicpu.op_ref_reg(A_LEA,TCGSize2OpSize[OS_ADDR],href,NR_STACK_POINTER_REG));
end;
var
@ -314,7 +314,8 @@ unit cgcpu;
{ remove stackframe }
if not nostackframe then
begin
if current_procinfo.framepointer=NR_STACK_POINTER_REG then
if (current_procinfo.framepointer=NR_STACK_POINTER_REG) or
(current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
begin
stacksize:=current_procinfo.calc_stackframe_size;
if (target_info.stackalign>4) and
@ -325,9 +326,11 @@ unit cgcpu;
(po_assembler in current_procinfo.procdef.procoptions)) then
stacksize := align(stacksize+sizeof(aint),target_info.stackalign) - sizeof(aint);
if stacksize<>0 then
increase_fp(stacksize);
increase_sp(stacksize);
if (not paramanager.use_fixed_stack) then
internal_restore_regs(list,true);
if (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
list.concat(Taicpu.op_reg(A_POP,tcgsize2opsize[OS_ADDR],NR_FRAME_POINTER_REG));
end
else
begin

3
compiler/i386/cpunode.pas
View File

@ -54,6 +54,9 @@ unit cpunode;
n386mem,
n386set,
n386inl,
{$ifdef TEST_WIN32_SEH}
n386flw,
{$endif TEST_WIN32_SEH}
n386mat
;

680
compiler/i386/n386flw.pas Normal file
View File

@ -0,0 +1,680 @@
{
Copyright (c) 2011 by Free Pascal development team
Generate Win32-specific exception handling code
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 n386flw;
{$i fpcdefs.inc}
interface
uses
node,nflw,ncgflw,psub;
type
ti386raisenode=class(tcgraisenode)
function pass_1 : tnode;override;
end;
ti386onnode=class(tcgonnode)
procedure pass_generate_code;override;
end;
ti386tryexceptnode=class(tcgtryexceptnode)
procedure pass_generate_code;override;
end;
ti386tryfinallynode=class(tcgtryfinallynode)
finalizepi: tcgprocinfo;
constructor create(l,r:TNode);override;
constructor create_implicit(l,r,_t1:TNode);override;
function pass_1: tnode;override;
function simplify(forinline: boolean): tnode;override;
procedure pass_generate_code;override;
end;
implementation
uses
cutils,globtype,globals,verbose,systems,
nbas,ncal,nmem,nutils,
symconst,symbase,symtable,symsym,symdef,
cgbase,cgobj,cgcpu,cgutils,tgobj,
cpubase,htypechk,
parabase,paramgr,pdecsub,pass_1,pass_2,ncgutil,cga,
aasmbase,aasmtai,aasmdata,aasmcpu,procinfo,cpupi;
var
endexceptlabel: tasmlabel;
{ ti386raisenode }
function ti386raisenode.pass_1 : tnode;
var
statements : tstatementnode;
raisenode : tcallnode;
begin
{ difference from generic code is that address stack is not popped on reraise }
if (target_info.system<>system_i386_win32) or assigned(left) then
result:=inherited pass_1
else
begin
result:=internalstatements(statements);
raisenode:=ccallnode.createintern('fpc_reraise',nil);
include(raisenode.callnodeflags,cnf_call_never_returns);
addstatement(statements,raisenode);
end;
end;
{ ti386onnode }
procedure ti386onnode.pass_generate_code;
var
oldflowcontrol : tflowcontrol;
exceptvarsym : tlocalvarsym;
begin
if (target_info.system<>system_i386_win32) then
begin
inherited pass_generate_code;
exit;
end;
location_reset(location,LOC_VOID,OS_NO);
oldflowcontrol:=flowcontrol;
flowcontrol:=flowcontrol*[fc_unwind]+[fc_inflowcontrol];
{ RTL will put exceptobject into EAX when jumping here }
cg.a_reg_alloc(current_asmdata.CurrAsmList,NR_FUNCTION_RESULT_REG);
{ Retrieve exception variable }
if assigned(excepTSymtable) then
exceptvarsym:=tlocalvarsym(excepTSymtable.SymList[0])
else
exceptvarsym:=nil;
if assigned(exceptvarsym) then
begin
exceptvarsym.localloc.loc:=LOC_REFERENCE;
exceptvarsym.localloc.size:=OS_ADDR;
tg.GetLocal(current_asmdata.CurrAsmList,sizeof(pint),voidpointertype,exceptvarsym.localloc.reference);
cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,NR_FUNCTION_RESULT_REG,exceptvarsym.localloc.reference);
end;
cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_FUNCTION_RESULT_REG);
if assigned(right) then
secondpass(right);
{ deallocate exception symbol }
if assigned(exceptvarsym) then
begin
tg.UngetLocal(current_asmdata.CurrAsmList,exceptvarsym.localloc.reference);
exceptvarsym.localloc.loc:=LOC_INVALID;
end;
cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
cg.a_jmp_always(current_asmdata.CurrAsmList,endexceptlabel);
flowcontrol:=oldflowcontrol+(flowcontrol-[fc_inflowcontrol]);
end;
{ ti386tryfinallynode }
function reset_regvars(var n: tnode; arg: pointer): foreachnoderesult;
begin
case n.nodetype of
temprefn:
make_not_regable(n,[]);
calln:
include(tprocinfo(arg).flags,pi_do_call);
end;
result:=fen_true;
end;
function copy_parasize(var n: tnode; arg: pointer): foreachnoderesult;
begin
case n.nodetype of
calln:
tcgprocinfo(arg).allocate_push_parasize(tcallnode(n).pushed_parasize);
end;
result:=fen_true;
end;
constructor ti386tryfinallynode.create(l, r: TNode);
begin
inherited create(l,r);
if (target_info.system<>system_i386_win32) or (
{ Don't create child procedures for generic methods, their nested-like
behavior causes compilation errors because real nested procedures
aren't allowed for generics. Not creating them doesn't harm because
generic node tree is discarded without generating code. }
assigned(current_procinfo.procdef.struct) and
(df_generic in current_procinfo.procdef.struct.defoptions)
) then
exit;
finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
finalizepi.force_nested;
finalizepi.procdef:=create_finalizer_procdef;
finalizepi.entrypos:=r.fileinfo;
finalizepi.entryswitches:=r.localswitches;
finalizepi.exitpos:=current_filepos; // last_endtoken_pos?
finalizepi.exitswitches:=current_settings.localswitches;
{ Regvar optimization for symbols is suppressed when using exceptions, but
temps may be still placed into registers. This must be fixed. }
foreachnodestatic(r,@reset_regvars,finalizepi);
end;
constructor ti386tryfinallynode.create_implicit(l, r, _t1: TNode);
begin
inherited create_implicit(l, r, _t1);
if (target_info.system<>system_i386_win32) then
exit;
{ safecall procedures can handle implicit finalization as part of "except" flow }
if implicitframe and (current_procinfo.procdef.proccalloption=pocall_safecall) then
exit;
if assigned(current_procinfo.procdef.struct) and
(df_generic in current_procinfo.procdef.struct.defoptions) then
InternalError(2013012501);
finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
finalizepi.force_nested;
finalizepi.procdef:=create_finalizer_procdef;
finalizepi.entrypos:=current_filepos;
finalizepi.exitpos:=current_filepos; // last_endtoken_pos?
finalizepi.entryswitches:=r.localswitches;
finalizepi.exitswitches:=current_settings.localswitches;
include(finalizepi.flags,pi_has_assembler_block);
include(finalizepi.flags,pi_do_call);
end;
function ti386tryfinallynode.pass_1: tnode;
var
selfsym: tparavarsym;
begin
result:=inherited pass_1;
if (target_info.system=system_i386_win32) then
begin
{ safecall method will access 'self' from except block -> make it non-regable }
if implicitframe and (current_procinfo.procdef.proccalloption=pocall_safecall) and
is_class(current_procinfo.procdef.struct) then
begin
selfsym:=tparavarsym(current_procinfo.procdef.parast.Find('self'));
if (selfsym=nil) or (selfsym.typ<>paravarsym) then
InternalError(2011123101);
selfsym.varregable:=vr_none;
end;
end;
end;
function ti386tryfinallynode.simplify(forinline: boolean): tnode;
begin
result:=inherited simplify(forinline);
if (target_info.system<>system_i386_win32) then
exit;
if (result=nil) and assigned(finalizepi) then
begin
finalizepi.code:=right;
foreachnodestatic(right,@copy_parasize,finalizepi);
right:=ccallnode.create(nil,tprocsym(finalizepi.procdef.procsym),nil,nil,[]);
firstpass(right);
{ For implicit frames, no actual code is available at this time,
it is added later in assembler form. So store the nested procinfo
for later use. }
if implicitframe then
begin
current_procinfo.finalize_procinfo:=finalizepi;
{ don't leave dangling pointer }
tcgprocinfo(current_procinfo).final_asmnode:=nil;
end;
end;
end;
procedure emit_scope_start(handler,data: TAsmSymbol);
var
href: treference;
hreg: tregister;
begin
hreg:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
reference_reset_base(href,hreg,0,sizeof(pint));
href.segment:=NR_FS;
emit_reg_reg(A_XOR,S_L,hreg,hreg);
emit_sym(A_PUSH,S_L,data);
emit_reg(A_PUSH,S_L,NR_FRAME_POINTER_REG);
emit_sym(A_PUSH,S_L,handler);
emit_ref(A_PUSH,S_L,href);
emit_reg_ref(A_MOV,S_L,NR_ESP,href);
end;
procedure emit_scope_end;
var
href: treference;
hreg,hreg2: tregister;
begin
hreg:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
hreg2:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
reference_reset_base(href,hreg,0,sizeof(pint));
href.segment:=NR_FS;
emit_reg_reg(A_XOR,S_L,hreg,hreg);
emit_reg(A_POP,S_L,hreg2);
emit_const_reg(A_ADD,S_L,3*sizeof(pint),NR_ESP);
emit_reg_ref(A_MOV,S_L,hreg2,href);
end;
procedure ti386tryfinallynode.pass_generate_code;
var
finallylabel,
exceptlabel,
safecalllabel,
endfinallylabel,
exitfinallylabel,
continuefinallylabel,
breakfinallylabel,
oldCurrExitLabel,
oldContinueLabel,
oldBreakLabel : tasmlabel;
oldflowcontrol,tryflowcontrol : tflowcontrol;
is_safecall: boolean;
hreg: tregister;
begin
if (target_info.system<>system_i386_win32) then
begin
inherited pass_generate_code;
exit;
end;
location_reset(location,LOC_VOID,OS_NO);
tryflowcontrol:=[];
oldBreakLabel:=nil;
oldContinueLabel:=nil;
continuefinallylabel:=nil;
breakfinallylabel:=nil;
exceptlabel:=nil;
safecalllabel:=nil;
is_safecall:=implicitframe and (current_procinfo.procdef.proccalloption=pocall_safecall);
{ check if child nodes do a break/continue/exit }
oldflowcontrol:=flowcontrol;
flowcontrol:=[fc_inflowcontrol];
current_asmdata.getjumplabel(finallylabel);
current_asmdata.getjumplabel(endfinallylabel);
{ the finally block must catch break, continue and exit }
{ statements }
oldCurrExitLabel:=current_procinfo.CurrExitLabel;
if implicitframe then
exitfinallylabel:=finallylabel
else
current_asmdata.getjumplabel(exitfinallylabel);
current_procinfo.CurrExitLabel:=exitfinallylabel;
if assigned(current_procinfo.CurrBreakLabel) then
begin
oldContinueLabel:=current_procinfo.CurrContinueLabel;
oldBreakLabel:=current_procinfo.CurrBreakLabel;
if implicitframe then
begin
breakfinallylabel:=finallylabel;
continuefinallylabel:=finallylabel;
end
else
begin
current_asmdata.getjumplabel(breakfinallylabel);
current_asmdata.getjumplabel(continuefinallylabel);
end;
current_procinfo.CurrContinueLabel:=continuefinallylabel;
current_procinfo.CurrBreakLabel:=breakfinallylabel;
end;
{ Start of scope }
if is_safecall then
begin
with cg.rg[R_INTREGISTER] do
used_in_proc:=used_in_proc+[RS_EBX,RS_ESI,RS_EDI];
current_asmdata.getjumplabel(exceptlabel);
emit_scope_start(
current_asmdata.RefAsmSymbol('__FPC_except_safecall'),
exceptlabel
);
end
else
emit_scope_start(
current_asmdata.RefAsmSymbol('__FPC_finally_handler'),
current_asmdata.RefAsmSymbol(finalizepi.procdef.mangledname)
);
{ try code }
if assigned(left) then
begin
secondpass(left);
tryflowcontrol:=flowcontrol;
if codegenerror then
exit;
end;
{ don't generate line info for internal cleanup }
current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoStart));
cg.a_label(current_asmdata.CurrAsmList,finallylabel);
emit_scope_end;
if is_safecall then
begin
current_asmdata.getjumplabel(safecalllabel);
hreg:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,0,hreg);
cg.a_jmp_always(current_asmdata.CurrAsmList,safecalllabel);
{ RTL handler will jump here on exception }
cg.a_label(current_asmdata.CurrAsmList,exceptlabel);
handle_safecall_exception;
cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,NR_FUNCTION_RESULT_REG,hreg);
cg.a_label(current_asmdata.CurrAsmList,safecalllabel);
end;
{ end cleanup }
current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoEnd));
{ generate finally code as a separate procedure }
{ !!! this resets flowcontrol, how to check flow away? }
if not implicitframe then
tcgprocinfo(current_procinfo).generate_exceptfilter(finalizepi);
flowcontrol:=[fc_inflowcontrol];
{ right is a call to finalizer procedure }
secondpass(right);
{ goto is allowed if it stays inside the finally block,
this is checked using the exception block number }
if (flowcontrol-[fc_gotolabel])<>[fc_inflowcontrol] then
CGMessage(cg_e_control_flow_outside_finally);
if codegenerror then
exit;
{ don't generate line info for internal cleanup }
current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoStart));
if not implicitframe then
begin
if tryflowcontrol*[fc_exit,fc_break,fc_continue]<>[] then
cg.a_jmp_always(current_asmdata.CurrAsmList,endfinallylabel);
{ do some magic for exit,break,continue in the try block }
if fc_exit in tryflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,exitfinallylabel);
cg.g_call(current_asmdata.CurrAsmList,'_FPC_leave');
cg.a_jmp_always(current_asmdata.CurrAsmList,oldCurrExitLabel);
end;
if fc_break in tryflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,breakfinallylabel);
cg.g_call(current_asmdata.CurrAsmList,'_FPC_leave');
cg.a_jmp_always(current_asmdata.CurrAsmList,oldBreakLabel);
end;
if fc_continue in tryflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,continuefinallylabel);
cg.g_call(current_asmdata.CurrAsmList,'_FPC_leave');
cg.a_jmp_always(current_asmdata.CurrAsmList,oldContinueLabel);
end;
end;
if is_safecall then
cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_INT,OS_INT,hreg,NR_FUNCTION_RETURN_REG);
cg.a_label(current_asmdata.CurrAsmList,endfinallylabel);
{ end cleanup }
current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoEnd));
current_procinfo.CurrExitLabel:=oldCurrExitLabel;
if assigned(current_procinfo.CurrBreakLabel) then
begin
current_procinfo.CurrContinueLabel:=oldContinueLabel;
current_procinfo.CurrBreakLabel:=oldBreakLabel;
end;
flowcontrol:=oldflowcontrol+(tryflowcontrol-[fc_inflowcontrol]);
end;
{ ti386tryexceptnode }
procedure ti386tryexceptnode.pass_generate_code;
var
exceptlabel,oldendexceptlabel,
lastonlabel,
exitexceptlabel,
continueexceptlabel,
breakexceptlabel,
exittrylabel,
continuetrylabel,
breaktrylabel,
oldCurrExitLabel,
oldContinueLabel,
oldBreakLabel : tasmlabel;
onlabel,
filterlabel: tasmlabel;
oldflowcontrol,tryflowcontrol,
exceptflowcontrol : tflowcontrol;
hnode : tnode;
hlist : tasmlist;
onnodecount : tai_const;
label
errorexit;
begin
if (target_info.system<>system_i386_win32) then
begin
inherited pass_generate_code;
exit;
end;
location_reset(location,LOC_VOID,OS_NO);
oldflowcontrol:=flowcontrol;
flowcontrol:=[fc_inflowcontrol];
{ this can be called recursivly }
oldBreakLabel:=nil;
oldContinueLabel:=nil;
oldendexceptlabel:=endexceptlabel;
{ Win32 SEH unwinding does not preserve registers. Indicate that they are
going to be destroyed. }
cg.alloccpuregisters(current_asmdata.CurrAsmList,R_INTREGISTER,[RS_EAX,RS_EBX,RS_ECX,RS_EDX,RS_ESI,RS_EDI]);
cg.dealloccpuregisters(current_asmdata.CurrAsmList,R_INTREGISTER,[RS_EAX,RS_EBX,RS_ECX,RS_EDX,RS_ESI,RS_EDI]);
{ save the old labels for control flow statements }
oldCurrExitLabel:=current_procinfo.CurrExitLabel;
if assigned(current_procinfo.CurrBreakLabel) then
begin
oldContinueLabel:=current_procinfo.CurrContinueLabel;
oldBreakLabel:=current_procinfo.CurrBreakLabel;
end;
{ get new labels for the control flow statements }
current_asmdata.getjumplabel(exittrylabel);
current_asmdata.getjumplabel(exitexceptlabel);
if assigned(current_procinfo.CurrBreakLabel) then
begin
current_asmdata.getjumplabel(breaktrylabel);
current_asmdata.getjumplabel(continuetrylabel);
current_asmdata.getjumplabel(breakexceptlabel);
current_asmdata.getjumplabel(continueexceptlabel);
end;
current_asmdata.getjumplabel(exceptlabel);
current_asmdata.getjumplabel(endexceptlabel);
current_asmdata.getjumplabel(lastonlabel);
filterlabel:=nil;
{ start of scope }
if assigned(right) then
begin
current_asmdata.getdatalabel(filterlabel);
emit_scope_start(
current_asmdata.RefAsmSymbol('__FPC_on_handler'),
filterlabel);
end
else
emit_scope_start(
current_asmdata.RefAsmSymbol('__FPC_except_handler'),
exceptlabel);
{ set control flow labels for the try block }
current_procinfo.CurrExitLabel:=exittrylabel;
if assigned(oldBreakLabel) then
begin
current_procinfo.CurrContinueLabel:=continuetrylabel;
current_procinfo.CurrBreakLabel:=breaktrylabel;
end;
secondpass(left);
tryflowcontrol:=flowcontrol;
if codegenerror then
goto errorexit;
emit_scope_end;
{ jump over except handlers }
cg.a_jmp_always(current_asmdata.CurrAsmList,endexceptlabel);
if fc_exit in tryflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,exittrylabel);
emit_scope_end;
cg.a_jmp_always(current_asmdata.CurrAsmList,oldCurrExitLabel);
end;
if fc_break in tryflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,breaktrylabel);
emit_scope_end;
cg.a_jmp_always(current_asmdata.CurrAsmList,oldBreakLabel);
end;
if fc_continue in tryflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,continuetrylabel);
emit_scope_end;
cg.a_jmp_always(current_asmdata.CurrAsmList,oldContinueLabel);
end;
{ target for catch-all handler }
cg.a_label(current_asmdata.CurrAsmList,exceptlabel);
{ set control flow labels for the except block }
{ and the on statements }
current_procinfo.CurrExitLabel:=exitexceptlabel;
if assigned(oldBreakLabel) then
begin
current_procinfo.CurrContinueLabel:=continueexceptlabel;
current_procinfo.CurrBreakLabel:=breakexceptlabel;
end;
flowcontrol:=[fc_inflowcontrol];
{ on statements }
if assigned(right) then
begin
{ emit filter table to a temporary asmlist }
hlist:=TAsmList.Create;
new_section(hlist,sec_rodata,filterlabel.name,4);
cg.a_label(hlist,filterlabel);
onnodecount:=tai_const.create_32bit(0);
hlist.concat(onnodecount);
hnode:=right;
while assigned(hnode) do
begin
if hnode.nodetype<>onn then
InternalError(2011103101);
{ TODO: make it done without using global label }
current_asmdata.getglobaljumplabel(onlabel);
hlist.concat(tai_const.create_sym(current_asmdata.RefAsmSymbol(tonnode(hnode).excepttype.vmt_mangledname,AT_DATA)));
hlist.concat(tai_const.create_sym(onlabel));
cg.a_label(current_asmdata.CurrAsmList,onlabel);
secondpass(hnode);
inc(onnodecount.value);
hnode:=tonnode(hnode).left;
end;
{ add 'else' node to the filter list, too }
if assigned(t1) then
begin
hlist.concat(tai_const.create_32bit(-1));
hlist.concat(tai_const.create_sym(lastonlabel));
inc(onnodecount.value);
end;
{ now move filter table to permanent list all at once }
maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
current_asmdata.asmlists[al_typedconsts].concatlist(hlist);
hlist.free;
end;
cg.a_label(current_asmdata.CurrAsmList,lastonlabel);
if assigned(t1) then
begin
{ here we don't have to reset flowcontrol }
{ the default and on flowcontrols are handled equal }
secondpass(t1);
cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
if (flowcontrol*[fc_exit,fc_break,fc_continue]<>[]) then
cg.a_jmp_always(current_asmdata.CurrAsmList,endexceptlabel);
end;
exceptflowcontrol:=flowcontrol;
if fc_exit in exceptflowcontrol then
begin
{ do some magic for exit in the try block }
cg.a_label(current_asmdata.CurrAsmList,exitexceptlabel);
cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
cg.a_jmp_always(current_asmdata.CurrAsmList,oldCurrExitLabel);
end;
if fc_break in exceptflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,breakexceptlabel);
cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
cg.a_jmp_always(current_asmdata.CurrAsmList,oldBreakLabel);
end;
if fc_continue in exceptflowcontrol then
begin
cg.a_label(current_asmdata.CurrAsmList,continueexceptlabel);
cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
cg.a_jmp_always(current_asmdata.CurrAsmList,oldContinueLabel);
end;
cg.a_label(current_asmdata.CurrAsmList,endexceptlabel);
errorexit:
{ restore all saved labels }
endexceptlabel:=oldendexceptlabel;
{ restore the control flow labels }
current_procinfo.CurrExitLabel:=oldCurrExitLabel;
if assigned(oldBreakLabel) then
begin
current_procinfo.CurrContinueLabel:=oldContinueLabel;
current_procinfo.CurrBreakLabel:=oldBreakLabel;
end;
{ return all used control flow statements }
flowcontrol:=oldflowcontrol+(exceptflowcontrol +
tryflowcontrol - [fc_inflowcontrol]);
end;
initialization
craisenode:=ti386raisenode;
connode:=ti386onnode;
ctryexceptnode:=ti386tryexceptnode;
ctryfinallynode:=ti386tryfinallynode;
end.

5
compiler/options.pas
View File

@ -3449,6 +3449,11 @@ if (target_info.abi = abi_eabihf) then
def_system_macro('FPC_USE_WIN64_SEH');
{$endif DISABLE_WIN64_SEH}
{$ifdef TEST_WIN32_SEH}
if target_info.system=system_i386_win32 then
def_system_macro('FPC_USE_WIN32_SEH');
{$endif TEST_WIN32_SEH}
{$ifdef ARM}
{ define FPC_DOUBLE_HILO_SWAPPED if needed to properly handle doubles in RTL }
if (init_settings.fputype in [fpu_fpa,fpu_fpa10,fpu_fpa11]) and

17
compiler/x86/cgx86.pas
View File

@ -2569,7 +2569,6 @@ unit cgx86;
procedure tcgx86.g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean);
var
stackmisalignment: longint;
para: tparavarsym;
regsize: longint;
{$ifdef i8086}
dgroup: treference;
@ -2651,7 +2650,18 @@ unit cgx86;
{ Return address and FP are both on stack }
current_asmdata.asmcfi.cfa_def_cfa_offset(list,2*sizeof(pint));
current_asmdata.asmcfi.cfa_offset(list,NR_FRAME_POINTER_REG,-(2*sizeof(pint)));
list.concat(Taicpu.op_reg_reg(A_MOV,tcgsize2opsize[OS_ADDR],NR_STACK_POINTER_REG,NR_FRAME_POINTER_REG));
if current_procinfo.procdef.proctypeoption<>potype_exceptfilter then
list.concat(Taicpu.op_reg_reg(A_MOV,tcgsize2opsize[OS_ADDR],NR_STACK_POINTER_REG,NR_FRAME_POINTER_REG))
else
begin
push_regs;
gen_load_frame_for_exceptfilter(list);
{ Need only as much stack space as necessary to do the calls.
Exception filters don't have own local vars, and temps are 'mapped'
to the parent procedure.
maxpushedparasize is already aligned at least on x86_64. }
//localsize:=current_procinfo.maxpushedparasize;
end;
current_asmdata.asmcfi.cfa_def_cfa_register(list,NR_FRAME_POINTER_REG);
end;
@ -2672,7 +2682,8 @@ unit cgx86;
{$ifdef i386}
if (not paramanager.use_fixed_stack) and
(current_procinfo.framepointer<>NR_STACK_POINTER_REG) then
(current_procinfo.framepointer<>NR_STACK_POINTER_REG) and
(current_procinfo.procdef.proctypeoption<>potype_exceptfilter) then
begin
regsize:=0;
push_regs;

4
rtl/inc/except.inc
View File

@ -397,10 +397,12 @@ begin
end;
{$ifndef FPC_SYSTEM_HAS_DONEEXCEPTION}
procedure fpc_doneexception;[public,alias:'FPC_DONEEXCEPTION'] compilerproc;
begin
Internal_PopObjectStack.Free;
end;
{$endif FPC_SYSTEM_HAS_DONEEXCEPTION}
procedure fpc_raise_nested;[public,alias:'FPC_RAISE_NESTED']compilerproc;
begin
@ -408,6 +410,7 @@ begin
Internal_Reraise;
end;
{$ifndef FPC_SYSTEM_HAS_SAFECALLHANDLER}
function fpc_safecallhandler(obj: TObject): HResult; [public,alias:'FPC_SAFECALLHANDLER']; compilerproc;
var
raiselist: PExceptObject;
@ -426,4 +429,5 @@ begin
result:=E_UNEXPECTED;
exc.Free;
end;
{$endif FPC_SYSTEM_HAS_SAFECALLHANDLER}

4
rtl/inc/objpash.inc
View File

@ -333,6 +333,10 @@
refcount : Longint;
Framecount : Longint;
Frames : PCodePointer;
{$ifdef FPC_USE_WIN32_SEH}
SEHFrame : Pointer;
ReraiseBuf : jmp_buf;
{$endif FPC_USE_WIN32_SEH}
end;
Const

4
rtl/win/systhrd.inc
View File

@ -225,12 +225,12 @@ var
{$ifdef DEBUG_MT}
writeln('Jumping to thread function of thread ',Win32GetCurrentThreadId);
{$endif DEBUG_MT}
{$ifdef FPC_USE_WIN64_SEH}
{$if defined(FPC_USE_WIN64_SEH) or defined(FPC_USE_WIN32_SEH)}
{ use special 'top-level' exception handler around the thread function }
ThreadMain:=main_wrapper(ti.p,pointer(ti.f));
{$else FPC_USE_WIN64_SEH}
ThreadMain:=ti.f(ti.p);
{$endif FPC_USE_WIN64_SEH}
{$endif FPC_USE_WIN64_SEH or FPC_USE_WIN32_SEH}
end;

365
rtl/win32/seh32.inc Normal file
View File

@ -0,0 +1,365 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2013 by Free Pascal development team
Support for 32-bit Windows exception handling
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.
**********************************************************************}
const
EXCEPTION_UNWIND = EXCEPTION_UNWINDING or EXCEPTION_EXIT_UNWIND;
type
TDispatcherContext=record
end;
PSEHFrame=^TSEHFrame;
TSEHFrame=record
Next: PSEHFrame;
Addr: Pointer;
_EBP: PtrUint;
HandlerArg: Pointer;
end;
procedure RtlUnwind(
TargetFrame: Pointer;
TargetIp: Pointer;
ExceptionRecord: PExceptionRecord;
ReturnValue: Pointer);
stdcall; external 'kernel32.dll' name 'RtlUnwind';
{$ifdef FPC_USE_WIN32_SEH}
function NullHandler(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl;
begin
result:=ExceptionContinueSearch;
end;
function GetBacktrace(Context: TContext; StartingFrame: Pointer; out Frames: PPointer): Longint;
begin
// TODO
Frames:=nil;
result:=0;
end;
function fpc_RaiseException(Obj: TObject; AnAddr,AFrame: Pointer): TObject; [public,alias: 'FPC_RAISEEXCEPTION']; compilerproc;
var
ctx: TContext;
args: array[0..3] of PtrUint;
begin
//RtlCaptureContext(ctx);
args[0]:=PtrUint(AnAddr);
args[1]:=PtrUint(Obj);
args[2]:=GetBacktrace(ctx,AFrame,PPointer(args[3]));
RaiseException(FPC_EXCEPTION_CODE,EXCEPTION_NONCONTINUABLE,4,@args[0]);
result:=nil;
end;
procedure fpc_reraise; [public,alias:'FPC_RERAISE']; compilerproc;
var
hp: PExceptObject;
begin
hp:=ExceptObjectStack;
ExceptObjectStack:=hp^.next;
TSEHFrame(hp^.SEHFrame^).Addr:=@NullHandler;
longjmp(hp^.ReraiseBuf,1);
end;
{ Parameters are dummy and used to force "ret 16" at the end;
this removes a TSEHFrame record from the stack }
procedure _fpc_leave(a1,a2,a3,a4:pointer); [public,alias:'_FPC_leave']; stdcall; compilerproc; assembler; nostackframe;
asm
movl 4(%esp),%eax
movl %eax,%fs:(0)
movl %ebp,%eax
call 16(%esp)
end;
function PopObjectStack: PExceptObject;
var
hp: PExceptObject;
begin
hp:=ExceptObjectStack;
if hp=nil then
halt(255)
else
begin
ExceptObjectStack:=hp^.next;
if assigned(hp^.frames) then
freemem(hp^.frames);
end;
result:=hp;
end;
function __FPC_finally_handler(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl; [public,alias:'__FPC_finally_handler'];
begin
if (rec.ExceptionFlags and EXCEPTION_UNWIND)<>0 then
begin
{ prevent endless loop if things go bad in user routine }
frame.Addr:=@NullHandler;
TUnwindProc(frame.HandlerArg)(frame._EBP);
end;
result:=ExceptionContinueSearch;
end;
function __FPC_default_handler(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl; [public,alias:'__FPC_DEFAULT_HANDLER'];
var
code: longint;
Obj: TObject;
Adr: Pointer;
begin
if (rec.ExceptionFlags and EXCEPTION_UNWIND)=0 then
begin
RtlUnwind(@frame,nil,@rec,nil);
if rec.ExceptionCode<>FPC_EXCEPTION_CODE then
begin
code:=RunErrorCode(rec);
if code<0 then
SysResetFPU;
Adr:=rec.ExceptionAddress;
Obj:=nil;
if Assigned(ExceptObjProc) then
Obj:=TObject(TExceptObjProc(ExceptObjProc)(abs(code),rec));
if Obj=nil then
RunError(abs(code));
end
else
begin
Obj:=TObject(rec.ExceptionInformation[1]);
Adr:=rec.ExceptionInformation[0];
code:=217;
end;
if Assigned(ExceptProc) then
begin
ExceptProc(Obj,Adr,0,nil {TODO: backtrace});
Halt(217);
end
else
RunError(abs(code));
end;
result:=ExceptionContinueExecution;
end;
function NestedHandler(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl;
var
hp: PExceptObject;
begin
if (rec.ExceptionFlags and EXCEPTION_UNWIND)<>0 then
begin
hp:=PopObjectStack;
if hp^.refcount=0 then
hp^.FObject.Free;
end;
result:=ExceptionContinueSearch;
end;
function __FPC_except_safecall(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl; forward;
procedure CommonHandler(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
TargetAddr: Pointer);
var
Exc: TExceptObject;
code: Longint;
begin
if rec.ExceptionCode<>FPC_EXCEPTION_CODE then
begin
Exc.FObject:=nil;
code:=RunErrorCode(rec);
if Assigned(ExceptObjProc) then
Exc.FObject:=TObject(TExceptObjProc(ExceptObjProc)(abs(code),rec));
if (Exc.FObject=nil) and (frame.Addr<>Pointer(@__FPC_except_safecall)) then
Exit;
Exc.Addr:=rec.ExceptionAddress;
Exc.FrameCount:=GetBacktrace(context,nil,Exc.Frames);
if code<0 then
SysResetFPU;
end
else
begin
Exc.Addr:=rec.ExceptionInformation[0];
Exc.FObject:=TObject(rec.ExceptionInformation[1]);
Exc.Framecount:=Longint(PtrUInt(rec.ExceptionInformation[2]));
Exc.Frames:=rec.ExceptionInformation[3];
end;
RtlUnwind(@frame,nil,@rec,nil);
Exc.Refcount:=0;
Exc.SEHFrame:=@frame;
{ link to ExceptObjectStack }
Exc.Next:=ExceptObjectStack;
ExceptObjectStack:=@Exc;
frame.Addr:=@NestedHandler;
if setjmp(Exc.ReraiseBuf)=0 then
asm
movl Exc.FObject,%eax
movl frame,%edx
movl TargetAddr,%ecx // load ebp-based var before changing ebp
movl TSEHFrame._EBP(%edx),%ebp
jmpl *%ecx
end;
{ control comes here if exception is re-raised }
rec.ExceptionFlags:=rec.ExceptionFlags and (not EXCEPTION_UNWINDING);
end;
function __FPC_except_handler(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl; [public,alias:'__FPC_except_handler'];
begin
if (rec.ExceptionFlags and EXCEPTION_UNWIND)=0 then
begin
{ Athlon prefetch bug? }
if (rec.ExceptionCode=STATUS_ACCESS_VIOLATION) and
is_prefetch(pointer(Context.eip)) then
begin
result:=ExceptionContinueExecution;
exit;
end;
CommonHandler(rec,frame,context,frame.HandlerArg);
end;
result:=ExceptionContinueSearch;
end;
{ Safecall procedures are expected to handle OS exceptions even if they cannot be
converted to language exceptions. This is indicated by distinct handler address. }
function __FPC_except_safecall(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl; [public,alias:'__FPC_except_safecall']; assembler; nostackframe;
asm
jmp __FPC_except_handler
end;
function __FPC_on_handler(
var rec: TExceptionRecord;
var frame: TSEHFrame;
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl; [public,alias:'__FPC_on_handler'];
var
TargetAddr: Pointer;
begin
if (rec.ExceptionFlags and EXCEPTION_UNWIND)=0 then
begin
{ Athlon prefetch bug? }
if (rec.ExceptionCode=STATUS_ACCESS_VIOLATION) and
is_prefetch(pointer(Context.eip)) then
begin
result:=ExceptionContinueExecution;
exit;
end;
{ Are we going to catch it? }
TargetAddr:=FilterException(rec,0,PtrUInt(frame.HandlerArg));
if assigned(TargetAddr) then
CommonHandler(rec,frame,context,TargetAddr);
end;
result:=ExceptionContinueSearch;
end;
function fpc_safecallhandler(obj: TObject): HResult; [public,alias:'FPC_SAFECALLHANDLER']; compilerproc;
var
hp: PExceptObject;
exc: TObject;
begin
hp:=PopObjectStack;
exc:=hp^.FObject;
if Assigned(obj) and Assigned(exc) then
result:=obj.SafeCallException(exc,hp^.Addr)
else
result:=E_UNEXPECTED;
if hp^.refcount=0 then
exc.Free;
asm
movl %ebp,%edx // save current frame
movl hp,%ecx
movl TExceptObject.SEHFrame(%ecx),%ecx // target ESP minus sizeof(TSEHFrame)
movl (%ecx),%eax
movl %eax,%fs:(0) // restore SEH chain
movl __RESULT,%eax
movl TSEHFrame._EBP(%ecx),%ebp // restore EBP
leal 16(%ecx),%esp // restore ESP past the SEH frame
jmpl 4(%edx) // jump to caller
end;
end;
procedure fpc_doneexception;[public,alias:'FPC_DONEEXCEPTION'] compilerproc;
var
hp: PExceptObject;
begin
hp:=PopObjectStack;
if hp^.refcount=0 then
hp^.FObject.Free;
erroraddr:=nil;
asm
movl %ebp,%edx // save current frame
movl hp,%eax
movl TExceptObject.SEHFrame(%eax),%eax // target ESP minus sizeof(TSEHFrame)
movl (%eax),%ecx
movl %ecx,%fs:(0) // restore SEH chain
movl TSEHFrame._EBP(%eax),%ebp // restore EBP
leal 16(%eax),%esp // restore ESP, removing SEH frame
jmpl 4(%edx) // jump to caller
end;
end;
function main_wrapper(arg: Pointer; proc: Pointer): ptrint; assembler; nostackframe;
asm
xorl %ecx,%ecx
pushl $__FPC_default_handler
pushl %fs:(%ecx)
movl %esp,%fs:(%ecx)
call *%edx
xorl %ecx,%ecx
popl %edx
movl %edx,%fs:(%ecx)
popl %ecx
end;
{$endif FPC_USE_WIN32_SEH}

32
rtl/win32/system.pp
View File

@ -29,6 +29,13 @@ interface
{$define DISABLE_NO_THREAD_MANAGER}
{$define HAS_WIDESTRINGMANAGER}
{$ifdef FPC_USE_WIN32_SEH}
{$define FPC_SYSTEM_HAS_RAISEEXCEPTION}
{$define FPC_SYSTEM_HAS_RERAISE}
{$define FPC_SYSTEM_HAS_DONEEXCEPTION}
{$define FPC_SYSTEM_HAS_SAFECALLHANDLER}
{$endif FPC_USE_WIN32_SEH}
{ include system-independent routine headers }
{$I systemh.inc}
@ -138,6 +145,11 @@ const
valgrind_used : false;
);
{$ifdef FPC_USE_WIN32_SEH}
function main_wrapper(arg: Pointer; proc: Pointer): ptrint; forward;
procedure OutermostHandler; external name '__FPC_DEFAULT_HANDLER';
{$endif FPC_USE_WIN32_SEH}
{ include system independent routines }
{$I system.inc}
@ -177,8 +189,10 @@ begin
{ what about Input and Output ?? PM }
{ now handled, FPK }
end;
{$ifndef FPC_USE_WIN32_SEH}
if not IsLibrary then
remove_exception_handlers;
{$endif FPC_USE_WIN32_SEH}
{ do cleanup required by the startup code }
EntryInformation.asm_exit();
@ -194,24 +208,30 @@ var
procedure Exe_entry(const info : TEntryInformation);[public,alias:'_FPC_EXE_Entry'];
var
ST : pointer;
xframe: TEXCEPTION_FRAME;
begin
EntryInformation:=info;
IsLibrary:=false;
{ install the handlers for exe only ?
or should we install them for DLL also ? (PM) }
{$ifndef FPC_USE_WIN32_SEH}
install_exception_handlers;
{$endif FPC_USE_WIN32_SEH}
{ This strange construction is needed to solve the _SS problem
with a smartlinked syswin32 (PFV) }
asm
{ allocate space for an exception frame }
pushl $0
pushl %fs:(0)
{ movl %esp,%fs:(0)
but don't insert it as it doesn't
point to anything yet
this will be used in signals unit }
movl %esp,%eax
leal xframe,%eax
{$ifndef FPC_USE_WIN32_SEH}
movl $0,TException_Frame.handler(%eax)
{$else}
movl $OutermostHandler,TException_Frame.handler(%eax)
{$endif FPC_USE_WIN32_SEH}
movl %fs:(0),%ecx
movl %ecx,TException_Frame.next(%eax)
movl %eax,System_exception_frame
pushl %ebp
xorl %eax,%eax
@ -348,6 +368,8 @@ type
{ type of functions that should be used for exception handling }
TTopLevelExceptionFilter = function (excep : PExceptionPointers) : Longint;stdcall;
{$i seh32.inc}
function SetUnhandledExceptionFilter(lpTopLevelExceptionFilter : TTopLevelExceptionFilter) : TTopLevelExceptionFilter;
stdcall;external 'kernel32' name 'SetUnhandledExceptionFilter';