+ Platform-specific exception support for x86_64-win64. Enable by cycling with OPT=-dTEST_WIN64_SEH.

git-svn-id: trunk@20098 -

.gitattributes

@@ -647,6 +647,7 @@ compiler/x86_64/cputarg.pas svneol=native#text/plain
 compiler/x86_64/nx64add.pas svneol=native#text/plain
 compiler/x86_64/nx64cal.pas svneol=native#text/plain
 compiler/x86_64/nx64cnv.pas svneol=native#text/plain
+compiler/x86_64/nx64flw.pas svneol=native#text/plain
 compiler/x86_64/nx64inl.pas svneol=native#text/plain
 compiler/x86_64/nx64mat.pas svneol=native#text/plain
 compiler/x86_64/r8664ari.inc svneol=native#text/plain

compiler/aggas.pas

@@ -1237,7 +1237,7 @@ implementation
 
            ait_seh_directive :
              begin
-{$ifdef TEST_WIN64_UNWIND}
+{$ifdef TEST_WIN64_SEH}
                AsmWrite(sehdirectivestr[tai_seh_directive(hp).kind]);
                case tai_seh_directive(hp).datatype of
                  sd_none:;
@@ -1258,7 +1258,7 @@ implementation
                      tostr(tai_seh_directive(hp).data.offset));
                end;
                AsmLn;
-{$endif TEST_WIN64_UNWIND}
+{$endif TEST_WIN64_SEH}
              end;
 
            else

compiler/assemble.pas

@@ -1294,6 +1294,13 @@ Implementation
                begin
                  ObjOutput.exportsymbol(ObjData.SymbolRef(Tai_symbol(hp).sym));
                end;
+            ait_symbol_end :
+               begin
+                 { recalculate size, as some preceding instructions
+                   could have been changed to smaller size }
+                 objsym:=ObjData.SymbolRef(Tai_symbol_end(hp).sym);
+                 objsym.size:=ObjData.CurrObjSec.Size-objsym.offset;
+               end;
              ait_datablock :
                begin
                  ObjOutput.exportsymbol(ObjData.SymbolRef(Tai_datablock(hp).sym));
@@ -1393,10 +1400,10 @@ Implementation
              ait_cutobject :
                if SmartAsm then
                 break;
-{$ifdef TEST_WIN64_UNWIND}
+{$ifdef TEST_WIN64_SEH}
              ait_seh_directive :
                tai_seh_directive(hp).generate_code(objdata);
-{$endif TEST_WIN64_UNWIND}
+{$endif TEST_WIN64_SEH}
            end;
            hp:=Tai(hp.next);
          end;

compiler/ncal.pas

@@ -162,6 +162,7 @@ interface
           { force the name of the to-be-called routine to a particular string,
             used for Objective-C message sending.  }
           property parameters : tnode read left write left;
+          property pushed_parasize: longint read pushedparasize;
        private
           AbstractMethodsList : TFPHashList;
        end;
@@ -2355,9 +2356,13 @@ implementation
                    begin
                      if not assigned(right) then
                        begin
-                         if not(assigned(procdefinition.owner.defowner)) then
+                         if assigned(procdefinition.owner.defowner) then
+                           para.left:=cloadparentfpnode.create(tprocdef(procdefinition.owner.defowner))
+                         { exceptfilters called from main level are not owned }
+                         else if procdefinition.proctypeoption=potype_exceptfilter then
+                           para.left:=cloadparentfpnode.create(current_procinfo.procdef)
+                         else
                            internalerror(200309287);
-                         para.left:=cloadparentfpnode.create(tprocdef(procdefinition.owner.defowner))
                        end
                      else
                        para.left:=gen_procvar_context_tree;

compiler/ncgutil.pas

@@ -2093,7 +2093,10 @@ implementation
         currpara : tparavarsym;
         paraloc  : pcgparalocation;
       begin
-        if (po_assembler in current_procinfo.procdef.procoptions) then
+        if (po_assembler in current_procinfo.procdef.procoptions) or
+        { exceptfilters have a single hidden 'parentfp' parameter, which
+          is handled by tcg.g_proc_entry. }
+           (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
           exit;
 
         { Allocate registers used by parameters }
@@ -2181,7 +2184,8 @@ implementation
         end;
 
         { initialisizes temp. ansi/wide string data }
-        inittempvariables(list);
+        if (current_procinfo.procdef.proctypeoption<>potype_exceptfilter) then
+          inittempvariables(list);
 
 {$ifdef OLDREGVARS}
         load_regvars(list,nil);
@@ -2190,7 +2194,17 @@ implementation
 
 
     procedure gen_finalize_code(list:TAsmList);
+      var
+        old_current_procinfo: tprocinfo;
       begin
+        old_current_procinfo:=current_procinfo;
+        if (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
+          begin
+            if (current_procinfo.parent.finalize_procinfo<>current_procinfo) then
+              exit;
+            current_procinfo:=current_procinfo.parent;
+          end;
+
 {$ifdef OLDREGVARS}
         cleanup_regvars(list);
 {$endif OLDREGVARS}
@@ -2220,6 +2234,7 @@ implementation
         if assigned(current_procinfo.procdef.parast) and
            not(po_assembler in current_procinfo.procdef.procoptions) then
           current_procinfo.procdef.parast.SymList.ForEachCall(@final_paras,list);
+        current_procinfo:=old_current_procinfo;
       end;
 
 
@@ -2620,6 +2635,13 @@ implementation
                     in the original location }
                   if (po_assembler in current_procinfo.procdef.procoptions) then
                     tparavarsym(vs).paraloc[calleeside].get_location(vs.initialloc)
+                  { exception filters receive their frame pointer as a parameter }
+                  else if (current_procinfo.procdef.proctypeoption=potype_exceptfilter) and
+                    (vo_is_parentfp in vs.varoptions) then
+                    begin
+                      location_reset(vs.initialloc,LOC_REGISTER,OS_ADDR);
+                      vs.initialloc.register:=NR_FRAME_POINTER_REG;
+                    end
                   else
                     begin
                       isaddr:=paramanager.push_addr_param(vs.varspez,vs.vardef,current_procinfo.procdef.proccalloption);

compiler/options.pas

@@ -2892,6 +2892,10 @@ if (target_info.system=system_arm_darwin) then
       def_system_macro('FPC_USE_TLS_DIRECTORY');
 {$endif not DISABLE_TLS_DIRECTORY}
 
+{$ifdef TEST_WIN64_SEH}
+    if target_info.system=system_x86_64_win64 then
+      def_system_macro('FPC_USE_WIN64_SEH');
+{$endif TEST_WIN64_SEH}
 
 {$ifdef ARM}
   { define FPC_DOUBLE_HILO_SWAPPED if needed to properly handle doubles in RTL }

compiler/procinfo.pas

@@ -65,6 +65,9 @@ unit procinfo;
           { procinfo of the main procedure that is inlining
             the current function, only used in tcgcallnode.inlined_pass2 }
           inlining_procinfo : tprocinfo;
+          { nested implicit finalzation procedure, used for platform-specific
+            exception handling }
+          finalize_procinfo : tprocinfo;
           { file location of begin of procedure }
           entrypos  : tfileposinfo;
           { file location of end of procedure }
@@ -148,6 +151,9 @@ unit procinfo;
 
           function get_first_nestedproc: tprocinfo;
           function has_nestedprocs: boolean;
+
+          { Add to parent's list of nested procedures even if parent is a 'main' procedure }
+          procedure force_nested;
        end;
        tcprocinfo = class of tprocinfo;
 
@@ -193,6 +199,11 @@ implementation
           parent.addnestedproc(Self);
       end;
 
+    procedure tprocinfo.force_nested;
+      begin
+        if Assigned(parent) and (parent.procdef.parast.symtablelevel<normal_function_level) then
+          parent.addnestedproc(Self);
+      end;
 
     destructor tprocinfo.destroy;
       begin

compiler/psub.pas

@@ -51,6 +51,7 @@ interface
         procedure printproc(pass:string);
         procedure generate_code;
         procedure generate_code_tree;
+        procedure generate_exceptfilter(nestedpi: tcgprocinfo);
         procedure resetprocdef;
         procedure add_to_symtablestack;
         procedure remove_from_symtablestack;
@@ -819,6 +820,24 @@ implementation
         resetprocdef;
       end;
 
+    procedure tcgprocinfo.generate_exceptfilter(nestedpi: tcgprocinfo);
+      var
+        saved_cg: tcg;
+      begin
+        if nestedpi.procdef.proctypeoption<>potype_exceptfilter then
+          InternalError(201201141);
+        { flush code generated this far }
+        aktproccode.concatlist(current_asmdata.CurrAsmList);
+        { save the codegen }
+        saved_cg:=cg;
+        cg:=nil;
+        nestedpi.generate_code;
+        { prevents generating code the second time when processing nested procedures }
+        nestedpi.resetprocdef;
+        cg:=saved_cg;
+        add_reg_instruction_hook:[email protected]_reg_instruction;
+      end;
+
     procedure tcgprocinfo.generate_code;
       var
         old_current_procinfo : tprocinfo;
@@ -845,8 +864,9 @@ implementation
         if (df_generic in procdef.defoptions) then
           internalerror(200511152);
 
-        { The RA and Tempgen shall not be available yet }
-        if assigned(tg) then
+        { For regular procedures the RA and Tempgen shall not be available yet,
+          but exception filters reuse Tempgen of parent }
+        if assigned(tg)<>(procdef.proctypeoption=potype_exceptfilter) then
           internalerror(200309201);
 
         old_current_procinfo:=current_procinfo;
@@ -958,7 +978,8 @@ implementation
           begin
             create_codegen;
 
-            setup_tempgen;
+            if (procdef.proctypeoption<>potype_exceptfilter) then
+              setup_tempgen;
 
             { Create register allocator, must come after framepointer is known }
             cg.init_register_allocators;
@@ -1018,14 +1039,19 @@ implementation
 
             cg.set_regalloc_live_range_direction(rad_forward);
 
-            gen_finalize_code(templist);
-            { the finalcode must be concated if there was no position available,
-              using insertlistafter will result in an insert at the start
-              when currentai=nil }
-            if assigned(final_asmnode.currenttai) then
-              aktproccode.insertlistafter(final_asmnode.currenttai,templist)
+            if assigned(finalize_procinfo) then
+              generate_exceptfilter(tcgprocinfo(finalize_procinfo))
             else
-              aktproccode.concatlist(templist);
+              begin
+                gen_finalize_code(templist);
+                { the finalcode must be concated if there was no position available,
+                  using insertlistafter will result in an insert at the start
+                  when currentai=nil }
+                if assigned(final_asmnode) and assigned(final_asmnode.currenttai) then
+                  aktproccode.insertlistafter(final_asmnode.currenttai,templist)
+                else
+                  aktproccode.concatlist(templist);
+              end;
             { insert exit label at the correct position }
             cg.a_label(templist,CurrExitLabel);
             if assigned(exitlabel_asmnode.currenttai) then
@@ -1221,13 +1247,15 @@ implementation
               current_asmdata.asmlists[al_procedures].concatlist(aktlocaldata);
 
             { only now we can remove the temps }
-            tg.resettempgen;
-
+            if (procdef.proctypeoption<>potype_exceptfilter) then
+              begin
+                tg.resettempgen;
+                tg.free;
+                tg:=nil;
+              end;
             { stop tempgen and ra }
-            tg.free;
             cg.done_register_allocators;
             destroy_codegen;
-            tg:=nil;
           end;
 
         dfabuilder.free;

compiler/symconst.pas

@@ -247,7 +247,8 @@ type
     potype_class_constructor, { class constructor }
     potype_class_destructor,  { class destructor  }
     potype_propgetter,        { Dispinterface property accessors }
-    potype_propsetter
+    potype_propsetter,
+    potype_exceptfilter       { SEH exception filter or termination handler }
   );
   tproctypeoptions=set of tproctypeoption;
 

compiler/utils/ppudump.pp

@@ -1440,7 +1440,8 @@ const
      (mask:potype_class_destructor;  str:'Class Destructor'),
      { Dispinterface property accessors }
      (mask:potype_propgetter;        str:'Property Getter'),
-     (mask:potype_propsetter;        str:'Property Setter')
+     (mask:potype_propsetter;        str:'Property Setter'),
+     (mask:potype_exceptfilter;      str:'SEH filter')
   );
   procopt : array[1..ord(high(tprocoption))] of tprocopt=(
      (mask:po_classmethod;     str:'ClassMethod'),

compiler/x86/cgx86.pas

@@ -156,7 +156,7 @@ unit cgx86;
        globals,verbose,systems,cutils,
        defutil,paramgr,procinfo,
        tgobj,ncgutil,
-       fmodule;
+       fmodule,symsym;
 
     const
       TOpCG2AsmOp: Array[topcg] of TAsmOp = (A_NONE,A_MOV,A_ADD,A_AND,A_DIV,
@@ -2147,6 +2147,7 @@ unit cgx86;
     procedure tcgx86.g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean);
       var
         stackmisalignment: longint;
+        para: tparavarsym;
       begin
 {$ifdef i386}
         { interrupt support for i386 }
@@ -2191,7 +2192,25 @@ 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
+                    { load framepointer from hidden $parentfp parameter }
+                    para:=tparavarsym(current_procinfo.procdef.paras[0]);
+                    if not (vo_is_parentfp in para.varoptions) then
+                      InternalError(201201142);
+                    if (para.paraloc[calleeside].location^.loc<>LOC_REGISTER) or
+                       (para.paraloc[calleeside].location^.next<>nil) then
+                      InternalError(201201143);
+                    list.concat(Taicpu.op_reg_reg(A_MOV,tcgsize2opsize[OS_ADDR],
+                      para.paraloc[calleeside].location^.register,NR_FRAME_POINTER_REG));
+                    { 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);
                 {
                   TODO: current framepointer handling is not compatible with Win64 at all:

compiler/x86_64/cgcpu.pas

@@ -39,6 +39,7 @@ unit cgcpu;
         procedure g_proc_entry(list : TAsmList; parasize:longint; nostackframe:boolean);override;
         procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean);override;
         procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);override;
+        procedure g_local_unwind(list: TAsmList; l: TAsmLabel);override;
 
         procedure a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize : tcgsize;intreg, mmreg: tregister; shuffle: pmmshuffle); override;
         procedure a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize : tcgsize;mmreg, intreg: tregister;shuffle : pmmshuffle); override;
@@ -50,7 +51,7 @@ unit cgcpu;
 
     uses
        globtype,globals,verbose,systems,cutils,cclasses,
-       symsym,defutil,paramgr,fmodule,
+       symsym,defutil,paramgr,fmodule,cpupi,
        rgobj,tgobj,rgcpu;
 
 
@@ -183,13 +184,20 @@ unit cgcpu;
         if cs_create_pic in current_settings.moduleswitches then
           list.concat(tai_regalloc.dealloc(NR_PIC_OFFSET_REG,nil));
 
+        { Prevent return address from a possible call from ending up in the epilogue }
+        { (restoring registers happens before epilogue, providing necessary padding) }
+        if (current_procinfo.flags*[pi_has_unwind_info,pi_do_call,pi_has_saved_regs])=[pi_has_unwind_info,pi_do_call] then
+          list.concat(Taicpu.op_none(A_NOP));
         { 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
                 if (current_procinfo.final_localsize<>0) then
                   cg.a_op_const_reg(list,OP_ADD,OS_ADDR,current_procinfo.final_localsize,NR_STACK_POINTER_REG);
+                if (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
+                  list.concat(Taicpu.op_reg(A_POP,tcgsize2opsize[OS_ADDR],NR_FRAME_POINTER_REG));
               end
             else if (target_info.system=system_x86_64_win64) then
               begin
@@ -208,7 +216,10 @@ unit cgcpu;
 
         list.concat(Taicpu.Op_none(A_RET,S_NO));
         if (pi_has_unwind_info in current_procinfo.flags) then
-          list.concat(cai_seh_directive.create(ash_endproc));
+          begin
+            tx86_64procinfo(current_procinfo).dump_scopes(list);
+            list.concat(cai_seh_directive.create(ash_endproc));
+          end;
       end;
 
 
@@ -275,6 +286,31 @@ unit cgcpu;
         List.concat(Tai_symbol_end.Createname(labelname));
       end;
 
+    procedure tcgx86_64.g_local_unwind(list: TAsmList; l: TAsmLabel);
+      var
+        para1,para2: tcgpara;
+        href:treference;
+      begin
+        if (target_info.system<>system_x86_64_win64) then
+          begin
+            inherited g_local_unwind(list,l);
+            exit;
+          end;
+        para1.init;
+        para2.init;
+        paramanager.getintparaloc(pocall_default,1,para1);
+        paramanager.getintparaloc(pocall_default,2,para2);
+        reference_reset_symbol(href,l,0,1);
+        { TODO: using RSP is correct only while the stack is fixed!!
+          (true now, but will change if/when allocating from stack is implemented) }
+        a_load_reg_cgpara(list,OS_ADDR,NR_STACK_POINTER_REG,para1);
+        a_loadaddr_ref_cgpara(list,href,para2);
+        paramanager.freecgpara(list,para2);
+        paramanager.freecgpara(list,para1);
+        g_call(current_asmdata.CurrAsmList,'_FPC_local_unwind');
+        para2.done;
+        para1.done;
+      end;
 
     procedure tcgx86_64.a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize : tcgsize; intreg, mmreg: tregister; shuffle: pmmshuffle);
       var

compiler/x86_64/cpunode.pas

@@ -54,6 +54,9 @@ unit cpunode;
        nx64cal,
        nx64cnv,
        nx64mat,
+{$ifdef TEST_WIN64_SEH}
+       nx64flw,
+{$endif TEST_WIN64_SEH}
        nx64inl
        ;
 

compiler/x86_64/cpupi.pas

@@ -28,13 +28,22 @@ unit cpupi;
 interface
 
     uses
-       psub,procinfo;
+       psub,procinfo,aasmbase,aasmdata;
 
     type
        tx86_64procinfo = class(tcgprocinfo)
+       private
+         scopes: TAsmList;
+         scopecount: longint;
+         unwindflags: byte;
+       public
          procedure set_first_temp_offset;override;
          procedure generate_parameter_info;override;
          function calc_stackframe_size:longint;override;
+         procedure add_finally_scope(startlabel,endlabel,handler:TAsmSymbol;implicit:Boolean);
+         procedure add_except_scope(trylabel,exceptlabel,endlabel,filter:TAsmSymbol);
+         procedure dump_scopes(list:TAsmList);
+         destructor destroy;override;
        end;
 
 
@@ -46,8 +55,13 @@ implementation
       globals,
       cutils,
       symconst,
+      aasmtai,
       tgobj;
 
+    const
+      SCOPE_FINALLY=0;
+      SCOPE_CATCHALL=1;
+      SCOPE_IMPLICIT=2;
 
     procedure tx86_64procinfo.set_first_temp_offset;
       begin
@@ -90,6 +104,62 @@ implementation
           result:=Align(tg.direction*tg.lasttemp+maxpushedparasize,8);
       end;
 
+    procedure tx86_64procinfo.add_finally_scope(startlabel,endlabel,handler:TAsmSymbol;implicit:Boolean);
+      begin
+        unwindflags:=unwindflags or 2;
+        if implicit then  { also needs catch functionality }
+          unwindflags:=unwindflags or 1;
+        inc(scopecount);
+        if scopes=nil then
+          scopes:=TAsmList.Create;
+
+        if implicit then
+          scopes.concat(tai_const.create_32bit(SCOPE_IMPLICIT))
+        else
+          scopes.concat(tai_const.create_32bit(SCOPE_FINALLY));
+        scopes.concat(tai_const.create_rva_sym(startlabel));
+        scopes.concat(tai_const.create_rva_sym(endlabel));
+        scopes.concat(tai_const.create_rva_sym(handler));
+      end;
+
+    procedure tx86_64procinfo.add_except_scope(trylabel,exceptlabel,endlabel,filter:TAsmSymbol);
+      begin
+        unwindflags:=unwindflags or 3;
+        inc(scopecount);
+        if scopes=nil then
+          scopes:=TAsmList.Create;
+
+        if Assigned(filter) then
+          scopes.concat(tai_const.create_rva_sym(filter))
+        else
+          scopes.concat(tai_const.create_32bit(SCOPE_CATCHALL));
+        scopes.concat(tai_const.create_rva_sym(trylabel));
+        scopes.concat(tai_const.create_rva_sym(exceptlabel));
+        scopes.concat(tai_const.create_rva_sym(endlabel));
+      end;
+
+    procedure tx86_64procinfo.dump_scopes(list: TAsmList);
+      var
+        hdir: tai_seh_directive;
+      begin
+        if (scopecount=0) then
+          exit;
+        hdir:=cai_seh_directive.create_name(ash_handler,'__FPC_specific_handler');
+        hdir.data.flags:=unwindflags;
+        list.concat(hdir);
+        list.concat(cai_seh_directive.create(ash_handlerdata));
+        list.concat(tai_const.create_32bit(scopecount));
+        list.concatlist(scopes);
+        { return to text, required for GAS compatibility }
+        { This creates a tai_align which is redundant here (although harmless) }
+        new_section(list,sec_code,lower(procdef.mangledname),0);
+      end;
+
+    destructor tx86_64procinfo.destroy;
+      begin
+        scopes.free;
+        inherited destroy;
+      end;
 
 begin
    cprocinfo:=tx86_64procinfo;

compiler/x86_64/nx64flw.pas

@@ -0,0 +1,559 @@
+{
+    Copyright (c) 2011 by Free Pascal development team
+
+    Generate Win64-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 nx64flw;
+
+{$i fpcdefs.inc}
+
+interface
+
+  uses
+    node,nflw,ncgflw,psub;
+
+  type
+    tx64raisenode=class(tcgraisenode)
+      procedure pass_generate_code;override;
+    end;
+
+    tx64onnode=class(tcgonnode)
+      procedure pass_generate_code;override;
+    end;
+
+    tx64tryexceptnode=class(tcgtryexceptnode)
+      procedure pass_generate_code;override;
+    end;
+
+    tx64tryfinallynode=class(tcgtryfinallynode)
+      finalizepi: tcgprocinfo;
+      constructor create(l,r:TNode);override;
+      constructor create_implicit(l,r,_t1: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;
+
+
+{ tx64raisenode }
+
+procedure tx64raisenode.pass_generate_code;
+  begin
+    { difference from generic code is that address stack is not popped on reraise }
+    if (target_info.system<>system_x86_64_win64) or assigned(left) then
+      inherited pass_generate_code
+    else
+      cg.g_call(current_asmdata.CurrAsmList,'FPC_RERAISE');
+  end;
+
+{ tx64onnode }
+
+procedure tx64onnode.pass_generate_code;
+  var
+    oldflowcontrol : tflowcontrol;
+    exceptvarsym : tlocalvarsym;
+  begin
+    if (target_info.system<>system_x86_64_win64) then
+      begin
+        inherited pass_generate_code;
+        exit;
+      end;
+
+    location_reset(location,LOC_VOID,OS_NO);
+
+    oldflowcontrol:=flowcontrol;
+    flowcontrol:=[fc_inflowcontrol];
+
+    { RTL will put exceptobject into RAX 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;
+
+{ tx64tryfinallynode }
+var
+  seq: longint=0;
+
+
+function create_pd: tprocdef;
+  var
+    st:TSymTable;
+    checkstack: psymtablestackitem;
+    sym:tprocsym;
+  begin
+    { get actual procedure symtable (skip withsymtables, etc.) }
+    st:=nil;
+    checkstack:=symtablestack.stack;
+    while assigned(checkstack) do
+      begin
+        st:=checkstack^.symtable;
+          if st.symtabletype in [staticsymtable,globalsymtable,localsymtable] then
+            break;
+          checkstack:=checkstack^.next;
+      end;
+    { Create a nested procedure, even from main_program_level. }
+    result:=tprocdef.create(max(normal_function_level,st.symtablelevel)+1);
+    result.struct:=current_procinfo.procdef.struct;
+    result.proctypeoption:=potype_exceptfilter;
+    handle_calling_convention(result);
+    sym:=tprocsym.create('$fin$'+tostr(seq));
+    st.insert(sym);
+    inc(seq);
+
+    result.procsym:=sym;
+    proc_add_definition(result);
+    result.forwarddef:=false;
+    result.aliasnames.insert(result.mangledname);
+    alloc_proc_symbol(result);
+  end;
+
+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 tx64tryfinallynode.create(l, r: TNode);
+  begin
+    inherited create(l,r);
+    if (target_info.system<>system_x86_64_win64) then
+      exit;
+    finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
+    finalizepi.force_nested;
+    finalizepi.procdef:=create_pd;
+    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 tx64tryfinallynode.create_implicit(l, r, _t1: TNode);
+  begin
+    inherited create_implicit(l, r, _t1);
+    if (target_info.system<>system_x86_64_win64) then
+      exit;
+    finalizepi:=tcgprocinfo(cprocinfo.create(current_procinfo));
+    finalizepi.force_nested;
+    finalizepi.procdef:=create_pd;
+
+    finalizepi.entrypos:=current_filepos;
+    finalizepi.exitpos:=current_filepos; // last_endtoken_pos?
+    finalizepi.entryswitches:=r.localswitches;
+    finalizepi.exitswitches:=current_settings.localswitches;
+    include(finalizepi.flags,pi_do_call);
+    finalizepi.allocate_push_parasize(32);
+  end;
+
+function tx64tryfinallynode.simplify(forinline: boolean): tnode;
+  begin
+    result:=inherited simplify(forinline);
+    if (target_info.system<>system_x86_64_win64) then
+      exit;
+    if (result=nil) 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_nop;
+  var
+    dummy: TAsmLabel;
+  begin
+    { To avoid optimizing away the whole thing, prepend a jumplabel with increased refcount }
+    current_asmdata.getjumplabel(dummy);
+    dummy.increfs;
+    cg.a_label(current_asmdata.CurrAsmList,dummy);
+    current_asmdata.CurrAsmList.concat(Taicpu.op_none(A_NOP,S_NO));
+  end;
+
+procedure tx64tryfinallynode.pass_generate_code;
+  var
+    trylabel,
+    endtrylabel,
+    finallylabel,
+    endfinallylabel,
+    oldexitlabel: tasmlabel;
+    oldflowcontrol: tflowcontrol;
+    catch_frame: boolean;
+  begin
+    if (target_info.system<>system_x86_64_win64) then
+      begin
+        inherited pass_generate_code;
+        exit;
+      end;
+
+    location_reset(location,LOC_VOID,OS_NO);
+
+    { Do not generate a frame that catches exceptions if the only action
+      would be reraising it. Doing so is extremely inefficient with SEH
+      (in contrast with setjmp/longjmp exception handling) }
+    catch_frame:=implicitframe and ((not has_no_code(t1)) or
+      (current_procinfo.procdef.proccalloption=pocall_safecall));
+
+    oldflowcontrol:=flowcontrol;
+    flowcontrol:=[fc_inflowcontrol];
+
+    current_asmdata.getjumplabel(trylabel);
+    current_asmdata.getjumplabel(endtrylabel);
+    current_asmdata.getjumplabel(finallylabel);
+    current_asmdata.getjumplabel(endfinallylabel);
+    oldexitlabel:=current_procinfo.CurrExitLabel;
+    if implicitframe then
+      current_procinfo.CurrExitLabel:=finallylabel;
+
+    { Start of scope }
+    { Padding with NOP is necessary here because exceptions in called
+      procedures are seen at the next instruction, while CPU/OS exceptions
+      like AV are seen at the current instruction.
+
+      So in the following code
+
+      raise_some_exception;        //(a)
+      try
+        pchar(nil)^:='0';          //(b)
+        ...
+
+      without NOP, exceptions (a) and (b) will be seen at the same address
+      and fall into the same scope. However they should be seen in different scopes.
+    }
+
+    emit_nop;
+    cg.a_label(current_asmdata.CurrAsmList,trylabel);
+
+    { try code }
+    if assigned(left) then
+      begin
+        { fc_unwind tells exit/continue/break statements to emit special
+          unwind code instead of just JMP }
+        if not implicitframe then
+          include(flowcontrol,fc_unwind);
+        secondpass(left);
+        exclude(flowcontrol,fc_unwind);
+        if codegenerror then
+          exit;
+      end;
+
+    { If the immediately preceding instruction is CALL,
+      its return address must not end up outside the scope, so pad with NOP. }
+    if catch_frame then
+      cg.a_jmp_always(current_asmdata.CurrAsmList,finallylabel)
+    else
+      emit_nop;
+
+    cg.a_label(current_asmdata.CurrAsmList,endtrylabel);
+
+    { Handle the except block first, so endtrylabel serves both
+      as end of scope and as unwind target. This way it is possible to
+      encode everything into a single scope record. }
+    if catch_frame then
+      begin
+        flowcontrol:=[fc_inflowcontrol];
+        secondpass(t1);
+        { note 1: this is not a 'finally' block, no flow restrictions apply
+          note 2: it contains autogenerated sequential code, flow away is impossible }
+        if flowcontrol<>[fc_inflowcontrol] then
+          CGMessage(cg_e_control_flow_outside_finally);
+        if codegenerror then
+          exit;
+
+        if (current_procinfo.procdef.proccalloption=pocall_safecall) then
+          begin
+            handle_safecall_exception;
+            cg.a_jmp_always(current_asmdata.CurrAsmList,endfinallylabel);
+          end
+        else
+          cg.a_call_name(current_asmdata.CurrAsmList,'FPC_RERAISE_IMPLICIT',false);
+      end;
+
+    flowcontrol:=[fc_inflowcontrol];
+    cg.a_label(current_asmdata.CurrAsmList,finallylabel);
+    { generate finally code as a separate procedure }
+    if not implicitframe then
+      tcgprocinfo(current_procinfo).generate_exceptfilter(finalizepi);
+    { right is a call to finalizer procedure }
+    secondpass(right);
+
+    if codegenerror then
+      exit;
+
+    { normal exit from safecall proc must zero the result register }
+    if implicitframe and (current_procinfo.procdef.proccalloption=pocall_safecall) then
+      cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,0,NR_FUNCTION_RESULT_REG);
+
+    cg.a_label(current_asmdata.CurrAsmList,endfinallylabel);
+
+    { generate the scope record in .xdata }
+    tx86_64procinfo(current_procinfo).add_finally_scope(trylabel,endtrylabel,
+      current_asmdata.RefAsmSymbol(finalizepi.procdef.mangledname),catch_frame);
+
+    if implicitframe then
+      current_procinfo.CurrExitLabel:=oldexitlabel;
+    flowcontrol:=oldflowcontrol;
+  end;
+
+{ tx64tryexceptnode }
+
+procedure tx64tryexceptnode.pass_generate_code;
+  var
+    trylabel,
+    exceptlabel,oldendexceptlabel,
+    lastonlabel,
+    exitexceptlabel,
+    continueexceptlabel,
+    breakexceptlabel,
+    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_x86_64_win64) 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;
+
+    { save the old labels for control flow statements }
+    oldCurrExitLabel:=current_procinfo.CurrExitLabel;
+    current_asmdata.getjumplabel(exitexceptlabel);
+    if assigned(current_procinfo.CurrBreakLabel) then
+      begin
+        oldContinueLabel:=current_procinfo.CurrContinueLabel;
+        oldBreakLabel:=current_procinfo.CurrBreakLabel;
+        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 }
+    current_asmdata.getjumplabel(trylabel);
+    emit_nop;
+    cg.a_label(current_asmdata.CurrAsmList,trylabel);
+
+    { control flow in try block needs no special handling,
+      just make sure that target labels are outside the scope }
+    secondpass(left);
+    tryflowcontrol:=flowcontrol;
+    if codegenerror then
+      goto errorexit;
+
+    { jump over except handlers }
+    cg.a_jmp_always(current_asmdata.CurrAsmList,endexceptlabel);
+
+    { end of scope }
+    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;
+        current_asmdata.getdatalabel(filterlabel);
+        new_section(hlist,sec_rodata_norel,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_rva_sym(current_asmdata.RefAsmSymbol(tonnode(hnode).excepttype.vmt_mangledname)));
+            hlist.concat(tai_const.create_rva_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_rva_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;
+
+    emit_nop;
+    cg.a_label(current_asmdata.CurrAsmList,endexceptlabel);
+    tx86_64procinfo(current_procinfo).add_except_scope(trylabel,exceptlabel,endexceptlabel,filterlabel);
+
+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:=tx64raisenode;
+  connode:=tx64onnode;
+  ctryexceptnode:=tx64tryexceptnode;
+  ctryfinallynode:=tx64tryfinallynode;
+end.
+

rtl/inc/except.inc

@@ -162,7 +162,7 @@ begin
     Halt(errorcode);
 end;
 
-
+{$ifndef FPC_SYSTEM_HAS_RAISEEXCEPTION}
 Function fpc_RaiseException (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
 var
   _ExceptObjectStack : PExceptObject;
@@ -182,6 +182,7 @@ begin
       RaiseProc(FObject,Addr,FrameCount,Frames);
   longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
 end;
+{$endif FPC_SYSTEM_HAS_RAISEEXCEPTION}
 
 
 Procedure fpc_PopAddrStack;[Public, Alias : 'FPC_POPADDRSTACK']; compilerproc;
@@ -272,6 +273,7 @@ begin
     end;
 end;
 
+{$ifndef FPC_SYSTEM_HAS_RERAISE}
 Procedure fpc_ReRaise;[Public, Alias : 'FPC_RERAISE']; compilerproc;
 var
   _ExceptAddrStack : PExceptAddr;
@@ -285,6 +287,7 @@ begin
   ExceptObjectStack^.refcount := 0;
   longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
 end;
+{$endif FPC_SYSTEM_HAS_RERAISE}
 
 function Internal_PopSecondObjectStack : TObject; external name 'FPC_POPSECONDOBJECTSTACK';
 function Internal_PopObjectStack: TObject; external name 'FPC_POPOBJECTSTACK';
@@ -369,7 +372,7 @@ begin
   else
     adr:=nil;
   exc:=Internal_PopObjectStack;
-  if Assigned(obj) then
+  if Assigned(obj) and Assigned(exc) then
     result:=obj.SafeCallException(exc,adr)
   else
     result:=E_UNEXPECTED;

rtl/win64/seh64.inc

@@ -211,3 +211,399 @@ procedure RaiseException(
   lpArguments: Pointer);  // msdn: *ULONG_PTR
   external 'kernel32.dll' name 'RaiseException';
 
+{ FPC specific stuff }
+{$ifdef FPC_USE_WIN64_SEH}
+const
+  FPC_EXCEPTION_CODE=$E0465043;
+  SCOPE_FINALLY=0;
+  SCOPE_CATCHALL=1;
+  SCOPE_IMPLICIT=2;
+
+type
+  PScopeRec=^TScopeRec;
+  TScopeRec=record
+    Typ: DWord;        { SCOPE_FINALLY: finally code in RvaHandler
+                         SCOPE_CATCHALL: unwinds to RvaEnd, RvaHandler is the end of except block
+                         SCOPE_IMPLICIT: finally code in RvaHandler, unwinds to RvaEnd
+                         otherwise: except with 'on' stmts, value is RVA of filter data }
+    RvaStart: DWord;
+    RvaEnd: DWord;
+    RvaHandler: DWord;
+  end;
+
+  PFilterRec=^TFilterRec;
+  TFilterRec=record
+    RvaClass: DWord;
+    RvaHandler: DWord;
+  end;
+
+  TUnwindProc=procedure(frame: QWord);
+  TExceptObjProc=function(code: Longint; const rec: TExceptionRecord): Pointer; { Exception }
+  TExceptClsProc=function(code: Longint): Pointer; { ExceptClass }
+
+{ note: context must be passed by value, so modifications are made to a local copy }
+function GetBacktrace(Context: TContext; StartingFrame: Pointer; out Frames: PPointer): Longint;
+var
+  UnwindHistory: UNWIND_HISTORY_TABLE;
+  RuntimeFunction: PRUNTIME_FUNCTION;
+  HandlerData: Pointer;
+  EstablisherFrame: QWord;
+  ImageBase: QWord;
+  FrameCount,FrameBufSize: Longint;
+begin
+  FillChar(UnwindHistory,sizeof(UNWIND_HISTORY_TABLE),0);
+  UnwindHistory.Unwind:=1;
+
+  FrameCount:=0;
+  FrameBufSize:=0;
+  Frames:=nil;
+  repeat
+    RuntimeFunction:=RtlLookupFunctionEntry(Context.Rip, ImageBase, @UnwindHistory);
+
+    if Assigned(RuntimeFunction) then
+      RtlVirtualUnwind(UNW_FLAG_NHANDLER, ImageBase, Context.Rip,
+        RuntimeFunction, Context, @HandlerData, @EstablisherFrame, nil)
+    else  { a leaf function }
+    begin
+      Context.Rip:=PQWord(Context.Rsp)^;
+      Inc(Context.Rsp, sizeof(Pointer));
+    end;
+
+    if (Context.Rip=0) or (FrameCount>=RaiseMaxFrameCount) then
+      break;
+
+    { The StartingFrame provides a way to skip several initial calls.
+      It's better to specify the number of skipped calls directly,
+      because the very purpose of this function is to retrieve stacktrace
+      even in optimized code (i.e. without rbp-based frames). But that's
+      limited by factors such as 'raise' syntax. }
+
+    if (Pointer(Context.Rbp)>StartingFrame) or (FrameCount>0) then
+    begin
+      if (FrameCount>=FrameBufSize) then
+        begin
+          Inc(FrameBufSize,16);
+          ReallocMem(Frames,FrameBufSize*sizeof(Pointer));
+        end;
+      Frames[FrameCount]:=Pointer(Context.Rip);
+      Inc(FrameCount);
+    end;
+  until False;
+  Result:=FrameCount;
+end;
+
+{$push}
+{$codealign localmin=16}          { TContext record requires this }
+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]);
+end;
+
+procedure localUnwind(frame,target: Pointer);[public,alias:'_FPC_local_unwind'];
+var
+  ctx: TContext;
+begin
+  RtlUnwindEx(frame,target,nil,nil,@ctx,nil);
+end;
+{$pop}
+
+procedure fpc_reraise; [public,alias:'FPC_RERAISE']; compilerproc;
+var
+  hp : PExceptObject;
+  args: array[0..3] of PtrUint;
+begin
+  hp:=ExceptObjectStack;
+  args[0]:=PtrUint(hp^.addr);               { copy and clear the exception stack top }
+  args[1]:=PtrUint(hp^.FObject);
+  args[2]:=hp^.FrameCount;
+  args[3]:=PtrUint(hp^.Frames);
+  hp^.refcount:=0;
+  hp^.FObject:=nil;
+  hp^.Frames:=nil;
+  RaiseException(FPC_EXCEPTION_CODE,EXCEPTION_NONCONTINUABLE,4,@args[0]);
+end;
+
+{ The only difference from fpc_reraise is removing the topmost exception.
+  Normally this is done in __FPC_specific_handler, but it won't work for implicit
+  frames, as there's no room in scope record to store the end rva of 'except' part.
+
+  This can only happen in functions which return managed result in register;
+  eventually compiler must be fixed to return managed types in parameters only. }
+
+procedure fpc_reraise_implicit; [public,alias:'FPC_RERAISE_IMPLICIT'];
+var
+  hp: PExceptObject;
+  args: array[0..3] of PtrUInt;
+begin
+  hp:=ExceptObjectStack;
+  args[0]:=PtrUint(hp^.addr);
+  args[1]:=PtrUint(hp^.FObject);
+  args[2]:=hp^.FrameCount;
+  args[3]:=PtrUint(hp^.Frames);
+  hp^.refcount:=0;
+  hp^.FObject:=nil;
+  hp^.Frames:=nil;
+  Internal_PopObjectStack.Free;
+  RaiseException(FPC_EXCEPTION_CODE,EXCEPTION_NONCONTINUABLE,4,@args[0]);
+end;
+
+function RunErrorCode(const rec: TExceptionRecord): longint;
+begin
+  { negative result means 'FPU reset required' }
+  case rec.ExceptionCode of
+    STATUS_INTEGER_DIVIDE_BY_ZERO:      result := 200;    { reDivByZero }
+    STATUS_FLOAT_DIVIDE_BY_ZERO:        result := -208;   { !!reZeroDivide }
+    STATUS_ARRAY_BOUNDS_EXCEEDED:       result := 201;    { reRangeError }
+    STATUS_STACK_OVERFLOW:              result := 202;    { reStackOverflow }
+    STATUS_FLOAT_OVERFLOW:              result := -205;   { reOverflow }
+    STATUS_FLOAT_DENORMAL_OPERAND,
+    STATUS_FLOAT_UNDERFLOW:             result := -206;   { reUnderflow }
+    STATUS_FLOAT_INEXACT_RESULT,
+    STATUS_FLOAT_INVALID_OPERATION,
+    STATUS_FLOAT_STACK_CHECK:           result := -207;   { reInvalidOp }
+    STATUS_INTEGER_OVERFLOW:            result := 215;    { reIntOverflow }
+    STATUS_ILLEGAL_INSTRUCTION:         result := -216;
+    STATUS_ACCESS_VIOLATION:            result := 216;    { reAccessViolation }
+    STATUS_CONTROL_C_EXIT:              result := 217;    { reControlBreak }
+    STATUS_PRIVILEGED_INSTRUCTION:      result := 218;    { rePrivilegedInstruction }
+  else
+    result := 255;                                        { reExternalException }
+  end;
+end;
+
+
+function FilterException(var rec:TExceptionRecord; imagebase: QWord; scope: PScopeRec): Pointer;
+var
+  ExClass: TClass;
+  i: Longint;
+  Filter: Pointer;
+  curFilt: PFilterRec;
+begin
+  result:=nil;
+  if rec.ExceptionCode=FPC_EXCEPTION_CODE then
+    ExClass:=TObject(rec.ExceptionInformation[1]).ClassType
+  else if Assigned(ExceptClsProc) then
+    ExClass:=TClass(TExceptClsProc(ExceptClsProc)(abs(RunErrorCode(rec))))
+  else
+    Exit; { if we cannot determine type of exception, don't handle it }
+  Filter:=Pointer(imagebase+scope^.Typ);
+  for i:=0 to PLongint(Filter)^-1 do
+  begin
+    CurFilt:=@PFilterRec(Filter+sizeof(Longint))[i];
+    if (CurFilt^.RvaClass=$FFFFFFFF) or
+      { TODO: exception might be coming from another module, need more advanced comparing }
+      (ExClass.InheritsFrom(TClass(imagebase+CurFilt^.RvaClass))) then
+    begin
+      result:=Pointer(imagebase+CurFilt^.RvaHandler);
+      exit;
+    end;
+  end;
+end;
+
+{$ifdef DEBUG_SEH}
+procedure PrintScope(idx: integer; scope: PScopeRec);
+begin
+  if IsConsole then
+  begin
+    write(stderr,'Scope #',idx,' ',hexstr(Scope^.RvaStart,8),' - ',hexStr(Scope^.RvaEnd,8));
+    writeln(stderr,' type=',Scope^.Typ);
+  end;
+end;
+{$endif DEBUG_SEH}
+
+function PushException(var rec: TExceptionRecord; var context: TContext;
+  out obj: TObject; AcceptNull: Boolean): Boolean;
+var
+  adr: Pointer;
+  Exc: PExceptObject;
+  Frames: PPointer;
+  FrameCount: Longint;
+  code: Longint;
+begin
+  Adr:=rec.ExceptionInformation[0];
+  Obj:=TObject(rec.ExceptionInformation[1]);
+  Framecount:=Longint(rec.ExceptionInformation[2]);
+  Frames:=rec.ExceptionInformation[3];
+
+  if rec.ExceptionCode<>FPC_EXCEPTION_CODE then
+  begin
+    Obj:=nil;
+    Result:=False;
+    code:=RunErrorCode(rec);
+    if Assigned(ExceptObjProc) then
+      Obj:=TObject(TExceptObjProc(ExceptObjProc)(abs(code),rec));
+    if (Obj=nil) and (not AcceptNull) then
+      Exit;
+    adr:=rec.ExceptionAddress;
+    FrameCount:=GetBacktrace(context,nil,Frames);
+    if code<0 then
+      SysResetFPU;
+  end;
+
+  New(Exc);
+  Exc^.FObject:=Obj;
+  Exc^.Addr:=adr;
+  Exc^.Frames:=Frames;
+  Exc^.FrameCount:=FrameCount;
+  Exc^.Refcount:=0;
+  { link to RaiseList }
+  Exc^.Next:=ExceptObjectStack;
+  ExceptObjectStack:=Exc;
+  Result:=True;
+end;
+
+function __FPC_default_handler(
+  var rec: TExceptionRecord;
+  frame: Pointer;
+  var context: TCONTEXT;
+  var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; [public,alias:'__FPC_DEFAULT_HANDLER'];
+label L1;
+var
+  exc: PExceptObject;
+  obj: TObject;
+begin
+  if (rec.ExceptionFlags and EXCEPTION_UNWIND)=0 then
+  begin
+    { Athlon prefetch bug? }
+    if (rec.ExceptionCode=STATUS_ACCESS_VIOLATION) and is_prefetch(pointer(Context.rip)) then
+    begin
+      result:=ExceptionContinueExecution;
+      exit;
+    end;
+    PushException(rec,context,obj,True);
+    RtlUnwindEx(frame, @L1, @rec, nil, dispatch.ContextRecord, dispatch.HistoryTable);
+  end
+  else if (rec.ExceptionFlags and EXCEPTION_TARGET_UNWIND)<>0 then
+  begin
+    Exc:=ExceptObjectStack;
+    if Exc^.FObject=nil then
+      RunError(abs(RunErrorCode(rec)))  // !!prints wrong backtrace
+    else
+    begin
+      { if ExceptObjProc=nil, ExceptProc is typically also nil,
+        so we cannot make much use of this backtrace }
+      if Assigned(ExceptProc) then
+      begin
+        ExceptProc(Exc^.FObject,Exc^.Addr,Exc^.FrameCount,Exc^.Frames);
+        Halt(217);
+      end;
+L1:
+      RunError(217);
+    end;
+  end;
+  result:=ExceptionContinueSearch;
+end;
+
+function __FPC_specific_handler(
+  var rec: TExceptionRecord;
+  frame: Pointer;
+  var context: TCONTEXT;
+  var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; [public,alias:'__FPC_specific_handler'];
+
+var
+  TargetRva,ControlRva: DWord;
+  scope: PScopeRec;
+  scopeIdx: DWord;
+  TargetAddr: Pointer;
+  obj:TObject;
+begin
+{$ifdef DEBUG_SEH}
+  if IsConsole then
+  begin
+    writeln(stderr,'Exception handler for ',BacktraceStrFunc(Pointer(dispatch.FunctionEntry^.BeginAddress+dispatch.ImageBase)));
+    writeln(stderr,'Code=', hexstr(rec.ExceptionCode,8),' Flags=',hexstr(rec.ExceptionFlags,2), ' CtrlPc=',hexstr(dispatch.ControlPc,16));
+  end;
+{$endif DEBUG_SEH}
+  result:=ExceptionContinueSearch;
+  ControlRva:=dispatch.ControlPc-dispatch.ImageBase;
+  ScopeIdx:=dispatch.ScopeIndex;
+  if (rec.ExceptionFlags and EXCEPTION_UNWIND)=0 then
+  begin
+    while ScopeIdx<PDWord(dispatch.HandlerData)^ do
+    begin
+      scope:=@PScopeRec(dispatch.HandlerData+sizeof(Dword))[ScopeIdx];
+{$ifdef DEBUG_SEH}
+      PrintScope(ScopeIdx, scope);
+{$endif DEBUG_SEH}
+      { Check if the exception was raised in the 'except' block,
+        and dispose the existing exception object if so. }
+      if (ControlRva>=scope^.RvaEnd) and (ControlRva<scope^.RvaHandler) and
+        ((scope^.Typ=SCOPE_CATCHALL) or (scope^.Typ>SCOPE_IMPLICIT)) then
+        Internal_PopObjectStack.Free
+      else if (ControlRva>=scope^.RvaStart) and (ControlRva<scope^.RvaEnd) and
+        (scope^.Typ<>SCOPE_FINALLY)then
+      begin
+        { Athlon prefetch bug? }
+        if (rec.ExceptionCode=STATUS_ACCESS_VIOLATION) and is_prefetch(pointer(Context.rip)) then
+        begin
+          result:=ExceptionContinueExecution;
+          exit;
+        end;
+
+        if scope^.Typ>SCOPE_IMPLICIT then  // filtering needed
+        begin
+          TargetAddr:=FilterException(rec,dispatch.ImageBase,scope);
+          if TargetAddr=nil then
+          begin
+            Inc(ScopeIdx);
+            Continue;
+          end;
+        end
+        else
+          TargetAddr:=Pointer(scope^.RvaEnd+dispatch.ImageBase);
+{$ifdef DEBUG_SEH}
+        if IsConsole then
+          writeln(stderr,'match at scope #',scopeIdx,', unwind target=',hexstr(TargetAddr));
+{$endif DEBUG_SEH}
+        if not PushException(rec,context,obj,Scope^.Typ=SCOPE_IMPLICIT) then
+          Exit;
+
+        { Does not return, control is transferred to TargetAddr,
+          obj is placed into RAX. }
+        RtlUnwindEx(frame, TargetAddr, @rec, obj, dispatch.ContextRecord, dispatch.HistoryTable);
+      end;
+      Inc(ScopeIdx);
+    end;
+  end
+  else
+  begin
+    TargetRva:=dispatch.TargetIp-dispatch.ImageBase;
+{$ifdef DEBUG_SEH}
+    if IsConsole then
+      writeln(stderr,'Unwind, TargetRva=',hexstr(TargetRva,8),' CtrlRva=',hexstr(ControlRva,8),' idx=',ScopeIdx);
+{$endif DEBUG_SEH}
+    while ScopeIdx<PDword(dispatch.HandlerData)^ do
+    begin
+      scope:=@PScopeRec(dispatch.HandlerData+sizeof(Dword))[ScopeIdx];
+{$ifdef DEBUG_SEH}
+      PrintScope(scopeIdx, scope);
+{$endif DEBUG_SEH}
+      if (ControlRva>=scope^.RvaStart) and (ControlRva<scope^.RvaEnd) and
+         ((scope^.Typ=SCOPE_FINALLY) or (scope^.Typ=SCOPE_IMPLICIT)) then
+      begin
+        if (TargetRva>=scope^.RvaStart) and (TargetRva<scope^.RvaEnd) and
+          ((rec.ExceptionFlags and EXCEPTION_TARGET_UNWIND)<>0) then
+        begin
+          Exit;
+        end;
+
+        dispatch.ScopeIndex:=ScopeIdx+1;
+{$ifdef DEBUG_SEH}
+        if IsConsole then
+          writeln(stderr,'calling handler @',hexstr(dispatch.imagebase+scope^.RvaHandler,16));
+{$endif DEBUG_SEH}
+        TUnwindProc(dispatch.ImageBase+scope^.RvaHandler)(context.rbp);
+      end;
+      Inc(ScopeIdx);
+    end;
+  end;
+end;
+{$endif FPC_USE_WIN64_SEH}
+

rtl/win64/system.pp

@@ -26,6 +26,11 @@ interface
 {$define DISABLE_NO_THREAD_MANAGER}
 {$define HAS_WIDESTRINGMANAGER}
 
+{$ifdef FPC_USE_WIN64_SEH}
+  {$define FPC_SYSTEM_HAS_RAISEEXCEPTION}
+  {$define FPC_SYSTEM_HAS_RERAISE}
+{$endif FPC_USE_WIN64_SEH}
+
 { include system-independent routine headers }
 {$I systemh.inc}
 
@@ -126,7 +131,9 @@ var
                          System Dependent Exit code
 *****************************************************************************}
 
+{$ifndef FPC_USE_WIN64_SEH}
 procedure install_exception_handlers;forward;
+{$endif FPC_USE_WIN64_SEH}
 procedure remove_exception_handlers;forward;
 procedure PascalMain;stdcall;external name 'PASCALMAIN';
 procedure fpc_do_exit;stdcall;external name 'FPC_DO_EXIT';
@@ -166,6 +173,20 @@ var
     to check if the call stack can be written on exceptions }
   _SS : Cardinal;
 
+{$ifdef FPC_USE_WIN64_SEH}
+procedure main_wrapper(p: TProcedure); assembler; nostackframe;
+asm
+    subq   $40, %rsp
+.seh_stackalloc 40
+.seh_endprologue
+    call   %rcx
+    nop                     { this nop is critical for exception handling }
+    addq   $40, %rsp
+.seh_handler __FPC_default_handler,@except,@unwind
+end;
+{$endif FPC_USE_WIN64_SEH}
+
+
 procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
   var
     ST : pointer;
@@ -173,7 +194,9 @@ procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
      IsLibrary:=false;
      { install the handlers for exe only ?
        or should we install them for DLL also ? (PM) }
+{$ifndef FPC_USE_WIN64_SEH}
      install_exception_handlers;
+{$endif FPC_USE_WIN64_SEH}
      ExitCode:=0;
      asm
         movq %rsp,%rax
@@ -186,7 +209,12 @@ procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
         movl %eax,_SS(%rip)
         movq %rbp,%rsi
         xorq %rbp,%rbp
+{$ifdef FPC_USE_WIN64_SEH}
+        lea  PASCALMAIN(%rip),%rcx
+        call main_wrapper
+{$else FPC_USE_WIN64_SEH}
         call PASCALMAIN
+{$endif FPC_USE_WIN64_SEH}
         movq %rsi,%rbp
      end ['RSI','RBP'];     { <-- specifying RSI allows compiler to save/restore it properly }
      { if we pass here there was no error ! }
@@ -271,6 +299,8 @@ type
 
 function AddVectoredExceptionHandler(FirstHandler : DWORD;VectoredHandler : TVectoredExceptionHandler) : longint;
         external 'kernel32' name 'AddVectoredExceptionHandler';
+
+{$ifndef FPC_USE_WIN64_SEH}
 const
   MaxExceptionLevel = 16;
   exceptLevel : Byte = 0;
@@ -442,6 +472,7 @@ procedure install_exception_handlers;
   begin
     AddVectoredExceptionHandler(1,@syswin64_x86_64_exception_handler);
   end;
+{$endif ndef FPC_USE_WIN64_SEH}
 
 
 procedure remove_exception_handlers;